From 8a5057fbdc5f8c5a4a5d1ec8cda424c2e8a71079 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Fri, 6 Aug 2021 12:14:55 -0700 Subject: [PATCH] Remove explicit old versions from cloned repo (#392) it took a long time to figure out how to restore old versions, using the './scripts/restore-versions file'. Now that it's there and tested it should be ok to remove them from new 'git clone' of medley --- CLTL2/CMLDEFFER.~2~ | 248 -- CLTL2/I-NEW.~3~ | 419 -- CLTL2/LLARRAYELT.~2~ | 2948 ------------- CLTL2/LLNEW.~2~ | 1418 ------ fonts/altofonts/fonts.widths.~1~ | Bin 14416 -> 0 bytes .../c0/GACHA08-MRR-C0.DISPLAYFONT.~1~ | Bin 828 -> 0 bytes .../c0/GACHA10-MRR-C0.DISPLAYFONT.~1~ | Bin 1236 -> 0 bytes .../GACHA08-MRR-C0.DISPLAYFONT.~1~ | Bin 828 -> 0 bytes .../GACHA10-MRR-C0.DISPLAYFONT.~1~ | Bin 1236 -> 0 bytes .../printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~ | Bin 6046 -> 0 bytes greetfiles/INIT.LCOM.~1~ | Bin 14347 -> 0 bytes greetfiles/INIT.~1~ | Bin 25582 -> 0 bytes greetfiles/LOCAL-INIT.LCOM.~37~ | Bin 6644 -> 0 bytes greetfiles/LOCAL-INIT.LCOM.~38~ | Bin 6453 -> 0 bytes greetfiles/LOCAL-INIT.LCOM.~39~ | Bin 6453 -> 0 bytes greetfiles/LOCAL-INIT.LCOM.~40~ | Bin 6592 -> 0 bytes greetfiles/LOCAL-INIT.LCOM.~41~ | Bin 6566 -> 0 bytes greetfiles/LOCAL-INIT.~32~ | 55 - greetfiles/LOCAL-INIT.~36~ | 55 - greetfiles/LOCAL-INIT.~39~ | 55 - greetfiles/LOCAL-INIT.~41~ | 55 - greetfiles/LOCAL-INIT.~42~ | 55 - greetfiles/LOCAL-INIT.~43~ | 55 - greetfiles/LOCAL-INIT.~44~ | 55 - greetfiles/LOCAL-INIT.~45~ | 55 - greetfiles/SIMPLE-INIT.~1~ | 1 - greetfiles/SIMPLE-INIT.~2~ | 1 - internal/library/ARCLEANUP.~1~ | 1 - internal/library/CALENDARHACKS.~3~ | 222 - internal/library/CONDITIONGRAPH.~2~ | 1 - internal/library/GIVE-AND-TAKE.~2~ | 1 - internal/library/MULTI-COMPILE.~4~ | 374 -- internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ | 920 ---- internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ | 925 ---- .../test/IO/Keyboard/logs/keyboard.log.~1~ | 13 - .../test/IO/Keyboard/logs/keyboard.log.~2~ | 13 - .../test/IO/Keyboard/logs/keyboard.log.~3~ | 15 - .../Library/TEDIT/hand-aux/.read-me-first.~1~ | Bin 3981 -> 0 bytes .../Library/TEDIT/hand-aux/.read-me-first.~2~ | Bin 4677 -> 0 bytes .../Library/TEDIT/hand-aux/.read-me-first.~3~ | Bin 5488 -> 0 bytes internal/test/env/DEdit/high-level.u.~1~ | 253 -- internal/test/env/DEdit/high-level.u.~2~ | 254 -- .../test/env/Debugger/hand/BreakWindow.u.~1~ | 3 - .../test/env/Debugger/hand/BreakWindow.u.~2~ | 3 - .../test/env/Debugger/hand/BreakWindow.u.~3~ | 3 - .../test/env/Debugger/hand/debugger.u.~1~ | 14 - .../test/env/Debugger/hand/debugger.u.~2~ | 14 - .../env/Debugger/logs/DebuggerOnly.log.~1~ | 44 - .../env/Debugger/logs/DebuggerOnly.log.~2~ | 38 - .../env/Debugger/logs/DebuggerOnly.log.~3~ | 26 - .../test/env/Debugger/logs/debugger.log.~1~ | 34 - .../test/env/Debugger/logs/debugger.log.~2~ | 32 - .../test/env/Debugger/logs/debugger.log.~3~ | 51 - .../test/env/Debugger/logs/debugger.log.~4~ | 48 - .../test/env/Debugger/logs/debugger.log.~5~ | 32 - .../test/env/Debugger/logs/debugger.log.~6~ | 37 - .../test/env/Debugger/logs/debugger.log.~7~ | Bin 1579 -> 0 bytes internal/test/env/Exec/Hand/DA.U.~1~ | 75 - internal/test/env/Exec/Hand/DA.U.~2~ | 75 - internal/test/env/Exec/Logs/Exec.log.~1~ | 5 - internal/test/env/Exec/Logs/Exec.log.~2~ | 8 - internal/test/env/Exec/Logs/Exec.log.~3~ | 5 - .../env/Program-Support/Auto/CLISP.TEST.~2~ | Bin 7660 -> 0 bytes .../code-editor/hand/Command-arglist.u.~1~ | 289 -- .../code-editor/hand/Command-arglist.u.~2~ | 289 -- .../code-editor/hand/Command-extract.u.~1~ | 336 -- .../code-editor/hand/Command-extract.u.~2~ | 335 -- .../env/code-editor/hand/Command-find.u.~1~ | 324 -- .../env/code-editor/hand/Command-find.u.~2~ | 324 -- .../env/code-editor/hand/Command-high.u.~1~ | 175 - .../env/code-editor/hand/Command-high.u.~2~ | 175 - .../env/code-editor/hand/Command-join.u.~1~ | 330 -- .../env/code-editor/hand/Command-join.u.~2~ | 330 -- .../env/code-editor/hand/Command-menu.u.~1~ | 315 -- .../env/code-editor/hand/Command-menu.u.~2~ | 315 -- .../env/code-editor/hand/Command-meta-o.u.~1~ | 367 -- .../env/code-editor/hand/Command-meta-o.u.~2~ | 365 -- .../env/code-editor/hand/Command-mutate.u.~1~ | 313 -- .../env/code-editor/hand/Command-mutate.u.~2~ | 313 -- .../env/code-editor/hand/Command-paren.u.~1~ | 337 -- .../env/code-editor/hand/Command-paren.u.~2~ | 342 -- .../code-editor/hand/Command-substitute.u.~1~ | 384 -- .../code-editor/hand/Command-substitute.u.~2~ | 383 -- .../code-editor/hand/Command-undo-redo.u.~1~ | 645 --- .../code-editor/hand/Command-undo-redo.u.~2~ | 645 --- .../test/env/code-editor/hand/Control.u.~1~ | 362 -- .../test/env/code-editor/hand/Control.u.~2~ | 2 - .../test/env/code-editor/hand/Interrupt.u.~1~ | 191 - .../test/env/code-editor/hand/Interrupt.u.~2~ | 191 - .../code-editor/hand/SEdit-3-mar-88.log.~1~ | 21 - .../code-editor/hand/SEdit-3-mar-88.log.~2~ | 20 - .../code-editor/hand/command-package.u.~1~ | 400 -- .../code-editor/hand/command-package.u.~2~ | 401 -- .../code-editor/hand/command-skip-next.u.~1~ | 273 -- .../code-editor/hand/command-skip-next.u.~2~ | 268 -- .../hand/inspect-defstruct.tedit.~1~ | Bin 9188 -> 0 bytes .../hand/inspect-defstruct.tedit.~2~ | Bin 9251 -> 0 bytes .../inspector/hand/inspect-macro.tedit.~1~ | Bin 5950 -> 0 bytes .../inspector/hand/inspect-macro.tedit.~2~ | Bin 6003 -> 0 bytes .../inspector/hand/inspectfieldflg.tedit.~1~ | Bin 3044 -> 0 bytes .../inspector/hand/inspectfieldflg.tedit.~2~ | Bin 3097 -> 0 bytes .../env/inspector/hand/inspectw.tedit.~1~ | Bin 9894 -> 0 bytes .../env/inspector/hand/inspectw.tedit.~2~ | Bin 9947 -> 0 bytes .../test/env/inspector/hand/userdef.test.~1~ | 34 - .../test/env/inspector/hand/userdef.test.~2~ | 37 - .../inspector/logs/inspect-defstruct.log.~1~ | 3 - .../inspector/logs/inspect-defstruct.log.~2~ | Bin 607 -> 0 bytes .../test/env/process-controls/hand/PSW.U.~1~ | 182 - .../test/env/process-controls/hand/PSW.U.~2~ | 182 - .../test/env/process-controls/hand/PSW.U.~3~ | 127 - .../program-analysis/hand/BROWSER-PART2.U.~1~ | 137 - .../program-analysis/hand/BROWSER-PART2.U.~2~ | 131 - .../program-analysis/hand/BROWSER-PART2.U.~3~ | 118 - .../program-analysis/hand/BROWSER-PART2.U.~4~ | 115 - .../program-analysis/hand/DATABASEFNS.U.~1~ | 190 - .../program-analysis/hand/DATABASEFNS.U.~2~ | 187 - .../program-analysis/hand/DATABASEFNS.U.~3~ | 185 - .../program-analysis/hand/DATABASEFNS.U.~4~ | 145 - .../env/program-analysis/hand/INSPECT.U.~1~ | 265 -- .../env/program-analysis/hand/INSPECT.U.~2~ | 263 -- .../env/program-analysis/hand/INSPECT.U.~3~ | 261 -- .../env/program-analysis/hand/INSPECT.U.~4~ | 228 - .../env/program-analysis/hand/INSPECT.U.~5~ | 228 - .../test/env/program-analysis/hand/SPY.U.~1~ | 264 -- .../test/env/program-analysis/hand/SPY.U.~2~ | 201 - .../test/env/program-analysis/hand/SPY.U.~3~ | 195 - .../program-analysis/hand/browser-part1.u.~1~ | 176 - .../program-analysis/hand/browser-part1.u.~2~ | 151 - .../program-analysis/hand/browser-part1.u.~3~ | Bin 5488 -> 0 bytes .../hand/databasefns.data.~1~ | 22 - .../hand/databasefns.data.~2~ | 22 - .../program-analysis/hand/masterscope.u.~1~ | 230 - .../program-analysis/hand/masterscope.u.~2~ | 220 - .../program-analysis/hand/masterscope.u.~3~ | 218 - .../program-analysis/hand/masterscope.u.~4~ | 216 - .../program-analysis/hand/masterscope.u.~5~ | 233 - .../program-analysis/hand/masterscope.u.~6~ | 220 - .../program-analysis/hand/masterscope.u.~7~ | 220 - library/.readme | 1 - library/CASH-FILE.DFASL.~1~ | Bin 4831 -> 0 bytes library/CASH-FILE.DFASL.~2~ | Bin 4831 -> 0 bytes library/CASH-FILE.DFASL.~3~ | Bin 4831 -> 0 bytes library/CASH-FILE.DFASL.~4~ | Bin 4825 -> 0 bytes library/COPYFILES.~1~ | 1 - library/DANDELIONKEYBOARDS.~1~ | 1 - library/DANDELIONKEYBOARDS.~2~ | 171 - library/DATABASEFNS.LCOM.~2~ | Bin 7624 -> 0 bytes library/DATABASEFNS.~1~ | 1 - library/DATABASEFNS.~2~ | 187 - library/DORADOKEYBOARDS.~1~ | 1 - library/DORADOKEYBOARDS.~2~ | 171 - library/DOSPRINT.~1~ | 56 - library/DOVEKEYBOARDS.~1~ | 1 - library/DOVEKEYBOARDS.~2~ | 171 - library/FILEBROWSER.~1~ | 1287 ------ library/FOREIGN-FUNCTIONS.~1~ | 1 - library/GRAPHER.~1~ | 3829 ----------------- library/GRAPHER.~3~ | 3199 -------------- library/IMAGEOBJ.~1~ | 302 -- library/KEYBOARDEDITOR.LCOM.~1~ | Bin 28406 -> 0 bytes library/KEYBOARDEDITOR.LCOM.~2~ | Bin 28389 -> 0 bytes library/KEYBOARDEDITOR.~1~ | 1 - library/MAIKOKEYBOARDS.~1~ | 1 - library/MAIKOKEYBOARDS.~2~ | Bin 9256 -> 0 bytes library/MASTERSCOPE.DFASL.~1~ | Bin 70332 -> 0 bytes library/MASTERSCOPE.DFASL.~3~ | Bin 70313 -> 0 bytes library/MASTERSCOPE.~1~ | 759 ---- library/MASTERSCOPE.~2~ | 1 - library/MASTERSCOPE.~3~ | 1 - library/MASTERSCOPE.~4~ | 1 - library/NSMAINTAIN.~1~ | 1 - library/PCTREE.~3~ | 251 -- library/POSTSCRIPTSTREAM.~1~ | 3729 ---------------- library/POSTSCRIPTSTREAM.~2~ | 2591 ----------- library/SAMEDIR.LCOM.~8~ | Bin 3484 -> 0 bytes library/SAMEDIR.~1~ | 1 - library/SAMEDIR.~2~ | 1 - library/SAMEDIR.~6~ | 1 - library/SAMEDIR.~7~ | 1 - library/SAMEDIR.~9~ | 1 - library/SEDIT-COMMONLISP.DFASL.~1~ | Bin 19774 -> 0 bytes library/SEDIT-COMMONLISP.~1~ | 1 - library/SKETCHELEMENTS.~1~ | 1 - library/TABLEBROWSER.~1~ | 1 - library/TABLEBROWSER.~2~ | 1 - library/TEDIT.~1~ | 1655 ------- library/TEDITABBREV.~1~ | 127 - library/TEDITCOMMAND.~1~ | 105 - library/TEDITFILE.~1~ | 1636 ------- library/TEDITFIND.~1~ | 632 --- library/TEDITFNKEYS.~2~ | 162 - library/TEDITFNKEYS.~3~ | 162 - library/TEXTOFD.~1~ | 1327 ------ library/TFBRAVO.~1~ | 1 - library/UNICODE.LCOM.~17~ | Bin 22583 -> 0 bytes library/UNICODE.~123~ | 7 - library/UNICODE.~166~ | 1 - library/UNIXCOMM.~1~ | 1 - library/UNIXPRINT.~1~ | 250 -- library/VIRTUALKEYBOARDS.~2~ | 1489 ------- library/VIRTUALKEYBOARDS.~5~ | 1489 ------- library/VIRTUALKEYBOARDS.~8~ | 1489 ------- library/lafite/LAFITE.~1~ | 500 --- library/lafite/LAFITEBROWSE.LCOM.~1~ | Bin 52039 -> 0 bytes library/lafite/LAFITEBROWSE.LCOM.~2~ | Bin 52417 -> 0 bytes library/lafite/LAFITEBROWSE.~1~ | 512 --- library/lafite/LAFITEBROWSE.~2~ | 153 - library/lafite/LAFITECOMMANDS.LCOM.~1~ | Bin 59005 -> 0 bytes library/lafite/LAFITECOMMANDS.LCOM.~2~ | Bin 59009 -> 0 bytes library/lafite/LAFITECOMMANDS.~1~ | 480 --- library/lafite/LAFITECOMMANDS.~2~ | 152 - library/lafite/LAFITEDECLS.~1~ | 223 - library/lafite/LAFITEFIND.~1~ | 97 - library/lafite/LAFITEFIND.~2~ | 191 - library/lafite/LAFITESEND.LCOM.~1~ | Bin 44962 -> 0 bytes library/lafite/LAFITESEND.LCOM.~2~ | Bin 45033 -> 0 bytes library/lafite/LAFITESEND.~1~ | 436 -- library/lafite/LAFITESEND.~2~ | 128 - library/lafite/LAFITESORT.~1~ | 90 - library/lafite/MAILSCAVENGE.LCOM.~1~ | Bin 11903 -> 0 bytes library/lafite/MAILSCAVENGE.LCOM.~2~ | Bin 11937 -> 0 bytes library/lafite/MAILSCAVENGE.~1~ | 105 - library/lafite/MAILSCAVENGE.~2~ | 1 - library/lafite/NEWNSMAIL.~1~ | 409 -- lispusers/BMENCODE.LCOM.~2~ | Bin 2996 -> 0 bytes lispusers/COMPAREDIRECTORIES.~270~ | 1 - lispusers/COMPAREDIRECTORIES.~271~ | 1 - lispusers/COMPAREDIRECTORIES.~274~ | 1 - lispusers/COMPAREDIRECTORIES.~2~ | 335 -- lispusers/COMPAREDIRECTORIES.~43~ | 145 - lispusers/COMPARESOURCES.LCOM.~3~ | Bin 10362 -> 0 bytes lispusers/COMPARESOURCES.~1~ | 1 - lispusers/COMPARESOURCES.~2~ | 1 - lispusers/COMPARESOURCES.~3~ | 1 - lispusers/COMPARETEXT.LCOM.~2~ | Bin 8347 -> 0 bytes lispusers/DICTTOOL.~1~ | 1 - lispusers/DICTTOOL.~2~ | 1369 ------ lispusers/DOC-OBJECTS.LCOM.~13~ | Bin 25604 -> 0 bytes lispusers/DOC-OBJECTS.~1~ | 1 - lispusers/DOC-OBJECTS.~7~ | 1 - lispusers/EVALOBJ.LCOM.~2~ | Bin 6568 -> 0 bytes lispusers/EVALOBJ.~1~ | 1 - lispusers/EVALOBJ.~2~ | 1 - lispusers/FILEWATCH.LCOM.~2~ | Bin 24656 -> 0 bytes lispusers/FILEWATCH.~1~ | 1 - lispusers/FILEWATCH.~2~ | Bin 59273 -> 0 bytes lispusers/LABEL.LCOM.~2~ | Bin 883 -> 0 bytes lispusers/LAFITETIMEDDELETE.~1~ | 1 - lispusers/LAFITETIMEDDELETE.~2~ | 228 - lispusers/LAMBDATRAN.LCOM.~2~ | Bin 3900 -> 0 bytes lispusers/LISPNERD.~1~ | 1 - lispusers/LISPNERD.~2~ | 1 - lispusers/NSDISPLAYSIZES.TEDIT.~2~ | Bin 6436 -> 0 bytes lispusers/NSDISPLAYSIZES.~2~ | 1 - lispusers/NSPROTECTION.LCOM.~2~ | Bin 23527 -> 0 bytes lispusers/NSPROTECTION.~1~ | 1 - lispusers/NSPROTECTION.~2~ | 225 - lispusers/PLOT.~1~ | 1 - lispusers/PLOT.~2~ | 2946 ------------- lispusers/PLOTOBJECTS.~1~ | 1 - lispusers/PLOTOBJECTS.~2~ | 1263 ------ lispusers/PRETTYFILEINDEX.LCOM.~2~ | Bin 41483 -> 0 bytes lispusers/PRETTYFILEINDEX.~1~ | 1 - lispusers/PRETTYFILEINDEX.~2~ | 166 - lispusers/READBRUSH.LCOM.~2~ | Bin 4299 -> 0 bytes lispusers/READBRUSH.~1~ | 1 - lispusers/READBRUSH.~2~ | 183 - lispusers/SETDEFAULTPRINTER.LCOM.~2~ | Bin 3044 -> 0 bytes lispusers/SETDEFAULTPRINTER.~1~ | 1 - lispusers/SETDEFAULTPRINTER.~2~ | 1 - lispusers/SIMPLIFY.LCOM.~2~ | Bin 1714 -> 0 bytes lispusers/TEDITDORADOKEYS.~1~ | 1 - lispusers/TEDITDORADOKEYS.~2~ | 1 - lispusers/TEDITKEY.~1~ | 1 - lispusers/TMAX-DATE.LCOM.~2~ | Bin 6476 -> 0 bytes lispusers/TMAX-ENDNOTE.LCOM.~2~ | Bin 9811 -> 0 bytes lispusers/TMAX-ENDNOTE.~1~ | 1 - lispusers/TMAX-ENDNOTE.~2~ | 1 - lispusers/TMAX-INDEX.LCOM.~2~ | Bin 17838 -> 0 bytes lispusers/TMAX-INDEX.~1~ | 1 - lispusers/TMAX-INDEX.~2~ | 186 - lispusers/TMAX-NGRAPH.LCOM.~2~ | Bin 9537 -> 0 bytes lispusers/TMAX-NGRAPH.~2~ | 1 - lispusers/TMAX-NGROUP.LCOM.~2~ | Bin 17978 -> 0 bytes lispusers/TMAX-NGROUP.~1~ | 1 - lispusers/TMAX-NGROUP.~2~ | 662 --- lispusers/TMAX-NUMBER.LCOM.~3~ | Bin 15075 -> 0 bytes lispusers/TMAX-NUMBER.~1~ | 1 - lispusers/TMAX-NUMBER.~2~ | 1 - lispusers/TMAX-XREF.LCOM.~3~ | Bin 10260 -> 0 bytes lispusers/TMAX.INDEX.~1~ | Bin 244 -> 0 bytes lispusers/TMAX.LCOM.~3~ | Bin 17647 -> 0 bytes lispusers/TMAX.TOC.~1~ | Bin 2115 -> 0 bytes lispusers/TMAX.~1~ | 1 - lispusers/TMAX.~2~ | 242 -- lispusers/TWODGRAPHICS.LCOM.~2~ | Bin 16320 -> 0 bytes lispusers/WDWHACKS.TEDIT.~1~ | Bin 3720 -> 0 bytes lispusers/WDWHACKS.TEDIT.~2~ | Bin 3768 -> 0 bytes lispusers/WDWHACKS.~1~ | 1 - lispusers/WDWHACKS.~2~ | 9 - lispusers/WHO-LINE.~1~ | 1 - lispusers/WHO-LINE.~2~ | 747 ---- lispusers/comparetext.~1~ | 654 --- lispusers/comparetext.~2~ | 660 --- obsolete/sources/MAPATOMS.~2~ | 1 - obsolete/sunloadup/FASTINIT.DFASL.~2~ | Bin 1430 -> 0 bytes obsolete/sunloadup/INIT.MAKEINITDSK.~1~ | 45 - obsolete/sunloadup/INIT.MAKEINITDSK.~2~ | 48 - obsolete/sunloadup/INIT.MAKEINITDSK.~3~ | 48 - obsolete/sunloadup/LOADFULL.LISP.~1~ | 30 - obsolete/sunloadup/LOADFULL.LISP.~2~ | 29 - obsolete/sunloadup/LOADUP-BIG.LISP.~1~ | Bin 3919 -> 0 bytes obsolete/sunloadup/LOADUP-BIG.LISP.~2~ | Bin 3993 -> 0 bytes obsolete/sunloadup/LOADUP.LISP.~1~ | Bin 3919 -> 0 bytes obsolete/sunloadup/LOADUP.LISP.~2~ | Bin 3911 -> 0 bytes obsolete/sunloadup/LOADUP.LISP.~3~ | Bin 3911 -> 0 bytes obsolete/sunloadup/LOADUP.LISP.~4~ | Bin 3995 -> 0 bytes obsolete/sunloadup/LOADUP.LISP.~5~ | Bin 3997 -> 0 bytes obsolete/sunloadup/LOADUP.LISP.~6~ | 96 - obsolete/sunloadup/LOADUP.LISP.~7~ | 96 - obsolete/sunloadup/LOADUP.LOG.~10~ | 1 - obsolete/sunloadup/LOADUP.LOG.~11~ | 1 - obsolete/sunloadup/LOADUP.LOG.~12~ | 1 - obsolete/sunloadup/LOADUP.LOG.~1~ | 335 -- obsolete/sunloadup/LOADUP.LOG.~2~ | 0 obsolete/sunloadup/LOADUP.LOG.~3~ | 1 - obsolete/sunloadup/LOADUP.LOG.~4~ | 1 - obsolete/sunloadup/LOADUP.LOG.~5~ | 1 - obsolete/sunloadup/LOADUP.LOG.~6~ | 1 - obsolete/sunloadup/LOADUP.LOG.~7~ | 1 - obsolete/sunloadup/LOADUP.LOG.~8~ | 1 - obsolete/sunloadup/LOADUP.LOG.~9~ | 1 - obsolete/sunloadup/SUNFONT.LCOM.~3~ | 1 - obsolete/sunloadup/SUNFONT.~3~ | 28 - sources/ACODE.LCOM.~5~ | Bin 19277 -> 0 bytes sources/ACODE.LCOM.~6~ | Bin 19294 -> 0 bytes sources/ACODE.~2~ | 392 -- sources/ACODE.~3~ | 1 - sources/ADIR.LCOM.~2~ | Bin 23208 -> 0 bytes sources/ADIR.LCOM.~4~ | Bin 23596 -> 0 bytes sources/ADIR.LCOM.~7~ | Bin 23850 -> 0 bytes sources/ADIR.~1~ | 1 - sources/ADIR.~4~ | 1 - sources/ADIR.~7~ | 1 - sources/ADISPLAY.~7~ | 1281 ------ sources/APRINT.LCOM.~1~ | Bin 24602 -> 0 bytes sources/APRINT.LCOM.~2~ | Bin 24748 -> 0 bytes sources/APRINT.~1~ | 1 - sources/APRINT.~2~ | 1 - sources/ASKUSER.LCOM.~1~ | Bin 11653 -> 0 bytes sources/ASKUSER.LCOM.~2~ | Bin 11847 -> 0 bytes sources/ASKUSER.LCOM.~3~ | Bin 11793 -> 0 bytes sources/ASKUSER.LCOM.~4~ | Bin 11782 -> 0 bytes sources/ASKUSER.LCOM.~5~ | Bin 12039 -> 0 bytes sources/ASKUSER.~1~ | 1 - sources/ASKUSER.~2~ | 1 - sources/ASKUSER.~3~ | 1 - sources/ASKUSER.~4~ | 1 - sources/ASKUSER.~5~ | 1 - sources/ATBL.LCOM.~4~ | Bin 35321 -> 0 bytes sources/ATBL.~1~ | 1 - sources/ATBL.~7~ | 1 - sources/ATTACHEDWINDOW.~3~ | 1 - sources/CMLARRAY-SUPPORT.~2~ | 726 ---- sources/CMLARRAYINSPECTOR.~2~ | 268 -- sources/CMLMODULES.DFASL.~4~ | Bin 2204 -> 0 bytes sources/CMLMODULES.~2~ | 1 - sources/CMLREADTABLE.~4~ | 1 - sources/CMLSMARTARGS.~2~ | 37 - sources/CMLWALK.dfasl.~1~ | Bin 11004 -> 0 bytes sources/CMLWALK.dfasl.~2~ | Bin 12710 -> 0 bytes sources/COREIO.LCOM.~1~ | Bin 16349 -> 0 bytes sources/COREIO.LCOM.~2~ | Bin 16410 -> 0 bytes sources/COREIO.~3~ | 1 - sources/COREIO.~4~ | 1 - sources/COURIER.~2~ | 751 ---- sources/DEXEC.LCOM.~11~ | Bin 4063 -> 0 bytes sources/DEXEC.LCOM.~12~ | Bin 4170 -> 0 bytes sources/DEXEC.~10~ | 1 - sources/DEXEC.~1~ | 1 - sources/DEXEC.~3~ | 1 - sources/DEXEC.~6~ | 1 - sources/DEXEC.~9~ | 1 - sources/DIRECTORY.LCOM.~1~ | Bin 10850 -> 0 bytes sources/DIRECTORY.~1~ | 1 - sources/DTDECLARE.~2~ | 1 - sources/FASLOAD.~1~ | 1 - sources/FASLOAD.~2~ | 1 - sources/FILEIO.~10~ | 1 - sources/FILEIO.~1~ | 1 - sources/FILEIO.~4~ | 1488 ------- sources/FILEIO.~5~ | 1487 ------- sources/FILEIO.~6~ | 1488 ------- sources/FILEIO.~7~ | 1 - sources/FILEIO.~8~ | 1 - sources/FILEIO.~9~ | 1 - sources/FONTPROFILE.~1~ | 1 - sources/HARDCOPY.LCOM.~6~ | Bin 48608 -> 0 bytes sources/HARDCOPY.~4~ | 1 - sources/HARDCOPY.~6~ | 1 - sources/INSPECT.LCOM.~7~ | Bin 47632 -> 0 bytes sources/INSPECT.~3~ | 35 - sources/INSPECT.~7~ | 35 - sources/INTERPRESS.LCOM.~6~ | Bin 60938 -> 0 bytes sources/INTERPRESS.~3~ | 1 - sources/INTERPRESS.~6~ | 1 - sources/IOCHAR.LCOM.~10~ | Bin 22579 -> 0 bytes sources/IOCHAR.LCOM.~5~ | Bin 22453 -> 0 bytes sources/IOCHAR.LCOM.~8~ | Bin 22466 -> 0 bytes sources/IOCHAR.LCOM.~9~ | Bin 22437 -> 0 bytes sources/IOCHAR.~1~ | 1 - sources/IOCHAR.~2~ | 1 - sources/IOCHAR.~3~ | 1 - sources/IOCHAR.~4~ | 1 - sources/IOCHAR.~5~ | 1 - sources/LLCHAR.LCOM.~1~ | Bin 23177 -> 0 bytes sources/LLCHAR.LCOM.~2~ | Bin 22278 -> 0 bytes sources/LLCHAR.~1~ | 865 ---- sources/LLCHAR.~2~ | 217 - sources/LLDATATYPE.~11~ | 1184 ----- sources/LLDISPLAY.LCOM.~2~ | 231 - sources/LLDISPLAY.~2~ | 1838 -------- sources/LLGC.~3~ | 296 -- sources/LLMVS.~1~ | 1 - sources/LLNEW.~15~ | 847 ---- sources/LLREAD.LCOM.~1~ | Bin 58688 -> 0 bytes sources/LLREAD.XLCOM | Bin 24825 -> 0 bytes sources/LLREAD.~1~ | 1666 ------- sources/LOADFNS.LCOM.~10~ | Bin 13466 -> 0 bytes sources/LOADFNS.~1~ | 1 - sources/LOADFNS.~7~ | 1 - sources/LOGOW.~2~ | 126 - sources/MAIKOETHER.LCOM.~2~ | Bin 6504 -> 0 bytes sources/MAIKOLOADUPFNS.LCOM.~1~ | Bin 8308 -> 0 bytes sources/MAIKOLOADUPFNS.LCOM.~2~ | Bin 9317 -> 0 bytes sources/MAIKOLOADUPFNS.~1~ | 589 --- sources/MAIKOLOADUPFNS.~2~ | 429 -- sources/NEWPRINTDEF.LCOM.~1~ | Bin 18491 -> 0 bytes sources/NEWPRINTDEF.LCOM.~2~ | Bin 18614 -> 0 bytes sources/NEWPRINTDEF.~1~ | 1 - sources/NEWPRINTDEF.~2~ | 1 - sources/PMAP.LCOM.~2~ | Bin 15707 -> 0 bytes sources/PMAP.LCOM.~3~ | Bin 15710 -> 0 bytes sources/PMAP.~2~ | 1 - sources/PRETTY.LCOM.~6~ | Bin 30039 -> 0 bytes sources/PRETTY.~3~ | 1 - sources/PRETTY.~6~ | 1 - sources/PRINTFN.LCOM.~4~ | Bin 6831 -> 0 bytes sources/PRINTFN.~3~ | 1 - sources/PRINTFN.~4~ | 1 - sources/RENAMEFNS.~2~ | 105 - sources/RENAMEMACROS.~2~ | 222 - sources/SEDIT-ATOMIC.DFASL.~1~ | Bin 16480 -> 0 bytes sources/SEDIT-ATOMIC.DFASL.~2~ | Bin 16733 -> 0 bytes sources/SEDIT-COMMANDS.DFASL.~3~ | Bin 52737 -> 0 bytes sources/SEDIT-COMMANDS.~1~ | 1 - sources/SEDIT-COMMANDS.~3~ | 1 - sources/SEDIT-CONVERT.dfasl.~1~ | Bin 1806 -> 0 bytes sources/SEDIT-CONVERT.dfasl.~2~ | Bin 2033 -> 0 bytes sources/SEDIT-WINDOW.DFASL.~1~ | Bin 33367 -> 0 bytes sources/SEDIT-WINDOW.DFASL.~2~ | Bin 30996 -> 0 bytes sources/SEDIT-WINDOW.~1~ | 1 - sources/SEDIT-WINDOW.~2~ | 1 - sources/TIME.LCOM.~4~ | Bin 9369 -> 0 bytes sources/TIME.~1~ | 1 - sources/TIME.~3~ | 1 - sources/TWODINSPECTOR.LCOM.~1~ | Bin 55277 -> 0 bytes sources/TWODINSPECTOR.~1~ | 661 --- sources/UFS.LCOM.~1~ | Bin 37135 -> 0 bytes sources/UFS.LCOM.~2~ | Bin 37179 -> 0 bytes sources/UFS.LCOM.~3~ | Bin 37187 -> 0 bytes sources/UFS.~1~ | 775 ---- sources/UFS.~2~ | 771 ---- sources/UFSCALLC.LCOM.~1~ | Bin 2428 -> 0 bytes sources/UFSCALLC.LCOM.~3~ | Bin 2563 -> 0 bytes sources/UFSCALLC.~1~ | 1 - sources/UFSCALLC.~2~ | 1 - sources/VMEM.LCOM.~2~ | Bin 6514 -> 0 bytes sources/XCLC-TOP-LEVEL.DFASL.~1~ | Bin 40650 -> 0 bytes sources/XCLC-TOP-LEVEL.DFASL.~9~ | Bin 41090 -> 0 bytes sources/XCLC-TOP-LEVEL.~10~ | 4 - sources/XCLC-TOP-LEVEL.~1~ | 1557 ------- 482 files changed, 86369 deletions(-) delete mode 100644 CLTL2/CMLDEFFER.~2~ delete mode 100644 CLTL2/I-NEW.~3~ delete mode 100644 CLTL2/LLARRAYELT.~2~ delete mode 100644 CLTL2/LLNEW.~2~ delete mode 100644 fonts/altofonts/fonts.widths.~1~ delete mode 100644 fonts/displayfonts/c0/GACHA08-MRR-C0.DISPLAYFONT.~1~ delete mode 100644 fonts/displayfonts/c0/GACHA10-MRR-C0.DISPLAYFONT.~1~ delete mode 100644 fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT.~1~ delete mode 100644 fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT.~1~ delete mode 100644 fontsold/displayfonts/printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~ delete mode 100644 greetfiles/INIT.LCOM.~1~ delete mode 100644 greetfiles/INIT.~1~ delete mode 100644 greetfiles/LOCAL-INIT.LCOM.~37~ delete mode 100644 greetfiles/LOCAL-INIT.LCOM.~38~ delete mode 100644 greetfiles/LOCAL-INIT.LCOM.~39~ delete mode 100644 greetfiles/LOCAL-INIT.LCOM.~40~ delete mode 100644 greetfiles/LOCAL-INIT.LCOM.~41~ delete mode 100644 greetfiles/LOCAL-INIT.~32~ delete mode 100644 greetfiles/LOCAL-INIT.~36~ delete mode 100644 greetfiles/LOCAL-INIT.~39~ delete mode 100644 greetfiles/LOCAL-INIT.~41~ delete mode 100644 greetfiles/LOCAL-INIT.~42~ delete mode 100644 greetfiles/LOCAL-INIT.~43~ delete mode 100644 greetfiles/LOCAL-INIT.~44~ delete mode 100644 greetfiles/LOCAL-INIT.~45~ delete mode 100644 greetfiles/SIMPLE-INIT.~1~ delete mode 100644 greetfiles/SIMPLE-INIT.~2~ delete mode 100644 internal/library/ARCLEANUP.~1~ delete mode 100644 internal/library/CALENDARHACKS.~3~ delete mode 100644 internal/library/CONDITIONGRAPH.~2~ delete mode 100644 internal/library/GIVE-AND-TAKE.~2~ delete mode 100644 internal/library/MULTI-COMPILE.~4~ delete mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ delete mode 100644 internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ delete mode 100644 internal/test/IO/Keyboard/logs/keyboard.log.~1~ delete mode 100644 internal/test/IO/Keyboard/logs/keyboard.log.~2~ delete mode 100644 internal/test/IO/Keyboard/logs/keyboard.log.~3~ delete mode 100644 internal/test/Library/TEDIT/hand-aux/.read-me-first.~1~ delete mode 100644 internal/test/Library/TEDIT/hand-aux/.read-me-first.~2~ delete mode 100644 internal/test/Library/TEDIT/hand-aux/.read-me-first.~3~ delete mode 100644 internal/test/env/DEdit/high-level.u.~1~ delete mode 100644 internal/test/env/DEdit/high-level.u.~2~ delete mode 100644 internal/test/env/Debugger/hand/BreakWindow.u.~1~ delete mode 100644 internal/test/env/Debugger/hand/BreakWindow.u.~2~ delete mode 100644 internal/test/env/Debugger/hand/BreakWindow.u.~3~ delete mode 100644 internal/test/env/Debugger/hand/debugger.u.~1~ delete mode 100644 internal/test/env/Debugger/hand/debugger.u.~2~ delete mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ delete mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ delete mode 100644 internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~1~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~2~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~3~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~4~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~5~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~6~ delete mode 100644 internal/test/env/Debugger/logs/debugger.log.~7~ delete mode 100644 internal/test/env/Exec/Hand/DA.U.~1~ delete mode 100644 internal/test/env/Exec/Hand/DA.U.~2~ delete mode 100644 internal/test/env/Exec/Logs/Exec.log.~1~ delete mode 100644 internal/test/env/Exec/Logs/Exec.log.~2~ delete mode 100644 internal/test/env/Exec/Logs/Exec.log.~3~ delete mode 100644 internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-arglist.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-arglist.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-extract.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-extract.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-find.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-find.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-high.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-high.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-join.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-join.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-menu.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-menu.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-meta-o.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-meta-o.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-mutate.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-mutate.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-paren.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-paren.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-substitute.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-substitute.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Control.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Control.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/Interrupt.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/Interrupt.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ delete mode 100644 internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ delete mode 100644 internal/test/env/code-editor/hand/command-package.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/command-package.u.~2~ delete mode 100644 internal/test/env/code-editor/hand/command-skip-next.u.~1~ delete mode 100644 internal/test/env/code-editor/hand/command-skip-next.u.~2~ delete mode 100644 internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ delete mode 100644 internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ delete mode 100644 internal/test/env/inspector/hand/inspect-macro.tedit.~1~ delete mode 100644 internal/test/env/inspector/hand/inspect-macro.tedit.~2~ delete mode 100644 internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ delete mode 100644 internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ delete mode 100644 internal/test/env/inspector/hand/inspectw.tedit.~1~ delete mode 100644 internal/test/env/inspector/hand/inspectw.tedit.~2~ delete mode 100644 internal/test/env/inspector/hand/userdef.test.~1~ delete mode 100644 internal/test/env/inspector/hand/userdef.test.~2~ delete mode 100644 internal/test/env/inspector/logs/inspect-defstruct.log.~1~ delete mode 100644 internal/test/env/inspector/logs/inspect-defstruct.log.~2~ delete mode 100644 internal/test/env/process-controls/hand/PSW.U.~1~ delete mode 100644 internal/test/env/process-controls/hand/PSW.U.~2~ delete mode 100644 internal/test/env/process-controls/hand/PSW.U.~3~ delete mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ delete mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ delete mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ delete mode 100644 internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ delete mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ delete mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ delete mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ delete mode 100644 internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ delete mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~1~ delete mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~2~ delete mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~3~ delete mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~4~ delete mode 100644 internal/test/env/program-analysis/hand/INSPECT.U.~5~ delete mode 100644 internal/test/env/program-analysis/hand/SPY.U.~1~ delete mode 100644 internal/test/env/program-analysis/hand/SPY.U.~2~ delete mode 100644 internal/test/env/program-analysis/hand/SPY.U.~3~ delete mode 100644 internal/test/env/program-analysis/hand/browser-part1.u.~1~ delete mode 100644 internal/test/env/program-analysis/hand/browser-part1.u.~2~ delete mode 100644 internal/test/env/program-analysis/hand/browser-part1.u.~3~ delete mode 100644 internal/test/env/program-analysis/hand/databasefns.data.~1~ delete mode 100644 internal/test/env/program-analysis/hand/databasefns.data.~2~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~1~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~2~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~3~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~4~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~5~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~6~ delete mode 100644 internal/test/env/program-analysis/hand/masterscope.u.~7~ delete mode 100644 library/.readme delete mode 100644 library/CASH-FILE.DFASL.~1~ delete mode 100644 library/CASH-FILE.DFASL.~2~ delete mode 100644 library/CASH-FILE.DFASL.~3~ delete mode 100644 library/CASH-FILE.DFASL.~4~ delete mode 100644 library/COPYFILES.~1~ delete mode 100644 library/DANDELIONKEYBOARDS.~1~ delete mode 100644 library/DANDELIONKEYBOARDS.~2~ delete mode 100644 library/DATABASEFNS.LCOM.~2~ delete mode 100644 library/DATABASEFNS.~1~ delete mode 100644 library/DATABASEFNS.~2~ delete mode 100644 library/DORADOKEYBOARDS.~1~ delete mode 100644 library/DORADOKEYBOARDS.~2~ delete mode 100644 library/DOSPRINT.~1~ delete mode 100644 library/DOVEKEYBOARDS.~1~ delete mode 100644 library/DOVEKEYBOARDS.~2~ delete mode 100644 library/FILEBROWSER.~1~ delete mode 100644 library/FOREIGN-FUNCTIONS.~1~ delete mode 100644 library/GRAPHER.~1~ delete mode 100644 library/GRAPHER.~3~ delete mode 100644 library/IMAGEOBJ.~1~ delete mode 100644 library/KEYBOARDEDITOR.LCOM.~1~ delete mode 100644 library/KEYBOARDEDITOR.LCOM.~2~ delete mode 100644 library/KEYBOARDEDITOR.~1~ delete mode 100644 library/MAIKOKEYBOARDS.~1~ delete mode 100644 library/MAIKOKEYBOARDS.~2~ delete mode 100644 library/MASTERSCOPE.DFASL.~1~ delete mode 100644 library/MASTERSCOPE.DFASL.~3~ delete mode 100644 library/MASTERSCOPE.~1~ delete mode 100644 library/MASTERSCOPE.~2~ delete mode 100644 library/MASTERSCOPE.~3~ delete mode 100644 library/MASTERSCOPE.~4~ delete mode 100644 library/NSMAINTAIN.~1~ delete mode 100644 library/PCTREE.~3~ delete mode 100644 library/POSTSCRIPTSTREAM.~1~ delete mode 100644 library/POSTSCRIPTSTREAM.~2~ delete mode 100644 library/SAMEDIR.LCOM.~8~ delete mode 100644 library/SAMEDIR.~1~ delete mode 100644 library/SAMEDIR.~2~ delete mode 100644 library/SAMEDIR.~6~ delete mode 100644 library/SAMEDIR.~7~ delete mode 100644 library/SAMEDIR.~9~ delete mode 100644 library/SEDIT-COMMONLISP.DFASL.~1~ delete mode 100644 library/SEDIT-COMMONLISP.~1~ delete mode 100644 library/SKETCHELEMENTS.~1~ delete mode 100644 library/TABLEBROWSER.~1~ delete mode 100644 library/TABLEBROWSER.~2~ delete mode 100644 library/TEDIT.~1~ delete mode 100644 library/TEDITABBREV.~1~ delete mode 100644 library/TEDITCOMMAND.~1~ delete mode 100644 library/TEDITFILE.~1~ delete mode 100644 library/TEDITFIND.~1~ delete mode 100644 library/TEDITFNKEYS.~2~ delete mode 100644 library/TEDITFNKEYS.~3~ delete mode 100644 library/TEXTOFD.~1~ delete mode 100644 library/TFBRAVO.~1~ delete mode 100644 library/UNICODE.LCOM.~17~ delete mode 100644 library/UNICODE.~123~ delete mode 100644 library/UNICODE.~166~ delete mode 100644 library/UNIXCOMM.~1~ delete mode 100644 library/UNIXPRINT.~1~ delete mode 100644 library/VIRTUALKEYBOARDS.~2~ delete mode 100644 library/VIRTUALKEYBOARDS.~5~ delete mode 100644 library/VIRTUALKEYBOARDS.~8~ delete mode 100644 library/lafite/LAFITE.~1~ delete mode 100644 library/lafite/LAFITEBROWSE.LCOM.~1~ delete mode 100644 library/lafite/LAFITEBROWSE.LCOM.~2~ delete mode 100644 library/lafite/LAFITEBROWSE.~1~ delete mode 100644 library/lafite/LAFITEBROWSE.~2~ delete mode 100644 library/lafite/LAFITECOMMANDS.LCOM.~1~ delete mode 100644 library/lafite/LAFITECOMMANDS.LCOM.~2~ delete mode 100644 library/lafite/LAFITECOMMANDS.~1~ delete mode 100644 library/lafite/LAFITECOMMANDS.~2~ delete mode 100644 library/lafite/LAFITEDECLS.~1~ delete mode 100644 library/lafite/LAFITEFIND.~1~ delete mode 100644 library/lafite/LAFITEFIND.~2~ delete mode 100644 library/lafite/LAFITESEND.LCOM.~1~ delete mode 100644 library/lafite/LAFITESEND.LCOM.~2~ delete mode 100644 library/lafite/LAFITESEND.~1~ delete mode 100644 library/lafite/LAFITESEND.~2~ delete mode 100644 library/lafite/LAFITESORT.~1~ delete mode 100644 library/lafite/MAILSCAVENGE.LCOM.~1~ delete mode 100644 library/lafite/MAILSCAVENGE.LCOM.~2~ delete mode 100644 library/lafite/MAILSCAVENGE.~1~ delete mode 100644 library/lafite/MAILSCAVENGE.~2~ delete mode 100644 library/lafite/NEWNSMAIL.~1~ delete mode 100644 lispusers/BMENCODE.LCOM.~2~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~270~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~271~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~274~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~2~ delete mode 100644 lispusers/COMPAREDIRECTORIES.~43~ delete mode 100644 lispusers/COMPARESOURCES.LCOM.~3~ delete mode 100644 lispusers/COMPARESOURCES.~1~ delete mode 100644 lispusers/COMPARESOURCES.~2~ delete mode 100644 lispusers/COMPARESOURCES.~3~ delete mode 100644 lispusers/COMPARETEXT.LCOM.~2~ delete mode 100644 lispusers/DICTTOOL.~1~ delete mode 100644 lispusers/DICTTOOL.~2~ delete mode 100644 lispusers/DOC-OBJECTS.LCOM.~13~ delete mode 100644 lispusers/DOC-OBJECTS.~1~ delete mode 100644 lispusers/DOC-OBJECTS.~7~ delete mode 100644 lispusers/EVALOBJ.LCOM.~2~ delete mode 100644 lispusers/EVALOBJ.~1~ delete mode 100644 lispusers/EVALOBJ.~2~ delete mode 100644 lispusers/FILEWATCH.LCOM.~2~ delete mode 100644 lispusers/FILEWATCH.~1~ delete mode 100644 lispusers/FILEWATCH.~2~ delete mode 100644 lispusers/LABEL.LCOM.~2~ delete mode 100644 lispusers/LAFITETIMEDDELETE.~1~ delete mode 100644 lispusers/LAFITETIMEDDELETE.~2~ delete mode 100644 lispusers/LAMBDATRAN.LCOM.~2~ delete mode 100644 lispusers/LISPNERD.~1~ delete mode 100644 lispusers/LISPNERD.~2~ delete mode 100644 lispusers/NSDISPLAYSIZES.TEDIT.~2~ delete mode 100644 lispusers/NSDISPLAYSIZES.~2~ delete mode 100644 lispusers/NSPROTECTION.LCOM.~2~ delete mode 100644 lispusers/NSPROTECTION.~1~ delete mode 100644 lispusers/NSPROTECTION.~2~ delete mode 100644 lispusers/PLOT.~1~ delete mode 100644 lispusers/PLOT.~2~ delete mode 100644 lispusers/PLOTOBJECTS.~1~ delete mode 100644 lispusers/PLOTOBJECTS.~2~ delete mode 100644 lispusers/PRETTYFILEINDEX.LCOM.~2~ delete mode 100644 lispusers/PRETTYFILEINDEX.~1~ delete mode 100644 lispusers/PRETTYFILEINDEX.~2~ delete mode 100644 lispusers/READBRUSH.LCOM.~2~ delete mode 100644 lispusers/READBRUSH.~1~ delete mode 100644 lispusers/READBRUSH.~2~ delete mode 100644 lispusers/SETDEFAULTPRINTER.LCOM.~2~ delete mode 100644 lispusers/SETDEFAULTPRINTER.~1~ delete mode 100644 lispusers/SETDEFAULTPRINTER.~2~ delete mode 100644 lispusers/SIMPLIFY.LCOM.~2~ delete mode 100644 lispusers/TEDITDORADOKEYS.~1~ delete mode 100644 lispusers/TEDITDORADOKEYS.~2~ delete mode 100644 lispusers/TEDITKEY.~1~ delete mode 100644 lispusers/TMAX-DATE.LCOM.~2~ delete mode 100644 lispusers/TMAX-ENDNOTE.LCOM.~2~ delete mode 100644 lispusers/TMAX-ENDNOTE.~1~ delete mode 100644 lispusers/TMAX-ENDNOTE.~2~ delete mode 100644 lispusers/TMAX-INDEX.LCOM.~2~ delete mode 100644 lispusers/TMAX-INDEX.~1~ delete mode 100644 lispusers/TMAX-INDEX.~2~ delete mode 100644 lispusers/TMAX-NGRAPH.LCOM.~2~ delete mode 100644 lispusers/TMAX-NGRAPH.~2~ delete mode 100644 lispusers/TMAX-NGROUP.LCOM.~2~ delete mode 100644 lispusers/TMAX-NGROUP.~1~ delete mode 100644 lispusers/TMAX-NGROUP.~2~ delete mode 100644 lispusers/TMAX-NUMBER.LCOM.~3~ delete mode 100644 lispusers/TMAX-NUMBER.~1~ delete mode 100644 lispusers/TMAX-NUMBER.~2~ delete mode 100644 lispusers/TMAX-XREF.LCOM.~3~ delete mode 100644 lispusers/TMAX.INDEX.~1~ delete mode 100644 lispusers/TMAX.LCOM.~3~ delete mode 100644 lispusers/TMAX.TOC.~1~ delete mode 100644 lispusers/TMAX.~1~ delete mode 100644 lispusers/TMAX.~2~ delete mode 100644 lispusers/TWODGRAPHICS.LCOM.~2~ delete mode 100644 lispusers/WDWHACKS.TEDIT.~1~ delete mode 100644 lispusers/WDWHACKS.TEDIT.~2~ delete mode 100644 lispusers/WDWHACKS.~1~ delete mode 100644 lispusers/WDWHACKS.~2~ delete mode 100644 lispusers/WHO-LINE.~1~ delete mode 100644 lispusers/WHO-LINE.~2~ delete mode 100644 lispusers/comparetext.~1~ delete mode 100644 lispusers/comparetext.~2~ delete mode 100644 obsolete/sources/MAPATOMS.~2~ delete mode 100644 obsolete/sunloadup/FASTINIT.DFASL.~2~ delete mode 100644 obsolete/sunloadup/INIT.MAKEINITDSK.~1~ delete mode 100644 obsolete/sunloadup/INIT.MAKEINITDSK.~2~ delete mode 100644 obsolete/sunloadup/INIT.MAKEINITDSK.~3~ delete mode 100644 obsolete/sunloadup/LOADFULL.LISP.~1~ delete mode 100644 obsolete/sunloadup/LOADFULL.LISP.~2~ delete mode 100644 obsolete/sunloadup/LOADUP-BIG.LISP.~1~ delete mode 100644 obsolete/sunloadup/LOADUP-BIG.LISP.~2~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~1~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~2~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~3~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~4~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~5~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~6~ delete mode 100644 obsolete/sunloadup/LOADUP.LISP.~7~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~10~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~11~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~12~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~1~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~2~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~3~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~4~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~5~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~6~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~7~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~8~ delete mode 100644 obsolete/sunloadup/LOADUP.LOG.~9~ delete mode 100644 obsolete/sunloadup/SUNFONT.LCOM.~3~ delete mode 100644 obsolete/sunloadup/SUNFONT.~3~ delete mode 100644 sources/ACODE.LCOM.~5~ delete mode 100644 sources/ACODE.LCOM.~6~ delete mode 100644 sources/ACODE.~2~ delete mode 100644 sources/ACODE.~3~ delete mode 100644 sources/ADIR.LCOM.~2~ delete mode 100644 sources/ADIR.LCOM.~4~ delete mode 100644 sources/ADIR.LCOM.~7~ delete mode 100644 sources/ADIR.~1~ delete mode 100644 sources/ADIR.~4~ delete mode 100644 sources/ADIR.~7~ delete mode 100644 sources/ADISPLAY.~7~ delete mode 100644 sources/APRINT.LCOM.~1~ delete mode 100644 sources/APRINT.LCOM.~2~ delete mode 100644 sources/APRINT.~1~ delete mode 100644 sources/APRINT.~2~ delete mode 100644 sources/ASKUSER.LCOM.~1~ delete mode 100644 sources/ASKUSER.LCOM.~2~ delete mode 100644 sources/ASKUSER.LCOM.~3~ delete mode 100644 sources/ASKUSER.LCOM.~4~ delete mode 100644 sources/ASKUSER.LCOM.~5~ delete mode 100644 sources/ASKUSER.~1~ delete mode 100644 sources/ASKUSER.~2~ delete mode 100644 sources/ASKUSER.~3~ delete mode 100644 sources/ASKUSER.~4~ delete mode 100644 sources/ASKUSER.~5~ delete mode 100644 sources/ATBL.LCOM.~4~ delete mode 100644 sources/ATBL.~1~ delete mode 100644 sources/ATBL.~7~ delete mode 100644 sources/ATTACHEDWINDOW.~3~ delete mode 100644 sources/CMLARRAY-SUPPORT.~2~ delete mode 100644 sources/CMLARRAYINSPECTOR.~2~ delete mode 100644 sources/CMLMODULES.DFASL.~4~ delete mode 100644 sources/CMLMODULES.~2~ delete mode 100644 sources/CMLREADTABLE.~4~ delete mode 100644 sources/CMLSMARTARGS.~2~ delete mode 100644 sources/CMLWALK.dfasl.~1~ delete mode 100644 sources/CMLWALK.dfasl.~2~ delete mode 100644 sources/COREIO.LCOM.~1~ delete mode 100644 sources/COREIO.LCOM.~2~ delete mode 100644 sources/COREIO.~3~ delete mode 100644 sources/COREIO.~4~ delete mode 100644 sources/COURIER.~2~ delete mode 100644 sources/DEXEC.LCOM.~11~ delete mode 100644 sources/DEXEC.LCOM.~12~ delete mode 100644 sources/DEXEC.~10~ delete mode 100644 sources/DEXEC.~1~ delete mode 100644 sources/DEXEC.~3~ delete mode 100644 sources/DEXEC.~6~ delete mode 100644 sources/DEXEC.~9~ delete mode 100644 sources/DIRECTORY.LCOM.~1~ delete mode 100644 sources/DIRECTORY.~1~ delete mode 100644 sources/DTDECLARE.~2~ delete mode 100644 sources/FASLOAD.~1~ delete mode 100644 sources/FASLOAD.~2~ delete mode 100644 sources/FILEIO.~10~ delete mode 100644 sources/FILEIO.~1~ delete mode 100644 sources/FILEIO.~4~ delete mode 100644 sources/FILEIO.~5~ delete mode 100644 sources/FILEIO.~6~ delete mode 100644 sources/FILEIO.~7~ delete mode 100644 sources/FILEIO.~8~ delete mode 100644 sources/FILEIO.~9~ delete mode 100644 sources/FONTPROFILE.~1~ delete mode 100644 sources/HARDCOPY.LCOM.~6~ delete mode 100644 sources/HARDCOPY.~4~ delete mode 100644 sources/HARDCOPY.~6~ delete mode 100644 sources/INSPECT.LCOM.~7~ delete mode 100644 sources/INSPECT.~3~ delete mode 100644 sources/INSPECT.~7~ delete mode 100644 sources/INTERPRESS.LCOM.~6~ delete mode 100644 sources/INTERPRESS.~3~ delete mode 100644 sources/INTERPRESS.~6~ delete mode 100644 sources/IOCHAR.LCOM.~10~ delete mode 100644 sources/IOCHAR.LCOM.~5~ delete mode 100644 sources/IOCHAR.LCOM.~8~ delete mode 100644 sources/IOCHAR.LCOM.~9~ delete mode 100644 sources/IOCHAR.~1~ delete mode 100644 sources/IOCHAR.~2~ delete mode 100644 sources/IOCHAR.~3~ delete mode 100644 sources/IOCHAR.~4~ delete mode 100644 sources/IOCHAR.~5~ delete mode 100644 sources/LLCHAR.LCOM.~1~ delete mode 100644 sources/LLCHAR.LCOM.~2~ delete mode 100644 sources/LLCHAR.~1~ delete mode 100644 sources/LLCHAR.~2~ delete mode 100644 sources/LLDATATYPE.~11~ delete mode 100644 sources/LLDISPLAY.LCOM.~2~ delete mode 100644 sources/LLDISPLAY.~2~ delete mode 100644 sources/LLGC.~3~ delete mode 100644 sources/LLMVS.~1~ delete mode 100644 sources/LLNEW.~15~ delete mode 100644 sources/LLREAD.LCOM.~1~ delete mode 100644 sources/LLREAD.XLCOM delete mode 100644 sources/LLREAD.~1~ delete mode 100644 sources/LOADFNS.LCOM.~10~ delete mode 100644 sources/LOADFNS.~1~ delete mode 100644 sources/LOADFNS.~7~ delete mode 100644 sources/LOGOW.~2~ delete mode 100644 sources/MAIKOETHER.LCOM.~2~ delete mode 100644 sources/MAIKOLOADUPFNS.LCOM.~1~ delete mode 100644 sources/MAIKOLOADUPFNS.LCOM.~2~ delete mode 100644 sources/MAIKOLOADUPFNS.~1~ delete mode 100644 sources/MAIKOLOADUPFNS.~2~ delete mode 100644 sources/NEWPRINTDEF.LCOM.~1~ delete mode 100644 sources/NEWPRINTDEF.LCOM.~2~ delete mode 100644 sources/NEWPRINTDEF.~1~ delete mode 100644 sources/NEWPRINTDEF.~2~ delete mode 100644 sources/PMAP.LCOM.~2~ delete mode 100644 sources/PMAP.LCOM.~3~ delete mode 100644 sources/PMAP.~2~ delete mode 100644 sources/PRETTY.LCOM.~6~ delete mode 100644 sources/PRETTY.~3~ delete mode 100644 sources/PRETTY.~6~ delete mode 100644 sources/PRINTFN.LCOM.~4~ delete mode 100644 sources/PRINTFN.~3~ delete mode 100644 sources/PRINTFN.~4~ delete mode 100644 sources/RENAMEFNS.~2~ delete mode 100644 sources/RENAMEMACROS.~2~ delete mode 100644 sources/SEDIT-ATOMIC.DFASL.~1~ delete mode 100644 sources/SEDIT-ATOMIC.DFASL.~2~ delete mode 100644 sources/SEDIT-COMMANDS.DFASL.~3~ delete mode 100644 sources/SEDIT-COMMANDS.~1~ delete mode 100644 sources/SEDIT-COMMANDS.~3~ delete mode 100644 sources/SEDIT-CONVERT.dfasl.~1~ delete mode 100644 sources/SEDIT-CONVERT.dfasl.~2~ delete mode 100644 sources/SEDIT-WINDOW.DFASL.~1~ delete mode 100644 sources/SEDIT-WINDOW.DFASL.~2~ delete mode 100644 sources/SEDIT-WINDOW.~1~ delete mode 100644 sources/SEDIT-WINDOW.~2~ delete mode 100644 sources/TIME.LCOM.~4~ delete mode 100644 sources/TIME.~1~ delete mode 100644 sources/TIME.~3~ delete mode 100644 sources/TWODINSPECTOR.LCOM.~1~ delete mode 100644 sources/TWODINSPECTOR.~1~ delete mode 100644 sources/UFS.LCOM.~1~ delete mode 100644 sources/UFS.LCOM.~2~ delete mode 100644 sources/UFS.LCOM.~3~ delete mode 100644 sources/UFS.~1~ delete mode 100644 sources/UFS.~2~ delete mode 100644 sources/UFSCALLC.LCOM.~1~ delete mode 100644 sources/UFSCALLC.LCOM.~3~ delete mode 100644 sources/UFSCALLC.~1~ delete mode 100644 sources/UFSCALLC.~2~ delete mode 100644 sources/VMEM.LCOM.~2~ delete mode 100644 sources/XCLC-TOP-LEVEL.DFASL.~1~ delete mode 100644 sources/XCLC-TOP-LEVEL.DFASL.~9~ delete mode 100644 sources/XCLC-TOP-LEVEL.~10~ delete mode 100644 sources/XCLC-TOP-LEVEL.~1~ diff --git a/CLTL2/CMLDEFFER.~2~ b/CLTL2/CMLDEFFER.~2~ deleted file mode 100644 index d4c2e7c2..00000000 --- a/CLTL2/CMLDEFFER.~2~ +++ /dev/null @@ -1,248 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") -(IL:FILECREATED "24-Mar-92 14:56:18" IL:|{DSK}local>lde>lispcore>sources>CMLDEFFER.;3| 40644 - - IL:|changes| IL:|to:| (IL:VARS IL:CMLDEFFERCOMS) - - IL:|previous| IL:|date:| " 4-Jan-92 15:32:26" -IL:|{DSK}local>lde>lispcore>sources>CMLDEFFER.;2|) - - -; Copyright (c) 1986, 1900, 1987, 1988, 1990, 1992 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 (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN)) (IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF)) (IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE 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 (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))) (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%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 DEFINER-VARIABLE-TYPE NAMED-PROGN)) (IL:COMS (IL:* IL:\; "Auxiliary functions") (IL:FUNCTIONS GET-DEFINER-NAME %DELETE-DEFINER) (IL:FUNCTIONS DEF-DEFINE-TYPE DEFDEFINER DEFDEFINER-VARIABLE-TYPE) (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) (QUOTE IL:*)) (CONSP (CDAR X)) (OR (MEMBER (CADAR X) (QUOTE (IL:\; IL:|;;| IL:|;;;| IL:|;;;;| IL:\|)) :TEST (FUNCTION EQ)) (IL:* IL:\; "a sedit comment") (EQ IL:*REMOVE-INTERLISP-COMMENTS* T) (IL:* IL:\; "always strip") (PROGN (IF (EQ IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :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) (QUOTE (: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 NIL (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* (QUOTE :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 (QUOTE :UNDEFINERS)) (GET TYPE (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) (DOLIST (FN (OR (GET (CAR DEFN) (QUOTE :UNDEFINERS)) (GET (CAR DEFN) (QUOTE 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 (QUOTE IL:EDIT) OPTIONS :TEST (FUNCTION EQ))) (T (EQ OPTIONS (QUOTE 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 (FUNCTION (LAMBDA (NAME) (LET ((DEF (%DEFINE-TYPE-GETDEF NAME TYPE (QUOTE (IL:NOCOPY))))) (IF (NULL DEF) (ERROR (QUOTE 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 (QUOTE IL:GETDEF) (IL:* IL:|;;| "The bletcherous lambda form is require by the interface to loadfns (can't pass a closure)") (IL:BQUOTE (IL:LAMBDA (FIRST SECOND) (AND (MEMBER FIRST (QUOTE (IL:\\\, (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))))) :TEST (FUNCTION EQ)) (LET ((NAMER (OR (GET FIRST (QUOTE :DEFINITION-NAME)) (GET FIRST (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)))) (IF (EQ NAMER (QUOTE SECOND)) (EQUAL SECOND (QUOTE (IL:\\\, NAME))) (EQUAL (FUNCALL NAMER (REMOVE-COMMENTS (IL:READ))) (QUOTE (IL:\\\, NAME))))))))))) (COND ((EQ (CAAR VAL) (QUOTE IL:NOT-FOUND\:)) NOTFOUND) ((CDR VAL) (CONS (QUOTE PROGN) VAL)) (T (CAR VAL))))) - -(DEFUN %DEFINE-TYPE-SAVE-DEFN (NAME TYPE DEFINITION) (SETQ TYPE (IL:GETFILEPKGTYPE TYPE (QUOTE 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 (FUNCTION 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 (QUOTE (IL:PROP IL:ALLPROP)) :TEST (FUNCTION EQ)))) (IL:/PUTHASH NAME DEFINITION HASH-TABLE) (IL:MARKASCHANGED NAME TYPE (IF OLD-DEFINITION (QUOTE IL:CHANGED) (QUOTE 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 (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))) :TEST (FUNCTION EQ)) (EQUAL NAME (FUNCALL (OR (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE :DEFINITION-NAME)) (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)) DEFN-WITHOUT-COMMENTS))) (SIGNAL (QUOTE 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 (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF)) - -(IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF)) - -(IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS)) - -(IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF)) - -(IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN)) - -(IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF)) - -(IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER)) -) -(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD - -(IL:* IL:|;;| "Set up fake definer prototype stuff for FNS") - -(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))) - -(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%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 (QUOTE SI::$$MACRO-FORM) BODY NAME NIL :ENVIRONMENT (QUOTE SI::$$MACRO-ENVIRONMENT)) (VALUES (IL:BQUOTE (LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT) (IL:\\\,@ PARSED-DECLARATIONS) (BLOCK (IL:\\\, NAME) (IL:\\\, 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) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (IL:\\\,@ BODY)) (EVAL-WHEN (EVAL) (UNLESS (OR (EQ IL:DFNFLG (QUOTE IL:PROP)) (EQ IL:DFNFLG (QUOTE IL:ALLPROP))) (LET ((IL:FILEPKGFLG NIL) (IL:DFNFLG T)) (IL:\\\,@ BODY))))))) - - - -(IL:* IL:\; "Compatibility with old cmldeffer") - - -(DEFMACRO IL:WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (WITHOUT-FILEPKG (IL:\\\,@ 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))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME)))))) - -(DEFMACRO DEFINER-VARIABLE-TYPE (NAME DEFINITION &OPTIONAL ENV) (LET* ((DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (TYPE (FUNCALL (GET NAME :TYPE-DISCRIMINATOR) DEFINITION-WITHOUT-COMMENTS)) (EXPANDER (GETF (GET NAME :DEFINITION-EXPANDER) TYPE)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME)))))) - -(DEFMACRO NAMED-PROGN (DEFINER NAME &REST FORMS) (IL:* IL:|;;| "Used by the compiler when processing definers") (IL:BQUOTE (PROGN (IL:\\\,@ FORMS) (QUOTE (IL:\\\, NAME))))) - - - -(IL:* IL:\; "Auxiliary functions") - - -(DEFUN GET-DEFINER-NAME (DEFINER STRING) (VALUES (INTERN (CONCATENATE (QUOTE STRING) STRING (STRING DEFINER)) (SYMBOL-PACKAGE DEFINER)))) - -(DEFUN %DELETE-DEFINER (NAME) (AND (SYMBOLP NAME) (LET ((TYPE (OR (GET NAME (QUOTE :DEFINER-FOR)) (GET NAME (QUOTE IL:DEFINER-FOR))))) (IL:/REMPROP NAME (QUOTE :DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE IL:DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE :DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE IL:DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE :DEFINITION-EXPANDER)) (WHEN TYPE (IF (GET TYPE (QUOTE :DEFINED-BY)) (IL:/PUTPROP TYPE (QUOTE :DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE :DEFINED-BY)))) (IL:/PUTPROP TYPE (QUOTE IL:DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE IL:DEFINED-BY))))) (IL:* IL:|;;| "need to remove the prototype function!") (LET* ((LOOKUP-TYPE (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST (FUNCTION EQ)))) (IL:/RPLACD LOOKUP-TYPE (REMOVE NAME (CDR LOOKUP-TYPE) :KEY (FUNCTION CAR)))))))) - -(DEFDEFINER (DEF-DEFINE-TYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEF-DEFINE-TYPE (IL:\\\, NAME) "Description string")))))) IL:DEFINE-TYPES (NAME DESCRIPTION &KEY UNDEFINER &AUX (CHANGELST (INTERN (CONCATENATE (QUOTE 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.") (IL:BQUOTE (PROGN (SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE IL:DEFINE-TYPES)) (QUOTE (IL:\\\, DESCRIPTION))) (PUSHNEW (QUOTE ((IL:\\\, NAME) X (IL:P IL:* (%DEFINE-TYPE-FILE-DEFINITIONS (QUOTE (IL:\\\, NAME)) (QUOTE X))))) IL:PRETTYDEFMACROS :TEST (QUOTE 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 (QUOTE ((IL:\\\, CHANGELST) (IL:\\\, NAME) (IL:\\\, DESCRIPTION))) IL:PRETTYTYPELST :TEST (QUOTE EQUAL)) (DEFGLOBALVAR (IL:\\\, 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 (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (QUOTE EQUAL) :SIZE 50 :REHASH-SIZE 50))) (PUSHNEW (QUOTE (IL:\\\, NAME)) IL:FILEPKGTYPES) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:GETDEF)) (QUOTE %DEFINE-TYPE-GETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:DELDEF)) (QUOTE %DEFINE-TYPE-DELDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:PUTDEF)) (QUOTE %DEFINE-TYPE-PUTDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEGETDEF)) (QUOTE %DEFINE-TYPE-FILEGETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEPKGCONTENTS)) (QUOTE IL:NILL)) (IL:\\\,@ (WHEN UNDEFINER (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, UNDEFINER)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)))))))))) - -(DEFDEFINER (DEFDEFINER (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (QUOTE IL:SEDIT)) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%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) (EDITDATE-OFFSET 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))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST BODY) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &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 (QUOTE &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-")))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPE))) (PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (AND UNDEFINER (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME "undefiner-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, UNDEFINER))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)))))))) (IL:\\\,@ (AND PROTOTYPE-FN (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME "prototype-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, PROTOTYPE-FN))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER (IL:\\\, (QUOTE (IL:\\\, TYPE))) (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV)))))))))) - -(DEFDEFINER (DEFDEFINER-VARIABLE-TYPE (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER-VARIABLE-TYPE (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (INTERN "SEDIT" "SEDIT")) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPES ARG-LIST &BODY BODY) (IL:* IL:|;;| "An extension to the DEFDEFINER universe, this allows the creation of definers that map to multiple file-package types. The test case, and the only case guaranteed to work, is DEFUN (which now must accept (DEFUN (SETF FOO)...), which needs to be stored as a SETFS file type).") (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINERS NIL) (PROTOTYPE-FNS NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (TYPE-DISCRIMINATOR NIL) (EXPANSION-FNS NIL) (DOCS NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINERS) (SETQ UNDEFINERS (CDR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPES) (SETQ PROTOTYPE-FNS (CDR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:TYPE-DISCRIMINATOR) (SETQ TYPE-DISCRIMINATOR (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (UNLESS TYPE-DISCRIMINATOR (ERROR "DEFDEFINER-VARIABLE-TYPE must have a TYPE-DISCRIMINATOR")) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (DOLIST (TYPE TYPES) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST (LET ((TB (GETF BODY TYPE))) (IF TB (LIST TB) (ERROR "No expansion-function for ~A" TYPE)))) (SETF (GETF EXPANSION-FNS TYPE) EXPANSION-FN) (WHEN DOC (SETQ DOCS (CONCATENATE (QUOTE STRING) DOCS (OR DOCS " -") (SYMBOL-NAME TYPE) ": " DOC))))) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &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 (QUOTE &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 ((NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-"))) (TYPE-DISCRIMINATOR-NAME (GET-DEFINER-NAME NAME "type-discriminator-fn-"))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPES))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (FUNCTION (IL:\\\, TYPE-DISCRIMINATOR))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :TYPE-DISCRIMINATOR)) (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (IL:\\\,@ (AND PROTOTYPE-FNS (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-prototype-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, (GETF PROTOTYPE-FNS TYPE)))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) TYPES))) (IL:\\\,@ (AND DOCS (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCS)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-definition-expander-"))) (EXPANSION-FN (GETF EXPANSION-FNS TYPE))) (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, TYPE))) (QUOTE (IL:\\\, EXPANDER-NAME)))))))) TYPES)) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (IL:\\\,@ (AND UNDEFINERS (MAPCAN (FUNCTION (LAMBDA (TYPE) (WHEN (GETF UNDEFINERS TYPE) (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-undefiner-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, (GETF UNDEFINERS TYPE)))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)) (QUOTE (IL:\\\, TYPE)))))))))) TYPES))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER-VARIABLE-TYPE (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, 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-VARIABLE-TYPE (DEFUN (:TYPE-DISCRIMINATOR (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) (QUOTE IL:FUNCTIONS)) ((CL::SETF-NAME-P NAME) (QUOTE IL:SETFS)) (T (ERROR "Can't determine type for DEFUN: ~s" NAME)))))) (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) NAME) ((CL::SETF-NAME-P NAME) (CADR NAME)) (T (ERROR "Bad function-name for DEFUN: ~s" NAME)))))) (:PROTOTYPES IL:FUNCTIONS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))) IL:SETFS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (SETF (IL:\\\, NAME)) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))) (:TEMPLATE (:NAME :ARG-LIST :BODY)) (:EDITDATE-OFFSET 3)) (IL:FUNCTIONS IL:SETFS) (NAME ARGS &BODY (BODY DECLS DOCUMENTATION) &ENVIRONMENT ENV) IL:FUNCTIONS (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ BODY))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCUMENTATION)))))))) IL:SETFS (IL:* IL:|;;| "The form is (defun (setf foo) (store-var &rest args) body)") (IL:* IL:|;;| "Strategy is to give the code a name with DEFUN-SETF-NAME. The name is stored on the :SETF-DEFUN property of the accessor. This name is there for convenience/documentation only; the name can't be reliably changed by smashing this property (i.e. (SETF (FDEFINITION '(SETF FOO)) #'BAR) essentially does (SETF (SYMBOL-FUNCTION (DEFUN-SETF-NAME 'FOO)) #'BAR); it does NOT change the :SETF-DEFUN property on FOO).") (LET* ((REAL-NAME (SECOND NAME)) (DEFUN-SETF-NAME (DEFUN-SETF-NAME REAL-NAME))) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, REAL-NAME) (IL:\\\,@ BODY))))) (SET-DEFUN-SETF (QUOTE (IL:\\\, REAL-NAME)) (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, REAL-NAME)) (QUOTE SETF)) (IL:\\\, DOCUMENTATION)))))))))) - -(DEFDEFINER (DEFINLINE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINLINE (IL:\\\, NAME) (IL:\\\,@ (%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 (IL:BQUOTE ((IL:\\\, (QUOTE LAMBDA)) (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ CODE)))))) (IL:BQUOTE (PROGN (DEFUN (IL:\\\, NAME) (IL:\\\, ARG-LIST) (IL:\\\,@ BODY)) (DEFOPTIMIZER (IL:\\\, NAME) (IL:\\\, (PACK (LIST "definline-" NAME) (SYMBOL-PACKAGE NAME))) (&REST ARGS) (CONS (QUOTE (IL:\\\, NEW-LAMBDA)) ARGS))))))) - -(DEFDEFINER (DEFMACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER (LAMBDA (NAME) (REMPROP NAME (QUOTE 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) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, CMACRONAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (MACRO-FUNCTION (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, CMACRONAME))) (IL:\\\,@ (AND DOC-STRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC-STRING)))))) (IL:\\\,@ (WHEN COMPILER::*NEW-COMPILER-IS-EXPANDING* (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:ARGNAMES)) (QUOTE (IL:\\\, (MAPCAR (FUNCTION (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) (IL:BQUOTE (DEFVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION))))))))) - -(DEFDEFINER (DEFPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION))))))))) - -(DEFDEFINER (DEFCONSTANT (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFCONSTANT (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (IL:\\\,@ (IF (CONSTANTP NAME) (IL:BQUOTE ((SET-CONSTANTP (QUOTE (IL:\\\, NAME)) NIL))))) (SETQ (IL:\\\, NAME) (IL:\\\, VALUE)) (PROCLAIM (QUOTE (SI::CONSTANT (IL:\\\, NAME)))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION))))))))) - -(DEFDEFINER (DEFGLOBALVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:* IL:|;;| "Use IL:SETQ here or the INIT dies.") (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION))))))))) - -(DEFDEFINER (DEFGLOBALPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, 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 (QUOTE 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) (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, ARGS))))) (T (LET ((SF (INTERN (CONCATENATE (QUOTE STRING) "interpret-" (STRING NAME)) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOC) (IL:PARSE-DEFMACRO ARGS (QUOTE $$TAIL) BODY NAME NIL :PATH (QUOTE $$TAIL) :ENVIRONMENT (QUOTE $$ENV)) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, SF))) (FUNCTION (LAMBDA ($$TAIL $$ENV) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, 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 NIL NIL :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 NIL :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 1992)) -(IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL))) -IL:STOP diff --git a/CLTL2/I-NEW.~3~ b/CLTL2/I-NEW.~3~ deleted file mode 100644 index 249e2cea..00000000 --- a/CLTL2/I-NEW.~3~ +++ /dev/null @@ -1,419 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED " 2-Dec-93 13:37:18" |{DSK}export>lispcore>sources>CLTL2>I-NEW.;3|) - - -(PRETTYCOMPRINT I-NEWCOMS) - -(RPAQQ I-NEWCOMS ((ADDVARS (LOCKEDFNS \\CLOCK0 \\GETINTERNALCLOCK \\BOXIDIFFERENCE \\BOXIPLUS \\BLT \\SLOWIQUOTIENT) (LOCKEDVARS \\RCLKSECOND \\RCLKMILLISECOND \\MISCSTATS)) (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 \\MAXDISKDA\s \\DISKDEBUG \\SPAREDISKWRITEBUFFER \\#EMUBUFFERS \\EMUBUFFERS \\LASTVMEMFILEPAGE |\\XVmem| |\\XVmemFmapBase| |\\XVmemFmapHighBase| |\\XVmemDiskBase|)) (FNS I.MAKEINITBFS) (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)) (FNS I.\\LOCKFN I.\\LOCKVAR I.\\LOCKCELL I.\\LOCKWORDS I.\\LOCKCODE) (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)) (FNS I.DUMPINITPAGES) (VARS INITCONSTANTS) (FNS I.SETUPPAGEMAP I.ADDPME I.MAKEROOMFORPME I.MAPPAGES) (FNS I.SETUPSTACK I.\\SETUPSTACK1 I.\\SETUPGUARDBLOCK I.\\MAKEFREEBLOCK) (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)) (FNS I.INITGC) (FNS I.NTYPX I.\\ALLOCMDSPAGE I.\\MAKEMDSENTRY I.\\INITMDSPAGE I.\\ASSIGNDATATYPE1 I.\\TYPENUMBERFROMNAME I.\\CREATECELL I.\\NEW2PAGE) (FNS I.CREATEMDSTYPETABLE I.INITDATATYPES I.INITDATATYPENAMES) (VARS \\BUILT-IN-SYSTEM-TYPES) (FNS I.FSETVAL I.SETPROPLIST I.PUTDEFN I.\\BLT) (FNS I.\\MKATOM I.\\CREATE.SYMBOL I.\\INITATOMPAGE I.\\MOVEBYTES I.\\STKMIN) (FNS I.COPYATOM I.INITATOMS) (FNS I.MAKEINITFIRST I.\\COPY I.MAKEINITLAST) (FNS I.\\CONS.UFN I.\\MAIKO.CONS.UFN I.\\INITCONSPAGE I.\\NEXTCONSPAGE) (FNS I.\\GETBASEBYTE I.\\PUTBASEBYTE I.CREATEPAGES I.\\NEW4PAGE) (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (FNS I.ALLOCSTRING I.%COPY-ONED-ARRAY I.%COPY-STRING-TO-ARRAY) (FNS I.\\#BLOCKDATACELLS I.\\PREFIXALIGNMENT? I.\\ALLOCBLOCK I.\\MAIKO.ALLOCBLOCK I.\\ALLOCBLOCK.NEW I.\\MAKEFREEARRAYBLOCK I.\\MERGEBACKWARD I.\\LINKBLOCK I.\\ALLOCHUNK) (FNS I.PREINITARRAYS I.POSTINITARRAYS I.FILEARRAYBASE I.FILEBLOCKTRAILER I.FILECODEBLOCK I.FILEPATCHBLOCK) (FNS I.\\SETUP.HUNK.TYPENUMBERS I.\\COMPUTE.HUNK.TYPEDECLS I.\\TURN.ON.HUNKING I.\\SETUP.TYPENUM.TABLE) (FNS I.DCODERD) (VARS \\OPCODES (I.CODERDTBL (COPYREADTABLE (QUOTE ORIG)))) (P (SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL))))) I.CODERDTBL) (SETSYNTAX (CHARCODE \|) (QUOTE (MACRO ALWAYS READVBAR)) I.CODERDTBL) (READTABLEPROP I.CODERDTBL (QUOTE USESILPACKAGE) NIL)) (FNS I.INITUFNTABLE I.\\SETUFNENTRY) (VARS INITPTRS INITVALUES) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) -) - -(ADDTOVAR LOCKEDFNS \\CLOCK0 \\GETINTERNALCLOCK \\BOXIDIFFERENCE \\BOXIPLUS \\BLT \\SLOWIQUOTIENT) - -(ADDTOVAR LOCKEDVARS \\RCLKSECOND \\RCLKMILLISECOND \\MISCSTATS) - -(ADDTOVAR 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) - -(ADDTOVAR LOCKEDVARS \\DISKREQUESTBLOCK \\SWAPREQUESTBLOCK \\MAINDISK \\SWAPDSK1 \\SWAPDSK2 \\ISFCHUNKSIZE - \\EMUSCRATCH \\EMUDISKBUFFERS \\EMUSWAPBUFFERS \\EMUDISKBUFEND \\MAXSWAPBUFFERS \\#DISKBUFFERS |\\InterfacePage| - \\ISFMAP \\ISFSCRATCHCAS \\ISFSCRATCHDAS \\SYSDISK \\#SWAPBUFFERS \\MAXDISKDA\s \\DISKDEBUG \\SPAREDISKWRITEBUFFER - \\#EMUBUFFERS \\EMUBUFFERS \\LASTVMEMFILEPAGE |\\XVmem| |\\XVmemFmapBase| |\\XVmemFmapHighBase| |\\XVmemDiskBase| -) -(DEFINEQ - -(I.MAKEINITBFS -(LAMBDA NIL (*) (*) (PROGN (*) (I.\\LOCKWORDS (SETQ I.MAINDISK ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36) (I.PUTBASEPTR I.MAINDISK 26 (I.\\COPY (QUOTE DSK))) (I.\\LOCKWORDS (SETQ I.SWAPDSK1 ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36) (I.\\LOCKWORDS (SETQ I.SWAPDSK2 ((LAMBDA ($$1) (I.PUTBASEPTR $$1 0 NIL) $$1) (I.\\ALLOCBLOCK 18))) 36)) (PROGN (*) (I.\\LOCKWORDS (SETQ I.SWAPREQUESTBLOCK (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 42 60) 1) 1))) (+ 42 60)) (I.\\LOCKWORDS (SETQ I.DISKREQUESTBLOCK (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 42 60) 1) 1))) (+ 42 60))) (|to| 3 |bind| PREV (FIRSTCB _ (I.\\ALLOCBLOCK 3)) |first| (I.\\LOCKWORDS (SETQ PREV FIRSTCB) 6) |do| (I.\\LOCKWORDS (SETQ PREV ((LAMBDA ($$1) (PROG1 (SETQ $$1 (I.\\ALLOCBLOCK 3)) (I.PUTBASEPTR $$1 0 PREV))) NIL)) 6) |finally| (I.PUTBASEPTR FIRSTCB 0 PREV) (*) (I.PUTBASEPTR I.MAINDISK 14 FIRSTCB)) (SETQ I.FREEPAGEFID (I.\\ALLOCBLOCK 3)) (*) (|for| I |from| 0 |to| 4 |do| (I.PUTBASE I.FREEPAGEFID I (UNSIGNED -1 16)))) -) -) - -(ADDTOVAR 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) - -(ADDTOVAR 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) -(DEFINEQ - -(I.\\LOCKFN -(LAMBDA (FN) (*) (I.\\LOCKCELL (SETQ FN (I.\\ATOMCELL (PROGN (I.\\COPY FN)) 10))) (COND ((NEQ 0 (LRSH (I.GETBASE FN 0) 15)) (I.\\LOCKCODE (I.GETBASEPTR FN 0))))) -) - -(I.\\LOCKVAR -(LAMBDA (VAR) (*) (I.\\LOCKCELL (I.\\ATOMCELL (PROGN (I.\\COPY VAR)) 12)))) - -(I.\\LOCKCELL -(LAMBDA (X NPGS) (*) (MKI.LOCKPAGES (I.VAG2 (I.HILOC X) (LOGAND (I.LOLOC X) 65280)) (OR NPGS 1)))) - -(I.\\LOCKWORDS -(LAMBDA (BASE NWORDS) (*) (MKI.LOCKPAGES (I.VAG2 (I.HILOC BASE) (LOGAND (I.LOLOC BASE) 65280)) (COND (NWORDS (LRSH (IPLUS (IPLUS (LOGAND (I.LOLOC BASE) 255) NWORDS) 255) 8)) (T 1)))) -) - -(I.\\LOCKCODE -(LAMBDA (CODEBLOCK) (*) (I.\\LOCKWORDS CODEBLOCK (LLSH (I.\\#BLOCKDATACELLS CODEBLOCK) 1)))) -) - -(ADDTOVAR 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) - -(ADDTOVAR 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) -(DEFINEQ - -(I.DUMPINITPAGES -(LAMBDA (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (*) (*) (I.ADDPME (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)) T) (*) (|for| I |from| CODEFIRSTPAGE |to| (SUB1 CODENEXTPAGE) |do| (*) (I.ADDPME I T)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION I.MAKEROOMFORPME)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION I.ADDPME)) (PROGN (*) (I.PUTBASE (I.VAG2 6 0) 19 NEXTPM) (I.PUTBASEFIXP (I.VAG2 6 0) 82 (SUB1 NEXTVMEM)) (I.PUTBASEFIXP (I.VAG2 6 0) 84 (SUB1 NEXTVMEM)) (I.PUTBASE (I.VAG2 6 0) 22 (I.GETBASE (I.VAG2 5 0) 0)) (I.PUTBASE (I.VAG2 6 0) 23 (I.GETBASE ((LAMBDA (VPAGE) (DECLARE (LOCALVARS VPAGE)) (I.ADDBASE (I.VAG2 5 0) (IPLUS (I.GETBASE (I.VAG2 6 512) (LRSH VPAGE 5)) (LOGAND VPAGE 31)))) (IPLUS (LLSH (I.HILOC (I.VAG2 6 512)) 8) (LRSH (I.LOLOC (I.VAG2 6 512)) 8))) 0)) (COND (VERSIONS (I.PUTBASE (I.VAG2 6 0) 8 (CAR VERSIONS)) (I.PUTBASE (I.VAG2 6 0) 10 (CADDR VERSIONS)) (I.PUTBASE (I.VAG2 6 0) 9 (CADR VERSIONS)))) (I.PUTBASE (I.VAG2 6 0) 15 5603)) (I.MAPPAGES 0 (ADD1 65533) (FUNCTION DUMPVP)) (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) (QUOTE BOTH)))))) (SETFILEPTR FILE |MKI.Page0Byte|)) (DUMPVP (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)))) -) -) - -(RPAQQ INITCONSTANTS ((* |;;;| "(LISPNAME VALUE BCPLNAME UCODENAME)") (CDRCODING 1 T T) (* \; "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON") (* |;;| "type numbers -- repeated on LLBASIC too") (\\SMALLP 1 SMALLTYPE |SmallType|) (\\FIXP 2 INTEGERTYPE |FixpType|) (\\FLOATP 3 FLTPTTYPE |FloatpType|) (\\LITATOM 4 ATOMTYPE |AtomType|) (\\LISTP 5 LISTTYPE |ListType|) (\\ARRAYP 6 ARRAYPTRTYPE |ArrayType|) (\\STRINGP 7 STRINGPTRTYPE) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| "TYPE TABLE CONSTANTS") (\\TT.TYPEMASK 2047 |TTTypeMask| T) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (* |;;| "page map") (|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) (|\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 65533) (\\MAXVMSEGMENT 255) (* |;;| "interface page") (|\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 16382) (|\\MaxMDSPage| 65533) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 2) (* \; "(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (23 0)) (|\\FirstArraySegment| 23) (|\\FirstArrayPage| 5888) (\\ARRAYSPACE2 (64 0)) (|\\DefaultSecondArrayPage| 16384) (* |;;| "stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; "none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) (* |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) (\\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 262144 NIL T) (\\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| (7 0) (|AHTspace| |AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (\\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) (|\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) (\\PNAME.HI 8) (\\DEFSPACE (10 0) (|DEFspace| |DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) (|VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) (\\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (6 512) (|PMTspace| |PMTbase|)) (|\\InterfacePage| (6 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| |INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 0)) (|\\MDSTypeTable| (20 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) (|\\MDSTTsize| 256 T) (\\MISCSTATS (6 2560) (|STATSspace| |MISCSTATSbase|)) (|\\UFNTable| (6 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (6 4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (6 4186)) (|\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (6 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) (|STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1 T T) (\\HTMAIN (16 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 256 T) (\\HTOVERFLOW (17 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (17 32768)) (\\HTCOLL (10 0) NIL (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) (|\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) (|\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) (|\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") (\\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; "if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; "(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (* \; "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 1536) (\\VP.FPTOVP 512) (\\NP.FPTOVP 1024) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 5120) (\\NP.TYPETABLE 256) (\\RP.TYPETABLE 2048) (\\VP.GCTABLE 4096) (\\NP.GCTABLE 256) (\\RP.GCTABLE 2304) (\\VP.GCOVERFLOW 4352) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 2560) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (\\VP.PRIMARYMAP 1538) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 1648) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (\\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772)) -) -(DEFINEQ - -(I.SETUPPAGEMAP -(LAMBDA NIL (*) (*) (PROG NIL (*) (MKI.NEWPAGE (I.VAG2 5 0) NIL T) (*) (I.CREATEPAGES (I.VAG2 6 512) 8 NIL T) (*) (*) (|for| I |from| 0 |to| (SUB1 (LLSH 8 8)) |do| (I.PUTBASE (I.VAG2 6 512) I 65535)) (SETQ NEXTPM 0) (|for| I |from| 0 |to| (SUB1 (LRSH 256 5)) |bind| (PAGEMAPKEY _ (LRSH (PROGN (IPLUS (LLSH (I.HILOC (I.VAG2 5 0)) 8) (LRSH (I.LOLOC (I.VAG2 5 0)) 8))) 5)) |do| (*) (I.PUTBASE (I.VAG2 6 512) (IPLUS PAGEMAPKEY I) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM 32))) (SETQ NEXTVMEM 2) (*) (I.CREATEPAGES (I.VAG2 6 28672) 16 NIL T))) -) - -(I.ADDPME -(LAMBDA (VP NEWPAGEOK) (*) (*) (PROG (PX PMP LOCKBASE) (COND ((IEQ (SETQ PMP (I.GETBASE (I.VAG2 6 512) (LRSH VP 5))) 65535) (*) (COND ((EVENP NEXTPM 256) (*) (SETQ PX (I.ADDBASE (I.VAG2 5 0) NEXTPM)) (OR NEWPAGEOK (IGREATERP (IPLUS (LLSH (I.HILOC PX) 8) (LRSH (I.LOLOC PX) 8)) VP) (HELP "page map needs new page after page map written out")) (MKI.NEWPAGE PX NIL T))) (I.PUTBASE (I.VAG2 6 512) (LRSH VP 5) (SETQ PMP NEXTPM)) (SETQ NEXTPM (IPLUS NEXTPM 32)))) (SETQ PX (IPLUS PMP (LOGAND VP 31))) (COND ((NEQ (I.GETBASE (I.VAG2 5 0) PX) 0) (HELP "page already in pagemap" VP)) (T (I.PUTBASE (I.VAG2 5 0) PX NEXTVMEM) (COND ((MKI.LOCKEDPAGEP VP) (*) (I.PUTBASE (SETQ LOCKBASE (I.ADDBASE (I.VAG2 6 28672) (LRSH VP 4))) 0 (LOGOR (LLSH 1 (IMOD VP 16)) (I.GETBASE LOCKBASE 0))))) (SETQ NEXTVMEM (ADD1 NEXTVMEM)))))) -) - -(I.MAKEROOMFORPME -(LAMBDA (VP) (*) (*) (COND ((IEQ (I.GETBASE (I.VAG2 6 512) (LRSH VP 5)) 65535) (*) (COND ((EVENP NEXTPM 256) (*) (MKI.NEWPAGE (I.ADDBASE (I.VAG2 5 0) NEXTPM) NIL T))) (I.PUTBASE (I.VAG2 6 512) (LRSH VP 5) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM 32))))) -) - -(I.MAPPAGES -(LAMBDA (BOT TOP FN) (*) (*) (PROG ((VP BOT) (IVP (IPLUS (LLSH (I.HILOC (I.VAG2 6 0)) 8) (LRSH (I.LOLOC (I.VAG2 6 0)) 8)))) 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))))) -) -) -(DEFINEQ - -(I.SETUPSTACK -(LAMBDA (INITFLG) (*) (*) (I.CREATEPAGES (I.VAG2 1 0) (IQUOTIENT 9216 256) NIL T) (*) (I.\\SETUPGUARDBLOCK 0 2) (*) (I.PUTBASE (I.VAG2 6 0) 0 (I.\\SETUPSTACK1 2 0 0 (IDIFFERENCE 768 2) 0 RESETPC RESETPTR NIL INITFLG)) (I.PUTBASE (I.VAG2 6 0) 1 0) (I.PUTBASE (I.VAG2 6 0) 6 0) (I.PUTBASE (I.VAG2 6 0) 2 0) (I.PUTBASE (I.VAG2 6 0) 3 0) (I.\\SETUPGUARDBLOCK (IDIFFERENCE 768 2) 2) (I.PUTBASE (I.VAG2 6 0) 30 (I.\\SETUPGUARDBLOCK 768 (IDIFFERENCE (IDIFFERENCE 9216 768) 2))) (I.PUTBASE (I.VAG2 6 0) 7 (I.\\SETUPGUARDBLOCK (IDIFFERENCE 9216 2) 2))) -) - -(I.\\SETUPSTACK1 -(LAMBDA (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH) (*) (COND ((OR INITFLG (IGREATERP (IDIFFERENCE STKEND STKP) (IPLUS (PROG1 (I.GETBASE DEFPTR 0) (*)) (PROG1 4 (*))))) (*) (PROG ((SP STKP)) (|if| ARGSLENGTH |then| (SETQ ARGSLENGTH (MIN ARGSLENGTH NARGS)) (I.\\BLT (I.VAG2 1 SP) ARGS (LLSH ARGSLENGTH 1)) (SETQ SP (PLUS SP (TIMES ARGSLENGTH 2))) (SETQ ARGS)) (FRPTQ NARGS (I.PUTBASEPTR (I.VAG2 1 0) SP (AND ARGS (PROG1 (CAR ARGS) (SETQ ARGS (CDR ARGS))))) (*) (SETQ SP (PLUS SP 2))) (AND (PROG1 (COND ((ODDP SP 4) (I.PUTBASEPTR (I.VAG2 1 0) SP NIL) (*) (SETQ SP (PLUS SP 2)) T)) (I.PUTBASE (I.VAG2 1 SP) 0 32768)) (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65279) (LLSH (LOGAND 1 1) 8)))) (I.VAG2 1 SP)) 8) 1)) (I.PUTBASE (I.VAG2 1 SP) 1 STKP) (SETQ STKP (IPLUS SP 2)) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (CONSTANT (CL:READ-FROM-STRING "#B11000001")) 8)))) (I.VAG2 1 STKP)) 8) (*) (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65280) (LOGAND 0 255)))) (I.VAG2 1 STKP)) 255) (I.PUTBASE (I.VAG2 1 STKP) 8 SP) (I.PUTBASE (I.VAG2 1 STKP) 1 (IPLUS ALINK 10 1)) (I.PUTBASE (I.VAG2 1 STKP) 9 (IPLUS CLINK 10)) (I.PUTBASEPTR (I.VAG2 1 STKP) 2 DEFPTR) (I.PUTBASE (I.VAG2 1 STKP) 5 PC) (SETQ SP (IPLUS STKP (PROGN 10))) (COND ((NOT INITFLG) (*) (RPTQ (LLSH (ADD1 (SIGNED (I.GETBASE DEFPTR 2) 16)) 1) (PROGN (*) (I.PUTBASE (I.VAG2 1 0) SP 65535) (SETQ SP (PLUS SP 2)))))) (I.PUTBASE (I.VAG2 1 STKP) 4 (SETQ SP (PLUS SP (PROGN 4)))) (*) (I.\\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP)) (RETURN STKP))))) -) - -(I.\\SETUPGUARDBLOCK -(LAMBDA (STKP LEN) (*) (I.PUTBASE (I.VAG2 1 STKP) 0 57344) (I.PUTBASE (I.VAG2 1 STKP) 1 LEN) STKP)) - -(I.\\MAKEFREEBLOCK -(LAMBDA (STK SIZE) (*) (PROGN (*) (I.PUTBASE (I.VAG2 1 STK) 1 SIZE) (I.PUTBASE (I.VAG2 1 STK) 0 40960))) -) -) - -(ADDTOVAR LOCKEDFNS \\RESETSTACK0 \\MAKEFRAME \\SETUPSTACK1 \\MAKEFREEBLOCK \\FAULTHANDLER \\KEYHANDLER - \\DUMMYKEYHANDLER \\DOTELERAID \\DUMMYTELERAID \\DOHARDRETURN \\DOGC \\CAUSEINTERRUPT \\INTERRUPTFRAME - \\CODEFORTFRAME \\DOSTACKOVERFLOW \\UNLOCKPAGES \\DOMISCAPPLY) - -(ADDTOVAR LOCKEDVARS |\\InterfacePage| \\DEFSPACE \\STACKSPACE \\KBDSTACKBASE \\MISCSTACKBASE \\SAVED.USER.CONTEXT - \\RUNNING.PROCESS \\NEED.HARDRESET.CLEANUP) -(DEFINEQ - -(I.INITGC -(LAMBDA NIL (*) (I.CREATEPAGES (I.VAG2 16 0) (LRSH (IPLUS 65536 255) 8) T T) (I.CREATEPAGES (I.VAG2 17 0) 1 T T) (I.CREATEPAGES (I.VAG2 17 32768) 1 T) (I.CREATEPAGES (I.VAG2 10 0) 1 NIL T) (I.CREATEPAGES (I.ADDBASE (I.VAG2 10 0) 256) (SUB1 (LRSH (IPLUS 262144 255) 8)) T) (I.PUTBASEFIXP (I.VAG2 10 0) 0 0) (I.PUTBASEFIXP (I.VAG2 10 0) 2 2)) -) -) -(DEFINEQ - -(I.NTYPX -(LAMBDA (X) (*) (*) (LOGAND (I.GETBASE (I.VAG2 20 0) (LRSH (IPLUS (LLSH (I.HILOC X) 8) (LRSH (I.LOLOC X) 8)) 1)) 2047)) -) - -(I.\\ALLOCMDSPAGE -(LAMBDA (TYP) (*) (PROG (VP VPTR) BEG (COND ((SETQ VP I.MDSFREELISTPAGE) (SETQ VPTR ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 VP) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (PROG ((NXT (I.GETBASEPTR VPTR 0))) (COND ((AND NXT (NOT (SMALLP NXT))) (\\MP.ERROR 26 "MDS Free Page link bad. ^N to continue" (PROG1 I.MDSFREELISTPAGE (SETQ I.MDSFREELISTPAGE))) (GO BEG)) (T (SETQ I.MDSFREELISTPAGE NXT))))) (T (NILL) (SETQ VP |I.NxtMDSPage|) (I.PUTBASEFIXP |I.NxtMDSPage| 0 (IDIFFERENCE VP (LRSH 512 8))) (*) (SETQ VPTR ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 VP) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE VPTR) 256)))) (I.\\MAKEMDSENTRY VP TYP) (RETURN VPTR))) -) - -(I.\\MAKEMDSENTRY -(LAMBDA (VP V) (*) (*) (I.PUTBASE (I.VAG2 20 0) (LRSH VP 1) (COND ((NILL) (LOGOR 32768 V)) (T V))))) - -(I.\\INITMDSPAGE -(LAMBDA (BASE SIZE PREV) (*) (*) (PROG ((SLOP (IREMAINDER 256 SIZE)) NPAGES LIMIT) (*) (COND ((AND (NEQ SLOP 0) (ILESSP SLOP (LRSH SIZE 1)) (ILESSP SIZE 256)) (*) (SETQ NPAGES (IQUOTIENT 512 256)) (SETQ LIMIT 256)) (T (SETQ NPAGES 1) (SETQ LIMIT 512))) (|to| NPAGES |do| (|for| (DISP _ 0) |while| (ILEQ (SETQ DISP (PLUS DISP SIZE)) LIMIT) |do| (I.PUTBASEPTR BASE 0 PREV) (SETQ PREV BASE) (SETQ BASE (I.ADDBASE BASE SIZE))) (SETQ BASE (I.ADDBASE BASE SLOP))) (RETURN PREV))) -) - -(I.\\ASSIGNDATATYPE1 -(LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (*) (*) (PROG ((I.NTYPX (I.\\TYPENUMBERFROMNAME NAME)) (SUPERTYPENUMBER (COND (SUPERTYPE (OR (I.\\TYPENUMBERFROMNAME SUPERTYPE) (ERROR SUPERTYPE ":INCLUDEd datatype but not currently declared"))) (T 0))) DTD REDECLARED NEWTYPENUM NEWDTD) (COND (I.NTYPX (*) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES I.NTYPX 18))) (COND ((AND (EQUAL PTRFIELDS (I.GETBASEPTR DTD 10)) (EQUAL SIZE (I.GETBASE DTD 3))) (*) (I.PUTBASEPTR DTD 6 DESCRIPTORS) (I.PUTBASE DTD 17 SUPERTYPENUMBER) (RETURN I.NTYPX)) ((EQ (I.GETBASE DTD 3) 0) (*)) ((OR (EQ CROSSCOMPILING T) (AND CROSSCOMPILING (NEQ (QUOTE Y) (ASKUSER 30 (SELECTQ CROSSCOMPILING (Y (QUOTE Y)) (QUOTE N)) (LIST (COND (SIZE "OK TO REDECLARE DATATYPE ") (T "OK to deallocate DATATYPE ")) NAME))))) (*) (RETURN I.NTYPX)) ((IGREATERP I.NTYPX |I.MaxSysTypeNum|) (*) (SETQ REDECLARED T)) (T (*) (ERROR "ILLEGAL DATA TYPE" NAME))))) (*) (COND ((NOT SIZE) (*)) (T (COND ((AND (EQ |I.MaxTypeNumber| 2047) (OR (NULL I.NTYPX) REDECLARED)) (LISPERROR "DATA TYPES FULL" NAME))) (PROGN (COND ((OR (NULL I.NTYPX) REDECLARED) (*) (SETQ NEWTYPENUM (SETQ |I.MaxTypeNumber| (PLUS |I.MaxTypeNumber| 1))) (SETQ NEWDTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES NEWTYPENUM 18))) (*) (COND ((IGEQ (IPLUS (LOGAND (I.LOLOC NEWDTD) 255) 18) 256) (*) (MKI.NEWPAGE (I.ADDBASE NEWDTD 18) T))) (COND (REDECLARED (*) (LET ((NEWTYPEENTRY (LOGOR NEWTYPENUM (LOGAND (I.GETBASE DTD 16) (LOGNOT 2047)))) FOUNDSOME) (\\MAPMDS I.NTYPX (FUNCTION (LAMBDA (PAGE) (I.\\MAKEMDSENTRY PAGE NEWTYPEENTRY) (SETQ FOUNDSOME T)))) (COND ((NOT FOUNDSOME) (*) (SETQ |I.MaxTypeNumber| (PLUS |I.MaxTypeNumber| -1))) (T (I.PUTBASEPTR DTD 6 NIL) (I.PUTBASEPTR DTD 8 NIL) (I.\\BLT NEWDTD DTD 18) (*) (PROGN (I.GETBASEPTR NEWDTD 10)) (NEQ (LOGAND (LRSH (I.PUTBASE NEWDTD 0 (LOGOR (LOGAND (I.GETBASE NEWDTD 0) 57343) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 13))) 13) 1) 0) (I.PUTBASE NEWDTD 16 NEWTYPEENTRY) (I.PUTBASEPTR NEWDTD 0 (NEW-SYMBOL-CODE (PACK* "Obsolete-" NAME) (I.ATOMNUMBER (PACK* "Obsolete-" NAME)))) (I.PUTBASEPTR DTD 4 NIL) (*))))) (T (*) (SETQ I.NTYPX NEWTYPENUM) (I.PUTBASEPTR (SETQ DTD NEWDTD) 0 (NEW-SYMBOL-CODE NAME (I.ATOMNUMBER NAME))))))) (COND ((NEQ SIZE 0) (*) (I.PUTBASE DTD 3 SIZE) (I.PUTBASEPTR DTD 6 (I.\\COPY DESCRIPTORS)) (I.PUTBASEPTR DTD 8 (I.\\COPY SPECS)) (I.PUTBASEPTR DTD 10 PTRFIELDS) (I.PUTBASE DTD 17 SUPERTYPENUMBER) (I.PUTBASE DTD 16 I.NTYPX) (*))) (*)) (RETURN (CL:VALUES I.NTYPX REDECLARED)))))) -) - -(I.\\TYPENUMBERFROMNAME -(LAMBDA (TYPE) (*) (AND TYPE (BIND (INDEX _ (NEW-SYMBOL-CODE TYPE (I.ATOMNUMBER TYPE))) |for| I |from| 1 |to| |I.MaxTypeNumber| |do| (COND ((EQ INDEX (I.GETBASEPTR (I.ADDBASE (I.VAG2 6 4096) (ITIMES I 18)) 0)) (RETURN I)))))) -) - -(I.\\CREATECELL -(LAMBDA (TYP) (*) (COND ((AND (NEQ 1 0) (EQ TYP 5)) (HELP "CREATECELL \\LISTP"))) (LET ((DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYP 18))) NEWCELL) (|while| (EQ (I.GETBASE DTD 3) 0) |do| (ERROR "Attempt to CREATE a type not declared yet" (\\TYPENAMEFROMNUMBER TYP))) (PROGN (COND ((SETQ NEWCELL (I.GETBASEPTR DTD 4)) (*) (I.PUTBASEPTR DTD 4 (I.GETBASEPTR NEWCELL 0)) (*) (LET ((CNT (SUB1 (I.GETBASE DTD 3)))) (*) (I.PUTBASE NEWCELL CNT 0) (I.\\BLT NEWCELL (I.ADDBASE NEWCELL 1) CNT)) (PROGN NEWCELL) NEWCELL) (T (*) (*) (*) (I.PUTBASEPTR DTD 4 (I.\\INITMDSPAGE (I.\\ALLOCMDSPAGE (I.GETBASE DTD 16)) (I.GETBASE DTD 3) (I.GETBASEPTR DTD 4))) (I.\\CREATECELL TYP)))))) -) - -(I.\\NEW2PAGE -(LAMBDA (BASE) (*) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE BASE) 256)))) -) -(DEFINEQ - -(I.CREATEMDSTYPETABLE -(LAMBDA NIL (*) (*) (*) (*) (*) (*) (*) (I.CREATEPAGES (I.VAG2 20 0) 256 NIL T) (PROG (VP) (*) (SETQ VP 0) (FRPTQ (LLSH 256 8) (I.PUTBASE (I.VAG2 20 0) VP 32768) (SETQ VP (PLUS VP 1))) (*) (|for| SEGMENT |in| (LIST 14 15) |do| (|for| PAGE |from| 0 |to| (SUB1 256) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY (LOGOR PAGE (LLSH SEGMENT 8)) (LOGOR 32768 8192 4096 2048 1)))) (|for| PAGE |from| 0 |to| (SUB1 256) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY (LOGOR PAGE (LLSH 7 8)) (LOGOR 32768 9)))) (I.CREATEPAGES (I.VAG2 6 2560) (LRSH 512 8) NIL T) (I.\\MAKEMDSENTRY (IPLUS (LLSH (I.HILOC (I.VAG2 6 2560)) 8) (LRSH (I.LOLOC (I.VAG2 6 2560)) 8)) (LOGOR 32768 8192 4096 2048 2))) -) - -(I.INITDATATYPES -(LAMBDA NIL (*) (*) (LET ((NSYSTYPES (LENGTH INITIALDTDCONTENTS))) (I.CREATEPAGES (I.VAG2 6 4096) 1 NIL T) (*) (I.CREATEPAGES (I.ADDBASE (I.VAG2 6 4096) 256) (SUB1 (LRSH (IPLUS (ADD1 (TIMES (ADD1 NSYSTYPES) 18)) 255) 8))) (*) (*) (|for| D |in| INITIALDTDCONTENTS |bind| DTD |as| TYPENO |from| 1 |do| (*) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18))) (*) (I.PUTBASE DTD 16 (LOGOR TYPENO (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP FLOATP))) 4096) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP FLOATP LITATOM NEW-ATOM))) 2048) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (SMALLP FIXP))) 8192) (T 0)) (COND ((EQ (CAR D) (QUOTE NEW-ATOM)) (*) 32768) (T 0)) (COND ((FMEMB (CAR D) (QUOTE (LITATOM NEW-ATOM))) (*) (CONSTANT 16384)) (T 0)) (COND ((NOT (CADR D)) (*) 32768) (T 0)))) (*) (COND ((EQ (CAR D) (QUOTE NEW-ATOM)) (*) (I.PUTBASE DTD 17 4))) (COND ((AND (CAR D) (CADR D)) (*) (I.PUTBASE DTD 3 (CADR D))))) (COND ((NEQ 1 0) (SETQ I.LISTPDTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES 5 18))))) (SETQ |I.MaxSysTypeNum| (SETQ |I.MaxTypeNumber| NSYSTYPES)) NIL)) -) - -(I.INITDATATYPENAMES -(LAMBDA NIL (*) (*) (*) (SETQ I.FINALIZATION.FUNCTIONS (I.\\ALLOCBLOCK (ADD1 2047) T)) (|for| D |in| INITIALDTDCONTENTS |as| I.NTYPX |from| 1 |do| (LET ((DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES I.NTYPX 18))) (FINAL (CADDDR D))) (*) (I.PUTBASEPTR DTD 0 (I.ATOMNUMBER (CAR D))) (*) (I.PUTBASEPTR DTD 10 (I.\\COPY (CADDR D))) (*) (|if| FINAL |then| (*) (NEQ (LOGAND (LRSH (I.PUTBASE DTD 0 (LOGOR (LOGAND (I.GETBASE DTD 0) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0) (I.PUTBASEPTR I.FINALIZATION.FUNCTIONS (LLSH I.NTYPX 1) (I.\\COPY FINAL))))) (PROGN (*) (NEQ (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12)))) (I.ADDBASE (I.VAG2 6 4096) (ITIMES 0 18))) 12) 1) 0) (I.PUTBASEPTR I.FINALIZATION.FUNCTIONS 0 (I.\\COPY (QUOTE \\RECLAIMARRAYBLOCK))))) -) -) - -(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)) -) -(DEFINEQ - -(I.FSETVAL -(LAMBDA (ATM VAL) (*) (*) (I.PUTBASEPTR (I.\\ATOMCELL ATM 12) 0 VAL))) - -(I.SETPROPLIST -(LAMBDA (ATM LST) (*) (I.PUTBASEPTR (I.\\ATOMCELL ATM (CONSTANT 2)) 0 LST))) - -(I.PUTDEFN -(LAMBDA (FN CA SIZE) (*) (*) (PROG ((DCELL (I.\\ATOMCELL FN 10)) (BLOCKINFO (PROGN (*) (I.FILECODEBLOCK (LRSH (IPLUS SIZE 3) 2) (IPLUS (LOGOR (LLSH (\\BYTELT CA 12) 8) (\\BYTELT CA (ADD1 12))) (PROGN 8))))) (BASE (I.FILEARRAYBASE))) (I.PUTBASEPTR DCELL 0 BASE) (LOGAND (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 53247) (LLSH (LOGAND (LOGAND (LRSH (\\BYTELT CA 8) 4) 3) 3) 12))) 12) 3) (NEQ (LOGAND (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 49151) (LLSH (LOGAND (COND ((EQ (LOGOR (LLSH (\\BYTELT CA 12) 8) (\\BYTELT CA (ADD1 12))) 0) 1) (T 0)) 1) 14))) 14) 1) 0) (NEQ (LRSH (I.PUTBASE DCELL 0 (LOGOR (LOGAND (I.GETBASE DCELL 0) 32767) (LLSH (COND (T 1) (T 0)) 15))) 15) 0) (NEQ (LOGAND (LRSH (I.PUTBASE DCELL 4 (LOGOR (LOGAND (I.GETBASE DCELL 4) 65527) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 3))) 3) 1) 0) (COND ((FMEMB FN LOCKEDFNS) (I.\\LOCKCELL DCELL 1) (I.\\LOCKCELL BASE (LRSH (IPLUS (IPLUS (LOGAND (I.LOLOC BASE) 255) (LRSH (IPLUS SIZE 1) 1)) 255) 8)))) (COND ((EQ FN (FUNCTION \\RESETSTACK)) (*) (SETQ RESETPTR (I.FILEARRAYBASE)) (SETQ RESETPC (LOGOR (LLSH (\\BYTELT CA 6) 8) (\\BYTELT CA (ADD1 6)))))) (AOUT CA 0 SIZE OUTX (QUOTE CODE)) (BOUTZEROS (IDIFFERENCE (SUB1 4) (IMOD (SUB1 SIZE) 4))) (I.FILEBLOCKTRAILER BLOCKINFO))) -) - -(I.\\BLT -(LAMBDA (DBASE SBASE NWORDS) (*) (*) (PROG ((NN (CONSTANT (EXPT 2 14)))) (RETURN (COND ((GREATERP NWORDS NN) (*) (I.\\BLT (I.ADDBASE DBASE NN) (I.ADDBASE SBASE NN) (DIFFERENCE NWORDS NN)) (I.\\BLT DBASE SBASE NN)) (T (|for| I |from| (SUB1 NWORDS) |by| -1 |to| 0 |do| (I.PUTBASE DBASE I (I.GETBASE SBASE I))) DBASE))))) -) -) -(DEFINEQ - -(I.\\MKATOM -(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (I.GETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (COND ((EQ LEN 0) (*) (SETQ HASH 0) (SETQ FIRSTBYTE 255) (GO LP))) (SETQ FIRSTCHAR (COND (FATP (I.GETBASE BASE OFFST)) (T (I.\\GETBASEBYTE BASE OFFST)))) (*) (COND ((AND (EQ LEN 1) (ILEQ FIRSTCHAR 255) |I.OneCharAtomBase|) (*) (RETURN (COND ((IGREATERP FIRSTCHAR (CHARCODE "9")) (I.ADDBASE |I.OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10))) ((IGEQ FIRSTCHAR (CHARCODE "0")) (*) (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) (T (I.ADDBASE |I.OneCharAtomBase| FIRSTCHAR))))) ((AND (NOT NONNUMERICP) (ILEQ FIRSTCHAR (CHARCODE "9")) (SETQ HASHENT (NILL BASE OFFST LEN FATP 10 \\ORIGREADTABLE))) (*) (RETURN HASHENT))) (*) (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (*) (PROGN (*) (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)) (COND (FATP (LOGAND (I.GETBASE BASE CHAR#) 255)) (T (I.\\GETBASEBYTE BASE CHAR#))))))) (*) LP (*) (COND ((NEQ 0 (SETQ HASHENT (I.GETBASE (I.VAG2 7 0) HASH))) (*) (COND ((AND (EQ (LRSH (I.GETBASE (SETQ PNBASE ((LAMBDA ($$1) (I.GETBASEPTR (COND ((AND (FIXP (PROGN $$1)) (ILESSP $$1 65535)) (I.ADDBASE (I.VAG2 8 0) (IPLUS 0 (ITIMES 10 (PROGN $$1))))) (T (I.ADDBASE (PROGN $$1) 0))) 0)) (SETQ ATM# (SUB1 HASHENT)))) 0) 8) LEN) (EQ FATCHARSEENP (AND (PROG1 (EQ 0 (LOGAND (I.GETBASE PNBASE 0) 255)) (*)) (NEQ 0 (LOGAND (LRSH (I.GETBASE (I.\\ATOMCELL (PROGN (I.ADDBASE (I.VAG2 0 0) ATM#)) (CONSTANT 2)) 3) 13) 1)))) (COND (FATCHARSEENP (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (*) (EQ (I.GETBASE PNBASE B1) (I.GETBASE BASE B2)))) (FATP (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (EQ (I.\\GETBASEBYTE PNBASE B1) (I.GETBASE BASE B2)))) (T (*) (|for| B1 |from| 1 |to| LEN |as| B2 |from| OFFST |always| (EQ (I.\\GETBASEBYTE PNBASE B1) (I.\\GETBASEBYTE BASE B2)))))) (RETURN (I.ADDBASE (I.VAG2 0 0) ATM#))) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (I.\\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP))) (I.PUTBASE (I.VAG2 7 0) HASH (ADD1 (I.ATOMNUMBER NEWATOM))) NEWATOM))))) -) - -(I.\\CREATE.SYMBOL -(LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (*) (*) (*) (LET ((PNBASE (I.\\ALLOCBLOCK (COND (FATCHARSEENP (*) (LRSH (IPLUS (ADD1 LEN) 1) 1)) (T (*) (LRSH (IPLUS (ADD1 LEN) 3) 2))))) PB CPP ATM) (COND ((IGEQ (SETQ ATM |I.AtomFrLst|) 12287) (*) (IGEQ (SETQ ATM |I.AtomFrLst|) 65535) (*) (*) (*) (SETQ ATM (I.\\CREATECELL 21)) (I.PUTBASEPTR (COND ((AND (FIXP ATM) (ILESSP ATM 65535)) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) (I.VAG2 8 0) (IPLUS 2 (ITIMES 10 ATM)))) (T (I.ADDBASE ATM 2))) 0 (QUOTE NOBIND))) ((EVENP ATM 256) (*) (*) (EVENP ATM 512) (*) (*) (LET ((PN (ITIMES 10 (LRSH ATM 8)))) (COND ((NEW-SYMBOL-CODE NIL (IGEQ PN (IDIFFERENCE 255 1))) (*) (NILL))) (I.\\MAKEMDSENTRY (LRSH ATM 8) (LOGOR 32768 16384 2048 4)) (*) (I.\\INITATOMPAGE PN) (*)))) ((LAMBDA (DATUMA0064) (DECLARE (LOCALVARS DATUMA0064)) (PROGN (I.PUTBASE DATUMA0064 0 (LOGOR (LOGAND 61440 (I.GETBASE DATUMA0064 0)) (LOGAND (I.HILOC PNBASE) 4095))) (I.PUTBASE DATUMA0064 (ADD1 0) (I.LOLOC PNBASE)) PNBASE)) (COND ((AND (FIXP ATM) (ILESSP ATM 65535)) (I.ADDBASE (I.VAG2 8 0) (IPLUS 0 (ITIMES 10 ATM)))) (T (I.ADDBASE ATM 0)))) (*) (COND (FATCHARSEENP (I.\\BLT (I.ADDBASE PNBASE 1) (I.ADDBASE BASE OFFSET) LEN)) (FATP (|for| I |from| OFFSET |as| J |from| 1 |to| LEN |do| (I.\\PUTBASEBYTE PNBASE J (I.GETBASE BASE I)))) (T (I.\\MOVEBYTES BASE OFFSET PNBASE 1 LEN))) (LRSH (I.PUTBASE PNBASE 0 (LOGOR (LOGAND (I.GETBASE PNBASE 0) 255) (LLSH LEN 8))) 8) (COND ((NOT T) (*) (PROGN PNBASE))) (SETQ |I.AtomFrLst| (ADD1 |I.AtomFrLst|)) (*) (AND (FIXP ATM) (SETQ ATM (I.ADDBASE (I.VAG2 0 0) ATM))) (COND (FATCHARSEENP (NEQ (LOGAND (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 3 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 3) 57343) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 13)))) (I.\\ATOMCELL ATM (CONSTANT 2))) 13) 1) 0))) ATM)) -) - -(I.\\INITATOMPAGE -(LAMBDA (PN) (*) (COND (NIL (PROG ((OFFSET (LLSH PN 8)) VALBASE) (*) (*) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 8 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 10 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (I.ADDBASE (I.ADDBASE (I.VAG2 2 0) OFFSET) OFFSET)) (I.\\NEW4PAGE (SETQ VALBASE (I.ADDBASE (I.ADDBASE (I.VAG2 12 0) OFFSET) OFFSET))) (FRPTQ (ITIMES 128 4) (*) (I.PUTBASEPTR VALBASE 0 (I.\\COPY (QUOTE NOBIND))) (SETQ VALBASE (I.ADDBASE VALBASE 2))))) (T (*) (LET ((OFFSET (LLSH PN 8)) (ATM (LLSH (IQUOTIENT PN 10) 8)) VALBASE) (*) (FOR I FROM 0 TO 9 AS OFF FROM OFFSET BY 256 DO (MKI.NEWPAGE (I.ADDBASE (I.VAG2 8 0) OFF))) (*) (FOR I FROM 0 TO 255 AS OFF FROM OFFSET BY 10 DO (I.PUTBASEPTR (I.VAG2 8 0) (IPLUS OFF 2) (QUOTE NOBIND))))))) -) - -(I.\\MOVEBYTES -(LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES) (*) (*) (COND ((IGREATERP NBYTES 0) (PROG ((SB (I.ADDBASE SBASE (LRSH SBYTE 1))) (DB (I.ADDBASE DBASE (LRSH DBYTE 1))) SBN DBN NWORDS) (COND ((EQ (SETQ SBN (IMOD SBYTE 2)) (SETQ DBN (IMOD DBYTE 2))) (*) (COND ((EQ SBN 1) (I.\\PUTBASEBYTE DB 1 (I.\\GETBASEBYTE SB 1)) (SETQ DB (I.ADDBASE DB 1)) (SETQ SB (I.ADDBASE SB 1)) (SETQ NBYTES (PLUS NBYTES -1)))) (I.\\BLT DB SB (SETQ NWORDS (LRSH NBYTES 1))) (COND ((EQ (IMOD NBYTES 2) 1) (I.\\PUTBASEBYTE (I.ADDBASE DB NWORDS) 0 (I.\\GETBASEBYTE (I.ADDBASE SB NWORDS) 0))))) (T (FRPTQ NBYTES (I.\\PUTBASEBYTE DB (PROG1 DBN (SETQ DBN (PLUS DBN 1))) (I.\\GETBASEBYTE SB (PROG1 SBN (SETQ SBN (PLUS SBN 1)))))))))))) -) - -(I.\\STKMIN -(LAMBDA (CODE CODEISBLOCK PRINT) (DECLARE (LOCALVARS)) (*) (*) (*) (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))) -) -) -(DEFINEQ - -(I.COPYATOM -(LAMBDA (X) (*) (*) (LET ((PKG (CL:SYMBOL-PACKAGE X))) (* \; "SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world") (COND ((EQ PKG *INTERLISP-PACKAGE*)) ((NULL PKG) (* \; "This is an uninterned symbol, so add prefix.") (SETQ X (CONCAT "" X))) ((EQ PKG *KEYWORD-PACKAGE*) (* \; "keywords eval to self, so also set top val") (MKI.DSET X X) (SETQ X (CONCAT ":" X))) (T (* |;;| "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") (CL:MULTIPLE-VALUE-BIND (SYM WHERE) (CL:FIND-SYMBOL (CL:SYMBOL-NAME X) PKG) (SETQ WHERE (SELECTQ WHERE (:INTERNAL "::") (:EXTERNAL ":") (ERROR "Where is this symbol?" X))) (COND ((EQ PKG *LISP-PACKAGE*) (SETQ SYM "LISP")) ((EQ PKG *COMMON-LISP-PACKAGE*) (SETQ SYM "CL")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "SYSTEM") (SETQ SYM "SI")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "CONDITIONS") (SETQ SYM "CONDITIONS")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "XEROX-COMMON-LISP") (SETQ SYM "XCL")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "COMPILER") (SETQ SYM "COMPILER")) ((CL:STRING= (CL:PACKAGE-NAME PKG) "FASL") (SETQ SYM "FASL")) (T (HELP "Can only translate symbols in IL, CL, XCL, CONDITIONS, SI, COMPILER, FASL and keywords" X))) (SETQ X (CONCAT SYM WHERE (CL:SYMBOL-NAME X))))))) (LET ((N (NCHARS X)) (BASE (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE I.SCRATCHSTRING 2) 14) 1)) (%ARRAY-BASE I.SCRATCHSTRING)) (T (I.GETBASEPTR I.SCRATCHSTRING 0)))) (OFFST (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE I.SCRATCHSTRING 2) 14) 1)) (%ARRAY-OFFSET I.SCRATCHSTRING)) (T (I.GETBASE I.SCRATCHSTRING 3))))) (*) (|for| I |from| 1 |to| N |do| (I.\\PUTBASEBYTE BASE (IPLUS OFFST I -1) (NTHCHARCODE X I))) (I.ATOMNUMBER (I.\\MKATOM BASE OFFST N)))) -) - -(I.INITATOMS -(LAMBDA NIL (*) (*) (I.CREATEPAGES (I.VAG2 7 0) 256) (SETQ I.SCRATCHSTRING (I.ALLOCSTRING 255)) (*) (*) (I.COPYATOM NIL) (*) (I.COPYATOM (QUOTE NOBIND)) (*) (*) (|for| C |from| 0 |to| 255 |when| (OR (ILESSP C (CHARCODE 0)) (IGREATERP C (CHARCODE 9))) |do| (I.COPYATOM (CHARACTER C))) (SETQ |I.OneCharAtomBase| (I.ADDBASE (I.VAG2 0 0) 2)) (*) (I.COPYATOM (FUNCTION \\EVALFORM)) (*) (I.COPYATOM (FUNCTION \\GC.HANDLEOVERFLOW)) (*) (I.COPYATOM (FUNCTION \\DTEST.UFN)) (*) (I.COPYATOM (FUNCTION \\OVERFLOWMAKENUMBER)) (*) (I.COPYATOM (FUNCTION \\MAKENUMBER)) (*) (I.COPYATOM (FUNCTION \\SETGLOBAL.UFN)) (*) (I.COPYATOM (FUNCTION \\SETFVAR.UFN)) (*) (I.COPYATOM (FUNCTION \\GCMAPTABLE)) (*) (I.COPYATOM (FUNCTION \\INTERPRETER)) (*) (OR (EQ (I.ATOMNUMBER (FUNCTION \\INTERPRETER)) 256) (HELP (FUNCTION \\INTERPRETER) " not atom 400Q"))) -) -) -(DEFINEQ - -(I.MAKEINITFIRST -(LAMBDA NIL (*) (I.CREATEMDSTYPETABLE) (I.\\SETUP.HUNK.TYPENUMBERS) (I.INITDATATYPES) (I.PREINITARRAYS) (I.\\TURN.ON.HUNKING) (I.INITATOMS) (I.INITDATATYPENAMES) (I.INITUFNTABLE) (I.INITGC) (MKI.NEWPAGE (I.VAG2 6 0) NIL T)) -) - -(I.\\COPY -(LAMBDA (X) (*) (*) (SELECTQ (TYPENAME X) ((LITATOM NEW-ATOM) (MKI.ATOM X)) (LISTP (PROG ((R (REVERSE X)) (V (I.\\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (I.\\CONS.UFN (I.\\COPY (CAR R)) V)) (SETQ R (CDR R)) (GO LP))) (RETURN V))) ((FIXP SMALLP) (PROG (V) (COND ((IGREATERP 0 X) (*) (COND ((IGREATERP X -65537) (*) (RETURN (I.ADDBASE (I.VAG2 15 0) (LOGAND X 65535)))))) ((ILESSP X 65536) (*) (RETURN (I.ADDBASE (I.VAG2 14 0) X)))) (*) (SETQ V (I.\\CREATECELL 2)) (I.PUTBASE V 0 (LOGOR (COND ((IGREATERP 0 X) 32768) (T 0)) (LOGAND (LRSH X 16) 32767))) (I.PUTBASE V 1 (LOGAND X 65535)) (RETURN V))) (ONED-ARRAY (I.%COPY-ONED-ARRAY X)) (STRINGP (*) (I.%COPY-STRING-TO-ARRAY X)) (FLOATP (PROG ((VAL (I.\\CREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (I.PUTBASE VAL 0 (\\GETBASE X 0)) (I.PUTBASE VAL 1 (\\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (CHARACTER (I.VAG2 7 (CL:CHAR-CODE X))) (ERROR X "can't be copied to remote file"))) -) - -(I.MAKEINITLAST -(LAMBDA (VERSIONS) (*) (I.SETUPSTACK T) (I.MAKEINITBFS) (PROGN (*) (SELECTQ (SYSTEMTYPE) ((D ALTO) (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) (I.SETPROPLIST A (I.\\COPY P))))) (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) (I.FSETVAL A (I.\\COPY (CDR V))))))) (PROG (AL GAG) (*) (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))) (MAPC AL (FUNCTION (LAMBDA (X) (I.SETPROPLIST (CAR X) (I.\\COPY (CDR X)))))) (PROGN (SETQ AL) (RECLAIM) (SETQ GAG (GCGAG GAG)) (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) (|push| AL (RPLACA V A))))) (GCGAG GAG)) (MAPC AL (FUNCTION (LAMBDA (X) (I.FSETVAL (CAR X) (I.\\COPY (CDR X)))))))) (*)) (PROG ((AFL (I.FILEARRAYBASE))) (*) (BOUTZEROS (IDIFFERENCE (TIMES 2 512) (LLSH (IMOD (I.LOLOC AFL) (TIMES 2 256)) 1))) (SETQ MKI.CODELASTPAGE ((LAMBDA (PTR) (DECLARE (LOCALVARS PTR)) (IPLUS (LLSH (I.HILOC PTR) 8) (LRSH (I.LOLOC PTR) 8))) (I.FILEARRAYBASE))) (*) (I.POSTINITARRAYS AFL (IPLUS 5888 MKI.CODESTARTOFFSET) MKI.CODELASTPAGE)) (MAPC (APPEND INITVALUES INITPTRS) (FUNCTION (LAMBDA (X) (*) (I.ATOMNUMBER (CAR X))))) (|for| X |in| INITVALUES |as| A |in| MKI.VALUES |do| (SETQ A (EVALV A)) (I.FSETVAL (CAR X) (COND ((OR (EQ A T) (EQ A NIL) (AND (FIXP A) (IGEQ A -65536) (ILEQ A 65535))) (I.\\COPY A)) (T (SHOULDNT))))) (|for| X |in| INITPTRS |as| A |in| MKI.PTRS |do| (I.FSETVAL (CAR X) (EVALV A))) (|for| X |in| LOCKEDVARS |do| (*) (IF (GETHASH X MKI.ATOMARRAY) THEN (I.\\LOCKVAR X) ELSE (|printout| T "***Note: Locked var " X " does not exist, proceeding anyway." T))) (I.SETUPPAGEMAP) (I.DUMPINITPAGES (IPLUS 5888 MKI.CODESTARTOFFSET) MKI.CODELASTPAGE VERSIONS)) -) -) -(DEFINEQ - -(I.\\CONS.UFN -(LAMBDA (X Y) (*) (COND ((ZEROP 1) (HELP) (PROG ((CELL (I.\\CREATECELL 5))) (I.PUTBASEPTR CELL 0 X) (I.PUTBASEPTR CELL 2 Y) (RETURN CELL)))) (PROGN (PROGN X) (PROGN Y) (*) (PROGN 1) (PROG (CNS.PAGE CELL) (SETQ CNS.PAGE (COND ((NOT Y) (COND ((AND (SETQ CNS.PAGE ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 (I.GETBASEFIXP I.LISTPDTD 14)) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (IGREATERP (LRSH (I.GETBASE CNS.PAGE 0) 8) 0))) (T (SETQ CNS.PAGE (I.\\NEXTCONSPAGE)))) (PROG ((.MK.NEWCELL (I.ADDBASE CNS.PAGE (LOGAND (I.GETBASE CNS.PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 X) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH 8 12))) 12) (RETURN .MK.NEWCELL))) ((AND (EQ (I.NTYPX Y) 5) (IGREATERP (LRSH (I.GETBASE (SETQ CNS.PAGE (I.VAG2 (I.HILOC Y) (LOGAND (I.LOLOC Y) 65280))) 0) 8) 0) (SETQ CELL (LET ((CDROFFSET (LOGAND (I.LOLOC Y) 255)) (OFFSET (LOGAND (I.GETBASE CNS.PAGE 0) 255)) CELL PRIOR) (WHILE (NEQ OFFSET 0) DO (COND ((AND (ILEQ OFFSET CDROFFSET) (IGEQ OFFSET (IDIFFERENCE CDROFFSET 14))) (*) (COND (PRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE CNS.PAGE OFFSET)) 0) 8) 8)))) (I.ADDBASE CNS.PAGE PRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE CNS.PAGE OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LOGOR 8 (LRSH (IDIFFERENCE CDROFFSET OFFSET) 1)) 12))) 12) (RETURN CELL))) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE CNS.PAGE OFFSET) 0) 8)))))) (*) (*) CELL) (T (LET ((PG (I.GETBASEFIXP I.LISTPDTD 14)) CELL CPG) (WHILE (IGREATERP PG 0) DO (COND ((SETQ CELL ((LAMBDA (PGA0065) (DECLARE (LOCALVARS PGA0065)) (LET ((OFFSET (LOGAND (I.GETBASE PGA0065 0) 255)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (LRSH (I.GETBASE PGA0065 0) 8) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (*) (COND (PRIORPRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0065 OFFSET)) 0) 8) 8)))) (I.ADDBASE PGA0065 PRIORPRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE PGA0065 0 (LOGOR (LOGAND (I.GETBASE PGA0065 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0065 OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE PGA0065 0 (LOGOR (LOGAND (I.GETBASE PGA0065 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PGA0065 0) 8)) -2) 8))) 8) (I.PUTBASEPTR (I.ADDBASE PGA0065 PRIOR) 0 Y) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LRSH (IDIFFERENCE PRIOR OFFSET) 1) 12))) 12) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE PGA0065 OFFSET) 0) 8)))))) (SETQ CPG ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 PG) 8) (LLSH (LOGAND $$1 255) 8))) NIL)))) (RETURN CELL)) (T (SETQ PG (I.GETBASEFIXP CPG 2))))) (OR CELL ((LAMBDA (PGA0066) (DECLARE (LOCALVARS PGA0066)) (LET ((OFFSET (LOGAND (I.GETBASE PGA0066 0) 255)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (LRSH (I.GETBASE PGA0066 0) 8) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (*) (COND (PRIORPRIOR (*) (LRSH ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 255) (LLSH (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0066 OFFSET)) 0) 8) 8)))) (I.ADDBASE PGA0066 PRIORPRIOR)) 8)) (T (*) (LOGAND (I.PUTBASE PGA0066 0 (LOGOR (LOGAND (I.GETBASE PGA0066 0) 65280) (LOGAND (LRSH (I.GETBASE (SETQ CELL (I.ADDBASE PGA0066 OFFSET)) 0) 8) 255))) 255))) (LRSH (I.PUTBASE PGA0066 0 (LOGOR (LOGAND (I.GETBASE PGA0066 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PGA0066 0) 8)) -2) 8))) 8) (I.PUTBASEPTR (I.ADDBASE PGA0066 PRIOR) 0 Y) (I.PUTBASEPTR CELL 0 X) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 4095) (LLSH (LRSH (IDIFFERENCE PRIOR OFFSET) 1) 12))) 12) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (LRSH (I.GETBASE (I.ADDBASE PGA0066 OFFSET) 0) 8)))))) (I.\\NEXTCONSPAGE))))))) (PROGN CNS.PAGE) (RETURN CNS.PAGE)))) -) - -(I.\\MAIKO.CONS.UFN -(LAMBDA (X Y) (*) (*) (COND ((ZEROP 1) (HELP) (PROG ((CELL (I.\\CREATECELL 5))) (I.PUTBASEPTR CELL 0 X) (I.PUTBASEPTR CELL 2 Y) (RETURN CELL)))) (PROGN (PROGN X) (PROGN Y) (*) (PROGN 1) (PROG (CNS.PAGE) (SETQ CNS.PAGE (COND ((AND (EQ (I.NTYPX Y) 5) (IGREATERP (LRSH (I.GETBASE (SETQ CNS.PAGE (I.VAG2 (I.HILOC Y) (LOGAND (I.LOLOC Y) 65280))) 0) 8) 0)) (*) ((LAMBDA (PAGE A D) (DECLARE (LOCALVARS PAGE A D)) (PROG ((.MK.NEWCELL (I.ADDBASE PAGE (LOGAND (I.GETBASE PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 A) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH D 12))) 12) (RETURN .MK.NEWCELL))) CNS.PAGE X (IPLUS 8 (LRSH (LOGAND (I.LOLOC Y) 255) 1)))) (T ((LAMBDA (PAGE A D) (DECLARE (LOCALVARS PAGE A D)) (PROG ((.MK.NEWCELL (I.ADDBASE PAGE (LOGAND (I.GETBASE PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE PAGE 0 (LOGOR (LOGAND (I.GETBASE PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 A) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH D 12))) 12) (RETURN .MK.NEWCELL))) (SETQ CNS.PAGE (I.\\NEXTCONSPAGE)) X (COND ((NULL Y) 8) (T (IPLUS 0 (LRSH (LOGAND (I.LOLOC (PROGN (PROGN (PROGN (PROG ((.MK.NEWCELL (I.ADDBASE CNS.PAGE (LOGAND (I.GETBASE CNS.PAGE 0) 255)))) (*) (LOGAND (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 65280) (LOGAND (LRSH (I.GETBASE .MK.NEWCELL 0) 8) 255))) 255) (*) (LRSH (I.PUTBASE CNS.PAGE 0 (LOGOR (LOGAND (I.GETBASE CNS.PAGE 0) 255) (LLSH (PLUS (PROGN (LRSH (I.GETBASE CNS.PAGE 0) 8)) -1) 8))) 8) (I.PUTBASEPTR .MK.NEWCELL 0 Y) (LRSH (I.PUTBASE .MK.NEWCELL 0 (LOGOR (LOGAND (I.GETBASE .MK.NEWCELL 0) 4095) (LLSH 0 12))) 12) (RETURN .MK.NEWCELL)))))) 255) 1)))))))) (PROGN CNS.PAGE) (RETURN CNS.PAGE)))) -) - -(I.\\INITCONSPAGE -(LAMBDA (BASE LINK) (*) (COND ((ZEROP 1) (HELP)) (T (PROG ((J (LOGAND (I.PUTBASE BASE 0 (LOGOR (LOGAND (I.GETBASE BASE 0) 65280) (LOGAND 254 255))) 255)) CELL) LP (COND ((IGREATERP J 4) (SETQ CELL (I.ADDBASE BASE J)) (I.PUTBASEPTR CELL 0 NIL) (LRSH (I.PUTBASE CELL 0 (LOGOR (LOGAND (I.GETBASE CELL 0) 255) (LLSH (SETQ J (IDIFFERENCE J 2)) 8))) 8) (GO LP))) (LRSH (I.PUTBASE BASE 0 (LOGOR (LOGAND (I.GETBASE BASE 0) 255) (LLSH 126 8))) 8) (*) (I.PUTBASEFIXP BASE 2 (IPLUS (LLSH (I.HILOC LINK) 8) (LRSH (I.LOLOC LINK) 8))) (RETURN BASE))))) -) - -(I.\\NEXTCONSPAGE -(LAMBDA NIL (*) (*) (PROG ((N (I.GETBASEFIXP I.LISTPDTD 14)) PG) (SETQ PG (I.\\ALLOCMDSPAGE (I.GETBASE I.LISTPDTD 16))) (I.\\INITCONSPAGE PG (I.\\INITCONSPAGE (I.ADDBASE PG 256) ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 N) 8) (LLSH (LOGAND $$1 255) 8))) NIL))) (I.PUTBASEFIXP I.LISTPDTD 14 (IPLUS (LLSH (I.HILOC PG) 8) (LRSH (I.LOLOC PG) 8))) (RETURN PG))) -) -) -(DEFINEQ - -(I.\\GETBASEBYTE -(LAMBDA (PTR N) (*) (*) (COND ((EVENP N) (LRSH (PROGN (I.GETBASE PTR (LRSH N 1))) 8)) (T (LOGAND (PROGN (I.GETBASE PTR (LRSH N 1))) 255)))) -) - -(I.\\PUTBASEBYTE -(LAMBDA (PTR DISP BYTE) (*) (*) (SETQ BYTE (PROG1 BYTE)) (I.PUTBASE PTR (LRSH (SETQ DISP (\\DTEST DISP (QUOTE SMALLP))) 1) (COND ((EVENP DISP 2) ((LAMBDA ($$1) (IPLUS (LLSH BYTE 8) (LOGAND $$1 255))) (I.GETBASE PTR (LRSH DISP 1)))) (T ((LAMBDA ($$1) (IPLUS (LLSH (LRSH $$1 8) 8) BYTE)) (I.GETBASE PTR (LRSH DISP 1)))))) BYTE) -) - -(I.CREATEPAGES -(LAMBDA (VA N BLANKFLG LOCKFLG) (*) (*) (|for| I |from| 0 |to| (SUB1 N) |do| (MKI.NEWPAGE (I.ADDBASE VA (LLSH I 8)) NIL LOCKFLG BLANKFLG)) VA) -) - -(I.\\NEW4PAGE -(LAMBDA (PTR) (*) (*) (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE (I.ADDBASE (MKI.NEWPAGE PTR) 256)) 256)) 256))) -) -) - -(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) -(DEFINEQ - -(I.ALLOCSTRING -(LAMBDA (N INITCHAR OLD FATFLG) (*) (SETQ N (FIX N)) (*) (COND ((OR (ILESSP N 0) (IGREATERP N 65535)) (LISPERROR "ILLEGAL ARG" N))) (COND ((NULL INITCHAR) (SETQ INITCHAR 0)) ((PROGN (*) (AND (SMALLP INITCHAR) (IGEQ INITCHAR 0)))) (T (SETQ INITCHAR (CHCON1 INITCHAR)))) (LET ((FATP (OR FATFLG (IGREATERP INITCHAR 255))) STRINGBASE) (*) (SETQ STRINGBASE (I.\\ALLOCBLOCK (COND (FATP (LRSH (IPLUS N 1) 1)) (T (LRSH (IPLUS N 3) 2))))) (COND ((STRINGP OLD) (PROGN ((LAMBDA ($$1) (PROG1 (SETQ $$1 (PROGN (NEQ (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 32767) (LLSH (COND (NIL 1) (T 0)) 15))) 15) 0) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR OLD 0 NIL) NIL) ((LAMBDA (STRING NV) (DECLARE (LOCALVARS STRING NV)) (LET ((%NEW-TYPE-NUMBER (SELECTC NV (0 %THIN-CHAR-TYPENUMBER) (1 %FAT-CHAR-TYPENUMBER) (SHOULDNT "Unknown typ value")))) (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE STRING 2) 14) 1)) (%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (LOGAND (I.PUTBASE STRING 2 (LOGOR (LOGAND (I.GETBASE STRING 2) 65280) (LOGAND %NEW-TYPE-NUMBER 255))) 255))))) OLD (PROGN (COND (FATP 1) (T 0)))) ((LAMBDA (STRING NV) (DECLARE (LOCALVARS STRING NV)) (I.PUTBASEFIXP STRING 4 NV) (I.PUTBASEFIXP STRING 6 NV) (COND ((%GENERAL-ARRAY-P STRING) (I.PUTBASEPTR STRING 8 (LIST NV)))) NV) OLD (PROGN N)) (PROGN (COND ((NOT (EQ 0 0)) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 64511) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 10))) 10) 1) 0))) (COND ((NEQ 0 (LOGAND (LRSH (I.GETBASE OLD 2) 14) 1)) (%SET-ARRAY-OFFSET OLD 0)) (T (I.PUTBASE OLD 3 0)))) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 63487) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 11))) 11) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 64511) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 10))) 10) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 65023) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 9))) 9) 1) 0) (NEQ (LOGAND (LRSH (I.PUTBASE OLD 2 (LOGOR (LOGAND (I.GETBASE OLD 2) 65279) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 8))) 8) 1) 0)) OLD)) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE $$1 2 (LOGOR (LOGAND (I.GETBASE $$1 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR $$1 0 STRINGBASE) STRINGBASE))) NIL))) (T (SETQ OLD ((LAMBDA ($$1 $$2) (PROG1 (SETQ $$2 ((LAMBDA (DATUMA0077) (DECLARE (LOCALVARS DATUMA0077)) (PROG1 DATUMA0077 (I.PUTBASEFIXP DATUMA0077 6 $$1))) ((LAMBDA (DATUMA0076 NEWVALUEA0075) (DECLARE (LOCALVARS DATUMA0076 NEWVALUEA0075)) (PROG1 DATUMA0076 (I.PUTBASEFIXP DATUMA0076 4 NEWVALUEA0075))) ((LAMBDA (DATUMA0074) (DECLARE (LOCALVARS DATUMA0074)) (PROG1 DATUMA0074 (I.PUTBASE DATUMA0074 3 0))) ((LAMBDA (DATUMA0073 NEWVALUEA0072) (DECLARE (LOCALVARS DATUMA0073 NEWVALUEA0072)) (PROG1 DATUMA0073 (LOGAND (I.PUTBASE DATUMA0073 2 (LOGOR (LOGAND (I.GETBASE DATUMA0073 2) 65280) (LOGAND NEWVALUEA0072 255))) 255))) ((LAMBDA (DATUMA0071 NEWVALUEA0070) (DECLARE (LOCALVARS DATUMA0071 NEWVALUEA0070)) (PROG1 DATUMA0071 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0071 2 (LOGOR (LOGAND (I.GETBASE DATUMA0071 2) 64511) (LLSH (LOGAND (COND (NEWVALUEA0070 1) (T 0)) 1) 10))) 10) 1) 0))) ((LAMBDA (DATUMA0069) (DECLARE (LOCALVARS DATUMA0069)) (PROG1 DATUMA0069 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0069 2 (LOGOR (LOGAND (I.GETBASE DATUMA0069 2) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0068) (DECLARE (LOCALVARS DATUMA0068)) (PROG1 DATUMA0068 (NEQ (LRSH (I.PUTBASE DATUMA0068 2 (LOGOR (LOGAND (I.GETBASE DATUMA0068 2) 32767) (LLSH (COND (NIL 1) (T 0)) 15))) 15) 0))) ((LAMBDA (DATUMA0067) (DECLARE (LOCALVARS DATUMA0067)) (PROG1 DATUMA0067 (I.PUTBASEPTR DATUMA0067 0 NIL))) (I.\\CREATECELL 14)))) (NOT (EQ 0 0))) (COND ((EQ (COND (FATP 1) (T 0)) 1) %FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)))) (SETQ $$1 N)))) (PROGN (NEQ (LOGAND (LRSH (I.PUTBASE $$2 2 (LOGOR (LOGAND (I.GETBASE $$2 2) 49151) (LLSH (LOGAND (COND (NIL 1) (T 0)) 1) 14))) 14) 1) 0) (I.PUTBASEPTR $$2 0 STRINGBASE) STRINGBASE))) NIL NIL)))) (COND ((NEQ 0 INITCHAR) (*) (COND (FATP (|for| I |from| 0 |to| (SUB1 N) |do| (I.PUTBASE STRINGBASE I INITCHAR))) (T (|for| I |from| 0 |to| (SUB1 N) |do| (I.\\PUTBASEBYTE STRINGBASE I INITCHAR))))))) OLD) -) - -(I.%COPY-ONED-ARRAY -(LAMBDA (LOCAL-ARRAY) (*) (PROG ((SIZE (|ffetch| (ONED-ARRAY TOTAL-SIZE) |of| LOCAL-ARRAY)) (BASE (|ffetch| (ONED-ARRAY BASE) |of| LOCAL-ARRAY)) (OFFSET (|ffetch| (ONED-ARRAY OFFSET) |of| LOCAL-ARRAY)) (TYPENUMBER (|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) 1) |then| (ERROR "Can't copy pointer arrays")) (SETQ NCELLS (LRSH (IPLUS (ITIMES (IPLUS SIZE OFFSET) (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) 31) 5)) (SETQ REMOTE-ARRAY ((LAMBDA (DATUMA0087) (DECLARE (LOCALVARS DATUMA0087)) (PROG1 DATUMA0087 (I.PUTBASEFIXP DATUMA0087 6 SIZE))) ((LAMBDA (DATUMA0086 NEWVALUEA0085) (DECLARE (LOCALVARS DATUMA0086 NEWVALUEA0085)) (PROG1 DATUMA0086 (I.PUTBASEFIXP DATUMA0086 4 NEWVALUEA0085))) ((LAMBDA (DATUMA0084) (DECLARE (LOCALVARS DATUMA0084)) (PROG1 DATUMA0084 (LOGAND (I.PUTBASE DATUMA0084 2 (LOGOR (LOGAND (I.GETBASE DATUMA0084 2) 65280) (LOGAND TYPENUMBER 255))) 255))) ((LAMBDA (DATUMA0083 NEWVALUEA0082) (DECLARE (LOCALVARS DATUMA0083 NEWVALUEA0082)) (PROG1 DATUMA0083 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0083 2 (LOGOR (LOGAND (I.GETBASE DATUMA0083 2) 65023) (LLSH (LOGAND (COND (NEWVALUEA0082 1) (T 0)) 1) 9))) 9) 1) 0))) ((LAMBDA (DATUMA0081 NEWVALUEA0080) (DECLARE (LOCALVARS DATUMA0081 NEWVALUEA0080)) (PROG1 DATUMA0081 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0081 2 (LOGOR (LOGAND (I.GETBASE DATUMA0081 2) 61439) (LLSH (LOGAND (COND (NEWVALUEA0080 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0079 NEWVALUEA0078) (DECLARE (LOCALVARS DATUMA0079 NEWVALUEA0078)) (PROG1 DATUMA0079 (I.PUTBASEPTR DATUMA0079 0 NEWVALUEA0078))) (I.\\CREATECELL 14) (I.\\ALLOCBLOCK NCELLS)) (%CHAR-TYPE-P TYPENUMBER)) (NEQ 0 (LOGAND (LRSH (I.GETBASE LOCAL-ARRAY 2) 9) 1)))) (I.GETBASEFIXP LOCAL-ARRAY 4)))) (SETQ REMOTE-BASE (I.GETBASEPTR REMOTE-ARRAY 0)) (|for| I |from| 0 |to| (SUB1 (LLSH NCELLS 1)) |do| (I.PUTBASE REMOTE-BASE I (\\GETBASE BASE I))) (RETURN REMOTE-ARRAY))) -) - -(I.%COPY-STRING-TO-ARRAY -(LAMBDA (LOCAL-STRING) (*) (*) (PROG ((SIZE (NCHARS LOCAL-STRING)) REMOTE-BASE REMOTE-ARRAY) (SETQ REMOTE-BASE (I.\\ALLOCBLOCK (LRSH (IPLUS (ITIMES SIZE 8) 31) 5))) (SETQ REMOTE-ARRAY ((LAMBDA (DATUMA0092) (DECLARE (LOCALVARS DATUMA0092)) (PROG1 DATUMA0092 (I.PUTBASEFIXP DATUMA0092 6 SIZE))) ((LAMBDA (DATUMA0091) (DECLARE (LOCALVARS DATUMA0091)) (PROG1 DATUMA0091 (I.PUTBASEFIXP DATUMA0091 4 SIZE))) ((LAMBDA (DATUMA0090) (DECLARE (LOCALVARS DATUMA0090)) (PROG1 DATUMA0090 (LOGAND (I.PUTBASE DATUMA0090 2 (LOGOR (LOGAND (I.GETBASE DATUMA0090 2) 65280) (LOGAND 67 255))) 255))) ((LAMBDA (DATUMA0089) (DECLARE (LOCALVARS DATUMA0089)) (PROG1 DATUMA0089 (NEQ (LOGAND (LRSH (I.PUTBASE DATUMA0089 2 (LOGOR (LOGAND (I.GETBASE DATUMA0089 2) 61439) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 12))) 12) 1) 0))) ((LAMBDA (DATUMA0088) (DECLARE (LOCALVARS DATUMA0088)) (PROG1 DATUMA0088 (I.PUTBASEPTR DATUMA0088 0 REMOTE-BASE))) (I.\\CREATECELL 14))))))) (|for| I |from| 0 |to| (SUB1 SIZE) |do| (I.\\PUTBASEBYTE REMOTE-BASE I (NTHCHARCODE LOCAL-STRING (ADD1 I)))) (RETURN REMOTE-ARRAY))) -) -) -(DEFINEQ - -(I.\\#BLOCKDATACELLS -(LAMBDA (DATAWORD) (*) (*) (PROG ((TYPENO (I.NTYPX DATAWORD))) (RETURN (COND ((EQ 0 TYPENO) (COND ((AND (EQ 0 (I.NTYPX DATAWORD)) (IGEQ (I.HILOC DATAWORD) 23)) (IDIFFERENCE (I.GETBASE (I.ADDBASE DATAWORD (IMINUS 2)) 1) 2)) (T (\\ILLEGAL.ARG DATAWORD)))) (T (OR (AND (OR I.HUNKING? (NEQ 0 (LOGAND (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18)) 6) 14) 1))) (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES TYPENO 18)) 3) 1)) (\\ILLEGAL.ARG DATAWORD))))))) -) - -(I.\\PREFIXALIGNMENT? -(LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE) (*) (*) (PROG ((DAT (LRSH (I.LOLOC (PROGN (PROGN (I.ADDBASE BASE 2)))) 1)) (ADJUSTMENT 0) FUDGE) (*) LP (COND ((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN)) 0)) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE)))) (SETQ DAT (PLUS DAT FUDGE)))) (COND ((AND INITONPAGE (NEQ (LOGAND DAT (CONSTANT (LOGXOR (SUB1 128) -1))) (LOGAND (IPLUS DAT INITONPAGE -1) (CONSTANT (LOGXOR (SUB1 128) -1))))) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT (SETQ FUDGE (IDIFFERENCE 128 (IMOD DAT 128))))) (SETQ DAT (PLUS DAT FUDGE)) (*))) (COND ((AND (EQ GCTYPE 2) (IGREATERP (IDIFFERENCE ARLEN 2) (SETQ FUDGE (IDIFFERENCE 32768 (SETQ DAT (IMOD DAT 32768)))))) (*) (SETQ ADJUSTMENT (PLUS ADJUSTMENT FUDGE)) (SETQ DAT (PLUS DAT FUDGE)) (*))) (*) (RETURN ADJUSTMENT))) -) - -(I.\\ALLOCBLOCK -(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst|)) (COND ((ILESSP NCELLS 2) (COND ((ILESSP NCELLS 0) (\\ILLEGAL.ARG NCELLS))) (SETQ NCELLS 2)) ((IGREATERP NCELLS 65533) (\\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE"))) (*) (SELECTQ GCTYPE (NIL (SETQ GCTYPE 0)) (T (SETQ GCTYPE 1)) NIL) (*) (COND ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) (IGREATERP INITONPAGE 128))) (\\ILLEGAL.ARG INITONPAGE))) (COND ((NULL ALIGN)) ((OR (ILESSP ALIGN 0) (IGREATERP ALIGN 128)) (\\ILLEGAL.ARG ALIGN)) ((ILEQ ALIGN 1) (SETQ ALIGN)) ((AND INITONPAGE (PROGN (*) NIL)) (ERROR "INITONPAGE and ALIGN too high"))) (OR (AND I.HUNKING? (ILEQ NCELLS 64) (I.\\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN)) (PROG ((ARLEN (IPLUS NCELLS 2)) ABLOCK) RETRY (PROGN (*) (SETQ ABLOCK (OR (NILL ARLEN GCTYPE INITONPAGE ALIGN) (I.\\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN) (PROGN (FRPTQ 10 (RECLAIM)) (*) (NILL ARLEN GCTYPE INITONPAGE ALIGN)) (GO FULL))) (*) (NEQ (LOGAND (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65534) (LOGAND (COND (T 1) (T 0)) 1))) 1) 0) (NEQ (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65534) (LOGAND (COND (T 1) (T 0)) 1)))) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) ABLOCK (IDIFFERENCE (I.GETBASE ABLOCK 1) 1))) 1) 0) (LOGAND (LRSH (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65529) (LLSH (LOGAND GCTYPE 3) 1))) 1) 3) (NILL ABLOCK NIL) (PROGN NCELLS) (*) (SETQ ABLOCK (I.ADDBASE ABLOCK 2)) (PROGN ABLOCK) (RETURN ABLOCK)) FULL (LISPERROR "ARRAYS FULL" NIL T) (*) (GO RETRY)))) -) - -(I.\\MAIKO.ALLOCBLOCK -(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst|)) (COND ((ILESSP NCELLS 2) (COND ((ILESSP NCELLS 0) (\\ILLEGAL.ARG NCELLS))) (SETQ NCELLS 2)) ((IGREATERP NCELLS 65533) (\\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE"))) (*) (SELECTQ GCTYPE (NIL (SETQ GCTYPE 0)) (T (SETQ GCTYPE 1)) NIL) (*) (*) (*) (COND ((NULL ALIGN)) ((OR (ILESSP ALIGN 0) (IGREATERP ALIGN 128)) (\\ILLEGAL.ARG ALIGN)) ((ILEQ ALIGN 1) (SETQ ALIGN)) ((AND INITONPAGE (PROGN (*) NIL)) (ERROR "INITONPAGE and ALIGN too high"))) (OR (AND I.HUNKING? (ILEQ NCELLS 64) (*) (I.\\ALLOCHUNK NCELLS GCTYPE NIL ALIGN)) (PROG ((ARLEN (IPLUS NCELLS 2)) ABLOCK) RETRY (PROGN (*) (SETQ ABLOCK (OR (NILL ARLEN GCTYPE NIL ALIGN) (I.\\ALLOCBLOCK.NEW ARLEN GCTYPE NIL ALIGN) (PROGN (FRPTQ 10 (RECLAIM)) (*) (NILL ARLEN GCTYPE INITONPAGE ALIGN)) (GO FULL))) (*) (NEQ (LOGAND (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65534) (LOGAND (COND (T 1) (T 0)) 1))) 1) 0) (NEQ (LOGAND ((LAMBDA ($$PUTBITS) (DECLARE (LOCALVARS $$PUTBITS)) (I.PUTBASE $$PUTBITS 0 (LOGOR (LOGAND (I.GETBASE $$PUTBITS 0) 65534) (LOGAND (COND (T 1) (T 0)) 1)))) ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) ABLOCK (IDIFFERENCE (I.GETBASE ABLOCK 1) 1))) 1) 0) (LOGAND (LRSH (I.PUTBASE ABLOCK 0 (LOGOR (LOGAND (I.GETBASE ABLOCK 0) 65529) (LLSH (LOGAND GCTYPE 3) 1))) 1) 3) (NILL ABLOCK NIL) (PROGN NCELLS) (SETQ ABLOCK (I.ADDBASE ABLOCK 2)) (PROG1 (PROGN ABLOCK) (PROGN 1)) (RETURN ABLOCK)) FULL (LISPERROR "ARRAYS FULL" NIL T) (*) (GO RETRY)))) -) - -(I.\\ALLOCBLOCK.NEW -(LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst| |I.NxtArrayPage|)) (*) (PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN) RETRY (COND ((AND (OR INITONPAGE ALIGN) (NEQ 0 (SETQ PREFIXLEN (I.\\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE |I.ArrayFrLst|)))) (*) (COND ((SETQ PREFIXLEN (I.\\ALLOCBLOCK.NEW PREFIXLEN)) (I.\\MERGEBACKWARD PREFIXLEN) (*)) (T (RETURN))))) (SETQ FINALWORD (I.ADDBASE (I.ADDBASE |I.ArrayFrLst| ARLEN) (SUB1 ARLEN))) (*) (SETQ NEXTFREEBLOCK (I.ADDBASE FINALWORD 1)) (COND ((IGREATERP (SETQ FINALPAGE (IPLUS (LLSH (I.HILOC FINALWORD) 8) (LRSH (I.LOLOC FINALWORD) 8))) (IDIFFERENCE |I.NxtMDSPage| 128)) (*) (SELECTQ (NILL (ADD1 (IDIFFERENCE FINALPAGE |I.NxtArrayPage|))) (T (*)) (0 (*) (GO RETRY)) (RETURN NIL)))) (*) (|until| (IGREATERP |I.NxtArrayPage| FINALPAGE) |do| (I.\\MAKEMDSENTRY |I.NxtArrayPage| 0) (I.\\NEW2PAGE ((LAMBDA ($$1) (I.VAG2 (LRSH (SETQ $$1 |I.NxtArrayPage|) 8) (LLSH (LOGAND $$1 255) 8))) NIL)) (I.PUTBASEFIXP |I.NxtArrayPage| 0 (IPLUS |I.NxtArrayPage| 2))) (RETURN (PROG1 (I.\\MAKEFREEARRAYBLOCK |I.ArrayFrLst| ARLEN) (SETQ |I.ArrayFrLst| NEXTFREEBLOCK))))) -) - -(I.\\MAKEFREEARRAYBLOCK -(LAMBDA (BLOCK LENGTH) (*) (I.PUTBASE BLOCK 0 43688) (I.PUTBASE BLOCK 1 LENGTH) (I.PUTBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BLOCK (IDIFFERENCE (I.GETBASE BLOCK 1) 1)) 0 43688) (I.PUTBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BLOCK (IDIFFERENCE (I.GETBASE BLOCK 1) 1)) 1 LENGTH) BLOCK) -) - -(I.\\MERGEBACKWARD -(LAMBDA (BASE) (*) (*) (PROG (ARLEN PARLEN PBASE PTRAILER SPLIT) (COND ((NULL BASE) (RETURN NIL)) ((OR (NOT (PROGN NIL)) (EQ BASE (I.VAG2 23 0)) (EQ BASE (I.VAG2 64 0)) (NEQ 0 (LOGAND (I.GETBASE (SETQ PTRAILER (I.ADDBASE BASE (IMINUS 2))) 0) 1))) (*) (RETURN (I.\\LINKBLOCK BASE)))) (SETQ PBASE ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) BASE (IMINUS (I.GETBASE PTRAILER 1)))) (NILL PBASE T) (\\DELETEBLOCK? PBASE) (RETURN (\\ARRAYBLOCKMERGER PBASE BASE)))) -) - -(I.\\LINKBLOCK -(LAMBDA (BASE) (*) (*) (COND (I.FREEBLOCKBUCKETS (COND ((ILESSP (I.GETBASE BASE 1) 4) (NILL BASE T)) (T (PROG ((FBL ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (I.ADDBASE (I.ADDBASE BASE N) N)) I.FREEBLOCKBUCKETS (IMIN (INTEGERLENGTH (I.GETBASE BASE 1)) 30))) FREEBLOCK) (SETQ FREEBLOCK (I.GETBASEPTR FBL 0)) (COND ((NULL FREEBLOCK) (I.PUTBASEPTR BASE 2 BASE) (I.PUTBASEPTR BASE 4 BASE)) (T (I.PUTBASEPTR BASE 2 FREEBLOCK) (I.PUTBASEPTR BASE 4 (I.GETBASEPTR FREEBLOCK 4)) (I.PUTBASEPTR (I.GETBASEPTR FREEBLOCK 4) 2 BASE) (I.PUTBASEPTR FREEBLOCK 4 BASE))) (I.PUTBASEPTR FBL 0 BASE) (NILL BASE T T)))))) BASE) -) - -(I.\\ALLOCHUNK -(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (*) (COND ((AND ALIGN (OR (IGREATERP ALIGN 64) (NOT (FMEMB ALIGN (SELECTC GCTYPE (0 (CONSTANT (|for| X |in| (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) |when| (AND (IGREATERP X 1) (ILEQ X 64) (POWEROFTWOP X)) |collect| X))) (1 (CONSTANT (|for| X |in| (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) |when| (AND (IGREATERP X 1) (ILEQ X 64) (POWEROFTWOP X)) |collect| X))) (2 (CONSTANT (LIST 2))) NIL))))) (*) (ERROR "Oddball alignment request" ALIGN))) (PROG ((TYPENUM.TABLE (SELECTC GCTYPE (0 I.UNBOXEDHUNK.TYPENUM.TABLE) (2 I.CODEHUNK.TYPENUM.TABLE) (1 I.PTRHUNK.TYPENUM.TABLE) (SHOULDNT))) (FAILCNT 0) DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS) BEG (|do| (SETQ DTNUMBER (I.\\GETBASEBYTE TYPENUM.TABLE NCELLS)) (SETQ HUNKSIZE (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18)) 3) 1)) |repeatuntil| (OR (NOT ALIGN) (EQ 0 (IREMAINDER (LRSH (I.GETBASE (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18)) 3) 1) ALIGN)) (COND ((IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE)) 64) (GO LOSE)) (T (*) NIL)))) LP (SETQ HUNK (I.\\CREATECELL DTNUMBER)) (COND ((OR (NULL INITONPAGE) (ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE 128 (LRSH (LOGAND (I.LOLOC HUNK) 255) 1))))) (*) (RETURN HUNK))) (*) (COND (T (*) (HELP "Call to \\ALLOCBLOCK with non-NIL INITONPAGE demand" INITONPAGE)) (T (COND ((AND (EQ GCTYPE 2) (ILEQ (IQUOTIENT (ITIMES 10 ONPAGE) HUNKSIZE) (COND ((ILEQ HUNKSIZE 24) 60) ((ILEQ HUNKSIZE 50) 50) (T 30)))) (*) (PROGN HUNK)) (T (*) (SETQ STRADDLERS (I.\\CONS.UFN HUNK STRADDLERS)))) (COND ((IGREATERP (SETQ FAILCNT (PLUS FAILCNT 1)) 16) (*) (GO LOSE)) ((EQ FAILCNT 8) (*) (SETQ NCELLS (ADD1 HUNKSIZE)) (AND STRADDLERS (SETQ \\HUNKREJECTS (NCONC STRADDLERS \\HUNKREJECTS))) (GO BEG))) (GO LP))) LOSE (AND STRADDLERS (SETQ \\HUNKREJECTS (NCONC STRADDLERS \\HUNKREJECTS))) (RETURN))) -) -) -(DEFINEQ - -(I.PREINITARRAYS -(LAMBDA NIL (*) (*) (DECLARE (GLOBALVARS |I.ArrayFrLst| |I.ArrayFrLst2| |I.NxtArrayPage|)) (SETQ |I.ArrayFrLst| (I.VAG2 23 0)) (SETQ |I.ArrayFrLst2| (I.VAG2 64 0)) (SETQ |I.NxtArrayPage| (IPLUS (LLSH (I.HILOC |I.ArrayFrLst|) 8) (LRSH (I.LOLOC |I.ArrayFrLst|) 8)))) -) - -(I.POSTINITARRAYS -(LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (*) (*) (SETQ I.FREEBLOCKBUCKETS (I.\\ALLOCBLOCK (ADD1 30))) (PROG ((EXTRACELLS (IDIFFERENCE (LLSH CODESTARTPAGE 7) (IPLUS (LLSH (I.HILOC |I.ArrayFrLst|) 15) (LRSH (I.LOLOC |I.ArrayFrLst|) 1))))) (*) (COND ((IGREATERP EXTRACELLS 65535) (|printout| T T T "POSTINITARRAYS: You pre-allocated too much string space." T 19 "MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about " (IDIFFERENCE (LRSH EXTRACELLS 7) 10) "." T) (HELP)) ((IGEQ EXTRACELLS 4) (*) (|printout| T T T "POSTINITARRAYS: There were " (LRSH EXTRACELLS 7) " 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 (LRSH (IMINUS EXTRACELLS) 7)) " to MKI.CODESTARTOFFSET on MAKEINIT." T) (HELP))) (*) (I.\\LINKBLOCK (I.\\ALLOCBLOCK.NEW EXTRACELLS)) (SETQ |I.ArrayFrLst| AFTERCODEPTR) (*) (SETQ |I.NxtArrayPage| CODENEXTPAGE) (|for| VP |from| (IPLUS (LLSH (I.HILOC (I.VAG2 23 0)) 8) (LRSH (I.LOLOC (I.VAG2 23 0)) 8)) |to| (IPLUS (LLSH (I.HILOC |I.NxtArrayPage|) 8) (LRSH (I.LOLOC |I.NxtArrayPage|) 8)) |by| (LRSH 512 8) |do| (I.\\MAKEMDSENTRY VP 0)))) -) - -(I.FILEARRAYBASE -(LAMBDA NIL (*) (I.ADDBASE (I.VAG2 23 0) (IPLUS (LLSH MKI.CODESTARTOFFSET 8) (LRSH (IDIFFERENCE (GETFILEPTR (OUTPUT)) |MKI.FirstDataByte|) 1)))) -) - -(I.FILEBLOCKTRAILER -(LAMBDA (BLOCKINFO) (*) (*) (BOUT16 OUTX 43689) (BOUT16 OUTX BLOCKINFO))) - -(I.FILECODEBLOCK -(LAMBDA (NCELLS INITONPAGE) (*) (*) (PROG (PREFIXLEN (ARLEN (IPLUS NCELLS 2))) (*) (COND ((NEQ 0 (SETQ PREFIXLEN (I.\\PREFIXALIGNMENT? ARLEN INITONPAGE 2 2 (I.FILEARRAYBASE)))) (*) (I.FILEPATCHBLOCK PREFIXLEN))) (BOUT16 OUTX 43693) (BOUT16 OUTX ARLEN) (RETURN ARLEN))) -) - -(I.FILEPATCHBLOCK -(LAMBDA (ARLEN) (*) (*) (BOUT16 OUTX 43688) (*) (BOUT16 OUTX ARLEN) (*) (COND ((IGREATERP ARLEN 1) (*) (BOUTZEROS (LLSH (IDIFFERENCE ARLEN 2) 2)) (*) (BOUT16 OUTX 43688) (*) (BOUT16 OUTX ARLEN))) NIL) -) -) -(DEFINEQ - -(I.\\SETUP.HUNK.TYPENUMBERS -(LAMBDA NIL (*) (*) (*) (SETQ INITIALDTDCONTENTS (APPEND \\BUILT-IN-SYSTEM-TYPES (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) 1 (QUOTE \\PTRHUNK)) (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) 0 (QUOTE \\UNBOXEDHUNK)) (I.\\COMPUTE.HUNK.TYPEDECLS (QUOTE (12 16 20 24 28 32 36 42 50 64)) 2 (QUOTE \\CODEHUNK))))) -) - -(I.\\COMPUTE.HUNK.TYPEDECLS -(LAMBDA (SIZELST GCTYPE PREFIX) (*) (*) (|for| HUNKSIZE |in| SIZELST BIND (FINAL _ (AND (EQ GCTYPE CODEBLOCK.GCT) (QUOTE \\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))) -) - -(I.\\TURN.ON.HUNKING -(LAMBDA NIL (*) (*) (SETQ I.UNBOXEDHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) 0 (QUOTE \\UNBOXEDHUNK))) (SETQ I.CODEHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (12 16 20 24 28 32 36 42 50 64)) 2 (QUOTE \\CODEHUNK))) (SETQ I.PTRHUNK.TYPENUM.TABLE (I.\\SETUP.TYPENUM.TABLE (QUOTE (2 4 5 6 7 8 10 12 16 24 32 42 64)) 1 (QUOTE \\PTRHUNK))) (SETQ I.HUNKING? T)) -) - -(I.\\SETUP.TYPENUM.TABLE -(LAMBDA (SIZELST GCTYPE PREFIX) (*) (*) (|for| I |from| 0 |to| 64 |bind| (HUNKSIZE _ -1) (SIZEL _ SIZELST) (TABLE _ (I.\\ALLOCBLOCK (LRSH (IPLUS (IPLUS 4 64) 3) 2) 0)) TNAME DTD DTNUMBER |do| (COND ((IGREATERP I HUNKSIZE) (*) (SETQ HUNKSIZE (OR (FIXP (PROG1 (CAR SIZEL) (SETQ SIZEL (CDR SIZEL)))) 64)) (SETQ TNAME (PACK* PREFIX HUNKSIZE)) (COND ((|for| |old| DTNUMBER |from| 1 |as| TYPE |in| INITIALDTDCONTENTS |when| (EQ (CAR TYPE) TNAME) |do| (*) (RETURN DTNUMBER)) (SETQ DTD (I.ADDBASE (I.VAG2 6 4096) (ITIMES DTNUMBER 18))) (LOGAND (LRSH (I.PUTBASE DTD 6 (LOGOR (LOGAND (I.GETBASE DTD 6) 53247) (LLSH (LOGAND GCTYPE 3) 12))) 12) 3) (NEQ (LOGAND (LRSH (I.PUTBASE DTD 6 (LOGOR (LOGAND (I.GETBASE DTD 6) 49151) (LLSH (LOGAND (COND (T 1) (T 0)) 1) 14))) 14) 1) 0)) (T (HELP "No type declaration for" TNAME))))) (I.\\PUTBASEBYTE TABLE I DTNUMBER) |finally| (RETURN TABLE))) -) -) -(DEFINEQ - -(I.DCODERD -(LAMBDA (FN) (*) (*) (*) (READC) (LET ((INSTREAM (GETSTREAM NIL (QUOTE INPUT))) (*READTABLE* (|if| (EQ *READTABLE* FILERDTBL) |then| (*) I.CODERDTBL |else| (*) *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) (QUOTE NAME)) (SETQ FRAMENAME (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE)))) (COND ((EQ (CAR NAMETABLE) (QUOTE L)) (SETQ LOCALARGS (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE)))) (COND (NAMETABLE (*) (|on| NAMETABLE |by| CDDDR |do| (SETQ NTSIZE (PLUS NTSIZE 1))) (SETQ NTSIZE (LOGAND (IPLUS (ADD1 (LLSH NTSIZE 1)) (CONSTANT (SUB1 4))) (CONSTANT (LOGXOR (SUB1 4) -1)))))) (SETQ NTWORDS (COND (NAMETABLE (IPLUS NTSIZE NTSIZE)) (T (CONSTANT 4)))) (*) (SETQ STARTPC (LLSH (IPLUS (PROGN 8) NTWORDS) 1)) (*) (COND (LOCALARGS (SETQ STARTLOCALS STARTPC) (*) (SETQ LOCALSIZE (LOGAND (IPLUS (ADD1 (LLSH (LRSH (FLENGTH LOCALARGS) 1) 1)) (CONSTANT (SUB1 (IQUOTIENT 4 2)))) (CONSTANT (LOGXOR (SUB1 (IQUOTIENT 4 2)) -1)))) (*) (SETQ LOCALSIZE (LLSH LOCALSIZE 1)) (*) (SETQ STARTPC (PLUS STARTPC (LLSH LOCALSIZE 1))))) (SETQ REALSIZE (LOGAND (IPLUS (IPLUS STARTPC CODELEN) (CONSTANT (SUB1 8))) (CONSTANT (LOGXOR (SUB1 8) -1)))) (SETQ CA (SCRATCHARRAY REALSIZE (LOGAND (IPLUS (ADD1 (LRSH (IPLUS STARTPC 3) 2)) (CONSTANT (SUB1 2))) (CONSTANT (LOGXOR (SUB1 2) -1))))) (AIN CA STARTPC CODELEN INSTREAM) (*) (|for| X |on| NAMETABLE |by| (CDDDR X) |as| NT1 |from| (IPLUS (SUB1 (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) (LLSH (PROGN 8) 1)) |by| (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1) |bind| (NTBYTESIZE _ (LLSH NTSIZE 1)) |do| (I.FIXUPSYM CA NT1 (CADDR X) -1) (*) (I.SETSTKNTOFFSET CA (IPLUS NT1 NTBYTESIZE) (SELECTQ (CAR X) (P (CONSTANT (LLSH 2 14))) (F (OR FVAROFFSET (SETQ FVAROFFSET (LLSH (LRSH NT1 2) 1))) (*) (CONSTANT (LLSH 3 14))) (I (CONSTANT (LLSH 0 14))) (SHOULDNT)) (CADR X)) (*)) (COND (LOCALARGS (*) (|for| X |on| LOCALARGS |by| (CDDR X) |as| NT |from| (IPLUS (SUB1 (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) STARTLOCALS) |by| (CONSTANT (LLSH (CONSTANT (I.WORDSPERNAMEENTRY)) 1)) |do| (I.FIXUPSYM CA NT (CADR X) -1) (*) (I.SETSTKNTOFFSET CA (IPLUS NT LOCALSIZE) (CONSTANT (LLSH 0 14)) (CAR X)) (*)))) (PROGN (*) ((LAMBDA (DEFA0094 VALUEA0093) (DECLARE (LOCALVARS DEFA0094 VALUEA0093)) (\\BYTESETA DEFA0094 2 (LRSH VALUEA0093 8)) (\\BYTESETA DEFA0094 (ADD1 2) (IMOD VALUEA0093 (CONSTANT (LLSH 1 8))))) CA (UNSIGNED (PROGN (COND ((EQ ARGTYPE 2) -1) (T NARGS))) 16)) ((LAMBDA (DEFA0096 VALUEA0095) (DECLARE (LOCALVARS DEFA0096 VALUEA0095)) (\\BYTESETA DEFA0096 4 (LRSH VALUEA0095 8)) (\\BYTESETA DEFA0096 (ADD1 4) (IMOD VALUEA0095 (CONSTANT (LLSH 1 8))))) CA (UNSIGNED (PROGN (SUB1 (LRSH (IPLUS (IPLUS NLOCALS NFREEVARS) 1) 1))) 16)) (PROGN (\\BYTESETA CA 6 (LRSH STARTPC 8)) (\\BYTESETA CA (ADD1 6) (IMOD STARTPC (CONSTANT (LLSH 1 8))))) (\\BYTESETA CA 8 (LOGOR (LOGAND (\\BYTELT CA 8) 207) (LLSH (LOGAND ARGTYPE 3) 4))) (I.FIXUPPTR CA 11 (I.\\COPY FRAMENAME)) (PROGN (\\BYTESETA CA 12 (LRSH NTSIZE 8)) (\\BYTESETA CA (ADD1 12) (IMOD NTSIZE (CONSTANT (LLSH 1 8))))) (\\BYTESETA CA 14 NLOCALS) (\\BYTESETA CA 15 (PROGN (OR FVAROFFSET 0))) ((LAMBDA (DEFA0098 VALUEA0097) (DECLARE (LOCALVARS DEFA0098 VALUEA0097)) (\\BYTESETA DEFA0098 0 (LRSH VALUEA0097 8)) (\\BYTESETA DEFA0098 (ADD1 0) (IMOD VALUEA0097 (CONSTANT (LLSH 1 8))))) CA (PROGN (I.\\STKMIN CA)))) (*) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPSYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPSYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (|for| X |on| (READ) |by| (CDDR X) |do| (I.FIXUPPTR CA (IPLUS (CAR X) STARTPC) (I.\\COPY (CADR X)))) (I.PUTDEFN FN CA (IPLUS STARTPC CODELEN))))) -) -) - -(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))) -) - -(RPAQ I.CODERDTBL (COPYREADTABLE (QUOTE ORIG))) - -(SETSYNTAX (CHARCODE ^Y) (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL))))) I.CODERDTBL) - -(SETSYNTAX (CHARCODE \|) (QUOTE (MACRO ALWAYS READVBAR)) I.CODERDTBL) - -(READTABLEPROP I.CODERDTBL (QUOTE USESILPACKAGE) NIL) -(DEFINEQ - -(I.INITUFNTABLE -(LAMBDA NIL (*) (I.CREATEPAGES (I.VAG2 6 3072) 2 NIL T) (|for| I |from| 0 |to| 255 |do| (I.\\SETUFNENTRY I (QUOTE \\UNKNOWN.UFN) 0 0)) (|for| X |in| \\OPCODES |when| (CADDDR (CDDR X)) |do| (I.\\SETUFNENTRY (PROG ((OP (CAR X))) (RETURN (|if| (LISTP OP) |then| (CAR OP) |else| OP))) (CADDDR (CDDR X)) (COND ((LISTP (CADDDR (CDR X))) (CADR (CADDDR (CDR X)))) (T (IDIFFERENCE (IPLUS 1 (COND ((EQ (CADDR X) 0) 0) (T 1))) (CADDDR (CDR X))))) (SELECTQ (CADDR X) (0 0) (1 1) (2 2) (3 (*) 3) (4 4) (5 5) (SHOULDNT))))) -) - -(I.\\SETUFNENTRY -(LAMBDA (INDEX FN NARGS NEXTRA) (*) (SETQ INDEX (I.ADDBASE (I.ADDBASE (I.VAG2 6 3072) INDEX) INDEX)) (I.PUTBASE INDEX 0 (I.ATOMNUMBER FN)) (LRSH (I.PUTBASE INDEX 1 (LOGOR (LOGAND (I.GETBASE INDEX 1) 255) (LLSH NEXTRA 8))) 8) (LOGAND (I.PUTBASE INDEX 1 (LOGOR (LOGAND (I.GETBASE INDEX 1) 65280) (LOGAND NARGS 255))) 255)) -) -) - -(RPAQQ INITPTRS ((\\MAINDISK) (\\SWAPDSK1) (\\SWAPDSK2) (\\SWAPREQUESTBLOCK) (\\DISKREQUESTBLOCK) (\\FREEPAGEFID) (\\FINALIZATION.FUNCTIONS) (|\\OneCharAtomBase| NIL) (\\SCRATCHSTRING) (\\LISTPDTD) (\\FREEBLOCKBUCKETS) (|\\ArrayFrLst|) (|\\ArrayFrLst2|) (\\UNBOXEDHUNK.TYPENUM.TABLE) (\\CODEHUNK.TYPENUM.TABLE) (\\PTRHUNK.TYPENUM.TABLE)) -) - -(RPAQQ INITVALUES ((|\\NxtMDSPage| |\\FirstMDSPage|) (|\\LeastMDSPage| |\\FirstMDSPage|) (|\\SecondMDSPage| |\\DefaultSecondMDSPage|) (|\\SecondArrayPage| |\\DefaultSecondArrayPage|) (\\MDSFREELISTPAGE) (|\\MaxSysTypeNum| 0) (|\\MaxTypeNumber|) (|\\AtomFrLst| 0) (|\\NxtArrayPage|) (\\HUNKING?)) -) -(DECLARE\: EVAL@COMPILE DONTCOPY - -(FILESLOAD (LOADCOMP) MAKEINIT) -) -STOP diff --git a/CLTL2/LLARRAYELT.~2~ b/CLTL2/LLARRAYELT.~2~ deleted file mode 100644 index 889fa5e4..00000000 --- a/CLTL2/LLARRAYELT.~2~ +++ /dev/null @@ -1,2948 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Jan-93 10:43:28" {DSK}lde>lispcore>sources>LLARRAYELT.;2 154426 - - changes to%: (RECORDS HARRAYP HASHSLOT SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK SAFTABLE) - - previous date%: " 4-Jan-93 23:51:47" {DSK}lde>lispcore>sources>LLARRAYELT.;1) - - -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LLARRAYELTCOMS) - -(RPAQQ LLARRAYELTCOMS - [(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 - LISP::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 LISP::PUTHASH - HARRAYPROP]) - -(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 (LISP: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 (LISP:VALUES DEFAULT NIL)) - (T DEFAULT] - (GO LP) - FOUND - (RETURN (COND - (RETURNMVS (LISP: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]) - -(LISP::PUTHASH - (LISP:LAMBDA (KEY LISP:HASH-TABLE VALUE &OPTIONAL (EXTRA NIL EXTRA-P)) - (* ; "Edited 23-Mar-87 12:00 by bvm:") - - (* ;; "SETF inverse for LISP:GETHASH. Subtlety is that LISP: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.") - - (LISP:CHECK-TYPE LISP:HASH-TABLE LISP:HASH-TABLE) - (\HASHACCESS KEY (LISP:IF EXTRA-P - EXTRA - VALUE) - LISP: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 (LISP: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 ((ORIG BITS 1) - (NIL BITS 1) - (READONLY FLAG) (* ; "probably no READONLY arrays now") - (NIL BITS 1) - (BASE POINTER) - (TYP BITS 4) - (NIL BITS 4) - (LENGTH BITS 24) - (OFFST FIXP)) - - (* ;; "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 4-Jan-93 02:06 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)) - (\PUTBASEFIXP \NxtArrayPage 0 (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 LISP::PUTHASH HARRAYPROP) -) -(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 -1990 1991 1992 1993)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (9331 21709 (AIN 9341 . 11614) (AOUT 11616 . 14218) (ARRAY 14220 . 19805) (ARRAYSIZE -19807 . 19947) (ARRAYTYP 19949 . 20545) (ARRAYORIG 20547 . 20714) (COPYARRAY 20716 . 21707)) (21875 -29520 (ELT 21885 . 23314) (ELTD 23316 . 24241) (SETA 24243 . 26500) (SETD 26502 . 27496) (SUBARRAY -27498 . 29518)) (29555 55164 (HARRAY 29565 . 29785) (HASHARRAY 29787 . 33810) (HARRAYP 33812 . 33961) -(HARRAYPROP 33963 . 37998) (HARRAYSIZE 38000 . 38165) (CLRHASH 38167 . 39539) (MAPHASH 39541 . 40670) -(GETHASH 40672 . 44252) (PUTHASH 44254 . 44485) (LISP::PUTHASH 44487 . 45199) (REMHASH 45201 . 45346) ( -\HASHRECLAIM 45348 . 47131) (\HASHACCESS 47133 . 52895) (REHASH 52897 . 53621) (\COPYHARRAYP 53623 . -54353) (\HASHTABLE.DEFPRINT 54355 . 55162)) (55165 55721 (STRINGHASHBITS 55175 . 55332) ( -STRING-EQUAL-HASHBITS 55334 . 55719)) (55722 57784 (\STRINGHASHBITS-UFN 55732 . 56838) ( -\STRING-EQUAL-HASHBITS-UFN 56840 . 57782)) (62071 67166 (\CODEARRAY 62081 . 62911) (\FIXCODENUM 62913 - . 63578) (\FIXCODEPTR 63580 . 64640) (\FIXCODESYM 64642 . 67164)) (78407 113562 (\ALLOCBLOCK 78417 . -82416) (\MAIKO.ALLOCBLOCK 82418 . 86610) (\ALLOCBLOCK.OLD 86612 . 91483) (\ALLOCBLOCK.NEW 91485 . -94410) (\PREFIXALIGNMENT? 94412 . 97955) (\MAKEFREEARRAYBLOCK 97957 . 98552) (\DELETEBLOCK? 98554 . -99659) (\LINKBLOCK 99661 . 101787) (\MERGEBACKWARD 101789 . 103150) (\MERGEFORWARD 103152 . 104249) ( -\ARRAYBLOCKMERGER 104251 . 106436) (\#BLOCKDATACELLS 106438 . 107674) (\COPYARRAYBLOCK 107676 . 109244 -) (\RECLAIMARRAYBLOCK 109246 . 111375) (\ADVANCE.ARRAY.SEGMENTS 111377 . 113560)) (113624 116057 ( -\BYTELT 113634 . 114433) (\BYTESETA 114435 . 115376) (\WORDELT 115378 . 116055)) (116058 116392 ( -\ARRAYTYPENAME 116068 . 116390)) (116515 120209 (\SHOW.ARRAY.FREELISTS 116525 . 120207)) (120522 -126272 (\CHECKARRAYBLOCK 120532 . 124907) (\PARSEARRAYSPACE 124909 . 125318) (\PARSEARRAYSPACE1 125320 - . 126270)) (126406 132672 (\ALLOCHUNK 126416 . 132670)) (133850 139746 (PREINITARRAYS 133860 . 134401 -) (POSTINITARRAYS 134403 . 137121) (FILEARRAYBASE 137123 . 137535) (FILEBLOCKTRAILER 137537 . 137832) -(FILECODEBLOCK 137834 . 138850) (FILEPATCHBLOCK 138852 . 139744)) (139783 145207 ( -\SETUP.HUNK.TYPENUMBERS 139793 . 140829) (\COMPUTE.HUNK.TYPEDECLS 140831 . 142111) (\TURN.ON.HUNKING -142113 . 142785) (\SETUP.TYPENUM.TABLE 142787 . 145205)) (147470 154071 (\HUNKFIT? 147480 . 148095) ( -\AB.NEXT 148097 . 151292) (\AB.BACK 151294 . 154069))))) -STOP diff --git a/CLTL2/LLNEW.~2~ b/CLTL2/LLNEW.~2~ deleted file mode 100644 index 9a145f88..00000000 --- a/CLTL2/LLNEW.~2~ +++ /dev/null @@ -1,1418 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Jan-93 17:42:57" {DSK}lde>lispcore>sources>LLNEW.;2 68199 - - changes to%: (FNS \COPY) - - previous date%: " 5-Jan-93 00:46:10" {DSK}lde>lispcore>sources>LLNEW.;1) - - -(* ; " -Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LLNEWCOMS) - -(RPAQQ LLNEWCOMS - ((PROPS (LLNEW FILETYPE)) - [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) - - - -(* ; "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) (* lmm " 2-NOV-81 18:34") - - (* ;; - "usually done in microcode; this def. uses GETBASE, VAG2, etc. and handles overflows too") - - (\VAG2 (fetch LOBYTE of (\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) (* JonL "31-Dec-83 23:39") - - (* ;; "case where H is byte and L is smallposp MUST be handled in microcode. Other cases may run error here.") - - (\VAG2 (.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 (LISP:NUMBERP X)) - (TYPEP X 'LISP:FIXNUM)) - (EQ X Y)) - [(LISP:FLOATP X) - - (* ;; - "32 bit compare --- differs from feqp in that the predicate is not true for -0.0 and 0.0") - - (AND (LISP:FLOATP Y) - (EQ (fetch LOWORD of X) - (fetch LOWORD of Y)) - (EQ (fetch HIWORD of X) - (fetch HIWORD of Y] - ((LISP:INTEGERP X) - (AND (LISP:INTEGERP Y) - (IEQP X Y))) - [(TYPEP X 'RATIO) - (AND (TYPEP Y 'RATIO) - (EQL (LISP::RATIO-NUMERATOR X) - (LISP::RATIO-NUMERATOR Y)) - (EQL (LISP::RATIO-DENOMINATOR X) - (LISP::RATIO-DENOMINATOR Y] - ((TYPEP X 'COMPLEX) - (AND (TYPEP Y 'COMPLEX) - (EQL (LISP::COMPLEX-REALPART X) - (LISP::COMPLEX-REALPART Y)) - (EQL (LISP::COMPLEX-IMAGPART X) - (LISP::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 4-Dec-92 04:13 by jds") - (COND - ((ZEROP CDRCODING) - (RAID)) - (T (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]) - -(\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 ((CNT BYTE) - (NEXTCELL BYTE) - (NIL WORD) - (NEXTPAGE FIXP))) -) - -(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 (LISP: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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (5709 12152 (\ADDBASE 5719 . 6526) (\GETBASE 6528 . 6772) (\PUTBASE 6774 . 7050) ( -\PUTBASE.UFN 7052 . 7332) (\PUTBASEPTR.UFN 7334 . 7656) (\PUTBITS.UFN 7658 . 8364) (\GETBASEBYTE 8366 - . 8793) (\PUTBASEBYTE 8795 . 9486) (\GETBASEPTR 9488 . 9838) (\PUTBASEPTR 9840 . 10158) (\HILOC 10160 - . 10384) (\LOLOC 10386 . 10610) (\VAG2 10612 . 10910) (\RPLPTR 10912 . 11389) (\RPLPTR.UFN 11391 . -12150)) (12153 13568 (EQ 12163 . 12381) (EQL 12383 . 13566)) (13611 14361 (LOC 13621 . 13952) (VAG -13954 . 14359)) (14362 15403 (CREATEPAGES 14372 . 14861) (\NEW4PAGE 14863 . 15401)) (19946 37091 (CONS - 19956 . 20262) (\CONS.UFN 20264 . 22682) (\MAIKO.CONS.UFN 22684 . 24937) (CAR 24939 . 25066) ( -\CAR.UFN 25068 . 26171) (CDR 26173 . 26300) (\CDR.UFN 26302 . 27901) (RPLACA 27903 . 28130) ( -\RPLACA.UFN 28132 . 29131) (RPLACD 29133 . 29268) (\RPLACD.UFN 29270 . 33021) (DOCOLLECT 33023 . 33287 -) (\RPLCONS 33289 . 35299) (ENDCOLLECT 35301 . 35509) (\INITCONSPAGE 35511 . 36485) (\NEXTCONSPAGE -36487 . 37089)) (37149 39484 (\RESTLIST.UFN 37159 . 38257) (\FINDKEY.UFN 38259 . 39482)) (50410 52206 -(CHECKCONSPAGES 50420 . 51359) (\CHECKCONSPAGE 51361 . 52204)) (52391 66997 (MAKEINITFIRST 52401 . -52739) (MAKEINITLAST 52741 . 58025) (\COPY 58027 . 60530) (\UNCOPY 60532 . 66995))))) -STOP diff --git a/fonts/altofonts/fonts.widths.~1~ b/fonts/altofonts/fonts.widths.~1~ deleted file mode 100644 index 1799fd46e1008a4f714f0256aff9bc9c3950768d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 14416 zcmeHN3v^UPny&imc8AUb5<+-HgkWG{W5|pQ?qJv>9YaH68XA)Zf+DlwF~SHs0p+2O1et*@yx4V-L zQQ33$>?~cU>Q;UKqpJSDs%}-?&P*3ll}reVHowetLEe(e%FyJh1PXBFy{ochQmDEu zZh1;810~}UU;%!QcXY}4(m-Vb0l3!_2$qKf2{7}gc*X<+6BF4P@8TI-Qd(Bhj^777 z97t>?^QZdC0>MdvaCvE*4Dhs67a#2^1D@_FE1xhS zDGLP?2*A6g2Ls`7pmJ;|TvlFcs{@{C1w&)osONTOS>sB=Wr@`?-rX~9VwI~PrYAc! z~6ySY4Rpn#H#o3ru0nhbTO$bgLUy)D+@S8m0KroOve3-v)mvCU*gdltw zCjtCs;8o!Of_v`mRtYt_#5PJ=JXgL_L0=6nQHQcGE+6rucm%1~|y0KxX=VO5|NNJnB7ca*OD-QUfBFd4c2$S|RUbEcXnO9}Af_XqBKD ztAq)uf9_is9}P-}%`#&YbICaATX^|P8+da2G@>6j| zR?Ak^EL*8XW$2PFb549ATa$)rM@DW`&2*O5QKKqCx=sbvx8)+)poSs;rW&C#s1orU z4M%w>xSEj%zw86Oh}435j?r-0fOw3x;@L;`p={Yl1?fAK4awoqxJVY`*-DMNJ^N%U zKEeRDjj8kXqLX1 zJo@94b2$|UWq~}8Qh{8Hz*qs|TzMXnbz-%q7oa>B`8rVtKA%`^$AiLzX8Xyd)mjF6 zQR6OMZvj$JwB!sedl343vH~24p!jtCyHIBBbw<0aKnsj!PU~2sZbP$}ftKnTfH2My z&1fNWFsE*(zz=r#1kXF3_pyMoUJH1RVtv3I z#+++(*N3%weK;s)=-I2+4xaaBwZI%N;CY@b==A|>k)G>VAGjXO+-9D?kYatjRxt%A zuM?V+>o={yTEcVRZXc+ibGlkTv0|ZAhnDIUk2!fw&?V^CoQdnhd3nPQyiPXWu)~dc z!S8oi;Yj3Ns#9N{8c9?6EgE@KolqzI*xSU`hvYd`U_x>#c1H!+U)emIOU9?T1qY)( zdQSb@Boc9J5_8kc|J`tXEr|7O!Qwx;o?VTeR3BMg@K)K1x611#I632KaSG+F;zx)a zUbmm%$2&+Nj%I#6LUyX1Qc0yMR0X54Ks&_!Vy(DWJk1!bp@oQRVsv1G5q5y@lsLtC z@w$~E6?WL8SrhG$1LeR3{!O&Wl+hv)Js)`o{Rq~6Pk3b$4HI7BrAj`1Fpuz>R5c4P zpCE8@8Aii!V(@Z~X`I*L3eGFTtXVV+=ZxKu$LR?9W}O2iS>RgilSmUJ_aGcaSclV6 zS2`+lsRxis=sSw?I>tboI=xji^RRa3b>FST&(RB56dfn24yBCb%jxB_{UIN&GnM(X%dQuUJmN4xnGBceysBv)%c)tL((PrUgbiSt>+F-o?AB5py@K=731ST&Wc) zc($-_SdU0CDduj9g@Ez88#A+2=p55HuLEv5Xg6lyZp)VEGCWr;H*zjn;987#sfRTS zw-2~CK{^|jMjleNst|Dv@Iu^p6k^mjYFZ;&0uHofA4i^x%uR12uA^GHk)LveT!j1x zwSzG|7LH-wZbYsUIxB(kDumk)o;j$wP-P^uox!Mu`_H{FWtL(~xO2A_`gH9M-He|2 z)X@~f^xUnc9-Ylyp+}gJPnOD!ZBecRbN7|Vc1x-AGe+`?4Da&Fe8Kf@+{$dFTj}W0 zUfK&eUYYAzBj@dvxti+X-TFB1*1O)Vrz9cHyOoe^vAtW*_ei#Pi)`-}Q9W+G8g1{Q z4tTdwW$3%C2G_gBi;j1TwRelvn;m+0c+9(~yNK_&Itp}w`_H{M9NN3}|3lub?996z zwaURe@-F<_)w*ou`GtB;Zg;r(Nex`5b=A6x@flWO`8k(Vm}#8npbF)7RcQSL^wBKO zflh#TyS$evEY~(@o(AG@LglN2>N&)NYB9Kxhm=R1RUT_P@UuYA;%R7$Q9E;oDIfE= z9|gEA;4U;#e$G$%n0!Zhxo_aDpET_xgqx>scN<&aSNh`4qZla+y z67rX5AH7FEFyon81b)%|qDf-W7ENxc%Fm^hxX+A$Rwajsi72fE#;BoizHM-LfNQCU z90J*hFi%Kwi7EQYX%o|8Se(X*arqrOZ?vzJRW4-*TBvDSQ(S8>Hiw{|D#wps|H-XJ zJ&|}xSYe`l$GabGW}8J|vjF|tyVN`Ufbf37){MMBA6ion2)egj>04Ecphl zpubT6fi>V5m0LF}A9&}f2k1%KrC!ouw?d$D;P&d@Szp>@%dsVYFxLAKxvPNp@ER;!RHnWx;gN(iDcF%FcQWIl~iuOiN&F*2V6@*$be zk;Wtonrj>A+vEvIZlq<18z~h#aO5GCg`H=X62SLR4dODSOshd1%soaf;3&7zGWa-) zzK2*yS=hDUiJQ4Qk@u-w#t;i}bND%Eg;@KrUL(AZZ+J}-Er|7f?v($(eec}wu+yKI z-=n{X4pXPqX}=I%csz?v-+I_(>9?MX*UYarf6jLM#jwhu;zHOV2^ z6~3fK(vx`Oy@I=@RCOy!nn)jDKfRB?nF0yXMb!`Q@)4l#r&9Wu`pZuti%1ty&)>?; z^1Jd^@(1FKd{w?6j*H`Rw|I;GQSOyb$_C7@`{Y*frF>1+(OhtBl|yB#xMbd$@w51= z0aoc58&;`QU3XEtUnBG%S4=lf?o2YcgscNEw6 z^%w8X>-hQ$JA4p%jlNKS?H5#&*t7VOXhKip*4ucRlTSvcEQgAAzK{6BSh;{928%euNg+>T!G;r-^3upc&VE8q+5P9^rg4YZG|vLtiaN zmZH<@K~Bw+B{c?$ORHrXqK(DchC3oxyQz(}bN!exHpR>=Ecy%ZnY!>s8eL`fwnfX0lJCOVng5 z)t`O&8h+L)JXG$GciSWfM9w3v1p&RC!20*B6Rw5e{6Ec92S zoHM~#f%CRKkdp%)YV2vvhbW%{-4jhT8ofYG)HE+c^cU;-eI$M<{zyLL2GhTYkLkDK zHSsaxD3sRYylLp!;P_Y$7Je~GEC`ziRZ-|Vv?9AQ^jpkh$Y~`4nll@ zxK4j?RyqQ(s!ahd%hCXDdfGa`aU(b@hP8gOUH|I!0D%hA7LwsXym z9b1;Bq4$z|Z+K#RTkbRdeW&}!x*fV*XI#GxMepTp6zkhp{P$hQEn`ZD-hDT62y@q~ zz1tvmG*xtGpIXC zOkJeEbY#nyQAc<1zHEE<6L_~Cb<}rk!(`u%SSMO%dzb4#w9h5-U0q{Bzm4{G-Yw?d zcU<#Vp%`z)b8_uinV*UrvdXPeeD_VkSnk}r9k0wA&3NXo1h94d%6tv)8X4ES&fIN* zclW@%Ew*>z^SHUY%l0nMU3gdbB;LEluyc+(cQb6?#=P5R?y_z5xa!=y9shGy`!UYD z34TQj&&V^bch8tIzuPc2I`FQ*?7CKnr*}Aax9G16MSh{S%DwU0@O1(0vG!X>Fg^#V zq5MTbC|b=t?$?C^xmjha;}lUd)mohH>u{ofU)_V;NV!)P(CYR9w7vAQ4vW-WwL&dW z-&LDcCLLC5tyFo54yeDOMr)%wX?fIC#CmAYR~yuWXbH|~DxU^Gb6+Y|_rNQ&=_wkB ze{m0_UbKj|$Yp537P$m%+JY7PDf&63$fNRi^b;z=JL4bdQM!$0wl0A@JEW8`}k>LbpIf4@BqC9`!Sv04BpC zSAl`x>EHcgTI3gaf1w{jx83x>NddO|IkZ)vaQynemIZ`cz&d_JpohCLB z*kzaq{!U@#pBw>B$rSIfS?d7wS8c_TJ^_*SdTcH+7Akh0jwv>&Au?ECuQ!>9?0!;f zg;q5IF&k`Xy2h+?1J+Rfh8}$)Xi4f{7P-V=sKog*rW8p{-Gj2pB?6Is3+BH_sWZl4nP>EyovNa_&-O(pa@|f z>y9Z}jy)S#-3^xA=hdjZa;UT2T@ZvNS@4AO@|qp@W7cZPH53YpvQrU`b8LWP<4Kpt zcSWrkI`6PX>o74nEM&UnL{MZJi`sA4<|vO@ZBqS@uvU}{6kGKYZ`@kj*Bf8xS6AU8 z1{3Sbn-wBXLy(F2=~V0UlLM3UWjDl0aFMO9sj#Gp(l*Dy4GTLU!89)kQm~k#^BuIzWf$D4n2F)J~mr hjxJIU^-(`vrv%-iyL696=rN7c1WnO2y`net{x^KDy9odQ diff --git a/fonts/displayfonts/c0/GACHA10-MRR-C0.DISPLAYFONT.~1~ b/fonts/displayfonts/c0/GACHA10-MRR-C0.DISPLAYFONT.~1~ deleted file mode 100644 index cdea2d8560db87ee8266c3eb7f9576ee4ddf58fe..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1236 zcmb`HQD|I66o&tEa&4xi#@WpVYP)u)H*1Ump^D&wq0Zjim_(EW3|LfzNE8c#8w4d% z<=#!K_pVBs6bdUS+v-Eq2cZwefT`d=Pwyi6HbrQbp*4sAo32RSJR+o?-5s zduHaFbLPxU1K5Yx(9O?cH@W}}Nd-&Qk<nfMWZdKaYNOZ4KZY~t^ z$158km{MhAVX1JWlx+Msp7BfDTg|0qKTLZ!J@JA7+YPJzE;sSI#LhusKJ-yeo1h`O zmwZti)xMW%abAbX*>L=%2@_jP4%`!_*KbYBs7mrmYeW9iPv7 zlZhYde$zHoFzTq+gvJ`Qu4$4+whb)H?+Am8)2wn|z__#I z_Om5&kGziV+Rm(h+77pW{=P?fV9gmj%r(e88vdg_?tg5YpWQc<9`qrPet8S-MhOq# zK|F$KJb|Zi3>CaA@5SqQ3#af7&R`Xv;5 z(Y0SDOKBjYYf!64fl&|Sq`kuDv3SFgZ^e6A) on>oh^*ylU>FyF^Vc$6RJNBMD{;pg}Teu-b@MShc4xXz8g00b}GI{*Lx diff --git a/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT.~1~ b/fontsold/displayfonts/presentation/GACHA08-MRR-C0.DISPLAYFONT.~1~ deleted file mode 100644 index 5e194ea05093ba6dbc42ac8d1e16c4db4498f786..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 828 zcmaJIZ`cz&d_JpohCLB z*kzaq{!U@#pBw>B$rSIfS?d7wS8c_TJ^_*SdTcH+7Akh0jwv>&Au?ECuQ!>9?0!;f zg;q5IF&k`Xy2h+?1J+Rfh8}$)Xi4f{7P-V=sKog*rW8p{-Gj2pB?6Is3+BH_sWZl4nP>EyovNa_&-O(pa@|f z>y9Z}jy)S#-3^xA=hdjZa;UT2T@ZvNS@4AO@|qp@W7cZPH53YpvQrU`b8LWP<4Kpt zcSWrkI`6PX>o74nEM&UnL{MZJi`sA4<|vO@ZBqS@uvU}{6kGKYZ`@kj*Bf8xS6AU8 z1{3Sbn-wBXLy(F2=~V0UlLM3UWjDl0aFMO9sj#Gp(l*Dy4GTLU!89)kQm~k#^BuIzWf$D4n2F)J~mr hjxJIU^-(`vrv%-iyL696=rN7c1WnO2y`net{x^KDy9odQ diff --git a/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT.~1~ b/fontsold/displayfonts/presentation/GACHA10-MRR-C0.DISPLAYFONT.~1~ deleted file mode 100644 index cdea2d8560db87ee8266c3eb7f9576ee4ddf58fe..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1236 zcmb`HQD|I66o&tEa&4xi#@WpVYP)u)H*1Ump^D&wq0Zjim_(EW3|LfzNE8c#8w4d% z<=#!K_pVBs6bdUS+v-Eq2cZwefT`d=Pwyi6HbrQbp*4sAo32RSJR+o?-5s zduHaFbLPxU1K5Yx(9O?cH@W}}Nd-&Qk<nfMWZdKaYNOZ4KZY~t^ z$158km{MhAVX1JWlx+Msp7BfDTg|0qKTLZ!J@JA7+YPJzE;sSI#LhusKJ-yeo1h`O zmwZti)xMW%abAbX*>L=%2@_jP4%`!_*KbYBs7mrmYeW9iPv7 zlZhYde$zHoFzTq+gvJ`Qu4$4+whb)H?+Am8)2wn|z__#I z_Om5&kGziV+Rm(h+77pW{=P?fV9gmj%r(e88vdg_?tg5YpWQc<9`qrPet8S-MhOq# zK|F$KJb|Zi3>CaA@5SqQ3#af7&R`Xv;5 z(Y0SDOKBjYYf!64fl&|Sq`kuDv3SFgZ^e6A) on>oh^*ylU>FyF^Vc$6RJNBMD{;pg}Teu-b@MShc4xXz8g00b}GI{*Lx diff --git a/fontsold/displayfonts/printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~ b/fontsold/displayfonts/printwheel/TITAN10-MRR-C0.DISPLAYFONT.~2~ deleted file mode 100644 index 32909c50e69571ad29fd8db84bde223bb8a34b65..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6046 zcmeI0e~48@6vxlKckbJ@jZMO039&^ef(pzaEXS12=%W{$tM+{B!nmf0b^>FUHqO|KISP|9QNDjkiPMJ&)s=kUPz0G5&z~qKqF@ z`Q#%mtyhJ{X3<}rqxKj1sq)*=)%;ZDtNbe6PG0#P1%Ho6z7$`jKHBNG@~=97JGwZ3 z)&Hvf2>&ALx71kEto~DeM#Is1@U*bMYSe_Mb!S8czMC(vx7P9J{HlLdeWgqL$L2TR zU#;yI&L8AW;e2QYqE$a(&%j#rm(xx2ALbcJsB?FZg$i`Tc%Z|1=+^ zrh7U)4?N$mudZ~=nOJJbm)ieyDIM}3%!jWRJzs*t`RVq+pZj{6lDPVl&#$*1a}-@tD9F40 zSIgqj`%$g%y^Yw5dPnj0tLK4_KliVE|MKx?{OWxxr8E1`M!E|A=>6=k@?ZWQ9Q}PL ze^31R;{9>*`S(S8hIl<+S5o8mw39#je9HN{+WGy)-52wEsD96!KRG`l{-VD3r@DSs zI?JD~RpxCf^$+T;YX3x|eZJK%y^oYyp}s@%!R@ldZgpN3?UlcdsJ6&oCJ(Qpa6i|H z)E~bd$2)(?L2PFBt-WK{zu%8l{dTms@AW;c_Y3`dsMOlVpJ(hSdl<6o6KoL)-U4rf zCU_t01iQgr@CEo1>;nhDL2wBC4939`k&tsV%m6wGI$Ma1=|3AhaZE_06vHK8-5FZ1i$hJ z4jG6#CTP67z$xG~Fcsiygs;*0;6iXQxD3n#R|9;E@G-gt+z##rOTk0nVK4|*f?@C+ zSPNbRo4_mJbwGZjZRz|w=zpaB6QSYDC*V`?Irz%^ME@J@^ZpKe4-R>re>3(=Dsxyb z=&o=04jSsgOa`Zd9zac)Gr?KlTyO!nD3za0zYfT^A>U>JSO{(cH>WbU(I@xjPH-Q1 z5DX|!8~uk}@9+Pj`*><&rPpTc=|Z11HS54eKbFdGO5d9+<8L7Qjvu4H9efCOf#54K zW=yn=iK$JIiDZhnUt{{^YWYYm5))5K?y0Yj;SSH?lFn6N1`m@5(Yn4k$?$4=(xmBg6k@)*x@M)iHf${F(>bB)MO zM(6R?X9@ioa*k|3ra}K!##Zt?Kz~41TbVxkH4gQCas~&BiTmYw#-A7Ue=Qc(CNpuQ zs9!`FslV!R1DozKY#@!r#Co~;#2()!ULlXlyRuQ{FuqT=%Gt8TW==g;@77uk7t5f` zC#TBMh-_?@Qn{_NBjqV|iS<&oULdZ6DQB`wwz@teYQw~R*47H5bGApw#SY7HGbKW1 zJG8%w?5=Va?7T|be=Nn$zuY6u$aI;C_4U%1^d*gCeP(^8?8b_TciQ+y+t7TMpA>iMcp45%e-(`tGFJX=*7MY0;t%=pUuaoI= zI{jgCrd1Cw9<}+_HE`9kQLd5;(^Fzh>pg zSJ!Wr)s(Nh`8pM zM#(dlt4FGr4c8QUGNwg|KoPw>vm_!S7q7Jj@j^l9`eHV}s3#*L8rkaa>~(vcw&?Go z%MVNL>W_Y7Z_xiiXKVQGPN&`L+)XF4?`|Co2A$pEyOwQviSOw#p+!=K_>I=CPcD^R zOo803L1#p-^U2;||LsM=LtN8q)I}Fl)R?9KQBgOXq9`BqdcwWC-#-`%kquUuNF*Xc zYqy42SR|}YC9&$oY$0;?-g1lCh3DRjNM+NRl-SyC?cVO}i(wyYj;PbqQP$j; zh?Z@4Y$q|XH|TuS?H}w5S|dhGayOG&%oKtZ47oeEQV%*!Pn<9&ob!5?WUHqwwY?AvHWql)#3fhB6>C~lG_v#K9fWs{0#9|=g`312U zN_IL$UDc?(pjkvgtV&Ocj3A!48?J5COwfSH>l6A>nEYJGiU{}$h4NX>`h|mAm>88y z9qr~tLFTNweX0BsIBVCK4udYqngy%onay|Q#_RFxA&vN%@Ra}2v& zT|reIt4lOo(@F5mWw9U{wzXa}tZKqF?NXuwBIs8btFB8~P4G#UaaIA%jk;rc-Ui6V z#JL+Y-<G8_I_{ZTvT8vc2d`u>Ok+pN!rT+y3Ve~d47 zXRh_$`xbTLdHm-0zPNZ%nT+0S_ZeGyMgsW@g9| zFv-`7+;Z!cHgE08A3m7+Yc7S`QOj05IeK_wTY5M+aoiXkF7kB8$dtCutGcZV>hCv3 zo8G!KHi;@06*t29JlM5wgyh2#cj2EUV>w(3Swi}k7ZdglOCjk~516}zt`%K}-#X;^`KN&my$VCUpzGoTbIqu(>0$xq(J?GwgFMV_O|HSkV0NM4kIpV+*mlIp%CM2i=KNJ;VUEd;xK(MC1l+e;TvlK33)m^l z8X#1uE;5Crs?Fq8zndZh8_(OxU??v-lgbOXV${v1$RroU2bS$N9J6WJCD_XJLjGt? zz7TXzgQ|j9j=5qGN2rS;rr=pb8}{*jy9&tm=aj)@{NaWmFH8QmClGr?_syEjor*tcX0c0B+B+$tlg3 zEJ$N6IdY;^II0}j8H#EuDaz7DEkpq)nl0p65=9nUo!{*Y=XYA&-mTWwo%xSigZcfv ze!s_6^XQ?A4_kxV{ls2tu$B0vGw6Sk03-$|!V*~G6D5#Nl;BUR#zvw72yX&wX2EOK z?ziv)vRHtstr$*;AQV?;pm@IeWERNflP0;I;Wb=emZWQWB#arHiE4%xRjic?x~*Y8 zw2>drWCP{%Q2;UMIx#2%NNh`T=OPWBD_9cf1N0iKHBGx>f}|(X;Q3^Q4lQPY7Ys?} zg=cwyerX8ML{kd5tXf`Cuq1_Z0T{4s!0vk0^h{c13Sv~Onugt|%Q|h#6{$3U4D{Qr zn-DO>MX6L8;IIx(rpOAIG#(bh-^a5?$ zsToxeAc*bK0(4kO8r`tT+$~pSah0o~jdOE;$GJJK!ZGtaI4`3JoasWd0CgH_Cwhvs znxWK&X|Gh>3J=1HjfN+eVKsrUio9tZ9P_ora2#Vp;LPjgU_Y>prKVMD8kQ$uZ%Hy7 zItn5O<5n#q1f()f3cRQqepjgWsH<$+%n5KGOYtfKYU!6UM}Z@u>jl`#XvqWyEsN;Q zhJ@`V0E^g2eUL$p#l!-(7-@jpIP*z zvoRvgQR)0}XK#K~wJb|v`w@MQ#bO$CKBvgfiO3Jz`*(gc&vDp1V%}<;*aN*#NI51V z^MupqBUl_f2Q98nPR9*aV!={HizIjc5*0x|OrGz3czYh|zTX*OeJ2g3_2gjPqAx@6 zjEURbt>OF@q6^{+ug`|QP7a`eJ|@N{26uQp6!t74`hjvqS!8ik20WK+mSQ3YN#WX> zQFJ8s&GmxFBaV+s#}Uz}DWWj5Doj9K!-H!RBoNT=6`TGbWMXlV=uUI2m|jUl-~P^b z1X2i5!^TIk$ln#LnhDeY<@=c<$#DQfUnPToT*$07869zc!5~+1}I`Os6V87enjfjZT z86FIFj3!+{@&_zKjLDov%lZE-HBUNU+xcfT0<1f!Jt3bk9&RY z%%q$S#_SDMUA>Qxu^lfV*MJ`MwbL5hL2*5fpK5ov6EF9BL~`ABn ztX{8kyVZ+`MF|^W*+vx{(nJ<^DH?_2We`<{wHAPH4O5m+mSLZ1Kvj^BENS@|E9vy4 z!_Fy6zY6sP=i(m%&I(Bb3+BT@c!{KxQ=fDjx}L-_0UOe3(P^_dtF!gpqFTD1Mn>lJ zX%JkVHd(sT7}FK{gMG$^gHxWg^o-`ZMoYFncf^fyscyAlC?sp#h13k4R*> z5KSHKKO)5UL_97~&`IEKh-gJ1wtZi02q=Z5rO_nB{dK|zI5hrK><@5gtszMiZIkSx zkxarOadv=Bq-!lM&NXcEs+3IeU?}G}?B@pGNya&DpF{Kw$nC5keT94wvPAW14jB*@ z0P6ecq?m@~Xi+trnuyX6Om3vyuA0NA^_$aE=cbot9)5R8(Oa6CZl{-?Je*x>&&>SI zjH=|Be!Mg@7HRcfXt2RU97c(cV7NgX6m}B7FGgR#?L&j_Kcj_{*M8@iaBEV8mL?k1nR}MarNkiW(U?dF(2IB0RZ8kkA`P6AK zlnw)2Bh<(EGLGJ+O?Vngf~Eoj4Ws14)R>s5Uz(YkS-N=h>y^hT>(Z^M_C@1Wdvo^O z;~&cN_%xc=SwlYU-kLdFy7=Q?k>}4nKKI)Xrv5-)Affs>gzD!Is%j_iDI)u1dd^W^tmr{!Ffk#JI4#ea-X%pI}E_PI~n zKiR$_ulfaE^XBZKy!7}rIg2y7gmaMRXEx72_@955v)4B--T$wtXf|6A9~gBcg-a>q zKeA%pK{Q#UTu73X8Db1UpLYltBgv2{K$;=ExWpjc$RNUI&7q8lD&(LnkXuFp8KxHu zO{K=@Ks`r9(@@XwgCb)XU*F79QUsIBHN<mA1uck3ut5}vO{oiPR2C4F*G+*ug{Qz4 zSrK5a3=WH0OMpVI$iRTnSIxkICDnliX_7Q-AJa(zU{L6TOi)(%fjkgMfsB?iLkNvw z?R-?1!s&%Gq!3av6&?8yrlKc9DsZ_W5lXlO6tNGHhJokXM3Ns{(ybVqKO*N+1^H!@ z&&Ul!%ovUqfC$aVr!?%+B0y10V?mP+K}Pnj1l6Y2$U%m=%_ooEV&!2qd3c$%T&c`h zalHGlhTT6qANIMhO<+PXPXS$s;|FkXDmRE-)yz`W+z41Xkyr#Hd4H@T;AA)sS5M=^ zz@eOfogx7F?xhm?JqoA!f(2I~TtRGvs2qXZXGN0b6(96cek5LYtr{{Na`}cp&Vv2| z{0ZosRfm{3O{?Tp2v%zU*HaMmKRIrQDw7nz{^;?|A&Th^=K+6D4wHr26+%f_R?Mpz zo&#*>HtKF;8A7{G`)^n!;nj?F{;5-n4?3U1Ji{p zdbpEQRB`&_pGf;u5TNTm+=ew0k?%qm5F^v&7pW70GtQ_`&IBzgaT;7fgXQW98mNqT zN6B);Q;5ZvSE238jWXg5Bru|Lh(5H4+ZV&(UGZ^ux846(wELZXx|XCXZqYs%bn)l* zpwk(mKx0NXn?6-aOf;u2&T0ZX0 zs|^H@qgIO75u~FN->4(-V!L6jAjyX0T#*8LqM&AT#ol&*wLG1!aeF@t*juKw*c4;FNq3g9l;|yC3QWXPRH}PcutRJlXzHhk2i`V z27{Xw6Tu^d%e>h@91~H?LNZIEYu7k@KHde02(6nO5dui`rc0V}=Hc1EJ1(^tr8T+- z@;O1N*9M)finNza#E&Fg>J!Nxp_P#<%kLbjl2#raZAcdepk?ZjpC~dk{8<9LZ z1G0)tS9>O5kN`i(*-);@g6U2G;iyHa<>K&U(<~)8-;dCjqU~^mcG3`R7yLWg^`xGj zRWq4YDuzGuDnvO~3K}&(G#PVsSOh8Xr13%JNc7Zgys^COm}?N8$N}<72@!evpUtOJ zBwLa0E>cBYv*y?AAKb!A13X9I+Ko}|9`aJCSJmr&b!!*-A@2CMeocSiSNxq{vD*&@ z{U8|BL*9r7J@#ulpCGm6*L|kyv`D-2pF_-aA6Qm@lJSn<3amY&5dP= zbRd8aQp9|Z<67@S<7xh7M>df=7G6c+RC+w5RJdUSE8%3Z6OEErj5&QJvso>v7D^jz zlq#8PFS0M~xYG?ccFMk9VjDmi*vE@)FuN~g3;sFg`5_u#t{c6PuH+cT5GG3c) zDe8O+c{=q|x{r}(4rt?>HyuvN_|i)chWvFukCIP{a||~Md?zMqu&zj`o~gzsO0b`r z#>=h}WszJsKwNkr$BCH4aba0Zj!D$KnvX%2aRV)yrDg?JP)c>1d|BMA$T(ds611M& zveIOtqI&wfmp1r=HqeE3bJ`XuEB;cqCulRsWuaBUJ@{~IjUp*})>SoX%O!&;JWD}f zN5&tGtr`gWZQ(%J20M2+=^wBtFLL%HZ`MV_oRYGqLUn%!2T

6=&{nbw( z-HF*0)Q#@8b~+&J667uRcXr^WNt8IIh^Rgh!JTL`W2bZl!@L znqV-<5L(p)ci?B>=U}L>3cxQ4Mf>oXv9o&NLrpJ@oyX{$0HVJXhStu+&l6Dg%fM$C zu2b>zR|TK7lV=F<^E2VI_QKHl>=EP0`Rtw($a(CrUmo=;Wci|?SBrdAsP{QRFX?Q6 zd5@r)=K(bAvlt?u4Qn-D_)f^VJQM!C0Iby}a4oFi7^r;#FsS~^1eK6GdtYB-TiSEM zTDA@^wTm-O_N&0F>d>_ymCLF5)3Ntrp!pZX3@uli^xjOpC}MczhV-I%Y_Z$-myb+DcehJ#C}}xKYGUj(+m=vp_!uumU{P{ulF}?$ZDO diff --git a/greetfiles/INIT.~1~ b/greetfiles/INIT.~1~ deleted file mode 100644 index c28c86e5bce6c6a762721cd50739130865001de1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 25582 zcmd5_dvoH*wZA)?@*k=4S4ee8CCF1FY;5CKZtY$f38OV2jU@btYb(JZkJ-V<1$Z8n z$+x+R8jW)m(#BceXY+zEcQ99ql|rXC-!^wtExx_?T6zC$)o< z+EIyZ{O0evd;X7qf1Cur`2E=r5B^}}f8DFpe&|0xE~CbEtL<*dHlk(tsWdvGNyRn1uDumPdYt&5hQZU6 z4SF*lz|xrR@1E=*mzcnFHXIH7A3pXTN4@b6qv7;1#BXO8;5L=F?9Z&USq~n+PKF=u zXH4mDvFh>h?mPP2Ch`Qym<$9@vDrt1PaHL7T>7BzISQX|&C_x;INCi<|)-sHoi_rOZ` zLGV$n?wx?q#Mk|~ftdm%0T~P68ZJ|sR@-3Tj@6^ufx35CJN_2WThdehfdo1`yJp8n z)!qHQ!~Mc$&XrRqfIHQyy0@nu9;gRZwYCFc^)0zDH`o|h;mfAcVT$WH#`~_;VkI%L z5>vVz^GZE4Jfm~LN;L6~);3BB@`PwX0KI2oZ5*ppo)=g*ntowIkd|B4nbq}J`P68D z3s_mP9M;gVTv&`2$=A%NEgh@^ieJ0vR{A-+b0fH}c41t!6L6OTw-o~-ZOnuq<1GP?Y%?-&`%`u?*bqfX#1owY% zcG0c6WnZ(z`{Vwz9VJF0-d6Fm7k_(w zT*!ivbd0)ZIi}&h{wR#C&Lomp7pCJu@thmirF4(XxnEuoxD~xy1X7oZ|-aD+;>;9#UWcK*(`TTS&-) zzOd#wzh-#gbypl?bL1{9M?bZ?9X+W=gw+mZ!EI#j1i+LKcCvEcn~=I@y{Ey`Z7^p2 zulRVa-|fu5cXI+_Cv|`DXi*J9yT?W2f-e`(plI$hH2)UIFC-$T7~bsVt@)dQW_n z4ad8-$uo;-7t5f8!I5i_WH>$Un4)j-kFH%O*~Qv0qUSnifU}e#k}L8G7`CM~;Cv#2 zq{CrmE))RtDQm-bfog?eWiYa?#HN+5?y1%}W0(466Y(aY#x6B@n?>w;*|gLaLRAck zA-U}gXMR@DN;H&!SGGFw>X4re)j@CV^E3XVt<@cCj_DK)(}yoBBQ9|M%!?L0F-)b? z(%PrGmJ$cgNn2pVgIhcp#m+V8?+$Yy8zv7Q$**B0{OFAa?3{<2(k3f9bD=CGCfqC! zUY8mYM73-WR_NReASB_XossiO4(Qvcz1FEWE$1x^%#)VU@Yu!` zEhYe0FLKSf&CTs>`M?qJgUInB+G>ovI9j5)l`UrTW!@+Ry~TrOVN`ILZcDdO2>GA4 zHfi&NQ{N+AxAB`)L~7%^-!gV1_=hQ0OaF0eV`GI-*~W&5IvRuF%pWjztagG=>d`UV zIY!`;!inIg6N-vqoEQ8j$NBBDsBLVN+(*AZMBwKWG#{dvtlxW@B2e{pI`bbGT-Pak z=za9>hR}o)zc-lmZt-mvu&a72!dKaNGrYr?WJtEPa|8a7uqDqe&)SNnwDD$k?~kb+ z7`$zJLY0>4Jqi>(KV(7CL~&I1f4&?$wWHs1K7sV@Q5p?Uz%W@Y2b zs6$%I5QhQ`Pl#vL=!ry=)-OV8ZE8oeDFGfNsEpF8Ug@QPCpe9@-Fcq2YSVx~Mpz?9Jt5&JBF_PL0BGX6G&8-=NX4$mP-l#x=BdrT$|@IEhn z5KmAxr=$RRL})Kl2Y?7o?^#g#fJ*P9qyZYOnl?xQOXds!Yx%4JUmzHS%cKrO+lBc9 zOmXd`fiTqOG6hi>|25JB5wJCL0+=5e#>*uFirOZ_|3z(*LI12ph1fhdq8=1z0fcn`HhTjQ){{0Zf`)7AxhTaM#a{~_vzf>q79t?PKvlvXpNlwXn)ltRJXr19*l)j2yMk9*`GU^e%)-NNtds(=4Ly`c1v;83ZI%kHf zIgWOnJFeFCtWzjz&(Z1nBFcLl;|%cz z>?5YA46#7N=rmEd(Dc|rEgnuHp8KbU+Ma{GFo1Fcl3+iJp|0nFMh!Wv6RbX~k;e9A zE0Y{8`tJP-FeOFfh*vb)Dqlj2L4-@Ag%*Y%ZGLH@@NJy1Swel7*zpLFBs!EkR$EKf zUU0z!a*L6qh$CzKPYBG?3Xm80mX&y^+qP%IGTJV&$bu?u6S(bUIZGtU1V|)Jo7nUy zqL69ulvF07q)|Ww(d)XBOD!0=kRgNzycw6(j%suJzIGT22o4PG^yIoKGRmeSU?VU} z^J#i?C^?-}Ib{}URQfA66Dz|wa9y(w>xM^SDH>arDOU20lItth4`qK{#I|mSA3pdK zHtnMrZOrbFe3)W$vwIW+swmq->}fniE{3mi3Q8I^IaG)lmGMREM%v4A!dE#+r{E?r zUHv=xEhfqj%rh=z9J?qIzdGn_kEGIg#TlfBsaAKSMV5a4l3&&RS4Nj=XJ3L)x-YSA zntjvIMY@NVoaEP@kVToThDd{u1BxAoD7T(|oo4L{Wwa`i!7EMF5KA*N#pI$@xI^P+ zYZHbe5pN;^A3oA0s`u-60z^^w#+n-K*AAHp$@Qq;d&_hku+O$tIWXYIJg2`0%f|x#zj~P79=-F$H zVh6}F3{)K@-57^{J@h6Y@%2i5y{WViN>dxbh{$x+aaC{98&6TRJyT8n)n;OjM*fE$ z3g}KyiG+$u4Hb_`=NaS`#zM!f&_=EBc!!K=q{u0nQIRTXa>PqI;C<+SR=z_qZcst> zSHHqDw4jQFE%S*1$& z5qfhI5W<5hv{{)3$qX)DGvsX(7EVM489sm#7e$(3m;vUh?Xtg-j%0s>E(>*fXgVbV zkEB&a)^{!fbmKOyOPveRuAQQ1#Mmgxb>Oam7ARIQJjj(c{NOGRiAfhdYFqRr%*^u4 z6=nbc4!a?|c#c>3;~)OOs%f$mfm--ngl6ix!_sBB3p*`-sSuW}9R?#w`TfpI>|w=l z9LxEAhP@Y$9=#Ho)T$rnJ<<=B$ML?v|{I!)Dl~U>X1<>K9qL zuo5c!YB222w);quZVSVKy907oG3-3EAPXr`Q7Zd~N}ejiN%CxGJP%%w$`9GV^H5qU zh2bIs2pB2C&;KZGQ<69GQbOay!08wyb1N`2siFkL5yXX$L0%6DGA=e@<%^onYfOfY zCT-6i9=A~@Z|QiFffBNf(zY)2AMqLs-N2uQoNeMU;-ALF{A0>2+w+fs0$#`}7RAwU z5z+#8D1GmppHhS`G z8V~1nItX1*a-U6~CdldE_mF`{+?@^ixgEGfL~*dWs#0yXKb}HQPvJ1ZcM|0Ri>jg~L8NWQ$~019jtnhux`AXWe}zyqnqs3;Ee3rR zB^Y7OKy%Jq3eHFKefA3{2&ydT>{#_kb^S;6=#W)wCwn!*o@Zrm$XN~Zvx-9Umj;S6 z@5(kbhlZjXk_y}^=aW(DNR088aZ`y9`NQ?A>>{8Lg9uTDQx)%%8q(2p^NP+2CVMJj)}9a-$jGHa4mQ0~ zSF0@(@Jg=K?txgTeX5k%J&aZg0u+3R^>>&KuX{M24hKGdUg5_ez!yPYZV%zy7-bSH z>zp~6DvAUZa=t2$IJ7nko@R*tRcyO~p|I(abjax>9;JtGnBeTy5y+13wN}QUskwYh zQJEJNhhXE;WZl8oG;!Z1&5zuno_z>lDV@ErLssuDYGE-Y*%15*M~1!;!w;(`d$8I@zJ0 zQPRnU7V3bw-FQn;brPHic7?~h6MNsWEU&@M_&Wa-m7)R`$%IfIfJTN^Z&Eo4Ee01P zabJah1%nfeJkb$PdF^kFc)x7Cp|gaM6cX5y?=Pvst-KY`P)Lp1ES?Y7$}4f$3L6n7 zUha50?tI88KVLwwvOM`1g%2Xagpm;}Ax{+Y^%5%#Io;7|d#RVE*Gvc`h-{LLYsjjN zH=bAz!54yuQ0`8nAemkyDS3=NA(d8Gv3#Nkmy=I3^fPlCf|pxv%*PVnkS?GD_HW_p zM}=v;+ajE)Wq78Ke19A-cTk1GiNZSPmc>eF2QjcG1p$Al*em5N8(i2MbLuJo~u;<_`|5Cd8~U^EN*5_ck_1H}nKw}pa!ehE{( z(?1lN06&T*gw5j4u}tLi=3T_-b0Q})AIQDuCIV+hTopvz6KPSht0aGg401(Ifep7m zO?RvxPIA?SJ3G%t+1B!8ztTP@J{K}C(?(JvY{F+Fy;x2aaiK-Zm4#$mH8vszL+Hxx z?!uKFsmJ@QdT_G4pK@ghp-6LxaKvhdgSn?af6$jxUR-~WpNo#~L70zbBilEeZRe9N z%}eQDd4cTgn!>L>{fVvuKm}%l=a_I72{(mYF}G{G-BXk@U7-c*nh4{xwJZK%Q=l2~ z1f1+uMR%9E=T!T|&K%8d8cv#Vn0(9oEsDQN{KEyKLC3xio0t}fhL^nYOH+@Fc40h-8#C58Nxmwx{K^x; z&dVIH`^*i;s%7F-5c zDA!;BX70{eUNF#1a{pVbELORfC2{G8I3E-`SGgCaq_6a#gL(h2CcfO|ChN@eC5*G2 zu1TwxMI7}!|8NNxUk-wGq9h|Fy{YsJxedBKkGrt)W)PBsD_jjya8E`g?Q?l{`G<+i zD3%17ylNx=rjhtQj94ix#wZE1;F67(AzA=5fhn|J{<4W{JFsd=44&oDyuBJxBYhdi z68kz=28HV-3Z-7<(v9$Ph$!Cy(=N%vRG%Qxjc(Q8wh;~jQW{Tr-?ec0q`XTb{K+Fm z;+l;u=z2w|u~zMg8$WS@oD5^E+*w&8u6Y;__UwC$Jtr6Mvdfg~`&(#Wc0jh?? z4nXyd$YievGcnV$(h(OEMj7$-K`Q5$v`G2m;FR z3~>emsoeFEPJvJUNP8>EH>-a4GI7Br`-k;}Yt4B@e-6 z+AQ&ts^Yl7r3vE9G_PA;lO?3YSyfy?)Sz|)mziPkRm%?)eiabzO6GU|!4hDlhhBdY zOiN5wa0!i9k-yeq1d0}lR0<>_ou_tqIV(RLzt-NN+FT+xpD$>gicE1)1yta+WGRFacS%YjT{v2Cm(p6x-PP{Wl3Jq;P0 zSrkaBt`YQBAb&xx{TmFUzNBz{XfM6@UZ6nl0dg+T@4Y3tONx>m2Qgr3W_ISy`|-{9 z-i%_HHOnz`HOn@0mQ!=-hNo9|^evMzmJ^!3Z3SM2Zuq8dg!-mEHN2?@CaL*sT44cI z%nD6|GTLfRKkenTyt+XcZcK+~-M!((b-+t6Q zJ#L=dw!5w7@$JX$!{heT!gA?$>#WynpA2r>ZdJFTpcO9PDymtmE)TcJ=Sf|!c_ou!7%?hPYx`U(6$wTU3Q@gfBN$r-Gmos$O96+Z@t+h&FwNfZ#-psVO zwgk>A6f{b=j+!SA+kF~zp|NsT_XCPeuDbOgOQ*f|?>gPHzNm{?8Lbd|S<@=2R>{K! zZ|zk?aUAiwYnW6q*3*hbd2(&zQ>vk{1hnW4JIvMf9pDC#F`c`X?>cqU374{z+E2}; z<{qZ-PkuK3)aCXc<@bl&{1N}0A3i@@Mr7U5b^L3kuBDVxp7yJDB{0L>ND*`2tmeW4 z&m?%!^WCZ$1o-2TwkC6{u6K~b04s}7t`(>EPt5Ufsh zHOjy<0OjzQ$RWy5u{5!&P@bL^W=O-@@w!Z!)YbEovgsHBdOn|5`9~W?MI+a@wk$`t zmpz=;TEn($4q2pt;XorWeIA5^v^*vDE+snncuxIDb4Rb66j+tYQp4dLI5?qM4VMTpo7UZf zIkU|4fW@&*FghPetlFmTG`w8R_3ObB5L<}GeG`z02H}9_0x;T%9U!<|oJ(!TLyL>^ z()m(;x9?bj!DzxA@e&4t>#ZyAzyBHg@bJ$vQQ9LXmWyO}n}=R=&^p4wUM)=dR4bqN zDXAsetNCu-2tW+{JqQ8OI^4NlCO&k*L12JmX}w5j+OBTU+FC>vo*q`W4a~zc_+jL3iG=*T!(M&$^DA>eVtKs+B)5<--XDKv~z}0nKpOe zoXtiJ`Xd9ec8S#(#2L>Js67!N@kwN$O^QkfuwXw6Wm%Q^jd^|ke_vlq!B=Vi&*)AB zSD4bH5$m3rSNa_ z#m|1bm|56fc=5rV_mVjMzWuBz9((bhXaAo2>zxhh>{xCU% zu34sS5P%v@1LE&FRoAI%R9dI1YokC2bAnP~%798Ljm;HaD6CWDA+UGg`iwtSU6T!L z#9GbA?J|JNR059PwhY5`m{SumiQ-wLB_vM|3K}^C!gK=5b%G_q^$d*?Ah?XDia42$ z1Xlvc2SPFj9|Z@8)X2dse9!Z+V$T>s70SI&!f-K$5}fBo{=-`%Sp{q5Pylv38{9=yO-NhKh)<64=JpDTe? z_fQ*vyI_3I+->MKA@epIPQ4?vEJvRi8)HEZVkDj{mg7Ml2&hm5gq*4l6lk+0A*kzX zWJwVUM@wjsvd0LcwYV)DP$Y#x7Lgh7l_lhAWkNufK+~C9QNmtY24&1Z&D+xAm7{cd!#GicMR0c5)#~xMJMq zcxfe4SP7Id4lNTm8(tPCWX34wd%lShflohB7$&lxRMTn2_w?P}sbNx-CAxJB*95+X zKyb5_CF(!z5899EVXxgD@I8V_K9eP-<^(h@;<#eQm{jfxP$HybZ8@%Q8fMidpbL5$ zwt2wZpfnt7KZpE|`k9p721+0pH2j)H+ED@vL&Gmo9az_^^2H-1JxXwr#)y@sOwgsl z;3+-noE&za&|$aTKlyk-e6OIxvmPrxvVfJJRvZO2l&|n~Q9C!Mst!}R^jWfQ1vQsXf zc)!=|J)&Hhlel{q9+>)y8fdYw!#Tre zYR4N!SBj}h@lvznt;W9Q?Y4XqCABc~5TuF{-8@(1KEFadi&kv-c}1@6HsA#ja#Ox& zj#1MCyZ@S5X}FGUi2}cbeE@`->x2n!E^$?hIR?UH>jzU`Nx2|SLsQZ*JRWpU2K|*o zSaIBZDjnYXTx^C5r`I))2i@T!@xB~75K|C*Lye{dcTSUHJvRu0s&9F?(U_ic!1HU0R55wi_wVc-Ym}7y^k%BwduAo3lsR_or znPGI?1b!L9GC!ROyY#R?phx`7b2i`?lcRRL z%l-BP9O`jjfKHu09iv!pA9DW2b{Cr?rVY7UY!&;41AYWJ-7untW9xMt;`lFPO}Y%t zQEnNon@9rDx0vf+n+Zn3Bp<|yAgxTK0KC(TULhnArD5bbKL1v9&M$mY1He4UMl$l< zb978f^k_gIZMwz*$(0+P*^CmLB9|~O zVI(_#hY)U? z;`GGKaVk#i`EAqjP*fs|kTRK*&(VHDr#Mf}PRX+?hS+KRzWsK2dBhOx^JH4SJk@@q zbbM)MA4h(dE=$H^_r6U=o=#L3B;<5l;=M^m9;)|fAp|Aru_FI%KJw3og2UZ6nl3+%Z-XND3$8Q3IyP$M@#Vk8i%2 zN5v3z(-yh9X^EU^*B!X!>a`txOMq|})AH&%sO73!s20mIC~~|1{G{9K976vXWRN~L{GH$bygBR)hWDSfPI|55 z`&Pf*>fL|dIqY@L3ah32?bE@ab3D3lIW^rv1Pk*O8Q>QAJgDo{yjm@2 zGCUr1qCGmlI~fdbS3x@NkB+*>PoayOHdr#CXsDm|df=Z8`==uSHCA|abybGL)(F*< zljCTJR;rdX`R%NIXXDVH`C5$dM zS+aI_>=kl+p{f}Ea4?p~je0caLp2+tTCsvAJ^;?H- zYt%l%#J*cd`BbaS`V`a>?A1M|VfaW4^xh8;q78KCdIc!y`~%-W+J*HZ;H~B829(Po zRk(Uk+cr!Oo#}W7P%0% z;bk1m0~M3~ZPO1p5YZDxK*0!PVovave;T@*Bf*#V$g6LDc5MOCSO}xY;zP`UwhoUP z4^dO z++N&&`PJdVYn|79{p#b!LYLpXX@peG54;WE{g^iVqOqWdlNOiG|88LzRAdFh+ozza z8W^5vI1i~E(12Kz(zkA#CE*L`=eX7GVX8r;7?2IShobebcf1 z6~^@(jS?WZjHim2nKlQP14s$Mm4i~j#w0azXcoTD)39l8tqQx@5S||3=BtKqgY8Q= zYd!V}CQgO%Qztfv0ff-_{Jo{j!n3^_2`tDJb-Tc+-mw$7v-}&py*BPav!6Wnn zS;d_Ix0B@xV12IoX2Zqa0J#f|&xzfpZUI)_rcI@Hf|k|rHDMzXWMhojlf_CrNCQ3; ziU=XQrXvcp`I0cG>t!&xFGWXlXs~2Q2!nEb&m2$$g+LaP8R9DoSgVyO0a-wrmhXiH zdu0_VV-9NGl@=o!n6QG%!KQK+D@{c#$(^^5JD09tOytBA=V8|zF{WCWmy8U3a$$NY z=ZfNb0t+tX62>%0)DrGZCB<{~-QCnMD9Q@ly9YA&`Jgmf?JU6XY&hyXho^&1XGD!U zQKp;)rEdEWwM5i^;u!bA3i_N=*xa%mPZ*+R0me#c2*VNwlxa%SHurN_EwLK~Ww(h9 z1w?PNNaBib;?Vd_SO*(=jo-MSNRx8GMFB`@ko`W4MrZJ%dwke`0f+t0@c82qP?rve zrvp-aVgV_iRvgAAMrln`0=g5>W?kl(t;-K!> zLBg3U)C}Sr$-p>S`a$aTg}@k_5~Jfu|9CW9J47pbtuub0t<$lQCMlU-*y@e?<5jed zvkMu>_y0$Qq_p7fNkXja_<>*ZOc&1vQ*OA*&Ka>M{o!cX9&}Gek$6;_m`e8q9@Pz$ zFEFz=xM4ROI+cQg)D!13&L`fHWChPEyBs@iL8iFvwoLH2jQ}PLj~4`ec-k4k3Fcz| zxYdhz3BM)4i~iu*Cot?Dw>!Yl1NvfeI-)NPN1b?=$DJpb)X_5|9lAs4VUycAq`G&h zJ#5>UrP)|Ea6I6Jh|>)tys<64p`$qZC9v@$VRKSN#_Oi&K71Fm`jwnN5ys3PQ@*53 zkv)Fjn4I3Zs${<9}Phsk1x< zn$Byna0>jUp+mwhDW%CA!%z;=2-3YGcHdeT&J+mTZb+xz=?WDh4|w7o2*2=Zd8C1dtOzAuPVZ0QHkOK$~#r!xenm+ zJfmXlH2Oe%WjRiGE3U>9UPu??sS2AeovU-I@XVa32#24#FDU3yPs`qo$&T-&D7eq-@6)h&KAv F^Is}mflmMc diff --git a/greetfiles/LOCAL-INIT.LCOM.~39~ b/greetfiles/LOCAL-INIT.LCOM.~39~ deleted file mode 100644 index c9e48a86352fab0b050f6fc3882c286bd3735273..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6453 zcmcIo&u`n<5ti*X-EPYu-Yrld=mt}w$x_D37AYyRlp|fAp|Aru_FI%KJw3og2UZ6nl3+%Z-XND3$8Q3IyP$M@#Vk8i%2 zN5v3z(-yh9X^EU^*B!X!>a`txOMq|})AH&%sO73!s20mIC~~|1{G{9K976vXWRN~L{GH$bygBR)hWDSfPI|55 z`&Pf*>fL|dIqY@L3ah32?bE@ab3D3lIW^rv1Pk*O8Q>QAJgDo{yjm@2 zGCUr1qCGmlI~fdbS3x@NkB+*>PoayOHdr#CXsDm|df=Z8`==uSHCA|abybGL)(F*< zljCTJR;rdX`R%NIXXDVH`C5$dM zS+aI_>=kl+p{f}Ea4?p~je0caLp2+tTCsvAJ^;?H- zYt%l%#J*cd`BbaS`V`a>?A1M|VfaW4^xh8;q78KCdIc!y`~%-W+J*HZ;H~B829(Po zRk(Uk+cr!Oo#}W7P%0% z;bk1m0~M3~ZPO1p5YZDxK*0!PVovave;T@*Bf*#V$g6LDc5MOCSO}xY;zP`UwhoUP z4^dO z++N&&`PJdVYn|79{p#b!LYLpXX@peG54;WE{g^iVqOqWdlNOiG|88LzRAdFh+ozza z8W^5vI1i~E(12Kz(zkA#CE*L`=eX7GVX8r;7?2IShobebcf1 z6~^@(jS?WZjHim2nKlQP14s$Mm4i~j#w0azXcoTD)39l8tqQx@5S||3=BtKqgY8Q= zYd!V}CQgO%Qztfv0ff-_{Jo{j!n3^_2`tDJb-Tc+-mw$7v-}&py*BPav!6Wnn zS;d_Ix0B@xV12IoX2Zqa0J#f|&xzfpZUI)_rcI@Hf|k|rHDMzXWMhojlf_CrNCQ3; ziU=XQrXvcp`I0cG>t!&xFGWXlXs~2Q2!nEb&m2$$g+LaP8R9DoSgVyO0a-wrmhXiH zdu0_VV-9NGl@=o!n6QG%!KQK+D@{c#$(^^5JD09tOytBA=V8|zF{WCWmy8U3a$$NY z=ZfNb0t+tX62>%0)DrGZCB<{~-QCnMD9Q@ly9YA&`Jgmf?JU6XY&hyXho^&1XGD!U zQKp;)rEdEWwM5i^;u!bA3i_N=*xa%mPZ*+R0me#c2*VNwlxa%SHurN_EwLK~Ww(h9 z1w?PNNaBib;?Vd_SO*(=jo-MSNRx8GMFB`@ko`W4MrZJ%dwke`0f+t0@c82qP?rve zrvp-aVgV_iRvgAAMrln`0=g5>W?kl(t;-K!> zLBg3U)C}Sr$-p>S`a$aTg}@k_5~Jfu|9CW9J47pbtuub0t<$lQCMlU-*y@e?<5jed zvkMu>_y0$Qq_p7fNkXja_<>*ZOc&1vQ*OA*&Ka>M{o!cX9&}Gek$6;_m`e8q9@Pz$ zFEFz=xM4ROI+cQg)D!13&L`fHWChPEyBs@iL8iFvwoLH2jQ}PLj~4`ec-k4k3Fcz| zxYdhz3BM)4i~iu*Cot?Dw>!Yl1NvfeI-)NPN1b?=$DJpb)X_5|9lAs4VUycAq`G&h zJ#5>UrP)|Ea6I6Jh|>)tys<64p`$qZC9v@$VRKSN#_Oi&K71Fm`jwnN5ys3PQ@*53 zkv)Fjn4I3Zs${<9}Phsk1x< zn$Byna0>jUp+mwhDW%CA!%z;=2-3YGcHdeT&J+mTZb+xz=?WDh4|w7o2*2=Zd8C1dtOzAuPVZ0QHkOK$~#r!xenm+ zJfmXlH2Oe%WjRiGE3U>9UPu??sS2AeovU-I@XVa32#24#FDU3yPs`qo$&T-&D7eq-@6)h&KAv F^Is}mflmMc diff --git a/greetfiles/LOCAL-INIT.LCOM.~40~ b/greetfiles/LOCAL-INIT.LCOM.~40~ deleted file mode 100644 index 1a7697219149c184653d69929cc4e826c31e3f4c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6592 zcmcIo&u`nv6_(>R-EPYu-Yrld=mxJulckK6E$T;PDTUXxNZE`jk|wFxZi99eS&7vs zmLbVajYV$-_AltQe?t(|mo3s9+Dq@f7bwvC0(&mdZyqI)qGUVGwnjn?hcj>9y!XBL zy%|L}YNl;uYNlmmOuOdLZC9)AXj=x!rX3ibW%{m6w>?AC18vhvbZ=_DL25QFDMCOM zqXI)GSuJOr)-aRH=CY&~EBKeo%cRJy-t&`Aw|z*xW0FbwT=#c=`_smt-5;z!Yo2tQ z$Lm(F)$Fc6Zy$EsXZe-ldbcw;Y4!T;_10;>-##9$TTWH8ps5+G+%FW;5L3=*Cw;7y z#ae5XtXj$EWP03hj~A1u{hO2i;7)~(d&8s7@l)zx^*S#>Sc7V(-7fiOgWl>eT%- zo%Gwk?(|LvtT#r{wdYa zSO&JVh81M$+73_#fEo5f({t>)VF$};O6{i>QVUO0_~XaM?|Y*CJAQswG`}Yvv)!|! zxrgT+-NIihbu*Prs^cDH&>@tC zb4z)ujH97gq)HS7WieZfq5=t_7)+(LsgSvsc+HUv%K*8fpyH5|sZgAnl`kiU1v2F@ zcQQ`~8t%;wN=p$GG{k}`9=Wksa^!gCmT7C&ii_B;H7u)UlSwMs#@=*SmV)45&$M-C z4=(x$4p`h^^S&>fp?&qo8{z9FI|p{o-6OXVgfrNfYL>Q)QAfi!JkbdQAs58fF2-K) zaYp@6b6cw$EuY2fUSfM|5oezhaY|> zYpl{M`0fXQXdUKUE0YL1 z|G?Lgk!h_!Xj+b@Q>hf@3|9-P+q&t&n2vWq#Zt^4RLI8?OAJl<64|C@QLYdlT_mRw z00Id&h8`4tVvG8L&_wu%{TZ_|IVWkRx#If!i% zZqOn{r336>KMiGtD%UoyY1jV!_01G)C5it6-7)8KrgW)DPr!xPe1RJSwDL$M0ozEc zAx)Uu2R1;3~- zXyKr1i|2o};06_0LE!CEQq>&ko>6xmib^3zB5R7Uu9=3V6Mz~H1L7aqRmZO8sJKQ| z$3i&~WEiEKDSaxcG}$iah5Q)=aD-v|repidjO#fX#XxXbo+=^8(cx3R00`Mt4JgRXmjtJ-mB{3h6^3TlfU+kDqf*r798e%d zfGkXAz*m~U)ykBBG$BpP_d~*7UO~#3gPM0ui<2}k&I&3!ThLjgv>>r~?!1lMxp+m! zL{3cPJk-&XjH%}51tUXWm@qk&V?}X21B5GL2|f*CT*5`Fq z04eomD@`;w8w}ge>1n^+9*WXkq)a(YO3n6ZQWA;!6Mb9|E3i3-u(@SBo}n96i{LAz zZs?YAAR8@=l-&jj3YvUPBZ(`%iLTL?u&SzSRsQ0VB8};SNr8mYB>O!Y z4$tUC=lHPqf)0D_!STmK66HD_p7w>};~fa)lZvA}h0=A+)^SD}9Q9tHK(FjJOhYJs z7i1KW@enn$@1oKq1wrG6hQ*exhEt2aime8$sW4Df5yo>J%|j)`)*5zIR33pCS)?C*Rc7_sA{W4Wf!deV6NSeFxx$21p+3tw~ zYj&x)eWJA{wib5Y@(h%soY6*bR1`i=uJWOImBb)gwQxvY^Sj5ISyuW7!O z7?m6Z!-<`QZePYSfI-c%gP1LsMJ2D1C1keYzg3O2U9tP!93zMaJIH^ zDqW#4{e@n{+$a@b0;enmr<`4OI~OlgS@Di6fOQAZ7wG5lk{tBtX?sW~h~nOHvpdOX zxQ?I~z5cULXwW%swTVGX;`ZfqC@w3G+R-YH+fQ(rGkND2q0WH1D39BRf-x^O1)F7* z-`P%Vn^A`sf>qP?uwh$TU4uCBD{#uM!XRV*8O@s_itt;+2UoJiSQv9gXk|ebk}^dT zxEUFr`u^CdI!iODEFe{dUgSDbW zXJzHlCy>Th0hl1oJ6w-s^T9thF_ayh_c@y+?iwbH!-q;9A+a*PhO@%k3QpVt2uF*P zUL;&NepA;dwl686$()Tr4l)pkLNRvVS{E?Iv}8z$U5s32pLsVI0<7Tk@pVj6_yto4 zUfURX8S_Vop37htQFn|<1%+SC+;I-;b|%yvTk|UZzKXs_qGG&5$~$rRTmvw%&!`v~ zOB6enm&!DX6As8bcZpgP>)ZX>nXj%@&= H;%ezX?G&gn diff --git a/greetfiles/LOCAL-INIT.LCOM.~41~ b/greetfiles/LOCAL-INIT.LCOM.~41~ deleted file mode 100644 index 154e2567a5f33467d011757223238d2739d40a1a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6566 zcmcIo&u`nv6_)Kb-EONO-Yrld=mxJulckN7Eb2#WDTUXxII|fAp|Aru_FI%KJw3ps{FHoTO1@>H^-#khpMafQ@ZUaOnhcj>9y!Xxb zy&2UIHPaTEnrVrQY1bUOpCheQ(aM$FU4>NTu>0(^-Dw?B_kW-|F?(pEgfB z&69Pjd)Vx(KWiOzTIYpqX}#0#pB{F5t@S6pR%`GWgZt~2Q`IdvYX;eS#nKWil{5Nj z57Xr^-C8B5RSJ2Sf7EM@Cv5%ZwAa5~p_A_5xP9`3+Hj!Gvk<1C+F7SV{&~N9HXyAS zIiJmD6*_7T;Ia~L&uf)pzEUVCZ?W>+H?>j(I#({!X|MI`cK58$eql-Jsc@Gn`GP{< zM0ATw=`jlGjv=UGtff_xa^zUXr&PnkG7zLUtRPd@cYr0pNZ1cd&#~*m4wjcFwV#?x z%{@usAOCFpzAK-9$G_i|kKdC&)6LVpxrN6a-^9Pe)Qyx{%F%w+s`w(vj2sdBqM8W~ zTtS6Axt>!MzK=gHGk~!jp{%5O#cQ?o#XpAE(?8J-79`Am6N1mK(O5K_({<)nJ*Bv!w4X zmNRRaF0eRW6BeBdEmkd|+YL8UbG*9048#_~c258@VIu<2TmVMfQ2-d1i*u>%sA+L= zo?pJ?-|hP*V=(M+pQD5Z|K{Pf4?p}&#_;G5+>xJ0K`a-^>Nbzu=HT$S)u+3KL`?JL z>6n5*X|Luvb;Ab%$nSmth}IF#wKB;~=O6e6c$e0Sgh$KK4O(3#28yc()osJ{5KPBA zpwenAA5<)aotR2vXez9dZCV!Pi}BtiavA|3kVs>gL769xs2@mAWR5tWu_&W4M^a7p zw@p9bM2z2%0TmfYMV#O-{x}RbXM%s;lTm&BlWTK8V%^>$0S^!MXE*zSi$}hoRzN3Z_MlS|Ni<$3b9Jd z{}SD?uA~xh^tNdj!j_yG%So8eA}v>)x(f%53=$!1-*jw$nQ=YCqZkOT z;;ABbrp?La1j-G;$|1LcjZJD~uq=Gf$!62u$_l$t7oHwq@~k1;VEYQrT8mzH&{e15SU%&kO{hgb?y#Ct0c;C5xeDfEtUi`(me&^3GUZvD>o*p6!a#dUja6P$N zCg^j;H|s8H18^4>pAowa-6AM&!E1n3xX>rH-aK3)>Yw)qt!KnFzO2qAWhzUg)@+}~ zC6TN@(e^<1d{Pl}-ooaV?RdfvRf~`-wJr=x9LSxfHf(c01GPjoO6qO{1qF@2E`h{V z-$c{!OITIa^(udHVSgkSED9u@CdKd4U~o>)+b2ie=XBI<^-n$?&~XzUAD#82K}KX<6KbLZJ0tjeg}yONIXEz?7OHmNyVmd!@y$6R>P@9U*%E* z_EZKastDs;N3&1~v$cj@m7L?#o*8UI(z!0&M$w9oVQeL|WJTwX5NBeqsjRH(aKDWs ziPOi*=#0h>XYw>Bmp|2WqT{1pvv;oW8sv1o)9|X|^7+!ygfTNXuJsOEm`$d0VzBPI zLdF?R!1b$KISp$u*r4>xh0k}q^CL=HQl!oy^@^}IJuHA?aP=3FsM0p5R2uqtOe00Z6HmS zevtTlDK3U9iNNu=dot*+9AOci<~hH}sgtQmk9K5oV6!vm4oAsxytzO?zW-l3lujCM zpT^9(jvx3{&vbD#m1e*5IGMGRV!_bX=u9AyT_t!S1< zt;e{s8NYLRN9{g!P#(9Aq+(tf3J%MV-#Jbkn_+_&f>k$+@WHn9x(;*luf!?8%7BdY zXE<&`D8g@%9=uU4M#fk(!YE6zNUIYvft!)hxu3-q&udhQo=7+?zo0^+GFXC z&G{z%ev^C;O~rJF)OXVGnE_y7pK>t@n!Ha=+>}fS6UCwx>G+5jk}^J_%}LeG&d~3v zJ|p=KFUc>d1jdQqrK{9?9Nqt;g2yVfOQe57!G|urvy5M%;zQH#EagelGn71iwMw%P i&k*T!T%gk`F4H8TPE_zx>Trj<4QjI;TL7c-YUw`=ouQ%t diff --git a/greetfiles/LOCAL-INIT.~32~ b/greetfiles/LOCAL-INIT.~32~ deleted file mode 100644 index 7ff0c5cd..00000000 --- a/greetfiles/LOCAL-INIT.~32~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Jun-2017 22:48:46" {DSK}Personal>local>medley3.5>current>LOCAL-INIT.;32 9225 changes to%: (VARS LOCAL-INITCOMS) previous date%: "15-Jun-2017 22:06:37" {DSK}Personal>local>medley3.5>current>LOCAL-INIT.;31) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)) (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) (DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/displayfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT) (SETQ USERNAME (UNIX-GETENV "USER"))) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)) (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (RPAQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/displayfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (LOCAL-INIT) (SETQ USERNAME (UNIX-GETENV "USER")) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2563 3388 (INTERLISPMODE 2573 . 3386)) (3962 7514 (LOCAL-INIT 3972 . 4583) (LoadPatches 4585 . 6533) (COLLECT-PATCH-FILES 6535 . 7512))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~36~ b/greetfiles/LOCAL-INIT.~36~ deleted file mode 100644 index 2945ebc3..00000000 --- a/greetfiles/LOCAL-INIT.~36~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 2-Jul-2017 17:13:31" {DSK}Personal>local>medley3.5>current>LOCAL-INIT.;36 9762 changes to%: (VARS LOCAL-INITCOMS) previous date%: "26-Jun-2017 13:36:35" {DSK}Personal>local>medley3.5>current>LOCAL-INIT.;35) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA) (P (FIXMETA)) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts) (CONCAT MEDLEYDIR '/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT) (SETQ USERNAME (UNIX-GETENV "USER"))) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) (FIXMETA [LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (RPAQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts) (CONCAT MEDLEYDIR '/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (LOCAL-INIT) (SETQ USERNAME (UNIX-GETENV "USER")) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2706 3531 (INTERLISPMODE 2716 . 3529)) (3990 7786 (LOCAL-INIT 4000 . 4611) (LoadPatches 4613 . 6561) (COLLECT-PATCH-FILES 6563 . 7540) (FIXMETA 7542 . 7784))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~39~ b/greetfiles/LOCAL-INIT.~39~ deleted file mode 100644 index eccdaf3b..00000000 --- a/greetfiles/LOCAL-INIT.~39~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 4-Apr-2018 11:06:31" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;39 10035 changes to%: (VARS LOCAL-INITCOMS) previous date%: "27-Mar-2018 07:18:26" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;38 ) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA) (P (FIXMETA)) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT) (SETQ USERNAME (UNIX-GETENV "USER"))) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) (FIXMETA [LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (LOCAL-INIT) (SETQ USERNAME (UNIX-GETENV "USER")) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2841 3666 (INTERLISPMODE 2851 . 3664)) (4125 7921 (LOCAL-INIT 4135 . 4746) (LoadPatches 4748 . 6696) (COLLECT-PATCH-FILES 6698 . 7675) (FIXMETA 7677 . 7919))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~41~ b/greetfiles/LOCAL-INIT.~41~ deleted file mode 100644 index e58d2c0b..00000000 --- a/greetfiles/LOCAL-INIT.~41~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Apr-2018 13:24:14" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;41 10332 changes to%: (VARS LOCAL-INITCOMS) previous date%: "23-Apr-2018 22:12:02" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;40 ) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA) (P (FIXMETA)) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) (FIXMETA [LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:") (KEYACTION 'BLANK-TOP '(METADOWN . METAUP) \CURRENTKEYACTION) (KEYACTION 'BLANK-TOP '(METADOWN . METAUP]) ) (FIXMETA) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2990 3815 (INTERLISPMODE 3000 . 3813)) (4274 8070 (LOCAL-INIT 4284 . 4895) (LoadPatches 4897 . 6845) (COLLECT-PATCH-FILES 6847 . 7824) (FIXMETA 7826 . 8068))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~42~ b/greetfiles/LOCAL-INIT.~42~ deleted file mode 100644 index 53352810..00000000 --- a/greetfiles/LOCAL-INIT.~42~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Dec-2018 17:13:47" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;42 10043 changes to%: (VARS LOCAL-INITCOMS) previous date%: "26-Apr-2018 13:24:14" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;41 ) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2960 3785 (INTERLISPMODE 2970 . 3783)) (4244 7796 (LOCAL-INIT 4254 . 4865) (LoadPatches 4867 . 6815) (COLLECT-PATCH-FILES 6817 . 7794))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~43~ b/greetfiles/LOCAL-INIT.~43~ deleted file mode 100644 index 53352810..00000000 --- a/greetfiles/LOCAL-INIT.~43~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "22-Dec-2018 17:13:47" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;42 10043 changes to%: (VARS LOCAL-INITCOMS) previous date%: "26-Apr-2018 13:24:14" {DSK}kaplan>Local>medley3.5>current>LOCAL-INIT.;41 ) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASLs) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2960 3785 (INTERLISPMODE 2970 . 3783)) (4244 7796 (LOCAL-INIT 4254 . 4865) (LoadPatches 4867 . 6815) (COLLECT-PATCH-FILES 6817 . 7794))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~44~ b/greetfiles/LOCAL-INIT.~44~ deleted file mode 100644 index 28c4eeab..00000000 --- a/greetfiles/LOCAL-INIT.~44~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Oct-2020 15:15:23"  {DSK}kaplan>Local>medley3.5>lispcore>current>LOCAL-INIT.;44 10136 changes to%: (VARS LOCAL-INITCOMS) previous date%: "22-Dec-2018 17:13:47" {DSK}kaplan>Local>medley3.5>lispcore>current>LOCAL-INIT.;43) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE] (P (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE)) (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3011 3836 (INTERLISPMODE 3021 . 3834)) (4295 7847 (LOCAL-INIT 4305 . 4916) (LoadPatches 4918 . 6866) (COLLECT-PATCH-FILES 6868 . 7845))))) STOP \ No newline at end of file diff --git a/greetfiles/LOCAL-INIT.~45~ b/greetfiles/LOCAL-INIT.~45~ deleted file mode 100644 index 2f56dcaf..00000000 --- a/greetfiles/LOCAL-INIT.~45~ +++ /dev/null @@ -1,55 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Oct-2020 15:19:00"  {DSK}kaplan>Local>medley3.5>lispcore>greetfiles>LOCAL-INIT.;45 10099 previous date%: "19-Oct-2020 15:15:23" {DSK}kaplan>Local>medley3.5>lispcore>greetfiles>LOCAL-INIT.;44) (PRETTYCOMPRINT LOCAL-INITCOMS) (RPAQQ LOCAL-INITCOMS [ (* ;; "Local (Mac) system greeting file") (FNS INTERLISPMODE) (VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (SITE 'LOCAL-MAC)) (P (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T))) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))) [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts] (DECLARE%: DONTEVAL@LOAD DOCOPY [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE] (P (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Local (Mac) system greeting file") (DEFINEQ (INTERLISPMODE - [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") - (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP"))) - (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? - then "OLD-INTERLISP-T" - else "INTERLISP")) - (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? - then "OLD-INTERLISP-FILE" - else "INTERLISP") - :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQQ SITE LOCAL-MAC) (BKSYSBUF " ") (* ;  "So tty window doesn't hang during greeting") (INTERLISPMODE) (DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ; "Edited 14-Jun-2017 14:45 by kaplan") (* ; "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") - -(* ;;; "Load all compiled files from the directory") - - (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) - (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* - bind (AFTERIDATE _ (if AFTERDATE - then (OR (IDATE AFTERDATE) - 0) - else 0)) join (COLLECT-PATCH-FILES - (DIRECTORYNAME DIRECTORY) - EXT AFTERIDATE)) - (FUNCTION (LAMBDA (X Y) - (LESSP (CDR X) - (CDR Y] (* ; - "files are sorted by increasing date") - (for file in files do (SELECTQ LDFLG - (HIDDEN (* ; - "Load the file, but don't put it on FILELST") - (LOAD? (CAR file) - T) - (SETQ FILELST (DREMOVE (FILENAMEFIELD - (CAR file) - 'NAME) - FILELST))) - (LOAD? (CAR file) - LDFLG))) - files]) (COLLECT-PATCH-FILES - [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") - - (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") - - (RESETLST - (LET ((FILING.ENUMERATION.DEPTH 1) - (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) - FILE DATE) - (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") - '(ICREATIONDATE) - '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) - when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) - NAKED-DIR) - (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) - AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers") (CONCAT MEDLEYDIR "/lispcore/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources"))) (RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches")) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts) (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts))) (DECLARE%: DONTEVAL@LOAD DOCOPY (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE)) (LOCAL-INIT) (* ;  "(SETQ USERNAME (UNIX-GETENV %"USER%"))") ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LOCAL-INIT COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2974 3799 (INTERLISPMODE 2984 . 3797)) (4258 7810 (LOCAL-INIT 4268 . 4879) (LoadPatches 4881 . 6829) (COLLECT-PATCH-FILES 6831 . 7808))))) STOP \ No newline at end of file diff --git a/greetfiles/SIMPLE-INIT.~1~ b/greetfiles/SIMPLE-INIT.~1~ deleted file mode 100644 index 4514f727..00000000 --- a/greetfiles/SIMPLE-INIT.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "24-Nov-2020 11:05:36" {DSK}larry>SIMPLE-INIT.;3 40372 changes to%: (VARS SIMPLE-INITCOMS) (TEMPLATES WITHOUT.PAGEHOLD) (FNS FIXVERSION) previous date%: "24-Nov-2020 10:20:03" {DSK}larry>SIMPLE-INIT.;1) (PRETTYCOMPRINT SIMPLE-INITCOMS) (RPAQQ SIMPLE-INITCOMS [(FNS INTERLISPMODE) [VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR] (P (INTERLISPMODE)) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library") (CONCAT MEDLEYDIR "/internal/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")) (IRM.HOST&DIR (CONCAT MEDLEYDIR "/docs/dinfo")) (DIRECTORIES (APPEND (LIST LOCALPATCHDIRECTORY) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))) [VARS (CUTEFLG T) (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts) (CONCAT MEDLEYDIR '/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts] [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE] (P (LOCAL-INIT)) (TEMPLATES WITHOUT.PAGEHOLD) (P (INTERLISPMODE)) (VARS (COMPILEIGNOREDECL T)) (COMMANDS cd cdd cdl cdll cdls cdlu cdm cdp phone pwd show) (FNS shell) (COMMANDS cdpg cdse cds cdsg) (VARS (DEFAULTFAXHOST) (DEFAULTCHATHOST) (DEFAULTCOPYRIGHTOWNER)) (ADDVARS (CHAT.ALLHOSTS) (FAXADDRESSES)) (P (LISTPUT IDLE.PROFILE 'ALLOWED.LOGINS NIL) (LISTPUT IDLE.PROFILE 'FORGET NIL) (LISTPUT IDLE.PROFILE 'TIMEOUT NIL)) (FNS INIT.SETUP FILE PPR PPV RELOAD LOADFOREDIT CLOSEI CLOSES CLOSET NTEDITWINDOWS CLOSEG CHANGED?) (ADDVARS (TEDIT.ABBREVS ("un" . "357,127") ("int" . "357,126") ("subset" . "357,131") ("superset" . "357,130") ("and" . "357,266") ("or" . "357,267") ("not" . "357,152") ("all" . "357,265") ("exist" . "357,264") ("def" . "357,162") ("compose" . "357,147"))) (DECLARE%: DONTEVAL@LOAD DOCOPY [P (* ;; "If Lisp sysout hasn't been updated with new code") (AND (ASSOC 'NS FONTDEFS) (FONTSET 'NS] (* ( (* ;; "Must be loaded before NSDISPLAYSIZES") (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) VIRTUALKEYBOARDS))) (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) NSDISPLAYSIZES FILEBROWSER THINFILES)) (VARS (DEFAULTPRINTINGHOST "") (DEFAULTPRINTERTYPE 'POSTSCRIPT)) [DECLARE%: DONTEVAL@LOAD DOCOPY (* ; "(FILES (SYSLOAD) UPCLISP MIME )") (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) SAMEDIR COPYFILES COMPILEBANG WDWHACKS FILEWATCH WHO-LINE SETDEFAULTPRINTER) (P (FILEWATCH 'ON] (COMS (FILEPKGCOMS MACROS) (ALISTS (PRETTYEQUIVLST OPENLAMBDA))) (P (AND (GETD 'INSTALL-WHO-LINE-OPTIONS) (PROGN (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (INSTALL-WHO-LINE-OPTIONS))) (AND (GETD 'XCL::ADD-WHERE-IS-DATABASE) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/WHEREIS.HASH")) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/system.hash"]) (DEFINEQ (INTERLISPMODE [LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26") (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD? then "OLD-INTERLISP-T" else "INTERLISP"))) (XCL:SET-DEFAULT-EXEC-TYPE (if OLD? then "OLD-INTERLISP-T" else "INTERLISP")) (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD? then "OLD-INTERLISP-FILE" else "INTERLISP") :PACKAGE "INTERLISP"]) ) (RPAQQ COMPILEIGNOREDECL T) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (INTERLISPMODE) (DEFINEQ (LOCAL-INIT [LAMBDA NIL (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY)) (* ;  "Edited 14-Jun-2017 14:45 by kaplan") (* ;  "Edited 14-Jun-2017 11:15 by kaplan") (* ;; "This is what gets called when LOCAL-INIT is loaded.") (BKSYSBUF " ") (* ;; "do the real work") (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) (CL:WHEN LOCALPATCHDIRECTORY (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (LoadPatches [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb") (* ;;; "Load all compiled files from the directory") (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*)) (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS* bind (AFTERIDATE _ (if AFTERDATE then (OR (IDATE AFTERDATE) 0) else 0)) join (COLLECT-PATCH-FILES (DIRECTORYNAME DIRECTORY) EXT AFTERIDATE)) (FUNCTION (LAMBDA (X Y) (LESSP (CDR X) (CDR Y] (* ;  "files are sorted by increasing date") (for file in files do (SELECTQ LDFLG (HIDDEN (* ;  "Load the file, but don't put it on FILELST") (LOAD? (CAR file) T) (SETQ FILELST (DREMOVE (FILENAMEFIELD (CAR file) 'NAME) FILELST))) (LOAD? (CAR file) LDFLG))) files]) (COLLECT-PATCH-FILES [LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb") (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.") (RESETLST (LET ((FILING.ENUMERATION.DEPTH 1) (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY)) FILE DATE) (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";") '(ICREATIONDATE) '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN)) when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY) NAKED-DIR) (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE)) AFTERIDATE)) collect (CONS FILE DATE))))]) ) (DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS) `(RESETLST (LET* ((TTYWINDOW ,WINDOW) (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN)) (NEW.PAGEFULLFN (FUNCTION NILL))) (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN) (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN) (COND ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN) NEW.PAGEFULLFN) (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN] TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN))) ,@FORMS)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library") (CONCAT MEDLEYDIR "/internal/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")) (RPAQ IRM.HOST&DIR (CONCAT MEDLEYDIR "/docs/dinfo")) (RPAQ DIRECTORIES (APPEND (LIST LOCALPATCHDIRECTORY) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQQ CUTEFLG T) (RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT))) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts) (CONCAT MEDLEYDIR '/fonts/altofonts))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts))) (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE)) (LOCAL-INIT) (SETTEMPLATE 'WITHOUT.PAGEHOLD 'MACRO) (INTERLISPMODE) (RPAQQ COMPILEIGNOREDECL T) (DEFCOMMAND cd (DIR) (/CNDIR DIR)) (DEFCOMMAND cdd NIL (CNDIR DICTDIR)) (DEFCOMMAND cdl NIL (CNDIR (CONCAT MEDLEYDIR "/lispcore/"))) (DEFCOMMAND cdll NIL (CNDIR (CONCAT MEDLEYDIR "/lispcore/library/"))) (DEFCOMMAND cdls NIL (CNDIR (CONCAT MEDLEYDIR "/lispcore/sources/"))) (DEFCOMMAND cdlu NIL (CNDIR (CONCAT MEDLEYDIR "/lispcore/lispusers/"))) (DEFCOMMAND cdm NIL (CNDIR MEDLEYDIR)) (DEFCOMMAND cdp NIL (CNDIR LFGPARSERDIR)) (DEFCOMMAND phone (name) (ShellCommand (CONCAT "phone " name))) (DEFCOMMAND pwd NIL (DIRECTORYNAME T)) (DEFCOMMAND (show :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T) T)) (DEFINEQ (shell [NLAMBDA LINE (* ;  "Edited 7-Sep-2020 13:28 by rmk:") [SETQ LINE (CONCATLIST (FOR X IN LINE JOIN (LIST X " "] (CL:WITH-OPEN-FILE (STREAM "{NODIRCORE}shell-dribble.txt" :DIRECTION :IO) (ShellCommand LINE STREAM) (SETFILEPTR STREAM 0) (UNTIL (EOFP STREAM) COLLECT (CL:READ-LINE STREAM :EOF-ERROR-P NIL :EOF-VALUE NIL]) ) (DEFCOMMAND cdpg NIL (CNDIR (CONCAT (UNIX-GETENV "HOME") "/sandbox/pargram_english/dev/src/"))) (DEFCOMMAND cdse NIL (CNDIR (CONCAT (UNIX-GETENV "HOME") "/sandbox/pargram_english/dev/src/Standard/"))) (DEFCOMMAND cds NIL (CNDIR (CONCAT (UNIX-GETENV "HOME") "/sandbox/"))) (DEFCOMMAND cdsg NIL (CNDIR (CONCAT (UNIX-GETENV "HOME") "/sandbox/pargram/pargram_german/standard/"))) (RPAQQ DEFAULTFAXHOST NIL) (RPAQQ DEFAULTCHATHOST NIL) (RPAQQ DEFAULTCOPYRIGHTOWNER NIL) (ADDTOVAR CHAT.ALLHOSTS ) (ADDTOVAR FAXADDRESSES ) (LISTPUT IDLE.PROFILE 'ALLOWED.LOGINS NIL) (LISTPUT IDLE.PROFILE 'FORGET NIL) (LISTPUT IDLE.PROFILE 'TIMEOUT NIL) (DEFINEQ (INIT.SETUP [NLAMBDA (LASTNAME FIRSTNAME INITIALS OPENFOLDER NSNAME) (* ;  "Edited 2-May-2020 13:44 by rmk:") (* ;  "Edited 26-Apr-2018 13:21 by rmk:") (* ; "Edited 6-Mar-99 11:56 by rmk:") (* ; "Edited 28-Feb-99 00:02 by rmk:") (* ; "Edited 4-Oct-98 10:02 by rmk:") (AND (LISTP (EVALV 'FB.DEFAULT.INFO)) (PUSHNEW FB.DEFAULT.INFO 'LENGTH)) (RPAQQ RECLAIMWAIT 20) (RPAQQ LCASEFLG NIL) (RPAQQ COPYRIGHTFLG NIL) (RPAQQ DWIMWAIT 30) (RPAQQ PFDEFAULT T) (RPAQQ CHANGESARRAY NIL) (RPAQQ AUTOBACKTRACEFLG T) (RPAQQ CLISPIFYENGLSHFLG NIL) (RPAQQ CUTEFLG NIL) (RPAQQ EDITCHARACTERS (J (H G) Z Y N (O NIL))) (RPAQQ **COMMENT**FLG " ; -- ") (RPAQQ EDITUNSAVEBLOCKFLG NIL) (RPAQQ NORMALCOMMENTSFLG T) (RPAQQ DEFAULTRENAMEMETHOD EDITCALLERS) (RPAQQ RECOMPILEDEFAULT EXPRS) (RPAQQ LINESPERPAGE 69) (RPAQQ CLEANUPOPTIONS (RC ST)) (RPAQQ TTYINCOMPLETEFLG NIL) (CL:WHEN (OPENWP LOGOW) (CLOSEW LOGOW)) (CL:UNLESS (WINDOWP (EVALV 'LFGLOGOW)) (WINDOWPROP PROMPTWINDOW 'TITLE NIL) (SHAPEW PROMPTWINDOW (CREATEREGION 20 (- SCREENHEIGHT 65) 542 63)) [LET ((PROMPTY (- SCREENHEIGHT 63))) (SHAPEW PROMPTWINDOW (CREATEREGION 20 PROMPTY 542 63)) (* ;  "Expand T only upwards to just below prompt") (SHAPEW T (CREATE REGION USING (WINDOWPROP T 'REGION) HEIGHT _ (- (- PROMPTY 4) (FETCH BOTTOM OF (WINDOWPROP T 'REGION]) (* ; "LAFITE") (SETQ OPENFOLDER (EVAL OPENFOLDER)) (CL:UNLESS (AND T (EQ OPENFOLDER 'NOMAIL)) (RPAQ LAFITEDEFAULTHOST&DIR (PACK* "{DSK}/TILDE/" LASTNAME "/MAIL/")) (RPAQQ LAFITEUSEHIGHESTVERSIONFLG T) (RPAQ LAFITESTATUSWINDOWPOSITION (CONS 585 (- SCREENHEIGHT 57))) (COND ((DEFINEDP 'LAFITE) (RPAQ LAFITEHARDCOPYFONT (FONTCREATE 'CLASSIC 10 NIL NIL 'DISPLAY)) (* ;; "Use bigger screen fonts on high-res monitor") (RPAQ LAFITEDISPLAYFONT (RPAQ LAFITEEDITORFONT (FONTCREATE 'CLASSIC (CL:IF (IGREATERP SCREENHEIGHT 1100) 14 10) NIL NIL 'DISPLAY))) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) LAFITEFIND) (RPAQ LAFITE.DONT.DISPLAY.HEADERS (RPAQ LAFITE.DONT.HARDCOPY.HEADERS (RPAQQ LAFITE.DONT.FORWARD.HEADERS ("Mime-Version" "Return-Path" "Redistributed" "Received" "Message-Id" "Format" "Errors-To" "Return-Receipt-To" "Posted-Date" "Postmark" "X-" "Line-Fold" "XNS-Transport-ID" "Illegal" :ORIGINAL)))) (SETQ NS.USER.NAME NSNAME) (SETQ UNIXMAIL.SEND.HOST 'fargo.parc.xerox.com) (SETQ UNIXMAIL.SPOOL.FILE (PACK* '/net/mailback/var/spool/mail/ (UNIX-USERNAME))) (LAFITEMODE 'UNIX) (LAFITE 'ON OPENFOLDER)))) (PUSH TEDIT.DEFAULT.PROPS `FONT `(CLASSIC 10)) (ADDTOVAR EDITMACROS [SHOWD NIL UP (ORR ((E (RESETFORM (OUTPUT T) (PROGN (PRINTDEF (OR [EDITGETD (%## 1) (AND (CDR L) (EDITL0 L '(!0] (ERROR!)) NIL T) (TERPRI))) T)) ((E 'SHOWD?]) (ADDTOVAR EDITCOMSA SHOWD) [EVAL `(ADDTOVAR INITIALSLST ,(LIST LASTNAME FIRSTNAME (PACK* INITIALS ":")))] (/PUSH DIRECTORIES LFGPARSERDIR DICTDIR NIL '{DSK}) (/PUSH LISPUSERSDIRECTORIES LFGPARSERDIR) (RPAQ LOGINHOST/DIR (PACK* "{dsk}/Users/" (L-CASE LASTNAME) "/lisp/")) (RPAQ EMPRESS.SCRATCH (LIST 5 (PACKFILENAME 'DIRECTORY '{DSK}/tmp/ 'BODY 'EMPRESS.SCRATCH))) (MOVD? 'EDITF 'EF) (MOVD? 'EDITV 'EV) (MOVD? 'EDITP 'EP) (MOVD? 'EDITREC 'ER) (RAISE) (* ;; "Now make sure that INIT isn't on FILELST--compensates for system 'feature'") (* ;; "(PUSH POSTGREETFORMS '(SMASHFILECOMS 'INIT) '(DELDEF 'INIT 'FILE))") (AND (NULL (EVALV 'TESTSYS)) (SETQ CLISPIFYPRETTYFLG 'CHANGES) (SETQ CLISPIFTRANFLG 'T]) (FILE [NLAMBDA ARGS (* rmk%: "18-Sep-87 15:35") [COND ((CDR ARGS) (/SETATOMVAL (FILECOMS (CAR ARGS)) (COND [(AND (LITATOM (CADR ARGS)) (NULL (CDDR ARGS))) (COPY (GETATOMVAL (CADR ARGS] (T (CDR ARGS] (RESETFORM (RADIX 10) (MAKEFILE (CAR ARGS]) (PPR [NLAMBDA X (* rmk%: "26-Sep-84 09:27") (for R D inside X do (AND (SETQ D (RECLOOK R)) (printout T .PPF D T)) (AND (SETQ D (FIELDLOOK R)) (printout T .PPFTL D T)) (AND (HASDEF 'DECLTYPES 'FILEPKGTYPE) (SETQ D (GETDEF R 'DECLTYPES 'CURRENT 'NOERROR)) (printout T .PPF D T]) (PPV [LAMBDA (X) (* ;  "Edited 6-Mar-2020 13:06 by rmk:") (PRINTDEF X) ""]) (RELOAD [LAMBDA (FILES NEWTOO) (* ; "Edited 7-Jun-93 17:33 by rmk:") (* ;; "Reloads new compiled versions and notices symbolics, skipping non-Lisp files in FILES. Only reloads already present files unless NEWTOO.") (* ;  "Get rid of versions, and also compile.ext extensions") [SETQ FILES (FOR F EXT INSIDE FILES COLLECT [SETQ EXT (U-CASE (FILENAMEFIELD F 'EXTENSION] (* ;  "Must wipe out NIL extension to eliminate period") (U-CASE (PACKFILENAME 'EXTENSION (AND (NOT (MEMB EXT *COMPILED-EXTENSIONS*)) EXT) 'VERSION NIL 'BODY F](* ;  "Eliminate duplicates, even through COMPILE.EXT") (SETQ FILES (FOR FTAIL ON FILES UNLESS (MEMB (CAR FTAIL) (CDR FTAIL)) COLLECT (CAR FTAIL))) (OR (MEMB NEWTOO LOADOPTIONS) (SETQ NEWTOO T)) (* ;  "NEWTOO is default LDFLG when file hasn't been loaded") (FOR F ROOTFNAME CNAME SNAME LDFLG IN FILES EACHTIME (SETQ ROOTFNAME (ROOTFILENAME F)) WHEN [SETQ LDFLG (OR NEWTOO (COND ((GETP ROOTFNAME 'FILE) T) ((GETP ROOTFNAME 'FILEDATES) 'SYSLOAD] WHEN (PROGN (IF (SETQ CNAME (FINDFILE-WITH-EXTENSIONS F NIL *COMPILED-EXTENSIONS*)) THEN (SETQ SNAME (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY CNAME))) ELSE (SETQ SNAME (FINDFILE F T))) (CL:WHEN SNAME (CL:UNLESS (LISPSOURCEFILEP SNAME) (SETQ SNAME NIL))) (OR CNAME SNAME (PROGN (PRINTOUT T "NOT FOUND: " F T) NIL))) COLLECT (* ;  "Don't fiddle properties at all if file isn't found") (* ;  "Don't do DELDEF, cause it will remove it from FILES commands in other files") [FOR LST IN '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES COPYRIGHT) DO (/SETTOPVAL LST (REMOVE ROOTFNAME (GETTOPVAL LST] (/REMPROP ROOTFNAME 'FILE) (/REMPROP ROOTFNAME 'FILECHANGES) (/REMPROP ROOTFNAME 'FILEMAP) (/REMPROP ROOTFNAME 'FILEDATES) (IF CNAME THEN (LOAD CNAME LDFLG)) (IF SNAME THEN (IF CNAME THEN (OR (EQ LDFLG 'SYSLOAD) (LOADFROM SNAME)) ELSE (LOAD SNAME LDFLG))) (FOR X IN (FILEFNSLST ROOTFNAME) DO (/REMPROP X 'EXPR)) (/RPLACD (GETP ROOTFNAME 'FILE)) (APPEND (MKLIST CNAME) (MKLIST SNAME]) (LOADFOREDIT [LAMBDA NIL (* ;  "Edited 24-Apr-2018 14:23 by rmk:") (* ;  "Edited 24-Apr-2018 14:23 by rmk:") (* ;  "Edited 22-Apr-2018 13:25 by rmk:") (* ;  "Edited 14-Jun-2017 13:36 by kaplan") (CL:WHEN (GETD 'TEDIT) (FILESLOAD (SYSLOAD FROM VALUEOF (APPEND '({dsk}/project/lfg/tedit/) LISPUSERSDIRECTORIES)) OBJECTOUTOFTEDIT MATRIX SUPSUB BOXOBJ UID TMAX TMAXPATCHES DOC-OBJECTS SKETCH GRAPHER SKETCHPATCH) (* ; "UID needed by TMAXPATCHES") (FILESLOAD (SYSLOAD FROM VALUEOF LFGPARSERDIR) LFGDISPLAY LFG-FSIMAGEOBJ TREEOBJECT SETIPCHARWIDTH))]) (CLOSEI [LAMBDA NIL (* ;  "Edited 27-Aug-2019 09:24 by rmk:") (* ;; "Close all inspector windows") (FOR W IN (OPENWINDOWS) WHEN (EQ 'INSPECTW.REPAINTFN (WINDOWPROP W 'REPAINTFN)) DO (CLOSEW W]) (CLOSES [LAMBDA NIL (* ;  "Edited 17-Jan-2020 10:53 by rmk:") (* ;  "Edited 27-Aug-2019 09:24 by rmk:") (* ;; "Close all SEDIT windows") (FOR W IN (OPENWINDOWS) WHEN (EQ 'SEDIT::REPAINTFN (WINDOWPROP W 'REPAINTFN)) DO (CLOSEW W]) (CLOSET [LAMBDA (ASKFORDIRTY) (* ;  "Edited 17-May-2020 11:16 by rmk:") (* ;  "Edited 22-Apr-2020 14:20 by rmk:") (* ;  "Edited 17-Mar-2020 23:00 by rmk:") (* ;  "Edited 16-Mar-2020 12:49 by rmk:") (* ;  "Edited 27-Aug-2019 09:24 by rmk:") (* ;; "Close all TEDIT windows, except sentence input window") (FOR W IN (OPENWINDOWS) WHEN (TEDITWINDOWP W) UNLESS (STRPOS "LFGINPUTWINDOW" (WINDOWPROP W 'TEDIT.TITLEMENUFN)) DO (CL:UNLESS ASKFORDIRTY (TEDIT.STREAMCHANGEDP (TEXTSTREAM W) T)) (CLOSEW W]) (NTEDITWINDOWS [LAMBDA NIL (* ;  "Edited 22-Apr-2020 14:21 by rmk:") (FOR W IN (OPENWINDOWS) COUNT (TEDITWINDOWP W]) (CLOSEG [LAMBDA NIL (* ;  "Edited 16-Mar-2020 12:49 by rmk:") (* ;  "Edited 27-Aug-2019 09:24 by rmk:") (* ;; "Close all grammar (rules, lexentries. templates, configs...) windows") (FOR W IN (OPENWINDOWS) WHEN (EQ 'STRUCTEDITOR.MENUFN (WINDOWPROP W 'TEDIT.TITLEMENUFN)) DO (CLOSEW W]) (CHANGED? [LAMBDA (NAME TYPE) (* ;  "Edited 5-Jul-2020 08:26 by rmk:") (* ;  "Edited 9-Jun-2020 23:25 by rmk:") (CL:UNLESS TYPE (SETQ TYPE (IF (AND (GETATOMVAL NAME) (NOT (GETD NAME))) THEN 'VARS ELSE 'FNS))) (LET ((FILE (WHEREIS NAME TYPE))) (IF (NULL FILE) THEN (PRINTOUT T NAME " as " TYPE " doesn't belong to a file" T) ELSEIF (CDR FILE) THEN (PRINTOUT T NAME " belongs to several files: " FILE ", not testing" T) ELSE (SETQ FILE (CAR FILE)) (LET [[CURRENT (GETDEF NAME TYPE NIL '(NOERROR NOCOPY] (FROMFILE (GETDEF NAME TYPE FILE '(NOERROR NOCOPY] (CL:WHEN (EQ TYPE 'FNS) (* ;; "Skip the file dates") [SETQ CURRENT `(,(CAR CURRENT) ,(CADR CURRENT) ,@(FOR FORM IN (CDDR CURRENT) UNLESS (EDITDATE? FORM) COLLECT FORM] [SETQ FROMFILE `(,(CAR FROMFILE) ,(CADR FROMFILE) ,@(FOR FORM IN (CDDR FROMFILE) UNLESS (EDITDATE? FORM) COLLECT FORM]) (IF (COMPARELST CURRENT FROMFILE T) THEN (PRINTOUT T NAME " has not changed") (CL:WHEN (MEMB NAME (GETP FILE 'FILE)) (PRINTOUT T ", removing it from " FILE " changes") [/RPLACD (GETP FILE 'FILE) (REMOVE NAME (GETP FILE 'FILE]) (CL:WHEN (AND (MEMB TYPE '(FNS FUNCTION)) (EXPRP NAME) (GETP NAME 'CODE)) (PRINTOUT T ", restoring compiled definition" T) (UNSAVEDEF NAME 'CODE)) (TERPRI T) (UNMARKASCHANGED NAME TYPE) 'SAME ELSE (PRINTOUT T NAME " has changed" T) (COMPARELISTS CURRENT FROMFILE T) 'DIFFERENT]) ) (ADDTOVAR TEDIT.ABBREVS ("un" . "357,127") ("int" . "357,126") ("subset" . "357,131") ("superset" . "357,130") ("and" . "357,266") ("or" . "357,267") ("not" . "357,152") ("all" . "357,265") ("exist" . "357,264") ("def" . "357,162") ("compose" . "357,147")) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "If Lisp sysout hasn't been updated with new code") (AND (ASSOC 'NS FONTDEFS) (FONTSET 'NS)) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) NSDISPLAYSIZES FILEBROWSER THINFILES) ) (RPAQ DEFAULTPRINTINGHOST "") (RPAQQ DEFAULTPRINTERTYPE POSTSCRIPT) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) SAMEDIR COPYFILES COMPILEBANG WDWHACKS FILEWATCH WHO-LINE SETDEFAULTPRINTER) (FILEWATCH 'ON) ) (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)))) (ADDTOVAR PRETTYEQUIVLST (OPENLAMBDA . LAMBDA)) (AND (GETD 'INSTALL-WHO-LINE-OPTIONS) (PROGN (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (INSTALL-WHO-LINE-OPTIONS))) (AND (GETD 'XCL::ADD-WHERE-IS-DATABASE) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/WHEREIS.HASH")) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/system.hash"))) (PRETTYCOMPRINT SIMPLE-INITCOMS) (RPAQQ SIMPLE-INITCOMS [(FNS INTERLISPMODE) [VARS (COMPILEIGNOREDECL T) (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR] (P (INTERLISPMODE)) (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES) (FUNCTIONS WITHOUT.PAGEHOLD) (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library") (CONCAT MEDLEYDIR "/internal/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")) (IRM.HOST&DIR (CONCAT MEDLEYDIR "/docs/dinfo")) (DIRECTORIES (APPEND (LIST LOCALPATCHDIRECTORY) LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))) [VARS (CUTEFLG T) (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM) ({DSK}/Users/ USER /Lisp/INIT.DFASL) ({DSK}/Users/ USER /Lisp/INIT] [VARS (*USEOLDFONTDIRECTORIES* NIL) [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts) (CONCAT MEDLEYDIR '/fonts/altofonts] [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts] (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts] [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE] (P (LOCAL-INIT)) (TEMPLATES WITHOUT.PAGEHOLD) (P (INTERLISPMODE)) (VARS (COMPILEIGNOREDECL T)) (COMMANDS cd cdd cdl cdll cdls cdlu cdm cdp phone pwd show) (FNS shell) (COMMANDS cdpg cdse cds cdsg) (VARS (DEFAULTFAXHOST) (DEFAULTCHATHOST) (DEFAULTCOPYRIGHTOWNER)) (ADDVARS (CHAT.ALLHOSTS) (FAXADDRESSES)) (P (LISTPUT IDLE.PROFILE 'ALLOWED.LOGINS NIL) (LISTPUT IDLE.PROFILE 'FORGET NIL) (LISTPUT IDLE.PROFILE 'TIMEOUT NIL)) (FNS INIT.SETUP FILE PPR PPV RELOAD LOADFOREDIT CLOSEI CLOSES CLOSET NTEDITWINDOWS CLOSEG CHANGED?) (ADDVARS (TEDIT.ABBREVS ("un" . "357,127") ("int" . "357,126") ("subset" . "357,131") ("superset" . "357,130") ("and" . "357,266") ("or" . "357,267") ("not" . "357,152") ("all" . "357,265") ("exist" . "357,264") ("def" . "357,162") ("compose" . "357,147"))) (DECLARE%: DONTEVAL@LOAD DOCOPY [P (* ;; "If Lisp sysout hasn't been updated with new code") (AND (ASSOC 'NS FONTDEFS) (FONTSET 'NS] (* ( (* ;; "Must be loaded before NSDISPLAYSIZES") (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) VIRTUALKEYBOARDS))) (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) NSDISPLAYSIZES FILEBROWSER THINFILES)) (VARS (DEFAULTPRINTINGHOST "") (DEFAULTPRINTERTYPE 'POSTSCRIPT)) [DECLARE%: DONTEVAL@LOAD DOCOPY (* ; "(FILES (SYSLOAD) UPCLISP MIME )") (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) SAMEDIR COPYFILES COMPILEBANG WDWHACKS FILEWATCH WHO-LINE SETDEFAULTPRINTER) (P (FILEWATCH 'ON] (COMS (FILEPKGCOMS MACROS) (ALISTS (PRETTYEQUIVLST OPENLAMBDA))) [P (AND (GETD 'INSTALL-WHO-LINE-OPTIONS) (PROGN (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP)) (INSTALL-WHO-LINE-OPTIONS))) (AND (GETD 'XCL::ADD-WHERE-IS-DATABASE) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/WHEREIS.HASH")) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/system.hash"] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPR FILE shell) (NLAML INIT.SETUP) (LAMA]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPR FILE shell) (ADDTOVAR NLAML INIT.SETUP) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4563 5388 (INTERLISPMODE 4573 . 5386)) (5490 9168 (LOCAL-INIT 5500 . 6237) (LoadPatches 6239 . 8187) (COLLECT-PATCH-FILES 8189 . 9166)) (11881 12397 (shell 11891 . 12395)) (13199 31687 ( INIT.SETUP 13209 . 19451) (FILE 19453 . 19878) (PPR 19880 . 20467) (PPV 20469 . 20673) (RELOAD 20675 . 24455) (LOADFOREDIT 24457 . 25656) (CLOSEI 25658 . 26008) (CLOSES 26010 . 26524) (CLOSET 26526 . 27981) (NTEDITWINDOWS 27983 . 28235) (CLOSEG 28237 . 28885) (CHANGED? 28887 . 31685))))) STOP \ No newline at end of file diff --git a/greetfiles/SIMPLE-INIT.~2~ b/greetfiles/SIMPLE-INIT.~2~ deleted file mode 100644 index ce56e33b..00000000 --- a/greetfiles/SIMPLE-INIT.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-Nov-2020 18:29:03" {DSK}larry>ilisp>medley>greetfiles>SIMPLE-INIT.;2 4356 changes to%: (VARS SIMPLE-INITCOMS) (FNS shell FIXVERSION) (TEMPLATES WITHOUT.PAGEHOLD) previous date%: "24-Nov-2020 10:20:03" {DSK}larry>SIMPLE-INIT.;1) (PRETTYCOMPRINT SIMPLE-INITCOMS) (RPAQQ SIMPLE-INITCOMS [[VARS (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR] (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library") (CONCAT MEDLEYDIR "/internal/library"))) (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (IRM.HOST&DIR (CONCAT MEDLEYDIR "/docs/dinfo/")) (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))) [VARS (LOGINHOST/DIR (OR (UNIX-GETENV "LOGINHOST/DIR") "{DSK}")) (USERGREETFILES (LET ((BASE (CONCAT LOGINHOST/DIR "/INIT"))) (LIST (CONCAT BASE ".LCOM") (CONCAT BASE ".DFASL") BASE] [VARS (DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR "/fonts/dispplayfonts") (CONCAT MEDLEYDIR "/fonts/altofonts"))) (INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR "/fonts/ipfonts"))) (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR "/fonts/postscriptfonts"] [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE] (COMMANDS cd pwd) (FNS shell) [P (CL:WHEN (GETD 'XCL::ADD-WHERE-IS-DATABASE) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/WHEREIS.HASH")) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/system.hash")))] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA shell) (NLAML) (LAMA]) (RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR)) (RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers") (CONCAT MEDLEYDIR "/library") (CONCAT MEDLEYDIR "/internal/library"))) (RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources"))) (RPAQ IRM.HOST&DIR (CONCAT MEDLEYDIR "/docs/dinfo/")) (RPAQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES)) (RPAQ LOGINHOST/DIR (OR (UNIX-GETENV "LOGINHOST/DIR") "{DSK}")) (RPAQ USERGREETFILES (LET ((BASE (CONCAT LOGINHOST/DIR "/INIT"))) (LIST (CONCAT BASE ".LCOM") (CONCAT BASE ".DFASL") BASE))) (RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR "/fonts/dispplayfonts") (CONCAT MEDLEYDIR "/fonts/altofonts"))) (RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR "/fonts/ipfonts"))) (RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR "/fonts/postscriptfonts"))) (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE)) (DEFCOMMAND cd (DIR) (/CNDIR DIR)) (DEFCOMMAND pwd NIL (DIRECTORYNAME T)) (DEFINEQ (shell [NLAMBDA LINE (* ;  "Edited 7-Sep-2020 13:28 by rmk:") [SETQ LINE (CONCATLIST (for X in LINE join (LIST X " "] (CL:WITH-OPEN-FILE (STREAM "{NODIRCORE}shell-dribble.txt" :DIRECTION :IO) (ShellCommand LINE STREAM) (SETFILEPTR STREAM 0) (until (EOFP STREAM) collect (CL:READ-LINE STREAM :EOF-ERROR-P NIL :EOF-VALUE NIL]) ) (CL:WHEN (GETD 'XCL::ADD-WHERE-IS-DATABASE) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/WHEREIS.HASH")) (XCL::ADD-WHERE-IS-DATABASE (CONCAT MEDLEYDIR "/loadups/system.hash"))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA shell) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3482 3998 (shell 3492 . 3996))))) STOP \ No newline at end of file diff --git a/internal/library/ARCLEANUP.~1~ b/internal/library/ARCLEANUP.~1~ deleted file mode 100644 index 3b1e793f..00000000 --- a/internal/library/ARCLEANUP.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Apr-92 18:06:57" |{PELE:MV:ENVOS}INTERNAL>LIBRARY>ARCLEANUP.;8| 14846 changes to%: (FNS AR.CLEANUP.DO.SUMMARIES) previous date%: "30-Mar-92 10:45:38" |{PELE:MV:ENVOS}INTERNAL>LIBRARY>ARCLEANUP.;6| ) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ARCLEANUPCOMS) (RPAQQ ARCLEANUPCOMS [(FILES AREDIT ARINDEX) (COMS (* ; "The main CLEANUP code") (FNS AR.CLEANUP AR.GET.NUMS.FROM.TDS AR.PRINT.AND.IP.FILE AR.QUERY.PRINT.AND.IP.FILE) (* ; "Special versions of CLEANUP") (FNS AR.CLEANUP.DO.SUMMARIES AR.CLEANUP.REDO.SUMMARIES AR.CLEANUP.NO.SUMMARIES)) (COMS (* ;  "List of names to generate summaries for") (INITVARS (AR.CLEANUP.HACKER.NAMES '(Bane Gadener Masinter Mitani Osamu Porter Prolog Shimizu Sybalsky vanMelle Welch)) (AR.CLEANUP.SORT.ORDER '(System%: Subsystem%: Status%: Priority%: Impact%:)) (AR.SUMMARY.DIRECTORY "{AR:MV:Envos}Summaries>")) (P (CL:PROCLAIM '(CL:SPECIAL AR.CLEANUP.HACKER.NAMES AR.CLEANUP.SORT.ORDER AR.SUMMARY.DIRECTORY]) (FILESLOAD AREDIT ARINDEX) (* ; "The main CLEANUP code") (DEFINEQ (AR.CLEANUP [LAMBDA (UPDATE.FLG INDEX.LOCAL.DIR SUMMARY.FLG SUMMARY.LOCAL.DIR) (* ; "Edited 7-Dec-89 18:25 by jds") (PROG ([LOCAL.AR.INDEX.NAME (AND INDEX.LOCAL.DIR (CONCAT INDEX.LOCAL.DIR 'AR.INDEX] INDEX.WINDOW) (COND (LOCAL.AR.INDEX.NAME (printout T "copying old AR index to " LOCAL.AR.INDEX.NAME "...") (COPYFILES AR.INDEX.DEFAULT.FILE.NAME LOCAL.AR.INDEX.NAME '>A) (printout T "done" T))) [COND (UPDATE.FLG (PROG ((SAVED.TDS.NAME (CONCAT AR.INFO.FILE.NAME '-PROCESSED)) NUMBERS INDEX.WINDOW) (COND ((NOT (INFILEP AR.INFO.FILE.NAME)) (printout T "No TDS file --- AR update aborted" T) (RETURN))) [SETQ NUMBERS (SORT (CL:REMOVE-DUPLICATES (while (INFILEP AR.INFO.FILE.NAME) join (until (NLSETQ (RENAMEFILE AR.INFO.FILE.NAME SAVED.TDS.NAME)) do (printout T "Can't rename TDS file --- trying again" T) (BLOCK 5000)) (AR.GET.NUMS.FROM.TDS SAVED.TDS.NAME] (COND ((NULL NUMBERS) (printout T "No numbers found in TDS file --- AR update aborted" T ) (RETURN))) (printout T "Will update AR numbers:" T NUMBERS T) (* ;; "update AR index") (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 400 200 400 65) "old index")) (AR.QFORM.GROUP.CREATE (OR LOCAL.AR.INDEX.NAME AR.INDEX.DEFAULT.FILE.NAME) INDEX.WINDOW) (printout T "updating AR index....") (AR.INDEX.UPDATE INDEX.WINDOW NUMBERS) (CLOSEW INDEX.WINDOW) (printout T "done" T) (COND (LOCAL.AR.INDEX.NAME (printout T "deleting old AR index from " LOCAL.AR.INDEX.NAME "...") (DELFILE LOCAL.AR.INDEX.NAME) (printout T "done" T "copying new index to file server..." (COPYFILE LOCAL.AR.INDEX.NAME AR.INDEX.DEFAULT.FILE.NAME) "done" T] (if SUMMARY.FLG then (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 660 100 350 132))) (AR.QFORM.GROUP.CREATE (OR LOCAL.AR.INDEX.NAME AR.INDEX.DEFAULT.FILE.NAME) INDEX.WINDOW) (* ; "make main unsorted summary") (* ; "print summaries for each person") (AR.CLEANUP.DO.SUMMARIES INDEX.WINDOW SUMMARY.LOCAL.DIR) (CLOSEW INDEX.WINDOW]) (AR.GET.NUMS.FROM.TDS (LAMBDA (FILENAME) (* ; "Edited 20-Feb-87 11:36 by jds") (* ;; "Gather the list of ARs that have changed from the %"Tool Driver Script%" file, where AREDIT makes note of edits that people make.") (PROG ((FILE (OPENSTREAM FILENAME (QUOTE INPUT) (QUOTE OLD))) NUMBERS) (SETQ NUMBERS (while (FILEPOS " -- (" FILE NIL NIL NIL T) bind NUM? when (NUMBERP (SETQ NUM? (PROGN (READ FILE) (READ FILE)))) collect NUM?)) (CLOSEF FILE) (RETURN NUMBERS))) ) (AR.PRINT.AND.IP.FILE (LAMBDA (QFORMWINDOW FILENAME SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (* ; "Edited 1-Mar-88 17:36 by bvm") (* ;; "Take a query form and make a summary from it onto FILENAME. If SUMMARY.LOCAL.DIR is given, the file is created there and then moved to the Summaries directory, else FILENAME is written directly (default dir is still the Summaries directory).") (* ;; "FIELDS-TO-PRINT is a listing of field-name & print-length pairs for what's to appear in the summary. Defaults to whatever AR.PRINT defaults it to.") (LET* ((REMOTETXTFILE (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE BODY) FILENAME (QUOTE EXTENSION) "txt" (AND (NOT (UNPACKFILENAME.STRING FILENAME (QUOTE HOST))) (BQUOTE (DIRECTORY (\, AR.SUMMARY.DIRECTORY)))))) (LOCALTXTFILE (COND (SUMMARY.LOCAL.DIR (CONCAT SUMMARY.LOCAL.DIR FILENAME ".txt")) (T (* ; "No Local directory specified, so put 'em right onto the main AR directory.") REMOTETXTFILE))) LOCALIPFILE) (printout T "Generating summary file: " FILENAME "... ") (SETQ LOCALTXTFILE (AR.MAKE.SUMMARY.FILE QFORMWINDOW LOCALTXTFILE FIELDS-TO-PRINT)) (COND (SUMMARY.LOCAL.DIR (* ; "Copy the text form of the summary to the AR directory") (printout T "copying... " (COPYFILE LOCALTXTFILE REMOTETXTFILE) " "))) (printout T "Creating Interpress file... " (SETQ LOCALIPFILE (AR.MAKE.SUMMARY.FILE QFORMWINDOW (AR.OPEN.IP.STREAM (PACKFILENAME.STRING (QUOTE EXTENSION) "IP" (QUOTE VERSION) NIL (QUOTE BODY) LOCALTXTFILE)) FIELDS-TO-PRINT)) " ") (COND (SUMMARY.LOCAL.DIR (* ; "Finally, copy the IP file back to the main AR directory and delete the local copies.") (printout T "copying... " (COPYFILE LOCALIPFILE (PACKFILENAME.STRING (QUOTE EXTENSION) "IP" (QUOTE VERSION) NIL (QUOTE BODY) REMOTETXTFILE)) " ") (DELFILE LOCALTXTFILE) (DELFILE LOCALIPFILE))) (printout T "done" T))) ) (AR.QUERY.PRINT.AND.IP.FILE (LAMBDA (INDEX.WINDOW.OR.FILE QLIST SLIST FILENAME SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (* ; "Edited 29-Feb-88 19:35 by bvm") (* ;; "Query on QLIST, sorted by SLIST, and make a summary and ip file for it. If INDEX.WINDOW.OR.FILE is not a window, we'll create and close a fake window, in which case INDEX.WINDOW.OR.FILE can be the name of the index file to use.") (LET* ((INDEX.WINDOW (WINDOWP INDEX.WINDOW.OR.FILE)) (OPENED INDEX.WINDOW)) (if (NOT OPENED) then (* ; "Make a fake query window") (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 660 100 350 65))) (LET ((AR.ALWAYS.CACHE.INDEX NIL)) (AR.QFORM.GROUP.CREATE (OR INDEX.WINDOW.OR.FILE AR.INDEX.DEFAULT.FILE.NAME) INDEX.WINDOW T))) (AR.QUERY INDEX.WINDOW QLIST SLIST) (AR.PRINT.AND.IP.FILE INDEX.WINDOW FILENAME SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (if (NOT OPENED) then (CLOSEW INDEX.WINDOW)))) ) ) (* ; "Special versions of CLEANUP") (DEFINEQ (AR.CLEANUP.DO.SUMMARIES [LAMBDA (INDEX.WINDOW SUMMARY.LOCAL.DIR) (* ; "Edited 1-Apr-92 16:55 by jds") (* ;; "Make various specialized summaries, then personal ones for each hacker") [LET ((SORT.ORDER (REMOVE 'Status%: AR.CLEANUP.SORT.ORDER))) (* ; "make report for Rooms") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased) (System%: IS Rooms)) SORT.ORDER "RoomsSummary" SUMMARY.LOCAL.DIR) (* ; "make report for Loops") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased) (System%: IS LOOPS)) SORT.ORDER "LoopsSummary" SUMMARY.LOCAL.DIR) (* ; "make report for Maiko") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased) (System%: IS Maiko)) SORT.ORDER "MaikoSummary" SUMMARY.LOCAL.DIR) (* ;  "make report for all Absolutely ARs") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased) (Priority%: IS Absolutely)) AR.CLEANUP.SORT.ORDER "AbsolutelySummary" SUMMARY.LOCAL.DIR) (* ;; "Report on all documentation ARs:") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased) (OR (System%: IS Documentation) (Subsystem%: IS Documentation) (|Problem Type:| IS Documentation))) AR.CLEANUP.SORT.ORDER "DocSummary" SUMMARY.LOCAL.DIR) (* ;; "Make a report of all open ARs:") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(Status%: >= Open/Unreleased) SORT.ORDER "OpenSummary" SUMMARY.LOCAL.DIR) (* ;; "make report for all Fixed ARs:") [AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(Status%: IS Fixed) SORT.ORDER "FixedSummary" SUMMARY.LOCAL.DIR '((Edit-Date%: 9 T) (Date%: 9 T) (System%: 13 T) (Subsystem%: 14) (Status%: 10 T) (Attn%: 13) (Subject%: 55) (Priority%: 10) (Impact%: 8) (|Problem Type:| 13] (* ;  "print summary of Fixed and Closed for Medley") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: IS Closed) (OR (Date%: >= 1-Jun-90) (Edit-Date%: >= 1-Jun-90))) '(Status%: System%: Subsystem%:) "ClosedSummary" SUMMARY.LOCAL.DIR '((Edit-Date%: 9 T) (Date%: 9 T) (System%: 13 T) (Subsystem%: 14) (Status%: 10 T) (Attn%: 13) (Subject%: 55) (Priority%: 10) (Impact%: 8) (|Problem Type:| 13] (for HACKER.NAME in AR.CLEANUP.HACKER.NAMES do (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW `(Attn%: HAS ,(OR (SUBSTRING HACKER.NAME 1 4) HACKER.NAME)) AR.CLEANUP.SORT.ORDER (CONCAT HACKER.NAME "Summary") SUMMARY.LOCAL.DIR]) (AR.CLEANUP.REDO.SUMMARIES (LAMBDA (INDEX.WINDOW SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 19:27 by bvm") (AR.CLEANUP.DO.SUMMARIES INDEX.WINDOW) (* ; "Dunno why there's this extra random summary...") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW (QUOTE (OR (AND (System%: IS Programming% Environment) (Subsystem%: IS Break% Package)) (AND (System%: IS Common% Lisp) (OR (Subsystem%: IS Debugging) (Subsystem%: IS Break% Package) (Subsystem%: IS Error% System))))) (QUOTE (Subsystem%: Status%:)) "KelleySummary" SUMMARY.LOCAL.DIR)) ) (AR.CLEANUP.NO.SUMMARIES (LAMBDA (UPDATE.FLG INDEX.LOCAL.DIR SUMMARY.FLG SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 17:06 by bvm") (AR.CLEANUP UPDATE.FLG INDEX.LOCAL.DIR NIL SUMMARY.LOCAL.DIR)) ) ) (* ; "List of names to generate summaries for") (RPAQ? AR.CLEANUP.HACKER.NAMES '(Bane Gadener Masinter Mitani Osamu Porter Prolog Shimizu Sybalsky vanMelle Welch)) (RPAQ? AR.CLEANUP.SORT.ORDER '(System%: Subsystem%: Status%: Priority%: Impact%:)) (RPAQ? AR.SUMMARY.DIRECTORY "{AR:MV:Envos}Summaries>") (CL:PROCLAIM '(CL:SPECIAL AR.CLEANUP.HACKER.NAMES AR.CLEANUP.SORT.ORDER AR.SUMMARY.DIRECTORY)) (PUTPROPS ARCLEANUP COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1698 8805 (AR.CLEANUP 1708 . 5632) (AR.GET.NUMS.FROM.TDS 5634 . 6105) ( AR.PRINT.AND.IP.FILE 6107 . 7924) (AR.QUERY.PRINT.AND.IP.FILE 7926 . 8803)) (8850 14249 ( AR.CLEANUP.DO.SUMMARIES 8860 . 13514) (AR.CLEANUP.REDO.SUMMARIES 13516 . 14047) ( AR.CLEANUP.NO.SUMMARIES 14049 . 14247))))) STOP \ No newline at end of file diff --git a/internal/library/CALENDARHACKS.~3~ b/internal/library/CALENDARHACKS.~3~ deleted file mode 100644 index 53c1c91a..00000000 --- a/internal/library/CALENDARHACKS.~3~ +++ /dev/null @@ -1,222 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "23-Mar-94 17:45:59" |{DSK}export>lispcore>internal>library>CALENDARHACKS.;3| 11258 - - |changes| |to:| (FNS PRINTMONTHIMAGE PRINT-NOTEBOOK-YEAR PRINT-SUMMARY-YEAR PRINT-SCALED-MONTH - ) - - |previous| |date:| "15-Jun-90 11:46:01" -|{DSK}export>lispcore>internal>library>CALENDARHACKS.;1|) - - -; Copyright (c) 1987, 1990, 1994 by Venue & Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT CALENDARHACKSCOMS) - -(RPAQQ CALENDARHACKSCOMS - ( - (* |;;| "Hacks for making reminder-book pages for calendars.") - - (FILES CALENDAR) - (COMS - (* |;;| "User level functions") - - (FNS PRINT-LAND-MONTH PRINT-LAND-YEAR PRINT-NOTEBOOK-MONTH PRINT-NOTEBOOK-YEAR - PRINT-SUMMARY-YEAR PRINT-NARROW-MONTH)) - (COMS - (* |;;| "Internal functions and macros") - - (FNS PRINT-SCALED-MONTH PRINTMONTHIMAGE) - (FUNCTIONS CAL-X CAL-Y)))) - - - -(* |;;| "Hacks for making reminder-book pages for calendars.") - - -(FILESLOAD CALENDAR) - - - -(* |;;| "User level functions") - -(DEFINEQ - -(PRINT-LAND-MONTH (LAMBDA (MONTH YEAR STREAM) (* \; "Edited 17-Oct-87 17:45 by jds") (* |;;| "Print a single month's calendar landscape on letter paper.") (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T))))) (PRINT-SCALED-MONTH MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6) (CLOSEF PRINTSTREAM)))) - -(PRINT-LAND-YEAR (LAMBDA (YEAR STREAM) (* \; "Edited 17-Oct-87 17:49 by jds") (* |;;| "Print a single month's calendar landscape on letter paper.") (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T))))) (|for| MONTH |from| 1 |to| 12 |do| (PRINT-SCALED-MONTH MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6) (DSPNEWPAGE PRINTSTREAM)) (CLOSEF PRINTSTREAM)))) - -(PRINT-NOTEBOOK-MONTH (LAMBDA (MONTH YEAR STREAM) (* \; "Edited 17-Sep-87 21:55 by jds") (* |;;| "Print a single month's calendar on a half-sheet, suitable for punching and putting in a Time-Design notebook or a 5 1/2 x 8 1/2\" reminder book.") (* |;;| "If you leave STREAM NIL, you'll get one page on the printer.") (PRINT-SCALED-MONTH MONTH YEAR 0 0 0.75 0.6 STREAM))) - -(PRINT-NOTEBOOK-YEAR - (LAMBDA (YEAR STREAM) (* \; "Edited 23-Mar-94 17:22 by turpiN:mv:envos") - - (* |;;| "Print a year's worth of month-calendar pages in half-sheet size.") - - (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT)))) - (|for| MONTH |from| 1 |to| 12 |do| (PRINT-SCALED-MONTH MONTH YEAR 0 - (COND - ((EVENP MONTH 2) - 13970) - (T 0)) - 0.75 0.6 PRINTSTREAM) - (COND - ((EVENP MONTH 2) - (DSPNEWPAGE PRINTSTREAM)))) - (CLOSEF PRINTSTREAM)))) - -(PRINT-SUMMARY-YEAR - (LAMBDA (YEAR STREAM) (* \; "Edited 23-Mar-94 17:36 by turpiN:mv:envos") - - (* |;;| "Print a year's worth of small months on 1 sheet of paper that will fit into a 8.25 x 10.5 format (for Time-Design books).") - - (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT '(LANDSCAPE T))))) - (|for| MONTH |from| 1 |to| 4 |as| YOFFSET |from| 44500 |by| -14800 - |do| (PRINT-SCALED-MONTH MONTH YEAR 227 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6)) - (|for| MONTH |from| 5 |to| 8 |as| YOFFSET |from| 44500 |by| -14800 - |do| (PRINT-SCALED-MONTH MONTH YEAR 25427 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6)) - (|for| MONTH |from| 9 |to| 12 |as| YOFFSET |from| 44500 |by| -14800 - |do| (PRINT-SCALED-MONTH MONTH YEAR 50627 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6)) - (CLOSEF PRINTSTREAM)))) - -(PRINT-NARROW-MONTH (LAMBDA (MONTH YEAR STREAM) (* \; "Edited 17-Sep-87 22:32 by jds") (PRINT-SCALED-MONTH MONTH YEAR 0 0 0.45 0.95 STREAM NIL NIL NIL '(LANDSCAPE T)))) -) - - - -(* |;;| "Internal functions and macros") - -(DEFINEQ - -(PRINT-SCALED-MONTH - (LAMBDA (MONTH YEAR X-OFFSET Y-OFFSET X-SCALE Y-SCALE STREAM DAYSIZE DATESIZE TINYSIZE OPTIONS) - (* \; "Edited 23-Mar-94 17:24 by turpiN:mv:envos") - - (* |;;| - "Print a month's calendar on STREAM. MONTH is a number 1-12, Year is the year, 19-- and all.") - - (PROG ((STREAM-EXISTED STREAM) - PBIGFONT PCALFONT PLITTLEFONT) - (SETCURSOR WAITINGCURSOR) - (PRINTOUT PROMPTWINDOW T "Formatting for print...") - (SETQ STREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT OPTIONS))) - (SETQ PBIGFONT (FONTCREATE 'MODERN (OR DAYSIZE 8) - NIL 0 STREAM)) - (SETQ PCALFONT (FONTCREATE 'CLASSIC (OR DATESIZE 12) - NIL 0 STREAM)) - (SETQ PLITTLEFONT (FONTCREATE 'MODERN (OR TINYSIZE 6) - NIL 0 STREAM)) - (PRINTMONTHIMAGE MONTH YEAR STREAM X-OFFSET Y-OFFSET X-SCALE (OR Y-SCALE X-SCALE) - PBIGFONT PCALFONT PLITTLEFONT) (* \; "Print horizontal lines") - (OR STREAM-EXISTED (CLOSEF STREAM)) - (PRINTOUT PROMPTWINDOW "done." T) - (CURSOR T)))) - -(PRINTMONTHIMAGE - (LAMBDA (MONTH YEAR STREAM XOFFSET YOFFSET X-SCALE Y-SCALE DAYFONT DATEFONT TINYDATEFONT) - (* \; "Edited 23-Mar-94 17:42 by turpiN:mv:envos") - - (* |;;| - "Print a month's calendar on STREAM. MONTH is a number 1-12, Year is the year, 19-- and all.") - - (* |;;| - " X-SCALE & XOFFSET, and Y-SCALE & YOFFSET are used in the CAL-X and CAL-Y macros, resp.") - - (* |;;| "DAYFONT and DATEFONT are used for printing the day names and dates/month title resp.") - - (DSPRESET STREAM) - (DSPRIGHTMARGIN 65535 STREAM) - (LET ((TITLESTRING (CONCAT (MONTHNAME MONTH) - " " YEAR))) - (MOVETO (- (CAL-X 37559) - (IQUOTIENT (STRINGWIDTH TITLESTRING DATEFONT) - 2)) - (CAL-Y 57827) - STREAM)) - (DSPFONT DATEFONT STREAM) - (PRINTOUT STREAM (MONTHNAME MONTH) - " " YEAR) - (LET ((DAYLABELS (APPEND (|for| N |from| 1 |to| (DAYOF MONTH 1 YEAR) - |collect| '\ ) - (|for| N |from| 1 |to| (DAYSIN MONTH YEAR) |collect| - N))) - (X 1559) - (Y 47339) - (CT 0)) - (|for| I |in| DAYLABELS |do| - - (* |;;| "Print blanks up to the first day of the month (to allow for not starting on Sunday), then print the dates.") - - (MOVETO (CAL-X X) - (CAL-Y Y) - STREAM) - (PRIN1 I STREAM) - (|add| X 10630) - (|add| CT 1) - (COND - ((EQ (IREMAINDER CT 7) - 0) - (SETQ X 1701) - (|add| Y -8974))))) - (|for| X |from| 850 |to| 75968 |by| 10630 |do| - - (* |;;| "Print vertical lines") - - (DRAWLINE (CAL-X X) - (CAL-Y 1701) - (CAL-X X) - (CAL-Y 55559) - 40 - 'PAINT STREAM)) - (|for| Y |from| 1701 |to| 55559 |by| 8974 |do| - - (* |;;| - "Print horizontal lines") - - (DRAWLINE (CAL-X 850) - (CAL-Y Y) - (CAL-X 75260) - (CAL-Y Y) - 40 - 'PAINT STREAM)) - (DSPFONT DAYFONT STREAM) - (|for| X |from| 2268 |to| 72567 |by| 10630 |as| D |from| 0 |to| - 6 - |do| - - (* |;;| "Print day names") - - (MOVETO (CAL-X X) - (CAL-Y 56126) - STREAM) - (PRIN1 (DAYNAME D) - STREAM)) - (COND - ((>= X-SCALE 0.7) - (DSPFONT PLITTLEFONT STREAM) - (SHOWMONTHSMALL (MONTHPLUS MONTH -1) - (MONTHYEARPLUS MONTH YEAR -1) - (CAL-X 54709) - (CAL-Y 2693) - (FTIMES X-SCALE 28.0) - STREAM) - (SHOWMONTHSMALL (MONTHPLUS MONTH 1) - (MONTHYEARPLUS MONTH YEAR 1) - (CAL-X 65480) - (CAL-Y 2693) - (FTIMES X-SCALE 28.0) - STREAM))) - STREAM)) -) - -(DEFMACRO CAL-X (VALUE) - `(+ XOFFSET (FIXR (FTIMES ,VALUE X-SCALE)))) - -(DEFMACRO CAL-Y (VALUE) - `(+ YOFFSET (FIXR (FTIMES ,VALUE Y-SCALE)))) -(PUTPROPS CALENDARHACKS COPYRIGHT ("Venue & Xerox Corporation" 1987 1990 1994)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (1199 4926 (PRINT-LAND-MONTH 1209 . 1638) (PRINT-LAND-YEAR 1640 . 2174) ( -PRINT-NOTEBOOK-MONTH 2176 . 2650) (PRINT-NOTEBOOK-YEAR 2652 . 3705) (PRINT-SUMMARY-YEAR 3707 . 4700) ( -PRINT-NARROW-MONTH 4702 . 4924)) (4976 11001 (PRINT-SCALED-MONTH 4986 . 6231) (PRINTMONTHIMAGE 6233 . -10999))))) -STOP diff --git a/internal/library/CONDITIONGRAPH.~2~ b/internal/library/CONDITIONGRAPH.~2~ deleted file mode 100644 index 48353744..00000000 --- a/internal/library/CONDITIONGRAPH.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL") (FILECREATED "14-Jun-90 21:03:42"  |{DSK}local>lde>lispcore>internal>library>CONDITIONGRAPH.;2| 5185 |changes| |to:| (VARS CONDITIONGRAPHCOMS) |previous| |date:| " 9-Dec-87 16:48:03" |{DSK}local>lde>lispcore>internal>library>CONDITIONGRAPH.;1|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CONDITIONGRAPHCOMS) (RPAQQ CONDITIONGRAPHCOMS ((DECLARE\: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY (XCL:FILE-ENVIRONMENTS :CONDITIONGRAPH)) (VARIABLES *CONDITION-GRAPH-WINDOW* *CONDITION-GRAPH-SEXPR*) (FUNCTIONS EDIT-CONDITIONS GRAPH-CONDITIONS CONDITION-SUBGRAPH CONDITION-SUBGRAPH-RECURSION RECOMPUTE-CONDITION-GRAPH-SEXPR COUNT-CONDITION-TYPES COUNT-CONDITION-TYPES-RECURSION) (PROP CONDITIONGRAPH))) (DECLARE\: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY (XCL:DEFINE-FILE-ENVIRONMENT :CONDITIONGRAPH :READTABLE "XCL" :PACKAGE "IL" :COMPILER :COMPILE-FILE) ) (CL:DEFVAR *CONDITION-GRAPH-WINDOW* NIL "Window in which to display the condition hierarchy graph.") (CL:DEFVAR *CONDITION-GRAPH-SEXPR* NIL "Tree structure representing last calculated condition type graph.") (CL:DEFUN EDIT-CONDITIONS (ROOT) (CL:LABELS ((EDIT-CONDITIONS-RECURSION (GRAPH) (CL:UNLESS (NULL GRAPH) (ED (CL:FIRST GRAPH) :STRUCTURES) (CL:MAPC #'EDIT-CONDITIONS-RECURSION (CL:REST GRAPH))))) (EDIT-CONDITIONS-RECURSION (CONDITION-SUBGRAPH ROOT NIL)))) (CL:DEFUN GRAPH-CONDITIONS (&OPTIONAL (ROOT 'CONDITION) (RECOMPUTE (NULL *CONDITION-GRAPH-SEXPR*)) W) (LET ((NEWW (SHOWGRAPH (LAYOUTSEXPR (CONDITION-SUBGRAPH ROOT RECOMPUTE) '(HORIZONTAL)) (OR W *CONDITION-GRAPH-WINDOW* (CL:FORMAT NIL "Condition type graph from: ~S" ROOT)) NIL NIL T))) (WINDOWPROP NEWW 'TITLE (CL:FORMAT NIL "Condition type graph from: ~S" ROOT)) (OR W *CONDITION-GRAPH-WINDOW* (CL:SETF *CONDITION-GRAPH-WINDOW* NEWW)))) (CL:DEFUN CONDITION-SUBGRAPH (ROOT RECOMPUTE &AUX (ONCE NIL) RESULT) (CL:UNLESS (CL:SUBTYPEP ROOT 'CONDITION) (CL:ERROR "~S is not a condition type.")) (CL:LOOP (CL:WHEN RECOMPUTE (RECOMPUTE-CONDITION-GRAPH-SEXPR)) (CL:SETF RESULT (CONDITION-SUBGRAPH-RECURSION ROOT *CONDITION-GRAPH-SEXPR*)) (CL:WHEN (OR ONCE RESULT) (CL:RETURN-FROM CONDITION-SUBGRAPH RESULT)) (CL:FORMAT *ERROR-OUTPUT* "Couldn't find ~S in current graph.") (CL:SETQ ONCE T RECOMPUTE T))) (CL:DEFUN CONDITION-SUBGRAPH-RECURSION (TARGET TREE) (COND ((NULL TREE) NIL) ((EQ TARGET (CL:FIRST TREE)) TREE) (T (CL:DOLIST (SUBTREE (CL:REST TREE)) (LET ((FOUND? (CONDITION-SUBGRAPH-RECURSION TARGET SUBTREE))) (CL:WHEN FOUND? (RETURN FOUND?))))))) (CL:DEFUN RECOMPUTE-CONDITION-GRAPH-SEXPR () (LET ((CGHASH (CL:MAKE-HASH-TABLE))) (CL:FORMAT *ERROR-OUTPUT* " Computing condition hierarchy graph.") (MAPCAR (DATATYPES) #'(CL:LAMBDA (SYMBOL) (BLOCK) (CL:WHEN (AND (NOT (CL:GETHASH SYMBOL CGHASH)) (CL:SUBTYPEP SYMBOL 'CONDITION)) (CL:DO ((TYPE SYMBOL (CONDITION-PARENT TYPE)) (CHAIN NIL)) ((COND ((NULL TYPE) (CL:SETF *CONDITION-GRAPH-SEXPR* CHAIN)) ((CL:GETHASH TYPE CGHASH) (NCONC (CL:GETHASH TYPE CGHASH) (LIST CHAIN))) (T NIL))) (CL:PRINC ".") (CL:SETF (CL:GETHASH TYPE CGHASH) (CL:SETF CHAIN (CL:IF (NULL CHAIN) (LIST TYPE) (LIST TYPE CHAIN)))))))))) (CL:DEFUN COUNT-CONDITION-TYPES () (COUNT-CONDITION-TYPES-RECURSION (CONDITION-SUBGRAPH 'CONDITION NIL))) (CL:DEFUN COUNT-CONDITION-TYPES-RECURSION (TREE) (COND ((NULL TREE) 0) ((CL:SYMBOLP TREE) 1) (T (FOR SUBTREE IN TREE SUM (COUNT-CONDITION-TYPES-RECURSION SUBTREE))))) (PUTPROPS CONDITIONGRAPH COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/library/GIVE-AND-TAKE.~2~ b/internal/library/GIVE-AND-TAKE.~2~ deleted file mode 100644 index 2324cfb2..00000000 --- a/internal/library/GIVE-AND-TAKE.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 3-Feb-91 14:11:40" |{PELE:MV:ENVOS}INTERNAL>LIBRARY>GIVE-AND-TAKE.;4| 14607 |changes| |to:| (COMMANDS "take") (FUNCTIONS TAKE-FILE) |previous| |date:| "15-Jun-90 14:20:18" |{PELE:MV:ENVOS}INTERNAL>LIBRARY>GIVE-AND-TAKE.;3|) ; Copyright (c) 1986, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT GIVE-AND-TAKECOMS) (RPAQQ GIVE-AND-TAKECOMS ((COMMANDS "give?" "taken?" "give" "take" "steal") (FUNCTIONS GIVE-OR-TAKE-FIND ADD-DEFAULT-REGISTRY SEND-STEAL-MESSAGE GIVE-FILE TAKE-FILE TAKEN?) (VARIABLES *GIVE-AND-TAKE-DIRECTORIES*) (PROP FILETYPE GIVE-AND-TAKE))) (DEFCOMMAND "give?" NIL (TAKEN? :GIVE? T)) (DEFCOMMAND "taken?" (&REST ARGS) (CL:APPLY #'TAKEN? ARGS)) (DEFCOMMAND "give" (&REST FILES) (FOR FILE IN FILES ALWAYS (GIVE-FILE FILE))) (DEFCOMMAND "take" (&REST FILES) (* |;;| "Give the issuer a \"lock\" on the files he asks for. If you give more than one file name, it'll stop if it hits one you can't have the lock to.") (FOR FILE IN FILES ALWAYS (TAKE-FILE FILE))) (DEFCOMMAND "steal" (&REST FILES) (FOR FILE IN FILES ALWAYS (TAKE-FILE FILE T))) (CL:DEFUN GIVE-OR-TAKE-FIND (FILENAME) (LET ((NAME (FINDFILE FILENAME T *GIVE-AND-TAKE-DIRECTORIES*))) (COND (NAME NAME) (T (CL:FORMAT T "~A does not exist and so cannot be taken or given.~%" FILENAME) NIL)))) (CL:DEFUN ADD-DEFAULT-REGISTRY (NAME) (* |;;;| "Adds default registry to NAME if there isn't one there already") (COND ((OR (STRPOS "." NAME) (NULL DEFAULTREGISTRY)) NAME) (T (CONCAT NAME "." DEFAULTREGISTRY)))) (CL:DEFUN SEND-STEAL-MESSAGE (THIEF AUTHOR FILE) (LAFITE.SENDMESSAGE (MKSTRING (CL:FORMAT NIL "Subject: File stolen To: ~A ~A just stole the file ~A from you. The STEAL command" AUTHOR THIEF FILE)))) (CL:DEFUN GIVE-FILE (FILENAME) "Find the file named and look for a STATUS file associated with it. If found and this user wrote it, then remove it, thus unlocking the file." (LET ((NAME (GIVE-OR-TAKE-FIND FILENAME)) STATUS-STREAM TAKEN-BY) (COND ((NULL NAME) NIL) ((NOT (STREAMP (SETQ STATUS-STREAM (CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING 'EXTENSION 'STATUS 'VERSION 1 'BODY NAME) 'INPUT NIL '(DON\'TCACHE))))))) (CL:FORMAT T "Sorry, but you can't give what you haven't taken.~%~A has not been taken by anyone, including you.~%" NAME) NIL) ((STRING-EQUAL (SETQ TAKEN-BY (ADD-DEFAULT-REGISTRY (CL:READ STATUS-STREAM))) (ADD-DEFAULT-REGISTRY (USERNAME))) (* \; "We're a winner") (DELFILE (CLOSEF STATUS-STREAM)) (CL:FORMAT T "~A is now unlocked.~%" NAME) T) (T (* \; "We're a loser") (CL:FORMAT T "Sorry, but you can't give what you haven't taken.~%~A was taken by ~A on ~A.~%" NAME TAKEN-BY (CL:READ STATUS-STREAM)) (CLOSEF STATUS-STREAM) NIL)))) (CL:DEFUN TAKE-FILE (FILENAME &OPTIONAL STEAL) (* |;;| "Find the given file and open a status file to be associated with it. If the file we open turns out to be version 1, then we've got the lock and we write our name and the date into the file. Otherwise, somebody (possibly us!) has already got it and the lock cannot be obtained. HOWEVER: If we're the lock's owner already, indicate success -- the point is to grab the lock, not to find out if it's locked before!") (RESETLST (PROG ((GROSS-LIST-HACK (LIST NIL NIL T)) NAME STATUS-NAME STATUS-NAME-PARTS STATUS-VERSION SUCCESS) (COND ((NOT (CL:SETF NAME (GIVE-OR-TAKE-FIND FILENAME))) (RETURN NIL))) (CL:SETF STATUS-NAME (PACKFILENAME.STRING 'EXTENSION 'STATUS 'VERSION NIL 'BODY NAME)) (CL:MACROLET ((STATUS-STREAM NIL '(CL:FIRST GROSS-LIST-HACK)) (STATUS-FULL-NAME NIL '(CL:SECOND GROSS-LIST-HACK)) (FINISHED-NORMALLY-P NIL '(CL:THIRD GROSS-LIST-HACK))) (RESETSAVE NIL (LIST (FUNCTION (CL:LAMBDA (NAME GROSS-LIST-HACK) (* |;;| "We have been interrupted during processing. Close any open streams and delete the status file we were making.") (CL:WHEN (NOT (FINISHED-NORMALLY-P)) (CL:FORMAT T "Interrupted during processing of ~A. Take aborted.~%" NAME) (CL:WHEN (AND (NULL (STATUS-FULL-NAME)) (STREAMP (STATUS-STREAM)) ) (* \; "If STATUS-FULL-NAME was never set, then STATUS-STREAM, if open, must refer to the new status file.") (CL:SETF (STATUS-FULL-NAME) (FULLNAME (STATUS-STREAM)))) (CL:IF (STREAMP (STATUS-STREAM)) (CLOSEF? (STATUS-STREAM))) (CL:IF (NOT (NULL (STATUS-FULL-NAME))) (DELFILE (STATUS-FULL-NAME)))))) NAME GROSS-LIST-HACK)) (CL:SETF (STATUS-STREAM) (OPENSTREAM STATUS-NAME 'OUTPUT NIL '(DON\'TCACHE))) (CL:SETF (STATUS-FULL-NAME) (FULLNAME (STATUS-STREAM))) (COND ((= (FILENAMEFIELD (STATUS-FULL-NAME) 'VERSION) 1) (* \; "We're a winner") (LET ((UNAME (ADD-DEFAULT-REGISTRY (USERNAME))) (D (DATE))) (CL:FORMAT (STATUS-STREAM) "~S ~S~%" UNAME D) (CLOSEF (STATUS-STREAM)) (CL:FORMAT T "~A is now locked by ~A at ~A.~%" NAME UNAME D)) (LET ((ROOTNAME (ROOTFILENAME NAME)) INSTALLEDVERSION) (COND ((AND (GET ROOTNAME 'FILE) (NOT (STRING-EQUAL NAME (SETQ INSTALLEDVERSION (CDAR (GET ROOTNAME 'FILEDATES)))))) (CL:FORMAT T "Warning: File ~A is different from loaded file ~A~%" NAME INSTALLEDVERSION)))) (CL:SETF SUCCESS T)) (T (* \; "We're a loser at first blush ") (* \;  "(exception: we had the file locked already)") (CLOSEF (STATUS-STREAM)) (DELFILE (STATUS-FULL-NAME)) (CL:SETF (STATUS-STREAM) (CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING 'VERSION 1 'BODY (STATUS-FULL-NAME)) 'INPUT NIL '(DON\'TCACHE))))) (COND ((NOT (STREAMP (STATUS-STREAM))) (CL:FORMAT T "Bad situation: Illegal versions of the status file exist.~&Try again in a moment or try to fix the problem.~%" ) (CL:SETF SUCCESS NIL)) (STEAL (* |;;|  "If we're going to steal it, we should send the former locker a notice.") (CL:FORMAT T "Stealing ~A (and sending ~A a message about it).~%" NAME (GETFILEINFO (STATUS-STREAM) 'AUTHOR)) (ADD.PROCESS `(SEND-STEAL-MESSAGE ',(USERNAME NIL NIL T) ',(GETFILEINFO (STATUS-STREAM) 'AUTHOR) ',NAME)) (CLOSEF (STATUS-STREAM)) (DELFILE (FULLNAME (STATUS-STREAM))) (CL:SETF SUCCESS (TAKE-FILE FILENAME NIL))) ((PROG1 (NOT (NLSETQ (LET ((TAKEN-BY (CL:READ (STATUS-STREAM))) (TAKEN-ON (CL:READ (STATUS-STREAM)))) (CL:IF (STRING-EQUAL TAKEN-BY (  ADD-DEFAULT-REGISTRY (USERNAME))) (PROGN (CL:FORMAT T "You've already had ~A taken, since ~A.~%" NAME TAKEN-ON) (* |;;| "This case is really a success: We've got the lock. Return T so the \"take\" command will keep going.") (CL:SETF SUCCESS T)) (CL:FORMAT T "Sorry, but ~A was already taken by ~A on ~A.~%" NAME TAKEN-BY TAKEN-ON))))) (CLOSEF (STATUS-STREAM))) (CL:FORMAT T "Bad situation: Only an illegal status file exists.~%Try again in a moment or try to fix the problem.~%" ) (CL:SETF SUCCESS NIL))))) (CL:SETF (FINISHED-NORMALLY-P) T)) (RETURN SUCCESS)))) (CL:DEFUN TAKEN? (&KEY ((:BY AUTHOR)) GIVE?) (COND ((NULL AUTHOR) (SETQ AUTHOR (USERNAME)) (COND ((STRPOS "." AUTHOR) (SETQ AUTHOR (SUBSTRING AUTHOR 1 (SUB1 (STRPOS "." AUTHOR))))))) ((OR (STRING-EQUAL AUTHOR "ANY") (STRING-EQUAL AUTHOR "ALL") (STRING-EQUAL AUTHOR "*")) (SETQ AUTHOR NIL))) (|printout| T "Looking for files taken by " (OR AUTHOR "any") T) (|for| DIR |in| *GIVE-AND-TAKE-DIRECTORIES* |do| (RESETLST (LET ((GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME "*" 'EXTENSION "STATUS") '(AUTHOR CREATIONDATE) '(RESETLST))) NEXT THISAUTHOR DIRPRINTED) (|while| (SETQ NEXT (\\GENERATENEXTFILE GEN)) |when| (PROGN (SETQ THISAUTHOR (\\GENERATEFILEINFO GEN 'AUTHOR)) (OR (NULL AUTHOR) (STRPOS AUTHOR THISAUTHOR 1 NIL T NIL UPPERCASEARRAY ))) |do| (COND ((NOT DIRPRINTED) (|printout| T T " " DIR T) (SETQ DIRPRINTED T))) (|printout| T (FILENAMEFIELD NEXT 'NAME) 16 (\\GENERATEFILEINFO GEN 'CREATIONDATE) 40 THISAUTHOR) (COND ((NOT GIVE?) (TERPRI T)) ((EQ (ASKUSER NIL NIL " Give? " NIL T) 'Y) (GIVE-FILE (PACKFILENAME.STRING 'EXTENSION NIL 'VERSION NIL 'BODY NEXT))))))))) (DEFGLOBALVAR *GIVE-AND-TAKE-DIRECTORIES* '("{Pele:mv:envos}Sources>" "{Pele:mv:envos}Library>" "{Pele:mv:envos}Internal>Library>" "{Pele:mv:envos}Lispcore>" "{Pele:mv:envos}Test>")) (PUTPROPS GIVE-AND-TAKE FILETYPE CL:COMPILE-FILE) (PUTPROPS GIVE-AND-TAKE COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/internal/library/MULTI-COMPILE.~4~ b/internal/library/MULTI-COMPILE.~4~ deleted file mode 100644 index c5767422..00000000 --- a/internal/library/MULTI-COMPILE.~4~ +++ /dev/null @@ -1,374 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "16-Nov-94 16:28:04" |{DSK}internal>library>MULTI-COMPILE.;4| 37236 - - |changes| |to:| (VARS MULTI-COMPILECOMS) - (FNS FIND-UNCOMPILED-FILES) - - |previous| |date:| " 9-Sep-94 13:03:19" |{DSK}internal>library>MULTI-COMPILE.;3|) - - -; Copyright (c) 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT MULTI-COMPILECOMS) - -(RPAQQ MULTI-COMPILECOMS - ( - (* |;;| "Support for compiling multiple files in one pass, for a bulk recompilation of the system (or some part of it).") - - (COMS (* \; "Function to compile multiple files without having one step on the next (so you could compile all the system with it).") - (FUNCTIONS BIGCOMP)) - (COMS (* \; "Function to identify all the source files on a given directory (useful for creating lists of things to compile)") - (FUNCTIONS FIND-ALL-SOURCE-FILES) - (FNS FIND-UNCOMPILED-FILES)) - (COMS (* \; - "Misc utility functions from the big Lyric recompiles.") - (FNS NEWERDCOMS? NEWERSOURCES? SETUP-FOR-RECOMPILE SMASH-OPCODES GET-DIRECTORY-LISTING - GET-OPEN-FILES) - - (* |;;| "Control variables") - - (VARS FILES-IN-FULL.SYSOUT FILES-IN-LIBRARY FILES-IN-LISP.SYSOUT FILES-IN-SOURCES - FORKED-FILES GARBAGE-OPCODES)) - (COMS (* \; - "Utilities for making mass-scale fixups to a library of files.") - (FNS FIX-FILES FIX-FILE FIX-COPYRIGHT FIX-FILE-COPYRIGHT QUALIFY-FIELDS FIX-TEDIT - FIX-DOCS)) - - (* |;;| "Removes bogus (CLISP ) translations that result from CLISPARRAY being NIL.") - - (FNS CLFIX) - (PROP FILETYPE MULTI-COMPILE) - (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA FIX-FILES))))) - - - -(* |;;| -"Support for compiling multiple files in one pass, for a bulk recompilation of the system (or some part of it)." -) - - - - -(* \; -"Function to compile multiple files without having one step on the next (so you could compile all the system with it)." -) - - -(CL:DEFUN BIGCOMP (FILENAMES SOURCEDIRS DESTDIR &OPTIONAL (DRIBBLE-FILE '"{DSK}BIGCOMP.DRIBBLE") - DELETE-DCOMS? DELETE-DRIBBLE?) - - (* |;;| "Compile all the files in the system.") - - (LET ((COMPLETION 'ERROR) - (NUM-FILES (LENGTH FILENAMES))) - (IDLE.SET.OPTION 'TIMEOUT T) (* \; "never idle") - (SETQ NOSPELLFLG T) (* \; "death to DWIM!") - (SETQ DWIMIFYCOMPFLG NIL) (* \; "I mean it") - - (* |;;| "do it") - - (CL:UNWIND-PROTECT - (PROGN (DRIBBLE DRIBBLE-FILE) - (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) - 'PAGEFULLFN - 'NILL) - (PRINTOUT NIL "= = = = = Setting up for full-system compilation run on " (DATE) - " = = = = =" T T) - (|for| FILE |in| FILENAMES |as| FILE-NUM |from| 1 - |do| (DSPNEWPAGE (GETSTREAM NIL 'OUTPUT)) - - (* |;;| "changed the destfile so it has the proper extension. It was compiling everything correctly, but naming all the files .lcom.") - - (LET* ((CF (COMPILE-FILE? FILE)) - (SOURCEFILE (FINDFILE FILE NIL SOURCEDIRS)) - (DESTFILE (PACKFILENAME 'BODY FILE 'DIRECTORY DESTDIR 'EXTENSION - (SELECTQ CF - (CL:COMPILE-FILE - 'DFASL) - 'LCOM)))) - (RESETLST - (RESETSAVE (RESETUNDO)) - (PRINTOUT NIL T "- - - " (OR CF 'BCOMPL) - "'ing file " SOURCEFILE " to " DESTFILE " at " (DATE) - " - - -" T) - (PRINTOUT NIL T "(File number " FILE-NUM " of " NUM-FILES ": " - (- NUM-FILES FILE-NUM) - " left)" T T) - (PRINT (SELECTQ CF - ((BCOMPL TCOMPL NIL) - (LISPXUNREAD '(F)) - (CL:FUNCALL (OR CF 'BCOMPL) - SOURCEFILE DESTFILE)) - (CL:FUNCALL CF SOURCEFILE :OUTPUT-FILE DESTFILE)) - T) - (PRINTOUT NIL T T "- - - End of " FILE " compilation - - -" T)) - (AND DELETE-DCOMS? (DELFILE DESTFILE)))) - (PRINTOUT NIL T T T "= = = = = END OF FULL-SYSTEM COMPILATION RUN = = = = =") - (SETQ COMPLETION 'SUCCESS)) - - (* |;;| "cleanup forms") - - (PRINTOUT NIL T "Compilation status: " COMPLETION T T) - (DRIBBLE) - (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) - 'PAGEFULLFN NIL)) - (SEND.FILE.TO.PRINTER DRIBBLE-FILE) - (AND DELETE-DRIBBLE? (DELFILE DRIBBLE-FILE)))) - - - -(* \; -"Function to identify all the source files on a given directory (useful for creating lists of things to compile)" -) - - -(CL:DEFUN FIND-ALL-SOURCE-FILES (DIRECTORY) - - (* |;;| "Return a list of every file that has a compiled equivalent on DIRECTORY. This is a way of finding out what needs to be recompiled for a bulk compile.") - - (LET ((DFASLS (FOR FILENAME IN (DIRECTORY (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY - "*.DFASL;")) - COLLECT (UNPACKFILENAME FILENAME 'NAME))) - (LCOMS (FOR FILENAME IN (DIRECTORY (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY - "*.LCOM;")) - COLLECT (UNPACKFILENAME FILENAME 'NAME)))) - (UNION (INTERSECTION DFASLS DFASLS) - (INTERSECTION LCOMS LCOMS)))) -(DEFINEQ - -(FIND-UNCOMPILED-FILES - (LAMBDA (SRCDIR DESTDIR) (* \; "Edited 16-Nov-94 16:23 by jds") - (LET ((SRCFILES (DIRECTORY (PACKFILENAME 'DIRECTORY SRCDIR 'BODY '*.\;))) - SFILE DFILE) - (|for| FILE |in| SRCFILES |do| (SETQ SFILE (UNPACKFILENAME FILE 'NAME)) - (COND - ((AND (SETQ DFILE (FINDFILE-WITH-EXTENSIONS - SFILE - (LIST DESTDIR) - '(DFASL LCOM))) - (ILESSP (GETFILEINFO DFILE 'ICREATIONDATE) - (GETFILEINFO FILE 'ICREATIONDATE))) - (PRINTOUT T FILE " needs compiling." T)) - ((NOT DFILE) - (PRINTOUT T FILE " has no compiled version." T)) - ))))) -) - - - -(* \; "Misc utility functions from the big Lyric recompiles.") - -(DEFINEQ - -(NEWERDCOMS? (LAMBDA (DIRPAIRS EXTENSIONS FILTER) (* \; "Edited 9-Dec-86 21:39 by bvm") (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}NEWSTRING>SOURCES> {ERIS}SOURCES>) ({ERIS}NEWSTRING>LIBRARY> {ERIS}LIBRARY>) ({ERIS}NEWSTRING>INTERNAL>LIBRARY> {ERIS}INTERNAL>LIBRARY>)))) (OR EXTENSIONS (SETQ EXTENSIONS '(LCOM DCOM))) (|for| PAIR |in| DIRPAIRS |join| (RESETLST (LET ((THISDIR (CAR PAIR)) (OTHERDIR (CADR PAIR)) (THISEXT (CAR EXTENSIONS)) (OTHEREXT (CADR EXTENSIONS)) NEXT DT OTHERFILE OTHERDT OTHERWDT THISAUTHOR DIRPRINTED GEN) (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY THISDIR 'NAME "*" 'EXTENSION THISEXT 'VERSION "") '(ICREATIONDATE) '(RESETLST))) (|while| (SETQ NEXT (\\GENERATENEXTFILE GEN)) |eachtime| (SETQ OTHERWDT NIL) |when| (AND (SETQ OTHERFILE (INFILEP (PACKFILENAME.STRING 'DIRECTORY OTHERDIR 'EXTENSION OTHEREXT 'VERSION NIL 'BODY NEXT))) (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE)) (OR (AND (SETQ OTHERDT (GETFILEINFO OTHERFILE 'ICREATIONDATE)) (< DT OTHERDT)) (AND (SETQ OTHERWDT (GETFILEINFO OTHERFILE 'IWRITEDATE)) (< DT OTHERWDT))) (OR (NULL FILTER) (CL:FUNCALL FILTER NEXT OTHERFILE DT OTHERDT OTHERWDT GEN))) |collect| (|if| (NOT DIRPRINTED) |then| (|printout| T T " " THISDIR 18 "This Date" 38 "Other Date" 58 "Author" T) (SETQ DIRPRINTED T)) (|printout| T (SUBSTRING NEXT (STRPOS THISDIR NEXT 1 NIL T T UPPERCASEARRAY)) 18 (GDATE DT) 38 (GDATE OTHERDT) 58) (|if| OTHERWDT |then| (|printout| T (GDATE OTHERWDT) " ")) (|printout| T (GETFILEINFO OTHERFILE 'AUTHOR) T) (FILENAMEFIELD NEXT 'NAME))))))) - -(NEWERSOURCES? (LAMBDA (DIRPAIRS FILTER) (* \; "Edited 9-Dec-86 23:07 by bvm") (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}NEWSTRING>SOURCES> {ERIS}SOURCES>) ({ERIS}NEWSTRING>LIBRARY> {ERIS}LIBRARY>) ({ERIS}NEWSTRING>INTERNAL>LIBRARY> {ERIS}INTERNAL>LIBRARY>)))) (|for| PAIR |in| DIRPAIRS |do| (RESETLST (LET ((THISDIR (CAR PAIR)) (OTHERDIR (CADR PAIR)) NEXT DT THISFILE THISDT WDT DIRPRINTED GEN) (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY OTHERDIR 'NAME "*" 'VERSION "") '(ICREATIONDATE IWRITEDATE AUTHOR) '(RESETLST))) (|while| (SETQ NEXT (\\GENERATENEXTFILE GEN)) |eachtime| (SETQ THISDT (SETQ WDT (SETQ DT NIL))) |when| (AND (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE)) (OR (NULL (SETQ THISFILE (INFILEP (PACKFILENAME.STRING 'DIRECTORY THISDIR 'EXTENSION COMPILE.EXT 'VERSION NIL 'BODY NEXT)))) (AND (SETQ THISDT (GETFILEINFO THISFILE 'ICREATIONDATE)) (OR (> DT THISDT) (AND (SETQ WDT (\\GENERATEFILEINFO GEN 'IWRITEDATE)) (> WDT THISDT))))) (OR (NULL FILTER) (CL:FUNCALL FILTER NEXT THISFILE DT WDT THISDT GEN))) |do| (|if| (NOT DIRPRINTED) |then| (|printout| T T " " OTHERDIR 18 " Its Date" 38 " Other Date" 58 "Author" T) (SETQ DIRPRINTED T)) (OR (GET (NAMEFIELD NEXT) 'FILEDATES) (PRIN1 "+" T)) (|printout| T (SUBSTRING NEXT (STRPOS OTHERDIR NEXT 1 NIL T T UPPERCASEARRAY )) 18 (GDATE DT) 38 (|if| THISDT |then| (GDATE THISDT) |else| " - - -") 58) (|if| WDT |then| (|printout| T (GDATE WDT) " ")) (|printout| T (\\GENERATEFILEINFO GEN 'AUTHOR) T))))))) - -(SETUP-FOR-RECOMPILE (LAMBDA NIL (* \; "Edited 8-Dec-86 21:23 by jop:") (* \;  "So we don't get alot of warnings") (SETQ *REMOVE-INTERLISP-COMMENTS* NIL) (* \;  "So we don't get asked stupid questions") (SETQ CROSSCOMPILING T) (* \;  "setup up new compiled file version") (PUTPROP ':D4 'CODEREADER (COPYALL (GETPROP 'D1 'CODEREADER))) (RPAQQ CODEINDICATOR :D4) (RPAQQ COMPILE.EXT LCOM) (* \;  "Smash garbage collectable opcodes") (SMASH-OPCODES GARBAGE-OPCODES) (* \; "Setup for unwind recompile") (LOAD '{ERIS}NEWSTRING>SOURCES>UNWINDMACROS 'SYSLOAD) (* \; "may not be necessary") (LOAD '{ERIS}NEWSTRING>SOURCES>PROC 'PROP) (* \; "Setup for new string recompile") (LOAD '{ERIS}NEWSTRING>SOURCES>LLCHAR 'PROP) (REMPROP 'STRINGP 'DOPVAL) (* \; "to get correct record def's") (LOAD '{ERIS}SOURCES>CMLARRAY 'PROP) (* \; "Setup for new stream record") (LOAD '{ERIS}NEWSTRING>SOURCES>FILEIO 'PROP) (* \;  "To setup packagified global type number vars") (LOAD '{ERIS}NEWSTRING>SOURCES>DTDECLARE.DCOM 'SYSLOAD) (* \;  "hack for typep - not needed if makesysdate > Nov 23") (CL:DEFTYPE :DATATYPE (OBJECT) `(DATATYPE ,OBJECT)) (* \; "dribble hack") (WBREAK NIL) (* \; "So the debuuger will compile") (LOAD '{ERIS}SOURCES>XCL-PACKAGE.DCOM) (* \; "To fix the broken FP printer") (LOADFNS '\\CONVERT.FLOATING.NUMBER '{ERIS}SOURCES>LLFLOAT.DCOM))) - -(SMASH-OPCODES (LAMBDA (OPCODE-ALIST) (* \; "Edited 24-Nov-86 17:56 by jop:") (LET (OPNUMBER) (CL:DOLIST (OPCODE OPCODE-ALIST) (SETQ OPNUMBER (CADR OPCODE)) (CL:NSUBSTITUTE-IF (LIST OPNUMBER ':UNUSED) (FUNCTION (CL:LAMBDA (OP) (EQL (CAR OP) OPNUMBER))) \\OPCODES :COUNT 1) (SETQ \\OPCODEARRAY NIL))))) - -(GET-DIRECTORY-LISTING (LAMBDA (DIRECTORY EXTENSION) (* \; "Edited 24-Nov-86 18:14 by jop:") (|for| X |infiles| (DIRECTORY.FILL.PATTERN DIRECTORY (OR EXTENSION "") "") |collect| (FILENAMEFIELD X 'NAME)))) - -(GET-OPEN-FILES (LAMBDA (DEVICE-NAME) (* \; "Edited 25-Nov-86 18:16 by jop:") (FETCH (FDEV OPENFILELST) OF (CDR (ASSOC DEVICE-NAME \\DEVICENAMETODEVICE))))) -) - - - -(* |;;| "Control variables") - - -(RPAQQ FILES-IN-FULL.SYSOUT - (PACKAGE-STARTUP LLPACKAGE LLSYMBOL CMLARRAY CMLLIST CMLMACROS DMISC COMPATIBILITY APUTDQ - LLDISPLAY FONT PASSWORDS LEAF PUP LLETHER PROC ERROR-RUNTIME DEFSTRUCT-RUN-TIME - BOOTSTRAP MISC AINTERRUPT AERROR ABASIC APRINT ATERM MOD44IO VANILLADISK PMAP ADIR AOFD - COREIO IOCHAR LLCODE ATBL DTDECLARE ASTACK LLTIMER LLKEY LLDATATYPE LLSTK LLCHAR LLREAD - LLBIGNUM LLFLOAT LLARITH LLARRAYELT LLMVS LLINTERP LLGC LLBASIC IMAGEIO FILEIO LLNEW - LLBFS LLSUBRS LLFAULT PACKAGE-CONVERSION-TABLE ACODE MACHINEINDEPENDENT POSTLOADUP - DEFPACKAGE-IMPORT XCL-PACKAGE LISP-PACKAGE FASL-PACKAGE COMPILER-PACKAGE BSP DPUPFTP - CMLCHARACTER CMLREADTABLE STACKFNS CMLMVS MACROS MACROAUX CMLSYMBOL CMLHASH CMLDEFFER - CMLPROGV CMLEVAL COMMON CMLSPECIALFORMS CONDITION-HIERARCHY XCLC-RUNTIME CMLTYPES - CL-ERROR AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN - ADVISE LOADFNS DIRECTORY FILEPKG RESOURCE DLAP BYTECOMPILER COMPILE HIST UNDO SPELL - DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST ASKUSER CMLUNDO CMLEXEC DEBUGGER TRACE - CMLDOC CMLPARSE CMLSETF CMLPRED CMLARRAY-OPTIMIZERS CMLREAD CMLWALK CMLSEQCOMMON - CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT CMLSEQ CMLARITH DEFSTRUCT - CMLMISCIO CMLCOMPILE CMLSTRING CLSTREAMS CMLDESTRUCT CMLFORMAT CMLENVIRONMENT CMLPRINT - CMLLOAD CMLFILESYS CMLFLOAT CMLTIME CMLRAND CMLMODULES ADDARITH READ-PRINT-PROFILE - CMLPATHNAME HPRINT MSANALYZE MSPARSE MASTERSCOPE AARITH ADISPLAY HLDISPLAY MENU - WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT - TWODINSPECTOR FREEMENU CMLARRAYINSPECTOR EDITINTERFACE TTYIN DISKDLION DOVEINPUTOUTPUT - DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER LLNS - TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER - ICONW SEDIT-ATOMIC SEDIT-COMMANDS SEDIT-COMMENTS SEDIT-LINEAR SEDIT-LISTS - SEDIT-TERMINAL SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT D-ASSEM-PACKAGE D-ASSEM FASL - XCLC-READER XCLC-ENV-CTXT XCLC-TREES XCLC-TOP-LEVEL XCLC-ALPHA XCLC-ANALYZE - XCLC-META-EVAL XCLC-ANNOTATE XCLC-GENCODE XCLC-PEEPHOLE XCLC-DATABASE XCL-COMPILER - CMLPACKAGE GIVE-AND-TAKE CHATTERMINAL DMCHAT CHAT PUPCHAT NSCHAT PRESS PUPPRINT - TEDITDECLS TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS TEDITFIND - TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION READNUMBER EDITBITMAP IMAGEOBJ - TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS TEDIT HRULE TEDITCHAT GRAPEVINE - MAILCLIENT NSMAIL LAFITEBROWSE LAFITESEND LAFITEMAIL LAFITE TABLEBROWSER FILEBROWSER - REMOTEVMEM VMEM READSYS RDSYS TELERAID GRAPHER SPY AREDIT HASH WHEREIS COPYFILES)) - -(RPAQQ FILES-IN-LIBRARY - (4045XLPDEFAULTPRINTER 4045XLPSTREAM ARCLEANUP AREDIT BROWSER BSEARCH CENTRONICS - CHARCODETABLES CHAT CHATDECLS CHATTERMINAL CLMAIL CML CMLARRAYINSPECTOR CMLDEBUGGER - CMLFLOATARRAY CMLHELP COLOR COLORDEMO CONDITIONGRAPH COPYFILES DANDELIONKEYBOARDS - DATABASEFNS DAYBREAKKEYBOARDS DEDIT DES DICOLOR DINFO DLRS232C DLTTY DMCHAT DO-TEST - DORADOCOLOR DORADOKEYBOARDS DOVEKEYBOARDS DOVERS232C DSKTEST EDITBITMAP ETHERRECORDS - FASTFX80STREAM FILEBROWSER FILECACHE FILECACHE-BROWSER FILECACHE-DECLS FILECACHE-HOSTUP - FILECACHE-SCAVENGE FILENAMES FONTSAMPLE FTPSERVER FX80STREAM FXPRINTER GCHAX - GIVE-AND-TAKE GRAPEVINE GRAPHER GRAPHZOOM HASH HELPSYS HRULE IMAGEOBJ KERMIT KERMITMENU - KEYBOARDEDITOR LAFITE LAFITEBROWSE LAFITEDECLS LAFITEFIND LAFITEMAIL LAFITESEND - LAMBDATRAN LISPDIAGNOSTICS LLCOLOR MACROTEST MACROTESTAUX MAILCLIENT MAILSCAVENGE - MAINTAIN MATMULT MERGE-FILEGEN MESATYPES MINISERVE MSHASH NEWDEBUG NSCHAT NSCHATSERVER - NSMAIL NSMAINTAIN NSTOASCIIDISPLAYFONT PCALLSTATS PCE PCEDISPLAY PCEERD PCEFLOPPY - PCEKEYBOARD PCEWINDOW PCMEMTEST PIXELBLT PUPCHAT PUPIDSERVER RDSYS READAIS READNUMBER - READSYS REMOTEVMEM RS232CHAT RS232CHATSERVER RS232CMENU SAMEDIR SCALEBITMAP SFFONT - SIMPLIFY SKETCHCOLOR SKETCHSTREAM SPY SYSEDIT TABLEBROWSER TABLEBROWSERDECLS TCP - TCPCHAT TCPCONFIG TCPDEBUG TCPFTP TCPHTE TCPLLAR TCPLLICMP TCPLLIP TCPNAMES TCPTFTP - TCPUDP TEDIT TEDITABBREV TEDITCHAT TEDITCOLOR TEDITCOMMAND TEDITDECLS TEDITFILE - TEDITFIND TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITKEY TEDITLOOKS TEDITMENU TEDITPAGE - TEDITPAGINATE |TEditPartOne| |TEditPartTwo| TEDITSCREEN TEDITSELECTION TEDITWINDOW - TEK4010 TEK4010CHAT TELERAID TEXEC TEXTOFD TFBRAVO TTYCHAT TWODINSPECTOR - VIRTUALKEYBOARDS VMEM VPCDISK VT100KP VTCHAT WHEREIS 4045STREAM BUSCOLOR BUSEXTENDER - BUSMASTER BUSMASTERARRAYBASE BUSTEST C150STREAM COLORNNCC COLOROBJ COLORPOLYGONS - DANDELIONUFO DANDELIONUFO4096 IRISCONSTANTS IRISIO IRISLIB IRISNET IRISSTREAM LOADIRIS)) - -(RPAQQ FILES-IN-LISP.SYSOUT - (PACKAGE-STARTUP LLPACKAGE LLSYMBOL CMLARRAY CMLLIST CMLMACROS DMISC COMPATIBILITY APUTDQ - LLDISPLAY FONT PASSWORDS LEAF PUP LLETHER PROC ERROR-RUNTIME DEFSTRUCT-RUN-TIME - BOOTSTRAP MISC AINTERRUPT AERROR ABASIC APRINT ATERM MOD44IO VANILLADISK PMAP ADIR AOFD - COREIO IOCHAR LLCODE ATBL DTDECLARE ASTACK LLTIMER LLKEY LLDATATYPE LLSTK LLCHAR LLREAD - LLBIGNUM LLFLOAT LLARITH LLARRAYELT LLMVS LLINTERP LLGC LLBASIC IMAGEIO FILEIO LLNEW - LLBFS LLSUBRS LLFAULT PACKAGE-CONVERSION-TABLE ACODE MACHINEINDEPENDENT POSTLOADUP - DEFPACKAGE-IMPORT XCL-PACKAGE LISP-PACKAGE FASL-PACKAGE COMPILER-PACKAGE BSP DPUPFTP - CMLCHARACTER CMLREADTABLE STACKFNS CMLMVS MACROS MACROAUX CMLSYMBOL CMLHASH CMLDEFFER - CMLPROGV CMLEVAL COMMON CMLSPECIALFORMS CONDITION-HIERARCHY CONDITION-HIERARCHY-SI - CONDITION-HIERARCHY-POST-SI CONDITION-HIERARCHY-IL XCLC-RUNTIME CMLTYPES CL-ERROR AFONT - EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN ADVISE LOADFNS - DIRECTORY FILEPKG RESOURCE DLAP BYTECOMPILER COMPILE HIST UNDO SPELL DWIM WTFIX CLISP - DWIMIFY CLISPIFY RECORD ASSIST ASKUSER CMLUNDO CMLEXEC DEBUGGER TRACE CMLDOC CMLPARSE - CMLSETF CMLPRED CMLARRAY-OPTIMIZERS CMLREAD CMLWALK CMLSEQCOMMON CMLSEQBASICS - CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT CMLSEQ CMLARITH DEFSTRUCT CMLMISCIO - CMLCOMPILE CMLSTRING CLSTREAMS CMLDESTRUCT CMLFORMAT CMLENVIRONMENT CMLPRINT CMLLOAD - CMLFILESYS CMLFLOAT CMLTIME CMLRAND CMLMODULES ADDARITH READ-PRINT-PROFILE CMLPATHNAME - HPRINT MSANALYZE MSPARSE MASTERSCOPE AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ - WINDOWSCROLL WINDOW WINDOWICON ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT TWODINSPECTOR - FREEMENU CMLARRAYINSPECTOR EDITINTERFACE TTYIN DISKDLION DOVEINPUTOUTPUT DOVEDISK - DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER LLNS TRSERVER - SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER ICONW - SEDIT-ATOMIC SEDIT-COMMANDS SEDIT-COMMENTS SEDIT-LINEAR SEDIT-LISTS SEDIT-TERMINAL - SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT D-ASSEM-PACKAGE D-ASSEM FASL XCLC-READER - XCLC-ENV-CTXT XCLC-TREES XCLC-TOP-LEVEL XCLC-ALPHA XCLC-ANALYZE XCLC-META-EVAL - XCLC-ANNOTATE XCLC-GENCODE XCLC-PEEPHOLE XCLC-DATABASE XCL-COMPILER CMLPACKAGE)) - -(RPAQQ FILES-IN-SOURCES - (ADVISE AFONT BREAK-AND-TRACE CL-ERROR CLOSURE-CACHE CMLDEFFER CMLENVIRONMENT CMLPACKAGE - CMLSETF CMLSMARTARGS CMLUNDO DEBUGGER DEFSTRUCT DESCRIBE ERROR-RUNTIME-AFTER-FASL - FASDUMP HPRINT IMPLICIT-KEY-HASH SEDIT-ACCESS SEDIT-ATOMIC SEDIT-BASE SEDIT-COMMANDS - SEDIT-COMMENTS SEDIT-EXPORTS SEDIT-INDENT SEDIT-LINEAR SEDIT-LIST-FORMATS SEDIT-LISTS - SEDIT-TERMINAL SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT WALKER XCL-EXTRAS XCLC-DATABASE - XCLC-OPTIMIZERS XCLC-TOP-LEVEL XCLC-TREES 10MBDRIVER AARITH ABASIC ACODE ADDARITH ADIR - ADISPLAY AERROR AINTERRUPT AOFD APRINT APUTDQ ARGLIST ASKUSER ASTACK ATBL ATERM - ATTACHEDWINDOW AUTHENTICATION NSFILING BOOTSTRAP BSP BYTECOMPILER CLEARINGHOUSE CLISP - CLISPIFY CLSTREAMS CMLARITH CMLARRAY-SUPPORT CMLARRAY CMLARRAYINSPECTOR CMLCHARACTER - CMLCOMPILE CMLDESTRUCT CMLDOC CMLEVAL CMLEXEC CMLFILESYS CMLFLOAT CMLFORMAT CMLHASH - CMLLIST CMLLOAD CMLMACROS CMLMISCIO CMLMODULES CMLMVS CMLPARSE CMLPATHNAME CMLPRED - CMLPRINT CMLPROGV CMLRAND CMLREAD CMLREADTABLE CMLSEQ CMLSEQBASICS CMLSEQCOMMON - CMLSEQFINDER CMLSEQMAPPERS CMLSEQMODIFY CMLSORT CMLSPECIALFORMS CMLSTEP CMLSTRING - CMLSYMBOL CMLTIME CMLTYPES COMMON COMPARE COMPATIBILITY COMPILE COMPILER-PACKAGE - CONDITION-HIERARCHY-IL CONDITION-HIERARCHY-POST-SI CONDITION-HIERARCHY-SI - CONDITION-HIERARCHY CONDITION-PACKAGE COREIO COROUTINE COURIER D-ASSEM-PACKAGE D-ASSEM - DEBUGEDIT DEFFER-RUNTIME DEFPACKAGE-IMPORT DEFSTRUCT-RUN-TIME DEXEC DIRECTORY DISKDLION - DLAP DLFIXINIT DMISC DOVEDISK DOVEDISPLAY DOVEETHER DOVEFLOPPY DOVEINPUTOUTPUT DOVEMISC - DPUPFTP DSKDISPLAY DSPRINTDEF DTDECLARE DWIM DWIMIFY EDIT EDITINTERFACE ERROR-RUNTIME - EXEC-COMMANDS FASL-PACKAGE FASLOAD FILEIO FILEPKG FLOPPY FONT FONTPROFILE FREEMENU - GAINSPACE HARDCOPY HIST HLDISPLAY ICONW IDLER IL-ERROR-STUFF IMAGEIO INSPECT-CLOSURE - INSPECT INTERPRESS IOCHAR LEAF LISP-PACKAGE CMLWALK DEBUGGER-EVAL DOVEVMEMSIZEPATCH - SEDIT-CONVERT SEDIT-DEBUG SEDIT-LOAD LLARITH LLARRAYELT LLBASIC LLBFS LLBIGNUM LLCHAR - LLCODE LLDATATYPE LLDISPLAY LLERROR LLETHER LLFAULT LLFLOAT LLGC LLINTERP LLKEY LLMVS - LLNEW LLNS LLPACKAGE LLREAD LLRESTART LLSTK LLSUBRS LLSYMBOL LLTIMER LOADFNS LOCALFILE - LOGOW LYRIC-PATCH-1 MACHINEINDEPENDENT MACROAUX MACROS MAKEINIT MEM MENU MISC MOD44IO - NEWPRINTDEF NSPRINT PACKAGE-CONVERSION-TABLE PACKAGE-STARTUP PAINTW PASSWORDS PMAP - POSTLOADUP PRETTY PRINTFN PROC PROFILE PUP READ-PRINT-PROFILE RECORD RENAMEFNS RESOURCE - SETF-RUNTIME SPELL SPELLFILE SPP STACKFNS SYSPRETTY TIME TRSERVER TTYIN TWODINSPECTOR - UNDO UNWINDMACROS VANILLADISK WEDIT WINDOW WINDOWICON WINDOWOBJ WINDOWSCROLL WRAPPERS - WTFIX XCL-COMPILER XCL-PACKAGE XCLC-ALPHA XCLC-ANALYZE XCLC-ANNOTATE XCLC-ENV-CTXT - XCLC-GENCODE XCLC-META-EVAL XCLC-PEEPHOLE XCLC-RUNTIME XCLC-TRANSFORMS XXFILL XXGEOM)) - -(RPAQQ FORKED-FILES (ABC APUTDQ ASTACK CMLEVAL CMLMVS DEFPACKAGE-IMPORT DLAP DTDECLARE DWIMIFY - FILEIO FILESETS LLBASIC LLCHAR LLCODE LLDATATYPE LLINTERP LLNEW LLSTK - MACHINEINDEPENDENT MACROS MISC PACKAGE-STARTUP PROC UNWINDMACROS - XCL-PACKAGE)) - -(RPAQQ GARBAGE-OPCODES - ((BOUT 33) - (DOCOLLECT 36) - (ENDCOLLECT 37) - (GETP 27) - (GETHASH 29) - (ELT 40) - (NTHCHC 41) - (SETA 42) - (RPLCHARCODE 43) - (EVALV 45) - (ATOMNUMBER 112) - (GETBASEFIXP.N 203) - (PUTBASEFIXP.N 204))) - - - -(* \; "Utilities for making mass-scale fixups to a library of files.") - -(DEFINEQ - -(FIX-FILES (CL:LAMBDA (FILENAMES SOURCEDIR DESTDIR &OPTIONAL (DRIBBLE-FILE '{DSK6}BIGCOMP.DRIBBLE) DELETE-DRIBBLE? RECORDS-TO-FIX) (* \; "Edited 15-Aug-90 12:02 by jds") (* |;;| "Make large-scale fix-ups to a bunch of files.") (CL:BLOCK FIX-FILES (LET ((COMPLETION 'ERROR) (NUM-FILES (LENGTH FILENAMES))) (IDLE.SET.OPTION 'TIMEOUT T) (SETQ NOSPELLFLG T) (SETQ DWIMIFYCOMPFLG NIL) (CL:UNWIND-PROTECT (PROGN (DRIBBLE DRIBBLE-FILE) (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) 'PAGEFULLFN 'NILL) (CNDIR DESTDIR) (PRINTOUT NIL "= = = = = Setting up for large-scale fix-up run on " (DATE) " = = = = =" T T) (|for| FILE |in| FILENAMES |as| FILE-NUM |from| 1 |do| (DSPNEWPAGE (GETSTREAM NIL 'OUTPUT)) (LET* ((SOURCEFILE (PACKFILENAME 'BODY FILE 'DIRECTORY SOURCEDIR)) (DESTFILE (PACKFILENAME 'BODY FILE 'DIRECTORY DESTDIR))) (RESETLST (PRINTOUT NIL T "Fixing file " SOURCEFILE " at " (DATE) " - - -" T) (PRINTOUT NIL T "(File number " FILE-NUM " of " NUM-FILES ": " (- NUM-FILES FILE-NUM) " left)" T T) (PRINT (FIX-FILE FILE RECORDS-TO-FIX) T) (PRINTOUT NIL T T "- - - End of " FILE " fix-up - - -" T)))) (PRINTOUT NIL T T T "= = = = = END OF CLEANUP RUN = = = = =") (SETQ COMPLETION 'SUCCESS)) (PRINTOUT NIL T "Fix-up status: " COMPLETION T T) (DRIBBLE) (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) 'PAGEFULLFN NIL)) (SEND.FILE.TO.PRINTER DRIBBLE-FILE) (AND DELETE-DRIBBLE? (DELFILE DRIBBLE-FILE)))))) - -(FIX-FILE (LAMBDA (FILE RECORD-NAMES MAKEFILE-ONLY?) (* \; "Edited 21-Jan-93 16:30 by jds") (* |;;| "Perform cleanup tasks on FILE.") (LOAD FILE 'PROP) (LOADCOMP FILE 'PROP) (* |;;| "(FIX-COPYRIGHT FILE)") (AND (FILEFNSLST FILE) (|for| RECNAME |in| (APPEND (FILECOMSLST FILE 'RECORDS) RECORD-NAMES) |do| (QUALIFY-FIELDS RECNAME FILE)) ) (MARKASCHANGED FILE 'FILES) (COND (MAKEFILE-ONLY? (MAKEFILE FILE)) (T (APPLY* 'CLEANUP FILE))))) - -(FIX-COPYRIGHT (LAMBDA (FILENAME) (LET ((CR (GETPROP FILENAME 'COPYRIGHT))) (COND (CR (RPLACA CR "Venue & Xerox Corporation")) (T (PUTPROP FILENAME 'COPYRIGHT (LIST "Venue" 1990))))))) - -(FIX-FILE-COPYRIGHT (LAMBDA (FILE) (LOADFROM FILE NIL 'PROP) (FIX-COPYRIGHT FILE) (MARKASCHANGED FILE 'FILES) (APPLY* 'CLEANUP FILE))) - -(QUALIFY-FIELDS (LAMBDA (RECNAME FILE) (* \; "Edited 28-Sep-87 14:41 by bvm:") (APPLY* 'EDITFNS FILE `(LPQ F ((*ANY* FETCH |fetch| REPLACE |replace| FFETCH |ffetch| FREPLACE |freplace| /REPLACE |/replace|) (*ANY* ,@(APPEND (RECORDFIELDNAMES RECNAME))) --) 2 (MBD ,RECNAME) 0 P)))) - -(FIX-TEDIT (LAMBDA (FILE) (* \; "Edited 17-Aug-90 16:07 by jds") (LET ((STRM (OPENTEXTSTREAM (MKATOM FILE)))) (TEDIT.SUBLOOKS STRM '(FAMILY OPTIMA) '(FAMILY CLASSIC)) (TEDIT.PUT STRM FILE) (CLOSEF STRM)))) - -(FIX-DOCS (LAMBDA (DIRECTORY) (LET ((FILES (|for| FILE |in| (DIRECTORY (CONCAT DIRECTORY "*.TEDIT;")) |collect| (PACKFILENAME.STRING 'VERSION NIL 'BODY FILE)))) (|for| FILE |in| FILES |do| (FIX-TEDIT FILE))))) -) - - - -(* |;;| -"Removes bogus (CLISP ) translations that result from CLISPARRAY being NIL." -) - -(DEFINEQ - -(CLFIX - (LAMBDA (FILE) (* \; "Edited 9-Sep-94 11:57 by jds") - (APPLY* 'EDITFNS FILE '(LPQ F CLISP\ 1 D D 0 P)))) -) - -(PUTPROPS MULTI-COMPILE FILETYPE CL:COMPILE-FILE) -(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA FIX-FILES) -) -(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (7131 8389 (FIND-UNCOMPILED-FILES 7141 . 8387)) (8461 19787 (NEWERDCOMS? 8471 . 12445) ( -NEWERSOURCES? 12447 . 16359) (SETUP-FOR-RECOMPILE 16361 . 18749) (SMASH-OPCODES 18751 . 19269) ( -GET-DIRECTORY-LISTING 19271 . 19568) (GET-OPEN-FILES 19570 . 19785)) (31690 36610 (FIX-FILES 31700 . -34497) (FIX-FILE 34499 . 35090) (FIX-COPYRIGHT 35092 . 35319) (FIX-FILE-COPYRIGHT 35321 . 35481) ( -QUALIFY-FIELDS 35483 . 36022) (FIX-TEDIT 36024 . 36330) (FIX-DOCS 36332 . 36608)) (36735 36917 (CLFIX -36745 . 36915))))) -STOP diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ deleted file mode 100644 index d0591915..00000000 --- a/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ +++ /dev/null @@ -1,920 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "23-Jun-88 16:06:34" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;6 46489 - - |changes| |to:| (VARS MAIKO-GC-TESTSCOMS) - (FNS MAIN-GC-TEST ARRAY-STRING-TEST VARIOUS-TYPES-TEST LIST-MANIPULATION-TEST - CODE-RECLAIM-TEST) - - |previous| |date:| "27-May-88 14:59:01" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;5) - - -; Copyright (c) 1988 by John Sybalsky & Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT MAIKO-GC-TESTSCOMS) - -(RPAQQ MAIKO-GC-TESTSCOMS - ((FILES DANCEROBJ GCHAX) - (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" - "{ERIS}XEROXPRIVATE>FONTS>") - (INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" - "{ERIS}XEROXPRIVATE>FONTS>")) - (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))) - (FNS MAIN-GC-TEST) - (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS - ARRAY-STRING-TEST VARIOUS-TYPES-TEST) - (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST) - (FNS ATOM-FULL-TEST STORAGE-FULL-TEST) - (COMS (FNS DATATYPE-TEST) - (RECORDS GC-TEST-TYPE) - - (* |;;| "DATATYPE TESTS") -) - (COMS - - (* |;;| "CODE RECLAIMATION TESTS") - - (FNS CODE-RECLAIM-TEST) - - (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.") - - (VARS (CODE-RECLAIM-TEST-TEMP-FN - '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN - (ASDF) - (LET (I) - (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (CL:FLET ((TEMP (ARG) - (SETQ ARG (FLOAT ARG)) - (EXPT (SQRT I) - (SQRT (COS (/ I 180)))))) - (CL:UNWIND-PROTECT - (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) - (SETQ I NIL))))))))))) - -(FILESLOAD DANCEROBJ GCHAX) - -(ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") - -(ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" - "{ERIS}XEROXPRIVATE>FONTS>") - -(SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)) -(DEFINEQ - -(MAIN-GC-TEST - (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT - CODE-COUNT) (* \; "Edited 23-Jun-88 13:30 by jds") - (DRIBBLE (OR DRIBBLE-FILE "{LPT}")) - (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE) - T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}") - T T) - (|for| I |from| 1 |to| (OR LIMIT 10) |do| (PRINTOUT T - "Starting Maiko GC tests, pass " - I T) - (ITEMS-ON-STACK-TEST (OR STACK-COUNT - 100)) - (MANY-BIGNUM-MAKER (OR BIGNUM-COUNT - 1000)) - (MANY-FIXP-MAKER (OR FIXP-COUNT 1000)) - (MANY-FLOAT-MAKER (OR FLOAT-COUNT 1000 - )) - (TEDIT-CRUNCH-TEST (OR TEDIT-COUNT 5)) - (ARRAY-STRING-TEST 3) - (LIST-MANIPULATION-TEST (OR LIST-COUNT - 5)) - (BOUNDARY-TESTS) - (CODE-RECLAIM-TEST (OR CODE-COUNT 20)) - (VARIOUS-TYPES-TEST (OR TYPE-COUNT 10) - ) - (FRPTQ 100 (RECLAIM)) - (STORAGE)) - (ATOM-FULL-TEST) - (STORAGE-FULL-TEST) - (DRIBBLE NIL))) -) -(DEFINEQ - -(ITEMS-ON-STACK-TEST - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:56 by jds") - (PRINTOUT T " Starting ITEMS-ON-STACK test for " LIMIT " iterations." T) - (FOR I FROM 1 TO LIMIT DO (LET ((X (CREATE CHARLOOKS)) - (Y (EXPT 1234.5 (RAND 3 7)))) - (ERSETQ (FRPTQ 5 (RECLAIM)) - (COND - ((\\ISONFREELIST X) - (HELP - "X is free, but pointer is on stack." - )) - ((\\ISONFREELIST Y) - (HELP - "Y is free, but pointer is on stack." - )))))))) - -(MANY-BIGNUM-MAKER - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") - (PRINTOUT T " Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T) - (LET (X Y Z W) - (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 12345678901234567890 - (RAND 1 I))) - (SETQ Y (IQUOTIENT X 3)) - (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) - (IREMAINDER Y 3) - (CL:FLOOR Y 2) - (CL:CEILING X 8))) - (SETQ W (/ Z Y)))))) - -(MANY-FIXP-MAKER - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") - (PRINTOUT T " Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T) - (LET (X Y Z W) - (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 543 (RAND 1 I))) - (SETQ Y (IQUOTIENT X 3)) - (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) - (IREMAINDER Y 3) - (CL:FLOOR Y 2) - (CL:CEILING X 8))) - (SETQ W (/ Z Y)))))) - -(MANY-FLOAT-MAKER - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:55 by jds") - (PRINTOUT T " Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T) - (LET (X Y Z W) - (FOR I FROM 1 TO LIMIT DO (SETQ X (FTIMES 1.0 (RAND 0 1))) - (SETQ Y (+ (SQRT I) - (EXPT (SQRT (SQRT I)) - 3.4))) - (SETQ Z (LOG Y)))))) - -(BOUNDARY-TESTS - (LAMBDA NIL (* \; "Edited 26-May-88 11:54 by jds") - - (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.") - - (PRINTOUT T " Starting Refcnt-63 crossing test" T) - (LET* ((ITEM (|create| FMTSPEC)) - (LIST (|for| I |from| 1 |to| 62 |collect| ITEM))) - (|for| I |from| 1 |to| 1000 |do| (|for| J |from| (LENGTH LIST) - |to| (+ 63 (RAND 1 10)) - |do| (SETQ LIST (CONS ITEM LIST))) - (|for| J |from| (LENGTH LIST) - |to| (- 63 (RAND 3 12)) - |do| (|pop| LIST)) - (COND - ((ZEROP (IMOD I 31)) - (RECLAIM)))) - (PRINTOUT T " Starting Refcount-500K <-> NIL test." T) - (|for| LOOP |from| 1 |to| 10 |do| (|for| I |from| 1 |to| 500000 - |do| (SETQ LIST (CONS ITEM LIST))) - (SETQ LIST NIL)) - (PRINTOUT T " Starting Refcount 1-2 boundary test." T) - (LET ((ITEM (LIST (|create| FMTSPEC)))) - (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (CAR ITEM)) - (SETQ ITEM2 NIL))) - (PRINTOUT T " Starting Refcount 1 + stack boundary test." T) - (LET ((ITEM (|create| FMTSPEC)) - ITEM2) - (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (LIST ITEM)) - (RPLACA ITEM2 NIL))) - (PRINTOUT T " Starting Refcount 0-1 boundary test." T) - (LET (ITEM) - (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM (LIST (|create| - FMTSPEC))) - (RPLACA ITEM NIL)))))) - -(ARRAY-STRING-TEST - (LAMBDA (LIMIT REAL-STRESS) (* \; "Edited 23-Jun-88 12:23 by jds") - - (* |;;| "Try out array & string creation, and substringing on the GC.") - - (PRINTOUT T " Starting Array & String test." T) - (FOR I FROM 1 TO (OR LIMIT 10) - DO (LET (STRINGS ARRAYS) - (FOR ARRAY-COUNT FROM 1 TO 5000 - COLLECT (CL:MAKE-ARRAY (RAND 10 (COND - (REAL-STRESS 65000) - (T (IMAX 100 (IQUOTIENT 65000 - ARRAY-COUNT))))))) - (FOR I FROM 1 TO 5000 COLLECT (BITMAPCREATE (RAND 1 512) - (RAND 1 512))) - (SETQ STRINGS (FOR STRING-COUNT FROM 1 TO 5000 - COLLECT (ALLOCSTRING (RAND 10 - (COND - (REAL-STRESS 65000) - (T (IMAX 100 (IQUOTIENT 65000 - STRING-COUNT - )))))))) - (FOR STRING IN STRINGS - COLLECT (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING) - 1)) - (RAND (ADD1 (LRSH (NCHARS STRING) - 1)) - (NCHARS STRING)))))))) - -(VARIOUS-TYPES-TEST - (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 12:04 by jds") - - (* |;;| - "Run thru creation and collection of various types that have caused trouble in the past. ") - - (PRINTOUT T " Starting various type cases." T) - (FOR REPEAT-COUNT FROM 1 TO (OR LIMIT 10) - DO (|for| TYPE IN '(VMEMPAGEP) AS CREATION-LIMIT IN '(100) - |do| (FOR I FROM 1 TO CREATION-LIMIT COLLECT (NCREATE TYPE)) - (DORECLAIM))))) -) -(DEFINEQ - -(TEDIT-CRUNCH-TEST - (LAMBDA (LIMIT) (* \; "Edited 27-May-88 13:06 by jds") - - (* |;;| "GC Testing -- stressing the world.") - - (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.") - - (PRINTOUT T " Starting TEDIT-CRUNCH test for " LIMIT " iterations." T) - (FOR PASS FROM 1 TO LIMIT DO (PRINTOUT T " Round " PASS " started " (DATE) - "." T) - (LET ((TS (OPENTEXTSTREAM - ' - |{ERIS}GC>Hand-Aux>ADVDICT-N-Z.TEDIT| - )) - TLIST) - (TEDIT.HARDCOPY TS '{CORE}FOO.IP T) - (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP) - (DELFILE '{DSK}FOO.IP) - (DELFILE '{CORE}FOO.IP) - (CLOSEF (FETCH (TEXTOBJ TXTFILE) - OF (TEXTOBJ TS))))))) - -(LIST-MANIPULATION-TEST - (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 14:03 by jds") - - (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.") - - (PRINTOUT T " Starting LIST-MANIPULATION test for " LIMIT " iterations." T) - (|for| PASS |from| 1 |to| LIMIT - |do| (PRINTOUT T " Round " PASS " started " (DATE) - "." T) - (LET ((TS (OPENTEXTSTREAM '|{ERIS}Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|)) - (LEN (RAND 0 100000)) - TLIST) - (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| TS)) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH LEN 1))) - |do| (|pop| TLIST)) - (|for| I |from| 1 |to| (RAND 1 100) |do| (SETQ TLIST - (CONS TS TLIST))) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) - 1))) - |do| (|pop| TLIST)) - (|for| I |from| 1 |to| (RAND 1 2000) |do| (SETQ TLIST - (CONS TS TLIST))) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) - 1))) - |do| (|pop| TLIST)) - (|for| \i |from| 1 |to| (RAND 1 1500) - |do| (SETQ TLIST (NCONC TLIST - (|for| J |from| 1 - |to| (RAND 1 10) - |join| (|for| K |from| 1 |to| - 3 - |collect| (CONS TS K)))))) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) - 1))) - |do| (|pop| TLIST)) - (CLOSEF (|fetch| (TEXTOBJ TXTFILE) |of| (TEXTOBJ TS)))) - (LET ((GC-ITEM (NCREATE 'VMEMPAGEP)) - (LEN (RAND 10 500)) - TLIST ELT) - (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| NIL)) - (|for| I |from| 1 |to| LEN |do| (SETQ ELT (CL:RANDOM LEN)) - (RPLACA (CL:NTHCDR ELT TLIST) - GC-ITEM) - (RPLACA (CL:NTHCDR (SUB1 I) - TLIST) - GC-ITEM)) - (|for| I |from| (SUB1 LEN) |to| 0 |by| -1 - |do| (RPLACD (CL:NTHCDR I TLIST) - GC-ITEM)))))) -) -(DEFINEQ - -(ATOM-FULL-TEST - (LAMBDA NIL (* \; "Edited 26-May-88 11:39 by jds") - (PRINTOUT T " Starting ATOM-space full test.") - (LET ((CUR-ATOM-COUNT |\\AtomFrLst|)) - (CL:UNWIND-PROTECT - (PROGN (SETQ |\\AtomFrLst| 64000) - (FOR I FROM 64000 TO 70000 DO (GENSYM 'GC-TEST))) - (SETQ |\\AtomFrLst| CUR-ATOM-COUNT))))) - -(STORAGE-FULL-TEST - (LAMBDA NIL (* \; "Edited 26-May-88 11:47 by jds") - (PRINTOUT T " Starting Storage-full test." T) - (ERSETQ (FOR I FROM 1 COLLECT (ARRAY 100))))) -) -(DEFINEQ - -(DATATYPE-TEST - (LAMBDA (LIMIT) (* \; "Edited 26-May-88 11:26 by jds") - (FOR I FROM 1 TO (OR LIMIT 10) - DO (FOR L FROM 1 TO 100 DO (FOR Y FROM 1 TO 20 - COLLECT (CREATE GC-TEST-TYPE - FIELD-1 _ T)) - (RECLAIM))))) -) -(DECLARE\: EVAL@COMPILE - -(DATATYPE GC-TEST-TYPE (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE) - (FIELD-5 FIXP) - FIELD-6 - (FIELD-7 WORD) - FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14 - FIXP) - FIELD-15 - (FIELD-16 XPOINTER) - FIELD-17 - (FIELD-18 BYTE) - (FIELD-19 FIXP) - FIELD-20 - (FIELD-21 BYTE) - FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE) - FIELD-26 - (FIELD-27 BYTE) - FIELD-28 - (FIELD-29 BYTE) - FIELD-30 - (FIELD-31 WORD) - FIELD-32 - (FIELD-33 XPOINTER) - FIELD-34 - (FIELD-35 FIXP) - FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG) - FIELD-40 - (FIELD-41 FLAG) - FIELD-42 - (FIELD-43 FIXP) - (FIELD-44 FIXP) - FIELD-45 - (FIELD-46 XPOINTER) - FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG) - (FIELD-51 BYTE) - FIELD-52 FIELD-53 (FIELD-54 BYTE) - FIELD-55 FIELD-56 (FIELD-57 BYTE) - (FIELD-58 WORD) - FIELD-59 FIELD-60 (FIELD-61 XPOINTER) - FIELD-62 FIELD-63 (FIELD-64 XPOINTER) - (FIELD-65 XPOINTER) - FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG) - FIELD-71 FIELD-72 (FIELD-73 WORD) - FIELD-74 - (FIELD-75 FLAG) - FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP) - (FIELD-81 FIXP) - FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER) - (FIELD-87 BYTE) - (FIELD-88 XPOINTER) - FIELD-89 - (FIELD-90 BYTE) - (FIELD-91 FLAG) - (FIELD-92 FIXP) - (FIELD-93 FIXP) - (FIELD-94 FLAG) - FIELD-95 - (FIELD-96 FLAG) - FIELD-97 - (FIELD-98 FLAG) - FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 - XPOINTER) - FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE) - FIELD-110 - (FIELD-111 WORD) - FIELD-112 - (FIELD-113 XPOINTER) - (FIELD-114 FLAG) - (FIELD-115 FIXP) - FIELD-116 FIELD-117 (FIELD-118 BYTE) - FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 - XPOINTER) - (FIELD-125 BYTE) - (FIELD-126 XPOINTER) - FIELD-127 FIELD-128 (FIELD-129 FIXP) - (FIELD-130 FLAG) - FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD) - (FIELD-136 FLAG) - FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD) - (FIELD-141 FLAG) - FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP) - FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG) - FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP) - FIELD-156 - (FIELD-157 BYTE) - FIELD-158 - (FIELD-159 FIXP) - (FIELD-160 WORD) - FIELD-161 - (FIELD-162 WORD) - (FIELD-163 FIXP) - FIELD-164 - (FIELD-165 FIXP) - FIELD-166 - (FIELD-167 FLAG) - (FIELD-168 BYTE) - FIELD-169 FIELD-170 (FIELD-171 XPOINTER) - (FIELD-172 BYTE) - FIELD-173 FIELD-174 (FIELD-175 FLAG) - (FIELD-176 BYTE) - (FIELD-177 WORD) - FIELD-178 - (FIELD-179 FIXP) - FIELD-180 FIELD-181 (FIELD-182 BYTE) - FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE) - (FIELD-189 FIXP) - FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE) - FIELD-194 - (FIELD-195 WORD) - FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD) - FIELD-201 - (FIELD-202 FLAG) - FIELD-203 - (FIELD-204 XPOINTER) - FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG) - FIELD-209 - (FIELD-210 WORD) - (FIELD-211 BYTE) - FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP) - FIELD-216 FIELD-217 (FIELD-218 XPOINTER) - FIELD-219 - (FIELD-220 FLAG) - FIELD-221 - (FIELD-222 FLAG) - (FIELD-223 WORD) - (FIELD-224 FLAG) - (FIELD-225 WORD) - FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 - XPOINTER) - FIELD-232 - (FIELD-233 WORD) - (FIELD-234 WORD) - FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 - FIELD-241 (FIELD-242 XPOINTER) - FIELD-243 - (FIELD-244 WORD) - FIELD-245 FIELD-246 (FIELD-247 XPOINTER) - FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 - FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER) - FIELD-259 - (FIELD-260 FIXP) - FIELD-261 FIELD-262 (FIELD-263 XPOINTER) - FIELD-264 - (FIELD-265 WORD) - (FIELD-266 FLAG) - FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE) - FIELD-273 FIELD-274 (FIELD-275 FLAG) - (FIELD-276 BYTE) - FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER) - (FIELD-281 WORD) - (FIELD-282 WORD) - FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD) - FIELD-287 - (FIELD-288 XPOINTER) - (FIELD-289 BYTE) - FIELD-290 - (FIELD-291 XPOINTER) - (FIELD-292 FLAG) - FIELD-293 FIELD-294 (FIELD-295 FLAG) - FIELD-296 FIELD-297 (FIELD-298 XPOINTER) - (FIELD-299 FIXP) - (FIELD-300 FIXP) - (FIELD-301 BYTE) - FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP) - FIELD-307 - (FIELD-308 FLAG) - (FIELD-309 FIXP) - FIELD-310 - (FIELD-311 XPOINTER) - FIELD-312 FIELD-313 (FIELD-314 BYTE) - FIELD-315 - (FIELD-316 WORD) - (FIELD-317 FIXP) - FIELD-318 - (FIELD-319 FLAG) - FIELD-320 - (FIELD-321 WORD))) -) - -(/DECLAREDATATYPE 'GC-TEST-TYPE - '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER - POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER - BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER - POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER - POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER - XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG - POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER - POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG - POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER - POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER - BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER - FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG - POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER - POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP - POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER - FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER - POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG - POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER - POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER - POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER - POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER - POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER - POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER - POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD - WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER - POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER - FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER - FLAG POINTER WORD) - '((GC-TEST-TYPE 0 POINTER) - (GC-TEST-TYPE 2 POINTER) - (GC-TEST-TYPE 4 POINTER) - (GC-TEST-TYPE 4 (BITS . 7)) - (GC-TEST-TYPE 6 FIXP) - (GC-TEST-TYPE 8 POINTER) - (GC-TEST-TYPE 10 (BITS . 15)) - (GC-TEST-TYPE 12 POINTER) - (GC-TEST-TYPE 14 POINTER) - (GC-TEST-TYPE 16 POINTER) - (GC-TEST-TYPE 18 POINTER) - (GC-TEST-TYPE 20 POINTER) - (GC-TEST-TYPE 22 POINTER) - (GC-TEST-TYPE 24 FIXP) - (GC-TEST-TYPE 26 POINTER) - (GC-TEST-TYPE 28 XPOINTER) - (GC-TEST-TYPE 30 POINTER) - (GC-TEST-TYPE 30 (BITS . 7)) - (GC-TEST-TYPE 32 FIXP) - (GC-TEST-TYPE 34 POINTER) - (GC-TEST-TYPE 34 (BITS . 7)) - (GC-TEST-TYPE 36 POINTER) - (GC-TEST-TYPE 38 POINTER) - (GC-TEST-TYPE 40 POINTER) - (GC-TEST-TYPE 40 (BITS . 7)) - (GC-TEST-TYPE 42 POINTER) - (GC-TEST-TYPE 42 (BITS . 7)) - (GC-TEST-TYPE 44 POINTER) - (GC-TEST-TYPE 44 (BITS . 7)) - (GC-TEST-TYPE 46 POINTER) - (GC-TEST-TYPE 11 (BITS . 15)) - (GC-TEST-TYPE 48 POINTER) - (GC-TEST-TYPE 50 XPOINTER) - (GC-TEST-TYPE 52 POINTER) - (GC-TEST-TYPE 54 FIXP) - (GC-TEST-TYPE 56 POINTER) - (GC-TEST-TYPE 58 POINTER) - (GC-TEST-TYPE 60 POINTER) - (GC-TEST-TYPE 60 (FLAGBITS . 0)) - (GC-TEST-TYPE 62 POINTER) - (GC-TEST-TYPE 62 (FLAGBITS . 0)) - (GC-TEST-TYPE 64 POINTER) - (GC-TEST-TYPE 66 FIXP) - (GC-TEST-TYPE 68 FIXP) - (GC-TEST-TYPE 70 POINTER) - (GC-TEST-TYPE 72 XPOINTER) - (GC-TEST-TYPE 74 POINTER) - (GC-TEST-TYPE 76 POINTER) - (GC-TEST-TYPE 78 POINTER) - (GC-TEST-TYPE 78 (FLAGBITS . 0)) - (GC-TEST-TYPE 76 (BITS . 7)) - (GC-TEST-TYPE 80 POINTER) - (GC-TEST-TYPE 82 POINTER) - (GC-TEST-TYPE 82 (BITS . 7)) - (GC-TEST-TYPE 84 POINTER) - (GC-TEST-TYPE 86 POINTER) - (GC-TEST-TYPE 86 (BITS . 7)) - (GC-TEST-TYPE 88 (BITS . 15)) - (GC-TEST-TYPE 90 POINTER) - (GC-TEST-TYPE 92 POINTER) - (GC-TEST-TYPE 94 XPOINTER) - (GC-TEST-TYPE 96 POINTER) - (GC-TEST-TYPE 98 POINTER) - (GC-TEST-TYPE 100 XPOINTER) - (GC-TEST-TYPE 102 XPOINTER) - (GC-TEST-TYPE 104 POINTER) - (GC-TEST-TYPE 106 POINTER) - (GC-TEST-TYPE 108 POINTER) - (GC-TEST-TYPE 110 POINTER) - (GC-TEST-TYPE 110 (FLAGBITS . 0)) - (GC-TEST-TYPE 112 POINTER) - (GC-TEST-TYPE 114 POINTER) - (GC-TEST-TYPE 89 (BITS . 15)) - (GC-TEST-TYPE 116 POINTER) - (GC-TEST-TYPE 116 (FLAGBITS . 0)) - (GC-TEST-TYPE 118 POINTER) - (GC-TEST-TYPE 120 POINTER) - (GC-TEST-TYPE 122 POINTER) - (GC-TEST-TYPE 124 POINTER) - (GC-TEST-TYPE 126 FIXP) - (GC-TEST-TYPE 128 FIXP) - (GC-TEST-TYPE 130 POINTER) - (GC-TEST-TYPE 132 POINTER) - (GC-TEST-TYPE 134 POINTER) - (GC-TEST-TYPE 136 POINTER) - (GC-TEST-TYPE 138 XPOINTER) - (GC-TEST-TYPE 138 (BITS . 7)) - (GC-TEST-TYPE 140 XPOINTER) - (GC-TEST-TYPE 142 POINTER) - (GC-TEST-TYPE 142 (BITS . 7)) - (GC-TEST-TYPE 140 (FLAGBITS . 0)) - (GC-TEST-TYPE 144 FIXP) - (GC-TEST-TYPE 146 FIXP) - (GC-TEST-TYPE 140 (FLAGBITS . 16)) - (GC-TEST-TYPE 148 POINTER) - (GC-TEST-TYPE 148 (FLAGBITS . 0)) - (GC-TEST-TYPE 150 POINTER) - (GC-TEST-TYPE 150 (FLAGBITS . 0)) - (GC-TEST-TYPE 152 POINTER) - (GC-TEST-TYPE 154 POINTER) - (GC-TEST-TYPE 156 POINTER) - (GC-TEST-TYPE 158 POINTER) - (GC-TEST-TYPE 160 POINTER) - (GC-TEST-TYPE 162 XPOINTER) - (GC-TEST-TYPE 164 POINTER) - (GC-TEST-TYPE 166 POINTER) - (GC-TEST-TYPE 168 POINTER) - (GC-TEST-TYPE 170 POINTER) - (GC-TEST-TYPE 170 (BITS . 7)) - (GC-TEST-TYPE 172 POINTER) - (GC-TEST-TYPE 174 (BITS . 15)) - (GC-TEST-TYPE 176 POINTER) - (GC-TEST-TYPE 178 XPOINTER) - (GC-TEST-TYPE 178 (FLAGBITS . 0)) - (GC-TEST-TYPE 180 FIXP) - (GC-TEST-TYPE 182 POINTER) - (GC-TEST-TYPE 184 POINTER) - (GC-TEST-TYPE 184 (BITS . 7)) - (GC-TEST-TYPE 186 POINTER) - (GC-TEST-TYPE 188 POINTER) - (GC-TEST-TYPE 190 POINTER) - (GC-TEST-TYPE 192 POINTER) - (GC-TEST-TYPE 194 POINTER) - (GC-TEST-TYPE 196 XPOINTER) - (GC-TEST-TYPE 196 (BITS . 7)) - (GC-TEST-TYPE 198 XPOINTER) - (GC-TEST-TYPE 200 POINTER) - (GC-TEST-TYPE 202 POINTER) - (GC-TEST-TYPE 204 FIXP) - (GC-TEST-TYPE 202 (FLAGBITS . 0)) - (GC-TEST-TYPE 206 POINTER) - (GC-TEST-TYPE 208 POINTER) - (GC-TEST-TYPE 210 POINTER) - (GC-TEST-TYPE 212 POINTER) - (GC-TEST-TYPE 175 (BITS . 15)) - (GC-TEST-TYPE 212 (FLAGBITS . 0)) - (GC-TEST-TYPE 214 POINTER) - (GC-TEST-TYPE 216 POINTER) - (GC-TEST-TYPE 218 POINTER) - (GC-TEST-TYPE 220 (BITS . 15)) - (GC-TEST-TYPE 218 (FLAGBITS . 0)) - (GC-TEST-TYPE 222 POINTER) - (GC-TEST-TYPE 224 POINTER) - (GC-TEST-TYPE 226 POINTER) - (GC-TEST-TYPE 228 FIXP) - (GC-TEST-TYPE 230 POINTER) - (GC-TEST-TYPE 232 POINTER) - (GC-TEST-TYPE 234 POINTER) - (GC-TEST-TYPE 236 POINTER) - (GC-TEST-TYPE 236 (FLAGBITS . 0)) - (GC-TEST-TYPE 238 POINTER) - (GC-TEST-TYPE 240 POINTER) - (GC-TEST-TYPE 242 POINTER) - (GC-TEST-TYPE 244 POINTER) - (GC-TEST-TYPE 246 FIXP) - (GC-TEST-TYPE 248 POINTER) - (GC-TEST-TYPE 248 (BITS . 7)) - (GC-TEST-TYPE 250 POINTER) - (GC-TEST-TYPE 252 FIXP) - (GC-TEST-TYPE 221 (BITS . 15)) - (GC-TEST-TYPE 254 POINTER) - (GC-TEST-TYPE 256 (BITS . 15)) - (GC-TEST-TYPE 257 FIXP) - (GC-TEST-TYPE 260 POINTER) - (GC-TEST-TYPE 262 FIXP) - (GC-TEST-TYPE 264 POINTER) - (GC-TEST-TYPE 264 (FLAGBITS . 0)) - (GC-TEST-TYPE 260 (BITS . 7)) - (GC-TEST-TYPE 266 POINTER) - (GC-TEST-TYPE 268 POINTER) - (GC-TEST-TYPE 270 XPOINTER) - (GC-TEST-TYPE 270 (BITS . 7)) - (GC-TEST-TYPE 272 POINTER) - (GC-TEST-TYPE 274 POINTER) - (GC-TEST-TYPE 274 (FLAGBITS . 0)) - (GC-TEST-TYPE 272 (BITS . 7)) - (GC-TEST-TYPE 259 (BITS . 15)) - (GC-TEST-TYPE 276 POINTER) - (GC-TEST-TYPE 278 FIXP) - (GC-TEST-TYPE 280 POINTER) - (GC-TEST-TYPE 282 POINTER) - (GC-TEST-TYPE 282 (BITS . 7)) - (GC-TEST-TYPE 284 POINTER) - (GC-TEST-TYPE 286 POINTER) - (GC-TEST-TYPE 288 POINTER) - (GC-TEST-TYPE 290 POINTER) - (GC-TEST-TYPE 292 POINTER) - (GC-TEST-TYPE 292 (BITS . 7)) - (GC-TEST-TYPE 294 FIXP) - (GC-TEST-TYPE 296 POINTER) - (GC-TEST-TYPE 298 POINTER) - (GC-TEST-TYPE 300 POINTER) - (GC-TEST-TYPE 300 (BITS . 7)) - (GC-TEST-TYPE 302 POINTER) - (GC-TEST-TYPE 304 (BITS . 15)) - (GC-TEST-TYPE 306 POINTER) - (GC-TEST-TYPE 308 POINTER) - (GC-TEST-TYPE 310 POINTER) - (GC-TEST-TYPE 312 POINTER) - (GC-TEST-TYPE 305 (BITS . 15)) - (GC-TEST-TYPE 314 POINTER) - (GC-TEST-TYPE 314 (FLAGBITS . 0)) - (GC-TEST-TYPE 316 POINTER) - (GC-TEST-TYPE 318 XPOINTER) - (GC-TEST-TYPE 320 POINTER) - (GC-TEST-TYPE 322 POINTER) - (GC-TEST-TYPE 324 POINTER) - (GC-TEST-TYPE 324 (FLAGBITS . 0)) - (GC-TEST-TYPE 326 POINTER) - (GC-TEST-TYPE 328 (BITS . 15)) - (GC-TEST-TYPE 326 (BITS . 7)) - (GC-TEST-TYPE 330 POINTER) - (GC-TEST-TYPE 332 POINTER) - (GC-TEST-TYPE 334 POINTER) - (GC-TEST-TYPE 336 FIXP) - (GC-TEST-TYPE 338 POINTER) - (GC-TEST-TYPE 340 POINTER) - (GC-TEST-TYPE 342 XPOINTER) - (GC-TEST-TYPE 344 POINTER) - (GC-TEST-TYPE 344 (FLAGBITS . 0)) - (GC-TEST-TYPE 346 POINTER) - (GC-TEST-TYPE 346 (FLAGBITS . 0)) - (GC-TEST-TYPE 329 (BITS . 15)) - (GC-TEST-TYPE 346 (FLAGBITS . 16)) - (GC-TEST-TYPE 348 (BITS . 15)) - (GC-TEST-TYPE 350 POINTER) - (GC-TEST-TYPE 352 POINTER) - (GC-TEST-TYPE 354 POINTER) - (GC-TEST-TYPE 356 POINTER) - (GC-TEST-TYPE 358 POINTER) - (GC-TEST-TYPE 360 XPOINTER) - (GC-TEST-TYPE 362 POINTER) - (GC-TEST-TYPE 349 (BITS . 15)) - (GC-TEST-TYPE 364 (BITS . 15)) - (GC-TEST-TYPE 366 POINTER) - (GC-TEST-TYPE 368 POINTER) - (GC-TEST-TYPE 370 POINTER) - (GC-TEST-TYPE 372 POINTER) - (GC-TEST-TYPE 374 POINTER) - (GC-TEST-TYPE 376 POINTER) - (GC-TEST-TYPE 378 POINTER) - (GC-TEST-TYPE 380 XPOINTER) - (GC-TEST-TYPE 382 POINTER) - (GC-TEST-TYPE 365 (BITS . 15)) - (GC-TEST-TYPE 384 POINTER) - (GC-TEST-TYPE 386 POINTER) - (GC-TEST-TYPE 388 XPOINTER) - (GC-TEST-TYPE 390 POINTER) - (GC-TEST-TYPE 392 POINTER) - (GC-TEST-TYPE 394 POINTER) - (GC-TEST-TYPE 396 POINTER) - (GC-TEST-TYPE 398 POINTER) - (GC-TEST-TYPE 400 POINTER) - (GC-TEST-TYPE 402 POINTER) - (GC-TEST-TYPE 404 POINTER) - (GC-TEST-TYPE 406 POINTER) - (GC-TEST-TYPE 408 POINTER) - (GC-TEST-TYPE 410 XPOINTER) - (GC-TEST-TYPE 412 POINTER) - (GC-TEST-TYPE 414 FIXP) - (GC-TEST-TYPE 416 POINTER) - (GC-TEST-TYPE 418 POINTER) - (GC-TEST-TYPE 420 XPOINTER) - (GC-TEST-TYPE 422 POINTER) - (GC-TEST-TYPE 424 (BITS . 15)) - (GC-TEST-TYPE 422 (FLAGBITS . 0)) - (GC-TEST-TYPE 426 POINTER) - (GC-TEST-TYPE 428 POINTER) - (GC-TEST-TYPE 430 POINTER) - (GC-TEST-TYPE 432 POINTER) - (GC-TEST-TYPE 434 POINTER) - (GC-TEST-TYPE 434 (BITS . 7)) - (GC-TEST-TYPE 436 POINTER) - (GC-TEST-TYPE 438 POINTER) - (GC-TEST-TYPE 438 (FLAGBITS . 0)) - (GC-TEST-TYPE 436 (BITS . 7)) - (GC-TEST-TYPE 440 POINTER) - (GC-TEST-TYPE 442 POINTER) - (GC-TEST-TYPE 444 POINTER) - (GC-TEST-TYPE 446 XPOINTER) - (GC-TEST-TYPE 425 (BITS . 15)) - (GC-TEST-TYPE 448 (BITS . 15)) - (GC-TEST-TYPE 450 POINTER) - (GC-TEST-TYPE 452 POINTER) - (GC-TEST-TYPE 454 POINTER) - (GC-TEST-TYPE 449 (BITS . 15)) - (GC-TEST-TYPE 456 POINTER) - (GC-TEST-TYPE 458 XPOINTER) - (GC-TEST-TYPE 458 (BITS . 7)) - (GC-TEST-TYPE 460 POINTER) - (GC-TEST-TYPE 462 XPOINTER) - (GC-TEST-TYPE 462 (FLAGBITS . 0)) - (GC-TEST-TYPE 464 POINTER) - (GC-TEST-TYPE 466 POINTER) - (GC-TEST-TYPE 466 (FLAGBITS . 0)) - (GC-TEST-TYPE 468 POINTER) - (GC-TEST-TYPE 470 POINTER) - (GC-TEST-TYPE 472 XPOINTER) - (GC-TEST-TYPE 474 FIXP) - (GC-TEST-TYPE 476 FIXP) - (GC-TEST-TYPE 472 (BITS . 7)) - (GC-TEST-TYPE 478 POINTER) - (GC-TEST-TYPE 480 POINTER) - (GC-TEST-TYPE 482 POINTER) - (GC-TEST-TYPE 484 POINTER) - (GC-TEST-TYPE 486 FIXP) - (GC-TEST-TYPE 488 POINTER) - (GC-TEST-TYPE 488 (FLAGBITS . 0)) - (GC-TEST-TYPE 490 FIXP) - (GC-TEST-TYPE 492 POINTER) - (GC-TEST-TYPE 494 XPOINTER) - (GC-TEST-TYPE 496 POINTER) - (GC-TEST-TYPE 498 POINTER) - (GC-TEST-TYPE 498 (BITS . 7)) - (GC-TEST-TYPE 500 POINTER) - (GC-TEST-TYPE 502 (BITS . 15)) - (GC-TEST-TYPE 503 FIXP) - (GC-TEST-TYPE 506 POINTER) - (GC-TEST-TYPE 506 (FLAGBITS . 0)) - (GC-TEST-TYPE 508 POINTER) - (GC-TEST-TYPE 505 (BITS . 15))) - '510) - - - -(* |;;| "DATATYPE TESTS") - - - - -(* |;;| "CODE RECLAIMATION TESTS") - -(DEFINEQ - -(CODE-RECLAIM-TEST - (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 11:54 by jds") - (LET NIL - - (* |;;| "Make sure there's a definition to compile.") - - (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN) - (EVAL CODE-RECLAIM-TEST-TEMP-FN)) - (PRINTOUT T " Starting code-block reclaim test" T) - (|for| I |from| 1 |to| LIMIT |do| (BKSYSBUF "ST -N -") - (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN)) - (PRINTOUT T " Starting MAPATOMS(GETD)" T) - (|for| I |from| 1 |to| LIMIT |do| (MAPATOMS (FUNCTION GETD)))))) -) - - - -(* |;;| -"The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed." -) - - -(RPAQQ CODE-RECLAIM-TEST-TEMP-FN - (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) - (LET (I) - (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (CL:FLET ((TEMP (ARG) - (SETQ ARG (FLOAT ARG)) - (EXPT (SQRT I) - (SQRT (COS (/ I 180)))))) - (CL:UNWIND-PROTECT - (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) - (SETQ I NIL))))))) -(PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (2908 5241 (MAIN-GC-TEST 2918 . 5239)) (5242 13684 (ITEMS-ON-STACK-TEST 5252 . 6415) ( -MANY-BIGNUM-MAKER 6417 . 7289) (MANY-FIXP-MAKER 7291 . 8077) (MANY-FLOAT-MAKER 8079 . 8686) ( -BOUNDARY-TESTS 8688 . 11155) (ARRAY-STRING-TEST 11157 . 13103) (VARIOUS-TYPES-TEST 13105 . 13682)) ( -13685 18528 (TEDIT-CRUNCH-TEST 13695 . 15107) (LIST-MANIPULATION-TEST 15109 . 18526)) (18529 19213 ( -ATOM-FULL-TEST 18539 . 18970) (STORAGE-FULL-TEST 18972 . 19211)) (19214 19732 (DATATYPE-TEST 19224 . -19730)) (44715 45405 (CODE-RECLAIM-TEST 44725 . 45403))))) -STOP diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ deleted file mode 100644 index ad353028..00000000 --- a/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ +++ /dev/null @@ -1,925 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED " 2-Aug-88 21:52:05" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;7 46959 - - |changes| |to:| (FNS MAIN-GC-TEST LIST-MANIPULATION-TEST CODE-RECLAIM-TEST) - - |previous| |date:| "23-Jun-88 16:06:34" {ERIS}GC>HAND>MAIKO-GC-TESTS.\;6) - - -; Copyright (c) 1988 by John Sybalsky & Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT MAIKO-GC-TESTSCOMS) - -(RPAQQ MAIKO-GC-TESTSCOMS - ((FILES DANCEROBJ GCHAX) - (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" - "{ERIS}XEROXPRIVATE>FONTS>") - (INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" - "{ERIS}XEROXPRIVATE>FONTS>")) - (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))) - (FNS MAIN-GC-TEST) - (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS - ARRAY-STRING-TEST VARIOUS-TYPES-TEST) - (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST) - (FNS ATOM-FULL-TEST STORAGE-FULL-TEST) - (COMS (FNS DATATYPE-TEST) - (RECORDS GC-TEST-TYPE) - - (* |;;| "DATATYPE TESTS") -) - (COMS - - (* |;;| "CODE RECLAIMATION TESTS") - - (FNS CODE-RECLAIM-TEST) - - (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.") - - (VARS (CODE-RECLAIM-TEST-TEMP-FN - '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN - (ASDF) - (LET (I) - (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (CL:FLET ((TEMP (ARG) - (SETQ ARG (FLOAT ARG)) - (EXPT (SQRT I) - (SQRT (COS (/ I 180)))))) - (CL:UNWIND-PROTECT - (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) - (SETQ I NIL))))))))))) - -(FILESLOAD DANCEROBJ GCHAX) - -(ADDTOVAR DISPLAYFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" "{ERIS}XEROXPRIVATE>FONTS>") - -(ADDTOVAR INTERPRESSFONTDIRECTORIES "{ERIS}GC>HAND-AUX>" - "{ERIS}XEROXPRIVATE>FONTS>") - -(SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)) -(DEFINEQ - -(MAIN-GC-TEST - (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT - CODE-COUNT TYPE-COUNT LIST-LEN-LIMIT) (* \; "Edited 23-Jun-88 13:30 by jds") - (DRIBBLE (OR DRIBBLE-FILE "{LPT}")) - (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE) - T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}") - T T) - (|for| I |from| 1 |to| (OR LIMIT 10) |do| (PRINTOUT T - "Starting Maiko GC tests, pass " - I T) - (ITEMS-ON-STACK-TEST (OR STACK-COUNT - 100)) - (MANY-BIGNUM-MAKER (OR BIGNUM-COUNT - 1000)) - (MANY-FIXP-MAKER (OR FIXP-COUNT 1000)) - (MANY-FLOAT-MAKER (OR FLOAT-COUNT 1000 - )) - (TEDIT-CRUNCH-TEST (OR TEDIT-COUNT 5)) - (ARRAY-STRING-TEST 3) - (LIST-MANIPULATION-TEST (OR LIST-COUNT - 5) - LIST-LEN-LIMIT) - (BOUNDARY-TESTS) - (CODE-RECLAIM-TEST (OR CODE-COUNT 20)) - (VARIOUS-TYPES-TEST (OR TYPE-COUNT 10) - ) - (FRPTQ 100 (RECLAIM)) - (STORAGE)) - (ATOM-FULL-TEST) - (STORAGE-FULL-TEST) - (DRIBBLE NIL))) -) -(DEFINEQ - -(ITEMS-ON-STACK-TEST - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:56 by jds") - (PRINTOUT T " Starting ITEMS-ON-STACK test for " LIMIT " iterations." T) - (FOR I FROM 1 TO LIMIT DO (LET ((X (CREATE CHARLOOKS)) - (Y (EXPT 1234.5 (RAND 3 7)))) - (ERSETQ (FRPTQ 5 (RECLAIM)) - (COND - ((\\ISONFREELIST X) - (HELP - "X is free, but pointer is on stack." - )) - ((\\ISONFREELIST Y) - (HELP - "Y is free, but pointer is on stack." - )))))))) - -(MANY-BIGNUM-MAKER - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") - (PRINTOUT T " Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T) - (LET (X Y Z W) - (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 12345678901234567890 - (RAND 1 I))) - (SETQ Y (IQUOTIENT X 3)) - (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) - (IREMAINDER Y 3) - (CL:FLOOR Y 2) - (CL:CEILING X 8))) - (SETQ W (/ Z Y)))))) - -(MANY-FIXP-MAKER - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:54 by jds") - (PRINTOUT T " Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T) - (LET (X Y Z W) - (FOR I FROM 1 TO LIMIT DO (SETQ X (CL:* 543 (RAND 1 I))) - (SETQ Y (IQUOTIENT X 3)) - (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7) - (IREMAINDER Y 3) - (CL:FLOOR Y 2) - (CL:CEILING X 8))) - (SETQ W (/ Z Y)))))) - -(MANY-FLOAT-MAKER - (LAMBDA (LIMIT) (* \; "Edited 25-May-88 11:55 by jds") - (PRINTOUT T " Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T) - (LET (X Y Z W) - (FOR I FROM 1 TO LIMIT DO (SETQ X (FTIMES 1.0 (RAND 0 1))) - (SETQ Y (+ (SQRT I) - (EXPT (SQRT (SQRT I)) - 3.4))) - (SETQ Z (LOG Y)))))) - -(BOUNDARY-TESTS - (LAMBDA NIL (* \; "Edited 26-May-88 11:54 by jds") - - (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.") - - (PRINTOUT T " Starting Refcnt-63 crossing test" T) - (LET* ((ITEM (|create| FMTSPEC)) - (LIST (|for| I |from| 1 |to| 62 |collect| ITEM))) - (|for| I |from| 1 |to| 1000 |do| (|for| J |from| (LENGTH LIST) - |to| (+ 63 (RAND 1 10)) - |do| (SETQ LIST (CONS ITEM LIST))) - (|for| J |from| (LENGTH LIST) - |to| (- 63 (RAND 3 12)) - |do| (|pop| LIST)) - (COND - ((ZEROP (IMOD I 31)) - (RECLAIM)))) - (PRINTOUT T " Starting Refcount-500K <-> NIL test." T) - (|for| LOOP |from| 1 |to| 10 |do| (|for| I |from| 1 |to| 500000 - |do| (SETQ LIST (CONS ITEM LIST))) - (SETQ LIST NIL)) - (PRINTOUT T " Starting Refcount 1-2 boundary test." T) - (LET ((ITEM (LIST (|create| FMTSPEC)))) - (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (CAR ITEM)) - (SETQ ITEM2 NIL))) - (PRINTOUT T " Starting Refcount 1 + stack boundary test." T) - (LET ((ITEM (|create| FMTSPEC)) - ITEM2) - (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM2 (LIST ITEM)) - (RPLACA ITEM2 NIL))) - (PRINTOUT T " Starting Refcount 0-1 boundary test." T) - (LET (ITEM) - (|for| I |from| 1 |to| 5000 |do| (SETQ ITEM (LIST (|create| - FMTSPEC))) - (RPLACA ITEM NIL)))))) - -(ARRAY-STRING-TEST - (LAMBDA (LIMIT REAL-STRESS) (* \; "Edited 23-Jun-88 12:23 by jds") - - (* |;;| "Try out array & string creation, and substringing on the GC.") - - (PRINTOUT T " Starting Array & String test." T) - (FOR I FROM 1 TO (OR LIMIT 10) - DO (LET (STRINGS ARRAYS) - (FOR ARRAY-COUNT FROM 1 TO 5000 - COLLECT (CL:MAKE-ARRAY (RAND 10 (COND - (REAL-STRESS 65000) - (T (IMAX 100 (IQUOTIENT 65000 - ARRAY-COUNT))))))) - (FOR I FROM 1 TO 5000 COLLECT (BITMAPCREATE (RAND 1 512) - (RAND 1 512))) - (SETQ STRINGS (FOR STRING-COUNT FROM 1 TO 5000 - COLLECT (ALLOCSTRING (RAND 10 - (COND - (REAL-STRESS 65000) - (T (IMAX 100 (IQUOTIENT 65000 - STRING-COUNT - )))))))) - (FOR STRING IN STRINGS - COLLECT (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING) - 1)) - (RAND (ADD1 (LRSH (NCHARS STRING) - 1)) - (NCHARS STRING)))))))) - -(VARIOUS-TYPES-TEST - (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 12:04 by jds") - - (* |;;| - "Run thru creation and collection of various types that have caused trouble in the past. ") - - (PRINTOUT T " Starting various type cases." T) - (FOR REPEAT-COUNT FROM 1 TO (OR LIMIT 10) - DO (|for| TYPE IN '(VMEMPAGEP) AS CREATION-LIMIT IN '(100) - |do| (FOR I FROM 1 TO CREATION-LIMIT COLLECT (NCREATE TYPE)) - (DORECLAIM))))) -) -(DEFINEQ - -(TEDIT-CRUNCH-TEST - (LAMBDA (LIMIT) (* \; "Edited 27-May-88 13:06 by jds") - - (* |;;| "GC Testing -- stressing the world.") - - (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.") - - (PRINTOUT T " Starting TEDIT-CRUNCH test for " LIMIT " iterations." T) - (FOR PASS FROM 1 TO LIMIT DO (PRINTOUT T " Round " PASS " started " (DATE) - "." T) - (LET ((TS (OPENTEXTSTREAM - ' - |{ERIS}GC>Hand-Aux>ADVDICT-N-Z.TEDIT| - )) - TLIST) - (TEDIT.HARDCOPY TS '{CORE}FOO.IP T) - (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP) - (DELFILE '{DSK}FOO.IP) - (DELFILE '{CORE}FOO.IP) - (CLOSEF (FETCH (TEXTOBJ TXTFILE) - OF (TEXTOBJ TS))))))) - -(LIST-MANIPULATION-TEST - (LAMBDA (LIMIT LENGTH-LIMIT) (* \; "Edited 23-Jun-88 14:03 by jds") - - (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.") - - (PRINTOUT T " Starting LIST-MANIPULATION test for " LIMIT " iterations." T) - (|for| PASS |from| 1 |to| LIMIT - |do| (PRINTOUT T " Round " PASS " started " (DATE) - "." T) - (LET ((TS (OPENTEXTSTREAM '|{ERIS}Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|)) - (LEN (RAND 0 (OR LENGTH-LIMIT 100000))) - TLIST) - (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| TS)) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH LEN 1))) - |do| (|pop| TLIST)) - (|for| I |from| 1 |to| (RAND 1 100) |do| (SETQ TLIST - (CONS TS TLIST))) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) - 1))) - |do| (|pop| TLIST)) - (|for| I |from| 1 |to| (RAND 1 2000) |do| (SETQ TLIST - (CONS TS TLIST))) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) - 1))) - |do| (|pop| TLIST)) - (|for| \i |from| 1 |to| (RAND 1 1500) - |do| (SETQ TLIST (NCONC TLIST - (|for| J |from| 1 - |to| (RAND 1 10) - |join| (|for| K |from| 1 |to| - 3 - |collect| (CONS TS K)))))) - (|for| I |from| 1 |to| (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST) - 1))) - |do| (|pop| TLIST)) - (CLOSEF (|fetch| (TEXTOBJ TXTFILE) |of| (TEXTOBJ TS)))) - (LET ((GC-ITEM (NCREATE 'VMEMPAGEP)) - (LEN (RAND 10 500)) - TLIST ELT) - (SETQ TLIST (|for| I |from| 1 |to| LEN |collect| NIL)) - (|for| I |from| 1 |to| LEN |do| (SETQ ELT (CL:RANDOM LEN)) - (RPLACA (CL:NTHCDR ELT TLIST) - GC-ITEM) - (RPLACA (CL:NTHCDR (SUB1 I) - TLIST) - GC-ITEM)) - (|for| I |from| (SUB1 LEN) |to| 0 |by| -1 - |do| (RPLACD (CL:NTHCDR I TLIST) - GC-ITEM)))))) -) -(DEFINEQ - -(ATOM-FULL-TEST - (LAMBDA NIL (* \; "Edited 26-May-88 11:39 by jds") - (PRINTOUT T " Starting ATOM-space full test.") - (LET ((CUR-ATOM-COUNT |\\AtomFrLst|)) - (CL:UNWIND-PROTECT - (PROGN (SETQ |\\AtomFrLst| 64000) - (FOR I FROM 64000 TO 70000 DO (GENSYM 'GC-TEST))) - (SETQ |\\AtomFrLst| CUR-ATOM-COUNT))))) - -(STORAGE-FULL-TEST - (LAMBDA NIL (* \; "Edited 26-May-88 11:47 by jds") - (PRINTOUT T " Starting Storage-full test." T) - (ERSETQ (FOR I FROM 1 COLLECT (ARRAY 100))))) -) -(DEFINEQ - -(DATATYPE-TEST - (LAMBDA (LIMIT) (* \; "Edited 26-May-88 11:26 by jds") - (FOR I FROM 1 TO (OR LIMIT 10) - DO (FOR L FROM 1 TO 100 DO (FOR Y FROM 1 TO 20 - COLLECT (CREATE GC-TEST-TYPE - FIELD-1 _ T)) - (RECLAIM))))) -) -(DECLARE\: EVAL@COMPILE - -(DATATYPE GC-TEST-TYPE (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE) - (FIELD-5 FIXP) - FIELD-6 - (FIELD-7 WORD) - FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14 - FIXP) - FIELD-15 - (FIELD-16 XPOINTER) - FIELD-17 - (FIELD-18 BYTE) - (FIELD-19 FIXP) - FIELD-20 - (FIELD-21 BYTE) - FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE) - FIELD-26 - (FIELD-27 BYTE) - FIELD-28 - (FIELD-29 BYTE) - FIELD-30 - (FIELD-31 WORD) - FIELD-32 - (FIELD-33 XPOINTER) - FIELD-34 - (FIELD-35 FIXP) - FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG) - FIELD-40 - (FIELD-41 FLAG) - FIELD-42 - (FIELD-43 FIXP) - (FIELD-44 FIXP) - FIELD-45 - (FIELD-46 XPOINTER) - FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG) - (FIELD-51 BYTE) - FIELD-52 FIELD-53 (FIELD-54 BYTE) - FIELD-55 FIELD-56 (FIELD-57 BYTE) - (FIELD-58 WORD) - FIELD-59 FIELD-60 (FIELD-61 XPOINTER) - FIELD-62 FIELD-63 (FIELD-64 XPOINTER) - (FIELD-65 XPOINTER) - FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG) - FIELD-71 FIELD-72 (FIELD-73 WORD) - FIELD-74 - (FIELD-75 FLAG) - FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP) - (FIELD-81 FIXP) - FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER) - (FIELD-87 BYTE) - (FIELD-88 XPOINTER) - FIELD-89 - (FIELD-90 BYTE) - (FIELD-91 FLAG) - (FIELD-92 FIXP) - (FIELD-93 FIXP) - (FIELD-94 FLAG) - FIELD-95 - (FIELD-96 FLAG) - FIELD-97 - (FIELD-98 FLAG) - FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 - XPOINTER) - FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE) - FIELD-110 - (FIELD-111 WORD) - FIELD-112 - (FIELD-113 XPOINTER) - (FIELD-114 FLAG) - (FIELD-115 FIXP) - FIELD-116 FIELD-117 (FIELD-118 BYTE) - FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 - XPOINTER) - (FIELD-125 BYTE) - (FIELD-126 XPOINTER) - FIELD-127 FIELD-128 (FIELD-129 FIXP) - (FIELD-130 FLAG) - FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD) - (FIELD-136 FLAG) - FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD) - (FIELD-141 FLAG) - FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP) - FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG) - FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP) - FIELD-156 - (FIELD-157 BYTE) - FIELD-158 - (FIELD-159 FIXP) - (FIELD-160 WORD) - FIELD-161 - (FIELD-162 WORD) - (FIELD-163 FIXP) - FIELD-164 - (FIELD-165 FIXP) - FIELD-166 - (FIELD-167 FLAG) - (FIELD-168 BYTE) - FIELD-169 FIELD-170 (FIELD-171 XPOINTER) - (FIELD-172 BYTE) - FIELD-173 FIELD-174 (FIELD-175 FLAG) - (FIELD-176 BYTE) - (FIELD-177 WORD) - FIELD-178 - (FIELD-179 FIXP) - FIELD-180 FIELD-181 (FIELD-182 BYTE) - FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE) - (FIELD-189 FIXP) - FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE) - FIELD-194 - (FIELD-195 WORD) - FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD) - FIELD-201 - (FIELD-202 FLAG) - FIELD-203 - (FIELD-204 XPOINTER) - FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG) - FIELD-209 - (FIELD-210 WORD) - (FIELD-211 BYTE) - FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP) - FIELD-216 FIELD-217 (FIELD-218 XPOINTER) - FIELD-219 - (FIELD-220 FLAG) - FIELD-221 - (FIELD-222 FLAG) - (FIELD-223 WORD) - (FIELD-224 FLAG) - (FIELD-225 WORD) - FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 - XPOINTER) - FIELD-232 - (FIELD-233 WORD) - (FIELD-234 WORD) - FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 - FIELD-241 (FIELD-242 XPOINTER) - FIELD-243 - (FIELD-244 WORD) - FIELD-245 FIELD-246 (FIELD-247 XPOINTER) - FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 - FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER) - FIELD-259 - (FIELD-260 FIXP) - FIELD-261 FIELD-262 (FIELD-263 XPOINTER) - FIELD-264 - (FIELD-265 WORD) - (FIELD-266 FLAG) - FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE) - FIELD-273 FIELD-274 (FIELD-275 FLAG) - (FIELD-276 BYTE) - FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER) - (FIELD-281 WORD) - (FIELD-282 WORD) - FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD) - FIELD-287 - (FIELD-288 XPOINTER) - (FIELD-289 BYTE) - FIELD-290 - (FIELD-291 XPOINTER) - (FIELD-292 FLAG) - FIELD-293 FIELD-294 (FIELD-295 FLAG) - FIELD-296 FIELD-297 (FIELD-298 XPOINTER) - (FIELD-299 FIXP) - (FIELD-300 FIXP) - (FIELD-301 BYTE) - FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP) - FIELD-307 - (FIELD-308 FLAG) - (FIELD-309 FIXP) - FIELD-310 - (FIELD-311 XPOINTER) - FIELD-312 FIELD-313 (FIELD-314 BYTE) - FIELD-315 - (FIELD-316 WORD) - (FIELD-317 FIXP) - FIELD-318 - (FIELD-319 FLAG) - FIELD-320 - (FIELD-321 WORD))) -) - -(/DECLAREDATATYPE 'GC-TEST-TYPE - '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER - POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER - BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER - POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER - POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER - XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG - POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER - POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG - POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER - POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER - BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER - FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG - POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER - POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP - POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER - FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER - POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG - POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER - POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER - POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER - POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER - POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER - POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER - POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD - WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER - POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER - FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER - FLAG POINTER WORD) - '((GC-TEST-TYPE 0 POINTER) - (GC-TEST-TYPE 2 POINTER) - (GC-TEST-TYPE 4 POINTER) - (GC-TEST-TYPE 4 (BITS . 7)) - (GC-TEST-TYPE 6 FIXP) - (GC-TEST-TYPE 8 POINTER) - (GC-TEST-TYPE 10 (BITS . 15)) - (GC-TEST-TYPE 12 POINTER) - (GC-TEST-TYPE 14 POINTER) - (GC-TEST-TYPE 16 POINTER) - (GC-TEST-TYPE 18 POINTER) - (GC-TEST-TYPE 20 POINTER) - (GC-TEST-TYPE 22 POINTER) - (GC-TEST-TYPE 24 FIXP) - (GC-TEST-TYPE 26 POINTER) - (GC-TEST-TYPE 28 XPOINTER) - (GC-TEST-TYPE 30 POINTER) - (GC-TEST-TYPE 30 (BITS . 7)) - (GC-TEST-TYPE 32 FIXP) - (GC-TEST-TYPE 34 POINTER) - (GC-TEST-TYPE 34 (BITS . 7)) - (GC-TEST-TYPE 36 POINTER) - (GC-TEST-TYPE 38 POINTER) - (GC-TEST-TYPE 40 POINTER) - (GC-TEST-TYPE 40 (BITS . 7)) - (GC-TEST-TYPE 42 POINTER) - (GC-TEST-TYPE 42 (BITS . 7)) - (GC-TEST-TYPE 44 POINTER) - (GC-TEST-TYPE 44 (BITS . 7)) - (GC-TEST-TYPE 46 POINTER) - (GC-TEST-TYPE 11 (BITS . 15)) - (GC-TEST-TYPE 48 POINTER) - (GC-TEST-TYPE 50 XPOINTER) - (GC-TEST-TYPE 52 POINTER) - (GC-TEST-TYPE 54 FIXP) - (GC-TEST-TYPE 56 POINTER) - (GC-TEST-TYPE 58 POINTER) - (GC-TEST-TYPE 60 POINTER) - (GC-TEST-TYPE 60 (FLAGBITS . 0)) - (GC-TEST-TYPE 62 POINTER) - (GC-TEST-TYPE 62 (FLAGBITS . 0)) - (GC-TEST-TYPE 64 POINTER) - (GC-TEST-TYPE 66 FIXP) - (GC-TEST-TYPE 68 FIXP) - (GC-TEST-TYPE 70 POINTER) - (GC-TEST-TYPE 72 XPOINTER) - (GC-TEST-TYPE 74 POINTER) - (GC-TEST-TYPE 76 POINTER) - (GC-TEST-TYPE 78 POINTER) - (GC-TEST-TYPE 78 (FLAGBITS . 0)) - (GC-TEST-TYPE 76 (BITS . 7)) - (GC-TEST-TYPE 80 POINTER) - (GC-TEST-TYPE 82 POINTER) - (GC-TEST-TYPE 82 (BITS . 7)) - (GC-TEST-TYPE 84 POINTER) - (GC-TEST-TYPE 86 POINTER) - (GC-TEST-TYPE 86 (BITS . 7)) - (GC-TEST-TYPE 88 (BITS . 15)) - (GC-TEST-TYPE 90 POINTER) - (GC-TEST-TYPE 92 POINTER) - (GC-TEST-TYPE 94 XPOINTER) - (GC-TEST-TYPE 96 POINTER) - (GC-TEST-TYPE 98 POINTER) - (GC-TEST-TYPE 100 XPOINTER) - (GC-TEST-TYPE 102 XPOINTER) - (GC-TEST-TYPE 104 POINTER) - (GC-TEST-TYPE 106 POINTER) - (GC-TEST-TYPE 108 POINTER) - (GC-TEST-TYPE 110 POINTER) - (GC-TEST-TYPE 110 (FLAGBITS . 0)) - (GC-TEST-TYPE 112 POINTER) - (GC-TEST-TYPE 114 POINTER) - (GC-TEST-TYPE 89 (BITS . 15)) - (GC-TEST-TYPE 116 POINTER) - (GC-TEST-TYPE 116 (FLAGBITS . 0)) - (GC-TEST-TYPE 118 POINTER) - (GC-TEST-TYPE 120 POINTER) - (GC-TEST-TYPE 122 POINTER) - (GC-TEST-TYPE 124 POINTER) - (GC-TEST-TYPE 126 FIXP) - (GC-TEST-TYPE 128 FIXP) - (GC-TEST-TYPE 130 POINTER) - (GC-TEST-TYPE 132 POINTER) - (GC-TEST-TYPE 134 POINTER) - (GC-TEST-TYPE 136 POINTER) - (GC-TEST-TYPE 138 XPOINTER) - (GC-TEST-TYPE 138 (BITS . 7)) - (GC-TEST-TYPE 140 XPOINTER) - (GC-TEST-TYPE 142 POINTER) - (GC-TEST-TYPE 142 (BITS . 7)) - (GC-TEST-TYPE 140 (FLAGBITS . 0)) - (GC-TEST-TYPE 144 FIXP) - (GC-TEST-TYPE 146 FIXP) - (GC-TEST-TYPE 140 (FLAGBITS . 16)) - (GC-TEST-TYPE 148 POINTER) - (GC-TEST-TYPE 148 (FLAGBITS . 0)) - (GC-TEST-TYPE 150 POINTER) - (GC-TEST-TYPE 150 (FLAGBITS . 0)) - (GC-TEST-TYPE 152 POINTER) - (GC-TEST-TYPE 154 POINTER) - (GC-TEST-TYPE 156 POINTER) - (GC-TEST-TYPE 158 POINTER) - (GC-TEST-TYPE 160 POINTER) - (GC-TEST-TYPE 162 XPOINTER) - (GC-TEST-TYPE 164 POINTER) - (GC-TEST-TYPE 166 POINTER) - (GC-TEST-TYPE 168 POINTER) - (GC-TEST-TYPE 170 POINTER) - (GC-TEST-TYPE 170 (BITS . 7)) - (GC-TEST-TYPE 172 POINTER) - (GC-TEST-TYPE 174 (BITS . 15)) - (GC-TEST-TYPE 176 POINTER) - (GC-TEST-TYPE 178 XPOINTER) - (GC-TEST-TYPE 178 (FLAGBITS . 0)) - (GC-TEST-TYPE 180 FIXP) - (GC-TEST-TYPE 182 POINTER) - (GC-TEST-TYPE 184 POINTER) - (GC-TEST-TYPE 184 (BITS . 7)) - (GC-TEST-TYPE 186 POINTER) - (GC-TEST-TYPE 188 POINTER) - (GC-TEST-TYPE 190 POINTER) - (GC-TEST-TYPE 192 POINTER) - (GC-TEST-TYPE 194 POINTER) - (GC-TEST-TYPE 196 XPOINTER) - (GC-TEST-TYPE 196 (BITS . 7)) - (GC-TEST-TYPE 198 XPOINTER) - (GC-TEST-TYPE 200 POINTER) - (GC-TEST-TYPE 202 POINTER) - (GC-TEST-TYPE 204 FIXP) - (GC-TEST-TYPE 202 (FLAGBITS . 0)) - (GC-TEST-TYPE 206 POINTER) - (GC-TEST-TYPE 208 POINTER) - (GC-TEST-TYPE 210 POINTER) - (GC-TEST-TYPE 212 POINTER) - (GC-TEST-TYPE 175 (BITS . 15)) - (GC-TEST-TYPE 212 (FLAGBITS . 0)) - (GC-TEST-TYPE 214 POINTER) - (GC-TEST-TYPE 216 POINTER) - (GC-TEST-TYPE 218 POINTER) - (GC-TEST-TYPE 220 (BITS . 15)) - (GC-TEST-TYPE 218 (FLAGBITS . 0)) - (GC-TEST-TYPE 222 POINTER) - (GC-TEST-TYPE 224 POINTER) - (GC-TEST-TYPE 226 POINTER) - (GC-TEST-TYPE 228 FIXP) - (GC-TEST-TYPE 230 POINTER) - (GC-TEST-TYPE 232 POINTER) - (GC-TEST-TYPE 234 POINTER) - (GC-TEST-TYPE 236 POINTER) - (GC-TEST-TYPE 236 (FLAGBITS . 0)) - (GC-TEST-TYPE 238 POINTER) - (GC-TEST-TYPE 240 POINTER) - (GC-TEST-TYPE 242 POINTER) - (GC-TEST-TYPE 244 POINTER) - (GC-TEST-TYPE 246 FIXP) - (GC-TEST-TYPE 248 POINTER) - (GC-TEST-TYPE 248 (BITS . 7)) - (GC-TEST-TYPE 250 POINTER) - (GC-TEST-TYPE 252 FIXP) - (GC-TEST-TYPE 221 (BITS . 15)) - (GC-TEST-TYPE 254 POINTER) - (GC-TEST-TYPE 256 (BITS . 15)) - (GC-TEST-TYPE 257 FIXP) - (GC-TEST-TYPE 260 POINTER) - (GC-TEST-TYPE 262 FIXP) - (GC-TEST-TYPE 264 POINTER) - (GC-TEST-TYPE 264 (FLAGBITS . 0)) - (GC-TEST-TYPE 260 (BITS . 7)) - (GC-TEST-TYPE 266 POINTER) - (GC-TEST-TYPE 268 POINTER) - (GC-TEST-TYPE 270 XPOINTER) - (GC-TEST-TYPE 270 (BITS . 7)) - (GC-TEST-TYPE 272 POINTER) - (GC-TEST-TYPE 274 POINTER) - (GC-TEST-TYPE 274 (FLAGBITS . 0)) - (GC-TEST-TYPE 272 (BITS . 7)) - (GC-TEST-TYPE 259 (BITS . 15)) - (GC-TEST-TYPE 276 POINTER) - (GC-TEST-TYPE 278 FIXP) - (GC-TEST-TYPE 280 POINTER) - (GC-TEST-TYPE 282 POINTER) - (GC-TEST-TYPE 282 (BITS . 7)) - (GC-TEST-TYPE 284 POINTER) - (GC-TEST-TYPE 286 POINTER) - (GC-TEST-TYPE 288 POINTER) - (GC-TEST-TYPE 290 POINTER) - (GC-TEST-TYPE 292 POINTER) - (GC-TEST-TYPE 292 (BITS . 7)) - (GC-TEST-TYPE 294 FIXP) - (GC-TEST-TYPE 296 POINTER) - (GC-TEST-TYPE 298 POINTER) - (GC-TEST-TYPE 300 POINTER) - (GC-TEST-TYPE 300 (BITS . 7)) - (GC-TEST-TYPE 302 POINTER) - (GC-TEST-TYPE 304 (BITS . 15)) - (GC-TEST-TYPE 306 POINTER) - (GC-TEST-TYPE 308 POINTER) - (GC-TEST-TYPE 310 POINTER) - (GC-TEST-TYPE 312 POINTER) - (GC-TEST-TYPE 305 (BITS . 15)) - (GC-TEST-TYPE 314 POINTER) - (GC-TEST-TYPE 314 (FLAGBITS . 0)) - (GC-TEST-TYPE 316 POINTER) - (GC-TEST-TYPE 318 XPOINTER) - (GC-TEST-TYPE 320 POINTER) - (GC-TEST-TYPE 322 POINTER) - (GC-TEST-TYPE 324 POINTER) - (GC-TEST-TYPE 324 (FLAGBITS . 0)) - (GC-TEST-TYPE 326 POINTER) - (GC-TEST-TYPE 328 (BITS . 15)) - (GC-TEST-TYPE 326 (BITS . 7)) - (GC-TEST-TYPE 330 POINTER) - (GC-TEST-TYPE 332 POINTER) - (GC-TEST-TYPE 334 POINTER) - (GC-TEST-TYPE 336 FIXP) - (GC-TEST-TYPE 338 POINTER) - (GC-TEST-TYPE 340 POINTER) - (GC-TEST-TYPE 342 XPOINTER) - (GC-TEST-TYPE 344 POINTER) - (GC-TEST-TYPE 344 (FLAGBITS . 0)) - (GC-TEST-TYPE 346 POINTER) - (GC-TEST-TYPE 346 (FLAGBITS . 0)) - (GC-TEST-TYPE 329 (BITS . 15)) - (GC-TEST-TYPE 346 (FLAGBITS . 16)) - (GC-TEST-TYPE 348 (BITS . 15)) - (GC-TEST-TYPE 350 POINTER) - (GC-TEST-TYPE 352 POINTER) - (GC-TEST-TYPE 354 POINTER) - (GC-TEST-TYPE 356 POINTER) - (GC-TEST-TYPE 358 POINTER) - (GC-TEST-TYPE 360 XPOINTER) - (GC-TEST-TYPE 362 POINTER) - (GC-TEST-TYPE 349 (BITS . 15)) - (GC-TEST-TYPE 364 (BITS . 15)) - (GC-TEST-TYPE 366 POINTER) - (GC-TEST-TYPE 368 POINTER) - (GC-TEST-TYPE 370 POINTER) - (GC-TEST-TYPE 372 POINTER) - (GC-TEST-TYPE 374 POINTER) - (GC-TEST-TYPE 376 POINTER) - (GC-TEST-TYPE 378 POINTER) - (GC-TEST-TYPE 380 XPOINTER) - (GC-TEST-TYPE 382 POINTER) - (GC-TEST-TYPE 365 (BITS . 15)) - (GC-TEST-TYPE 384 POINTER) - (GC-TEST-TYPE 386 POINTER) - (GC-TEST-TYPE 388 XPOINTER) - (GC-TEST-TYPE 390 POINTER) - (GC-TEST-TYPE 392 POINTER) - (GC-TEST-TYPE 394 POINTER) - (GC-TEST-TYPE 396 POINTER) - (GC-TEST-TYPE 398 POINTER) - (GC-TEST-TYPE 400 POINTER) - (GC-TEST-TYPE 402 POINTER) - (GC-TEST-TYPE 404 POINTER) - (GC-TEST-TYPE 406 POINTER) - (GC-TEST-TYPE 408 POINTER) - (GC-TEST-TYPE 410 XPOINTER) - (GC-TEST-TYPE 412 POINTER) - (GC-TEST-TYPE 414 FIXP) - (GC-TEST-TYPE 416 POINTER) - (GC-TEST-TYPE 418 POINTER) - (GC-TEST-TYPE 420 XPOINTER) - (GC-TEST-TYPE 422 POINTER) - (GC-TEST-TYPE 424 (BITS . 15)) - (GC-TEST-TYPE 422 (FLAGBITS . 0)) - (GC-TEST-TYPE 426 POINTER) - (GC-TEST-TYPE 428 POINTER) - (GC-TEST-TYPE 430 POINTER) - (GC-TEST-TYPE 432 POINTER) - (GC-TEST-TYPE 434 POINTER) - (GC-TEST-TYPE 434 (BITS . 7)) - (GC-TEST-TYPE 436 POINTER) - (GC-TEST-TYPE 438 POINTER) - (GC-TEST-TYPE 438 (FLAGBITS . 0)) - (GC-TEST-TYPE 436 (BITS . 7)) - (GC-TEST-TYPE 440 POINTER) - (GC-TEST-TYPE 442 POINTER) - (GC-TEST-TYPE 444 POINTER) - (GC-TEST-TYPE 446 XPOINTER) - (GC-TEST-TYPE 425 (BITS . 15)) - (GC-TEST-TYPE 448 (BITS . 15)) - (GC-TEST-TYPE 450 POINTER) - (GC-TEST-TYPE 452 POINTER) - (GC-TEST-TYPE 454 POINTER) - (GC-TEST-TYPE 449 (BITS . 15)) - (GC-TEST-TYPE 456 POINTER) - (GC-TEST-TYPE 458 XPOINTER) - (GC-TEST-TYPE 458 (BITS . 7)) - (GC-TEST-TYPE 460 POINTER) - (GC-TEST-TYPE 462 XPOINTER) - (GC-TEST-TYPE 462 (FLAGBITS . 0)) - (GC-TEST-TYPE 464 POINTER) - (GC-TEST-TYPE 466 POINTER) - (GC-TEST-TYPE 466 (FLAGBITS . 0)) - (GC-TEST-TYPE 468 POINTER) - (GC-TEST-TYPE 470 POINTER) - (GC-TEST-TYPE 472 XPOINTER) - (GC-TEST-TYPE 474 FIXP) - (GC-TEST-TYPE 476 FIXP) - (GC-TEST-TYPE 472 (BITS . 7)) - (GC-TEST-TYPE 478 POINTER) - (GC-TEST-TYPE 480 POINTER) - (GC-TEST-TYPE 482 POINTER) - (GC-TEST-TYPE 484 POINTER) - (GC-TEST-TYPE 486 FIXP) - (GC-TEST-TYPE 488 POINTER) - (GC-TEST-TYPE 488 (FLAGBITS . 0)) - (GC-TEST-TYPE 490 FIXP) - (GC-TEST-TYPE 492 POINTER) - (GC-TEST-TYPE 494 XPOINTER) - (GC-TEST-TYPE 496 POINTER) - (GC-TEST-TYPE 498 POINTER) - (GC-TEST-TYPE 498 (BITS . 7)) - (GC-TEST-TYPE 500 POINTER) - (GC-TEST-TYPE 502 (BITS . 15)) - (GC-TEST-TYPE 503 FIXP) - (GC-TEST-TYPE 506 POINTER) - (GC-TEST-TYPE 506 (FLAGBITS . 0)) - (GC-TEST-TYPE 508 POINTER) - (GC-TEST-TYPE 505 (BITS . 15))) - '510) - - - -(* |;;| "DATATYPE TESTS") - - - - -(* |;;| "CODE RECLAIMATION TESTS") - -(DEFINEQ - -(CODE-RECLAIM-TEST - (LAMBDA (LIMIT) (* \; "Edited 23-Jun-88 11:54 by jds") - (LET NIL - - (* |;;| "Make sure there's a definition to compile.") - - (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN) - (EVAL CODE-RECLAIM-TEST-TEMP-FN)) - (PRINTOUT T " Starting code-block reclaim test" T) - (|for| I |from| 1 |to| LIMIT |do| (BKSYSBUF "ST -N -") - (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN)) - (PRINTOUT T " Starting MAPATOMS(GETD)" T) - (|for| I |from| 1 |to| LIMIT |do| (MAPATOMS (FUNCTION GETD))) - (PRINTOUT T " Starting MAPATOMS(MOVD to DUMMYFN)" T) - (FOR I FROM 1 TO LIMIT DO (MAPATOMS #'(LAMBDA (FN-NAME) - (AND (GETD FN-NAME) - (MOVD FN-NAME - 'MAIKO-GC-TEST-DUMMY-FN)) - )))))) -) - - - -(* |;;| -"The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed." -) - - -(RPAQQ CODE-RECLAIM-TEST-TEMP-FN - (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF) - (LET (I) - (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (NLSETQ (DATE)) - (ERSETQ (DATE)) - (CL:FLET ((TEMP (ARG) - (SETQ ARG (FLOAT ARG)) - (EXPT (SQRT I) - (SQRT (COS (/ I 180)))))) - (CL:UNWIND-PROTECT - (FOR I FROM 1 TO 1000 COLLECT (TEMP I)) - (SETQ I NIL))))))) -(PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (2794 5208 (MAIN-GC-TEST 2804 . 5206)) (5209 13651 (ITEMS-ON-STACK-TEST 5219 . 6382) ( -MANY-BIGNUM-MAKER 6384 . 7256) (MANY-FIXP-MAKER 7258 . 8044) (MANY-FLOAT-MAKER 8046 . 8653) ( -BOUNDARY-TESTS 8655 . 11122) (ARRAY-STRING-TEST 11124 . 13070) (VARIOUS-TYPES-TEST 13072 . 13649)) ( -13652 18513 (TEDIT-CRUNCH-TEST 13662 . 15074) (LIST-MANIPULATION-TEST 15076 . 18511)) (18514 19198 ( -ATOM-FULL-TEST 18524 . 18955) (STORAGE-FULL-TEST 18957 . 19196)) (19199 19717 (DATATYPE-TEST 19209 . -19715)) (44700 45875 (CODE-RECLAIM-TEST 44710 . 45873))))) -STOP diff --git a/internal/test/IO/Keyboard/logs/keyboard.log.~1~ b/internal/test/IO/Keyboard/logs/keyboard.log.~1~ deleted file mode 100644 index 308b933d..00000000 --- a/internal/test/IO/Keyboard/logs/keyboard.log.~1~ +++ /dev/null @@ -1,13 +0,0 @@ -;;; Test results for sysout of 12-Feb-88 18:51:29 -;;; Tests run on 17-Feb-88 14:16:42 -;;; Running tests from ({eris}i/o>keyboard>hand>*.u;) - -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" -:BEFORE forms for test "Testing AskUser" in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" failed. -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" -:BEFORE forms for test "Testing PromptForWord" in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" failed. -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" -:BEFORE forms for test "Testing ReadNumber" in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" failed. -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" -:BEFORE forms for test "Testing TTYIN" in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" failed. -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/IO/Keyboard/logs/keyboard.log.~2~ b/internal/test/IO/Keyboard/logs/keyboard.log.~2~ deleted file mode 100644 index eab193eb..00000000 --- a/internal/test/IO/Keyboard/logs/keyboard.log.~2~ +++ /dev/null @@ -1,13 +0,0 @@ -;;; Test results for sysout of 12-Feb-88 18:51:29 -;;; Tests run on 17-Feb-88 14:21:48 -;;; Running tests from ({eris}i/o>keyboard>hand>*.u;) - -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" -:BEFORE forms for test "Testing AskUser" in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" failed. -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" -:BEFORE forms for test "Testing PromptForWord" in file "{ERIS}I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" failed. -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" -:BEFORE forms for test "Testing ReadNumber" in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" failed. -Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" -:BEFORE forms for test "Testing TTYIN" in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" failed. -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/IO/Keyboard/logs/keyboard.log.~3~ b/internal/test/IO/Keyboard/logs/keyboard.log.~3~ deleted file mode 100644 index 8bffe6e1..00000000 --- a/internal/test/IO/Keyboard/logs/keyboard.log.~3~ +++ /dev/null @@ -1,15 +0,0 @@ -;;; Test results for sysout of 12-Feb-88 18:51:29 -;;; Tests run on 2-Mar-88 15:20:41 -;;; Running tests from ({ERIS}I/O>Keyboard>Hand>*.U) - -Test "TTYIN, test default in the XCL exec" failed in file "{ERIS}I/O>KEYBOARD>HAND>ASKUSER.U;1" - -Test "Test decimal & abort" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" -Test "Test number font" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" -Test "Test can call from XCL" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" -Test "Test create.numberpad.reader" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" -Test "Test create.numberpad.reader" failed in file "{ERIS}I/O>KEYBOARD>HAND>READNUMBER.U;1" - -Test "Test shift select for TTYIN in XCL-TEST exec" failed in file "{ERIS}I/O>KEYBOARD>HAND>TTYIN.U;1" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/Library/TEDIT/hand-aux/.read-me-first.~1~ b/internal/test/Library/TEDIT/hand-aux/.read-me-first.~1~ deleted file mode 100644 index e03a0e3478fcc1ad0b0352331b82dabf37b53f4b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3981 zcmeHHO>Y}F5M|_i6irq15Fk17kV6l#AiF>hg|L9*-Jl8_E07i_atTU_l$HUt6i99x zwdfz}Pe}elPWeC18?NL?wp3V63#5hDh9u9tdGqGY$ayAp;6I8|?g!-qKdN49qlKIE zC)z0A%nR)~enrWJnH6HFf*uLOjRx3`c_{pa-dDU4*XXg3XV+4r@~Ei>06wm0qGuA6Yv1$16o)|bNZkS zD4g=DL@9%udD zTgl6D8rPmW$Z>7C|jx1Sy7y?!?vM8~?PdDeg4&jy1FSu8}C zBNYu9TMS;G9_^0Q|CtJ8-5V?uIqXnN#S7(dJJ^{rrq%2L=N4t55P=J1vDw8j;{xa$ zerVQA2kre)yOnA`Gh$Apiwn)sOvYYZYC4K(-4b3Mv}cgD5G3o$CEMZdY=_&~qPCyX z9VNwsQEpArl}J{Vtdrne;#n<}q>FpHV9?rWwVFv%imB>!7DY)Sl^=CFi2G_7zwe)C z{;v;XpcG&Gm$v5f(@q{el>FG z^G!H(kKKOOOSArIoEeY?TZw&nUh@$LAL#+Ee!GP?P9N)r4F<#6&lG@ncrKv#i|_`Zd*FjrAXau8l<=eX&shxp)gR5w^HSXIXE+A zQ7CQA0Z!9Qagrl4J(uvw7#vVFrsW)VT!L_+G*!=72?7f(jL6}_ zs7x%2S8&beniq+IQGlj`K`<9_x?txe6kT#vakZQ$&?iQmja24qK}p{MshHV%LYPRU zWtLNCa2LP#ppa0?3m2?2xDNK!DYVR~d=*Ka6c=7DK($pYRXk?h&hVr+9vwez3{FO8 z;8RmkIU3foSj=2-M2XBm9#hkEbf#gYfr%>CSVd(9PT=+>cy}&%Y7|@g;c<*c9``3` z{mJt|=jG{W7hc<3L^8!wH6A7 z#Qi`~?I`+Rx*Vtal|MrbWh_`C(2L0QQlx34HUdspYL+^m;}n&xMiewszkgZtmJXZs zsM+XBQ>1)B4y%a^;VgE(SS+b2GVc;x9X1PuRRt7#&84-YyIVWjZOz5@P4|u=xrPyX zBcwMnvL4B%5wweIt16Oi)lWAF+GwrD(*F*ECql4|)v(0xpl~OClcb$6XLd!yF4&Dk zZ^NE-hEMzTZtwWTSB_ zsnaF5vF$t6g;g#g7(p6Lx82bO)j~Cq7Fgn|H2vZ$v?^eD0TND2P1$5h3tU%-)UE%O z)z}3`dm4)y^XcysKC>Wz(650`5u3)}hQm>a?M$}-Xrp@%fs}caU^A8lv6HL3F0OFN zbGICiX}7_k!RDb_CA=s^4m91e61*)JYQaH7t=-OfCR(kk_U(2oOw?++@(B%xsUa%&6w9@Er-j9Ud?Em_CvK@V(Uusr*JK-kOKjNU#mM_w72AbU#}ckd04Ba7&j2M|84u zb4Tchr2A%8{}Jd$T14mew1|Pn6xuSaJ3_a|y4C92fwn35Tf9;Lf6&Q#S}xCRP?Bvz p-y^{`Xz>0!=sO1f2Mo~Qd_;NPngSAROu@enMMRH&4u1XN)t_Vm#b^Kk diff --git a/internal/test/Library/TEDIT/hand-aux/.read-me-first.~3~ b/internal/test/Library/TEDIT/hand-aux/.read-me-first.~3~ deleted file mode 100644 index 08f34d112e8bc0cb578ec6eb3a86a939de043a25..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5488 zcmeHJTW=dh6yBy6A;1WUO7w9akSJ2tB&jF}S(co5le%^7%H9$xRK$39?44$JXPMni z;v)VI54`bOBz^_r@09P%tXQyELH zr)*!wBCq+8%o+akl<_!=_(&8o;4zCOz-r8jNU$*>nM%zcq0}NM6cqg6X_^1n@S(QZ zl_L$MO`ps)jX79q)@!ZNNQ+~4$dfDfNL1Y}tGZDzK6qSLT{6bWN?X9i5cb4MmjM-F`@VVXbaTS~rZ$^8>br`5@ z$|QUuQ04PP6f76VLWA&(Pl#kNE=~&@BTiCyrY90M8G`}J#;BY?j|mVal&0+Eg#>|_ z7P&}aB3Fr+B`@QePc+Y>97+Ki2?oJLgz=O;D{;{TS0z`=Nrd~vh|v+tbipZUD$&zB+O9iMd6pIxPS-aKS^9KFh z`}OW#{~`F)lvIv_Em$bV#yO%yCLoWg(KA$L&dMArDqlktlnFS2*(c!LnBZ})*vt+O zLlp9$GejYKLw{W%lS?Cox@&iakGicV`~9BZ?hL#=zdz`BL&I37=X--k18+E7IYmNb z8ko{T!VtJ^D9Rmq|8tw;RKKui$e|1civ(&Bk)DV+uGjj&>FQcRmCtdC%vLQ58mZpD ztXWOlTW+vbZ_7N3`IHP+9p}SXXl$`iQc)z7gDn5$+8lZiz%zhlXg{4D+Dc-R()oF4Z%Yp*wSd2;nz^O7Qal=T9{Eg zr(qpzCD6052d&=yj@$NjA0N~owmRL~s=)2G_B+1k`u)AdvmJx3_}fFBaa2;5k7XfP zBJ$i!G*hk-KNjo(PoK%EF_WqxRf&OPnhVuF!nj1AX@S`RV}P?20;r_W18uXGN=Y>9%z9fJ`d9lzD%nOil-o9ztj{>qO`!e zf~RKu&$WieIhxZL+~`lcPx!b10fc@9G#4>x>^AK6eN1QC0-%ld9vmstAi`uUGh!!I zsVh#gGJ$KmYb}h?r6!ig}@eN=?X zszYY@GLFa8E~sIdN?q@_Wx~wL857_krgf#+Y`dAiticwPYSjdFyPJ&f?U1wS8o3e+tx3#e|g)R_OkuCVWMA@ocaA4 z7`o})c-U`ygPw^QkPT-+_V)bFD;#*F4{-MDI=&eFY7K5UAl&(m1mF%IEBJtZB>~_Y z^Ao!A8=Y8f7Fr|0dC-k-7ol|b_M(7vd`N;bcS*2ACo?mbguX|2FQ)Y$fi8tbbesSyn}u~r==r{$tM&Cjo8^pFBF#1teIi*Z&*}k7~a-zdnEQCxArY%m4rY diff --git a/internal/test/env/DEdit/high-level.u.~1~ b/internal/test/env/DEdit/high-level.u.~1~ deleted file mode 100644 index 08a976a2..00000000 --- a/internal/test/env/DEdit/high-level.u.~1~ +++ /dev/null @@ -1,253 +0,0 @@ -;; Being tested: DEdit -;; -;; Source: -;; -;; Created By: Henry Cate III -;; -;; Creation Date: March 2, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>DEdit>high-level.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Just touch various commands" - :before (progn - (setq window-list (do-test-menu-Setup "Various commands in DEdit"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Test able to bring up SEdit" - (let* ((user-result (do-test-menu-Message window-list 'high -" Test able to bring up SEdit -If there is no free Interlisp exec, bring up a another one. -In the Interlisp exec type: - -(FILESLOAD dedit) -(EDITMODE 'DEDIT) -(SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ED 'tempx) - -Click on the last option in the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Now try placing something after" - (let* ((user-result (do-test-menu-Message window-list 'high -" Now try placing something after -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In an Interlisp exec type: \"(ED 'tempx)\" -Click twice on the litatom \"efg\". -Type \"h\" and press the carriage return. -Select the first option on the DEdit menu, \"After\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try placing something before" - (let* ((user-result (do-test-menu-Message window-list 'high -" Try placing something before -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In an Interlisp exec type: \"(ED 'tempx)\" -Click twice on the litatom \"bye\". -Type \"Good\" and press the carriage return. -Select the option on the DEdit menu, \"Before\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|Good| il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try deleting" - (let* ((user-result (do-test-menu-Message window-list 'high -" Try deleting -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (Good bye) \"hi\" (b) cd 4)) -In an Interlisp exec type: \"(ED 'tempx)\" -Click twice on the litatom \"Good\". -Select the option on the DEdit menu, \"Delete\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try from XCL-text" - (let* ((user-result (do-test-menu-Message window-list 'high -" Try from XCL-text -Close the old DEdit window. -If there is no free Xerox Common Lisp exec, bring up a another one. -In the Xerox Common Lisp exec type: - -(cl:in-package 'xcl-test) -(SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ED 'tempx) - -Click on the last option in the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Test replace" - (let* ((user-result (do-test-menu-Message window-list 'high -" Test replace -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(ED 'tempx)\" -Click twice on the litatom \"efg\". -Type \"gfe\" and press the carriage return. -Select the option on the DEdit menu, \"Replace\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd gfe "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Test switch" - (let* ((user-result (do-test-menu-Message window-list 'high -" Test switch -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd gfe \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(ED 'tempx)\" -First click the litatom \"efg\". -Then click on the number \"4.5\". -Select the option on the DEdit menu, \"Switch\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 gfe 6/7 a cd 4.5 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try with dv." - (let* ((user-result (do-test-menu-Message window-list 'high -" Try with dv. -Close the old DEdit window. -In the Xerox Common Lisp exec type: - -(SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Click on the last option in the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "parenthesize" - (let* ((user-result (do-test-menu-Message window-list 'high -" parenthesize -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(il:dv 'tempx)\" -Click twice on the string \"hello\". -Select the option on the DEdit menu, \"()\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Un parenthesize" - (let* ((user-result (do-test-menu-Message window-list 'high -" Un parenthesize -Assumping DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg (\"hello\") \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(il:dv 'tempx)\" -First click the list \"(b)\". -Select the option on the DEdit menu, \"() out\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Now try editing a function" - (do-test-menu-Message window-list 'high -" Now try editing a function -Close the old DEdit window. -In the Xerox Common Lisp exec type: - -(defun temp-silly-bottom-fun (a b c) (list a b c)) -(defun temp-silly-fun (a b c) (temp-silly-bottom-fun a b c)) -(ED 'temp-silly-fun) - -Were you able to get this far? ")) - - -(do-test "See if find works." - (do-test-menu-Message window-list 'high -" See if find works. -Assumping DEdit is editing the function temp-silly-fun -Click twice on the first occurance of the litatom \"b\" -Select the option on the DEdit menu, \"Find\" -Did DEdit find the second occurance of the litatom \"b\"? ")) - - -(do-test "Test swap" - (do-test-menu-Message window-list 'high -" Test swap -Assumping DEdit is editing the function temp-silly-fun -First click on the first occurance of the litatom \"b\" -Then click on the second occurance of the litatom \"c\" -Select the option on the DEdit menu, \"Swap\" -Did the solid underline and dotted underline switch places? ")) - - -(do-test "Test reprint" - (do-test-menu-Message window-list 'high -" Test reprint -Assumping DEdit is editing the function temp-silly-fun -Watch carefully, -Select the option on the DEdit menu, \"Reprint\" -Does the function get reprinted? (Do the underlines get reprinted?) ")) - - -(do-test "Test editing of other functions" - (do-test-menu-Message window-list 'high -" Test editing of other functions -Assumping DEdit is editing the function temp-silly-fun -Click on the function call to \"temp-silly-bottom-fun\" -Select the option on the DEdit menu, \"Edit\" -Does the second function come up in DEdit? ")) - - - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the DEdit window by selecting Exit from both option window menus as they appear.")) - -) ; end of do-test-group - - -STOP - - diff --git a/internal/test/env/DEdit/high-level.u.~2~ b/internal/test/env/DEdit/high-level.u.~2~ deleted file mode 100644 index 67569912..00000000 --- a/internal/test/env/DEdit/high-level.u.~2~ +++ /dev/null @@ -1,254 +0,0 @@ -;; Being tested: DEdit -;; -;; Source: -;; -;; Created By: Henry Cate III -;; -;; Creation Date: March 2, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>DEdit>high-level.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Just touch various commands" - :before (progn - (setq window-list (do-test-menu-Setup "Various commands in DEdit"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Test able to bring up SEdit" - (let* ((user-result (do-test-menu-Message window-list 'high -" Test able to bring up SEdit -If there is no free Interlisp exec, bring up a another one. -In the Interlisp exec type: - -(FILESLOAD dedit) -(EDITMODE 'DEDIT) -(SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ED 'tempx) - -Click on the last option in the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Now try placing something after" - (let* ((user-result (do-test-menu-Message window-list 'high -" Now try placing something after -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In an Interlisp exec type: \"(ED 'tempx)\" -Click twice on the litatom \"efg\". -Type \"h\" and press the carriage return. -Select the first option on the DEdit menu, \"After\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try placing something before" - (let* ((user-result (do-test-menu-Message window-list 'high -" Try placing something before -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In an Interlisp exec type: \"(ED 'tempx)\" -Click twice with the left mouse button on the litatom \"bye\". -Type \"Good\" and press the carriage return. -Select the option on the DEdit menu, \"Before\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|Good| il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try deleting" - (let* ((user-result (do-test-menu-Message window-list 'high -" Try deleting -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg h \"hello\" \"BYE\" (Good bye) \"hi\" (b) cd 4)) -In an Interlisp exec type: \"(ED 'tempx)\" -Click twice with the left mouse button on the litatom \"Good\". -Select the option on the DEdit menu, \"Delete\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 il:\a il:|cd| il:|efg| il:\h "hello" "BYE" (il:|bye|) ("hi" (il:\b) il:|cd| 4)) (il:eval 'il:|tempx|)))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try from XCL-text" - (let* ((user-result (do-test-menu-Message window-list 'high -" Try from XCL-text -Close the old DEdit window. -If there is no free Xerox Common Lisp exec, bring up a another one. -In the Xerox Common Lisp exec type: - -(cl:in-package 'xcl-test) -(SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ED 'tempx) - -Click on the last option in the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Test replace" - (let* ((user-result (do-test-menu-Message window-list 'high -" Test replace -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(ED 'tempx)\" -Click twice with the left mouse button on the litatom \"efg\". -Type \"gfe\" and press the carriage return. -Select the option on the DEdit menu, \"Replace\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd gfe "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Test switch" - (let* ((user-result (do-test-menu-Message window-list 'high -" Test switch -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd gfe \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(ED 'tempx)\" -First click the litatom \"efg\" with the left mouse button. -Then click on the number \"4.5\". -Select the option on the DEdit menu, \"Switch\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 gfe 6/7 a cd 4.5 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Try with dv." - (let* ((user-result (do-test-menu-Message window-list 'high -" Try with dv. -Close the old DEdit window. -In the Xerox Common Lisp exec type: - -(SETQ tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Click on the last option in the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (EQUAL '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "parenthesize" - (let* ((user-result (do-test-menu-Message window-list 'high -" parenthesize -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(il:dv 'tempx)\" -Click twice with the left mouse button on the string \"hello\". -Select the option on the DEdit menu, \"()\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Un parenthesize" - (let* ((user-result (do-test-menu-Message window-list 'high -" Un parenthesize -Assuming DEdit just finished editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg (\"hello\") \"BYE\" (bye) (\"hi\" (b) cd 4)) -In the XCL-test exec type: \"(il:dv 'tempx)\" -First click the list \"(b)\" with the left mouse button on the \"(\". -Select the option on the DEdit menu, \"() out\" -Select the last option on the DEdit menu, \"Exit\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg ("hello") "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Now try editing a function" - (do-test-menu-Message window-list 'high -" Now try editing a function -Close the old DEdit window. -In the Xerox Common Lisp exec type: - -(defun temp-silly-bottom-fun (a b c) (list a b c)) -(defun temp-silly-fun (a b c) (temp-silly-bottom-fun a b c)) -(ED 'temp-silly-fun) - -Were you able to get this far? ")) - - -(do-test "See if find works." - (do-test-menu-Message window-list 'high -" See if find works. -Assuming DEdit is editing the function temp-silly-fun -Click twice on the first occurance of the litatom \"b\" -Select the option on the DEdit menu, \"Find\" -Did DEdit find the second occurance of the litatom \"b\"? ")) - - -(do-test "Test swap" - (do-test-menu-Message window-list 'high -" Test swap -Assuming DEdit is editing the function temp-silly-fun -First click with the left mouse button on the first occurance of the litatom \"b\" -Then click on the second occurance of the litatom \"c\" -Select the option on the DEdit menu, \"Swap\" -Did the solid underline and dotted underline switch places? ")) - - -(do-test "Test reprint" - (do-test-menu-Message window-list 'high -" Test reprint -Assuming DEdit is editing the function temp-silly-fun -Select the entire function by clicking on the first \"(\" with the left mouse button. -Watch carefully, -Select the option on the DEdit menu, \"Reprint\" -Does the function get reprinted? (Do the underlines get reprinted?) ")) - - -(do-test "Test editing of other functions" - (do-test-menu-Message window-list 'high -" Test editing of other functions -Assuming DEdit is editing the function temp-silly-fun -Click with the left mouse button on the function call to \"temp-silly-bottom-fun\" -Select the option on the DEdit menu, \"Edit\" -Does the second function come up in DEdit? ")) - - - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the DEdit window by selecting Exit from both option window menus as they appear.")) - -) ; end of do-test-group - - -STOP - - diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~1~ b/internal/test/env/Debugger/hand/BreakWindow.u.~1~ deleted file mode 100644 index 1fd6e93e..00000000 --- a/internal/test/env/Debugger/hand/BreakWindow.u.~1~ +++ /dev/null @@ -1,3 +0,0 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Erinyes}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test "bring up exec" (do-test-menu-message dtmw 'low (concatenate 'string "From the background menu, bring up a new exec. " "In the exec " "(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) (do-test-group "STEPPER" (do-test "call step" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon."))) (do-test "step space" (do-test-menu-message dtmw 'low (concatenate 'string "Type a space in the exec window after the colon. " "You should see a long progn form followed by a colon." " Type another space. " "You should see the rest of the first part of the form."))) (do-test "step Next" (do-test-menu-message dtmw 'low (concatenate 'string "Type N in the exec window after the colon. " "You should see a long lambda form."))) (do-test "step Debugger (AR 7709)" (do-test-menu-message dtmw 'low (concatenate 'string "Type d in the exec window after the colon. " "You should see a break window."))) (do-test "step break window OK" (do-test-menu-message dtmw 'low (concatenate 'string "Type ok in the break window and hit return. " "The break window should go a way and" " you should see a colon."))) (do-test "step Finish" (do-test-menu-message dtmw 'low (concatenate 'string "Type f in the exec widnow after the colon. " " You should see the word foo three times " "followed by a new Exec promp."))) (do-test "step uparrow" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon." " Type an uparrow. " "You should see the word abort and then an exec prompt.")))) (do-test-group ("EVAL UB OK") (do-test "menued commands" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter IL:*DEBUGGER-MENU-ITEMS* " "You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) (do-test "eval create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec " " (progn (unbreak foo) " " (defun foo nil (print \"hello\")) " " (break-function 'foo))(foo) " "You should then see a break window containing Breakpoint at foo"))) (do-test "pre eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"Not yet evaluated.\""))) (do-test "type eval" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the EVAL command. " "You should see \"hello\""))) (do-test "menu eval" (do-test-menu-message dtmw 'low (concatenate 'string "Select EVAL from the middle button menu in the break window. " "You should see \"hello\""))) (do-test "type ub" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the UB command. " "You should see (foo)"))) (do-test "post eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"hello\""))) (do-test "menu OK" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, select the OK command. " "The break window should disappear and " "you should see \"hello\" in the exec.")))) (do-test-group ("proceed comands") (do-test "create break window" (defun foo nil (proceed-case (break) (use-value (x) :report "Provide a value to use as the result" x) (nil nil :report "Just return NIL"))) (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "You should then see a break window containing " "Break"))) (do-test "use value PROCEED command from menu" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, " "select the PROCEED command. " "You should then see a menu pop up. " " Select \"Provide a value to use as the result\" from the menu. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PROCEED command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PROCEED command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Provide a value to use as the result. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PR command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PR command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Provide a value to use as the result. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window.")))) (do-test-group ("RETURN") (do-test "RETURN T command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN command. " "The break window should go away and " "you should see a NIL result in the exec."))) (do-test "RETURN command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN T command. " "The break window should go away and " "you should see a T result in the exec.")))) (do-test-group ("?= uparrow") (do-test "?= create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Type (foo) to the exec " "You should then see a break window "))) (do-test "type ?=" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the ?= command. " "You should see the two parameters: (break) and a Lexical Environment."))) (do-test "menu ?=" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ?= command. " "You should see the same two parameters."))) (do-test "BREAKDELIMITER correct default" (do-test-menu-message dtmw 'low (concatenate 'string "Enter IL:BREAKDELIMITER " "You should see some representation of a " "carriage return character such as a quoted new line."))) (do-test "menu ^" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ^ command. " "The break window should disappear " "and the caret should be back in the exec " "with no value returned.")))) (do-test-group "BREAK WINDOW" (do-test "create break window" (do-test-menu-message dtmw 'low (concatenate 'string "In an exec type control B to cause a break. " "You should see a break window pop up."))) (do-test "type BT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT command. " "You should see a backtrace scroll by. " "(If the window turns black, just hit a space.)"))) (do-test "type DBT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "menu BT" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window," "choose the BT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "type BT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT! command. " "You should see a longer backtrace scroll by."))) (do-test "menu DBT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT! command. " "You should see the detailed backtrace in a " "window appended to the side of the break window. "))) (do-test "menu BT!" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window, " "choose the BT! command. " "You should see a more detailed backtrace window appear " "appended to the side of the break window. "))) (do-test "scroll BT!" (do-test-menu-message dtmw 'low (concatenate 'string " You should be able to scroll up and down in the backtrace window."))) (do-test "BTV command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV command. " "You should see an even more detailed " "backtrace scroll by. " "Terminate scrolling by hitting CTRLe. "))) (do-test "BTV! command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV! command. " "You should see an even more detailed backtrace window appear " "scroll by. Terminate scrolling by hitting CTRLe. ")))) (do-test-group ("@ REVERT STOP") (do-test "@" (do-test-menu-message dtmw 'low (concatenate 'string "Enter an at-sign command. " "@ " "You should see @ = il:interrupt."))) (do-test "@ foo" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ foo " "[Note: space between the @ and foo.] " "You should see FOO not found."))) (do-test "@ exec-read" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read " "You should see @ = il:exec-read."))) (do-test "@ exec-read / 1 (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read / 1 " "You should see @ = il:exec-read again."))) (do-test "@ = exec-read (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ = exec-read " "You should see @ = il:exec-read again."))) (do-test "@ number (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ 3 " "You should see the name of the third stack item."))) (do-test "frame window" (do-test-menu-message dtmw 'low (concatenate 'string "In the backtrace window attached to the break window " "find IL:TTYIN and select it with the left mouse button. " "You should see the frame window for ttyin pop up. "))) (do-test "menu revert" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button In the break window " "(not the frame window) , " "select REVERT from the menu.. " "You should see the break window re-initialize as " "Breakpoint at IL:TTYIN. "))) (do-test "STOP" (do-test-menu-message dtmw 'low (concatenate 'string "Enter STOP " "The break window should disappear " "and the carot should be back in the exec.")))) (do-test-group ("*short-backtrace-filter*") (do-test "*short-backtrace-filter*" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec enter: il:*short-backtrace-filter* " "You should see an appropriate predicate name " "such as xcl::interesting-frame-p.")))) (do-test-group ("EDIT") (do-test "EDIT search for editable fn (AR 8137)" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "Enter EDIT in the resulting break window. " "An editor window for foo should appear. " "Close the editor window."))) (do-test "EDIT selected fn (AR 6231)" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the DBT command. " "Select the foo frame from the BT menu window with the mouse. " "Type EDIT in the break window. " "An editor window should appear."))) (do-test "EDIT OK (AR 8139)" (do-test-menu-message dtmw 'low (concatenate 'string "In the editor window, change the (BREAK) to \"hi\"." " Close the edit window. " "Type OK in the break window. " "\"hi\" should be returned in the exec.")))) (do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" (do-test-menu-message dtmw 'low (concatenate 'string "Open a new INTERLISP exec from the background menu. " "In that exec type control B to cause a break. " "See that *PACKAGE* is bound to # " "Uparrow out of the break window and close the exec."))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  ((v(A(l(P(<(X((((9(((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA 5  ² g   ) & -4 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # *& .1  / B5%A'*', + ./;''*', & .*;''*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 !  0&   -&#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 H1Q°zº \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~2~ b/internal/test/env/Debugger/hand/BreakWindow.u.~2~ deleted file mode 100644 index 48cc3dd3..00000000 --- a/internal/test/env/Debugger/hand/BreakWindow.u.~2~ +++ /dev/null @@ -1,3 +0,0 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Erinyes}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test "bring up exec" (do-test-menu-message dtmw 'low (concatenate 'string "From the background menu, bring up a new exec. " "In the exec " "(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) (do-test-group "STEPPER" (do-test "call step" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon."))) (do-test "step space" (do-test-menu-message dtmw 'low (concatenate 'string "Type a space in the exec window after the colon. " "You should see a long progn form followed by a colon." " Type another space. " "You should see the rest of the first part of the form."))) (do-test "step Next" (do-test-menu-message dtmw 'low (concatenate 'string "Type N in the exec window after the colon. " "You should see a long lambda form."))) (do-test "step Debugger (AR 7709)" (do-test-menu-message dtmw 'low (concatenate 'string "Type d in the exec window after the colon. " "You should see a break window."))) (do-test "step break window OK" (do-test-menu-message dtmw 'low (concatenate 'string "Type ok in the break window and hit return. " "The break window should go a way and" " you should see a colon."))) (do-test "step Finish" (do-test-menu-message dtmw 'low (concatenate 'string "Type f in the exec widnow after the colon. " " You should see the word foo three times " "followed by a new Exec promp."))) (do-test "step uparrow" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon." " Type an uparrow. " "You should see the word abort and then an exec prompt.")))) (do-test-group ("EVAL UB OK") (do-test "menued commands" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter IL:*DEBUGGER-MENU-ITEMS* " "You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) (do-test "eval create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec " " (progn (unbreak foo) " " (defun foo nil (print \"hello\")) " " (break-function 'foo))(foo) " "You should then see a break window containing Breakpoint at foo"))) (do-test "pre eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"Not yet evaluated.\""))) (do-test "type eval" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the EVAL command. " "You should see \"hello\""))) (do-test "menu eval" (do-test-menu-message dtmw 'low (concatenate 'string "Select EVAL from the middle button menu in the break window. " "You should see \"hello\""))) (do-test "type ub" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the UB command. " "You should see (foo)"))) (do-test "post eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"hello\""))) (do-test "menu OK" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, select the OK command. " "The break window should disappear and " "you should see \"hello\" in the exec.")))) (do-test-group ("proceed comands") (do-test "create break window" (defun foo nil (restart-case (break) (use-value (x) (or x (il:promptforword "Use a different value"))) (nil nil :report "Just return NIL"))) (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "You should then see a break window containing " "Break"))) (do-test "use value PROCEED command from menu" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, " "select the PROCEED command. " "You should then see a menu pop up. " " Select \"Use a different value\" from the menu. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PROCEED command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PROCEED command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Use a different value. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PR command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PR command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Use a different value. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window.")))) (do-test-group ("RETURN") (do-test "RETURN T command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN command. " "The break window should go away and " "you should see a NIL result in the exec."))) (do-test "RETURN command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN T command. " "The break window should go away and " "you should see a T result in the exec.")))) (do-test-group ("?= uparrow") (do-test "?= create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Type (foo) to the exec " "You should then see a break window "))) (do-test "type ?=" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the ?= command. " "You should see the two parameters: (break) and a Lexical Environment."))) (do-test "menu ?=" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ?= command. " "You should see the same two parameters."))) (do-test "BREAKDELIMITER correct default" (do-test-menu-message dtmw 'low (concatenate 'string "Enter IL:BREAKDELIMITER " "You should see some representation of a " "carriage return character such as a quoted new line."))) (do-test "menu ^" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ^ command. " "The break window should disappear " "and the caret should be back in the exec " "with no value returned.")))) (do-test-group "BREAK WINDOW" (do-test "create break window" (do-test-menu-message dtmw 'low (concatenate 'string "In an exec type control B to cause a break. " "You should see a break window pop up."))) (do-test "type BT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT command. " "You should see a backtrace scroll by. " "(If the window turns black, just hit a space.)"))) (do-test "type DBT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "menu BT" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window," "choose the BT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "type BT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT! command. " "You should see a longer backtrace scroll by."))) (do-test "menu DBT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT! command. " "You should see the detailed backtrace in a " "window appended to the side of the break window. "))) (do-test "menu BT!" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window, " "choose the BT! command. " "You should see a more detailed backtrace window appear " "appended to the side of the break window. "))) (do-test "scroll BT!" (do-test-menu-message dtmw 'low (concatenate 'string " You should be able to scroll up and down in the backtrace window."))) (do-test "BTV command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV command. " "You should see an even more detailed " "backtrace scroll by. " "Terminate scrolling by hitting CTRLe. "))) (do-test "BTV! command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV! command. " "You should see an even more detailed backtrace window appear " "scroll by. Terminate scrolling by hitting CTRLe. ")))) (do-test-group ("@ REVERT STOP") (do-test "@" (do-test-menu-message dtmw 'low (concatenate 'string "Enter an at-sign command. " "@ " "You should see @ = il:interrupt."))) (do-test "@ foo" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ foo " "[Note: space between the @ and foo.] " "You should see FOO not found."))) (do-test "@ exec-read" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read " "You should see @ = il:exec-read."))) (do-test "@ exec-read / 1 (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read / 1 " "You should see @ = il:exec-read again."))) (do-test "@ = exec-read (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ = exec-read " "You should see @ = il:exec-read again."))) (do-test "@ number (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ 3 " "You should see the name of the third stack item."))) (do-test "frame window" (do-test-menu-message dtmw 'low (concatenate 'string "In the backtrace window attached to the break window " "find IL:TTYIN and select it with the left mouse button. " "You should see the frame window for ttyin pop up. "))) (do-test "menu revert" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button In the break window " "(not the frame window) , " "select REVERT from the menu.. " "You should see the break window re-initialize as " "Breakpoint at IL:TTYIN. "))) (do-test "STOP" (do-test-menu-message dtmw 'low (concatenate 'string "Enter STOP " "The break window should disappear " "and the carot should be back in the exec.")))) (do-test-group ("*short-backtrace-filter*") (do-test "*short-backtrace-filter*" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec enter: il:*short-backtrace-filter* " "You should see an appropriate predicate name " "such as xcl::interesting-frame-p.")))) (do-test-group ("EDIT") (do-test "EDIT search for editable fn (AR 8137)" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "Enter EDIT in the resulting break window. " "An editor window for foo should appear. " "Close the editor window."))) (do-test "EDIT selected fn (AR 6231)" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the DBT command. " "Select the foo frame from the BT menu window with the mouse. " "Type EDIT in the break window. " "An editor window should appear."))) (do-test "EDIT OK (AR 8139)" (do-test-menu-message dtmw 'low (concatenate 'string "In the editor window, change the (BREAK) to \"hi\"." " Close the edit window. " "Type OK in the break window. " "\"hi\" should be returned in the exec.")))) (do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" (do-test-menu-message dtmw 'low (concatenate 'string "Open a new INTERLISP exec from the background menu. " "In that exec type control B to cause a break. " "See that *PACKAGE* is bound to # " "Uparrow out of the break window and close the exec."))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  ,Š,v,A,l,P,<,X,(,,9,,,G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) 5  ² g   ) & -4 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # 3& .1  / B5%2'*', + ./;'*', & .*;'*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 !  0&   -&#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 H1&°zº \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~3~ b/internal/test/env/Debugger/hand/BreakWindow.u.~3~ deleted file mode 100644 index 6a8efb24..00000000 --- a/internal/test/env/Debugger/hand/BreakWindow.u.~3~ +++ /dev/null @@ -1,3 +0,0 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Eris}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test "bring up exec" (do-test-menu-message dtmw 'low (concatenate 'string "From the background menu, bring up a new exec. " "In the exec " "(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) (do-test-group "STEPPER" (do-test "call step" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon."))) (do-test "step space" (do-test-menu-message dtmw 'low (concatenate 'string "Type a space in the exec window after the colon. " "You should see a long progn form followed by a colon." " Type another space. " "You should see the rest of the first part of the form."))) (do-test "step Next" (do-test-menu-message dtmw 'low (concatenate 'string "Type N in the exec window after the colon. " "You should see a long lambda form."))) (do-test "step Debugger (AR 7709)" (do-test-menu-message dtmw 'low (concatenate 'string "Type d in the exec window after the colon. " "You should see a break window."))) (do-test "step break window OK" (do-test-menu-message dtmw 'low (concatenate 'string "Type ok in the break window and hit return. " "The break window should go a way and" " you should see a colon."))) (do-test "step Finish" (do-test-menu-message dtmw 'low (concatenate 'string "Type f in the exec widnow after the colon. " " You should see the word foo three times " "followed by a new Exec promp."))) (do-test "step uparrow" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon." " Type an uparrow. " "You should see the word abort and then an exec prompt.")))) (do-test-group ("EVAL UB OK") (do-test "menued commands" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter IL:*DEBUGGER-MENU-ITEMS* " "You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) (do-test "eval create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec " " (progn (unbreak foo) " " (defun foo nil (print \"hello\")) " " (break-function 'foo))(foo) " "You should then see a break window containing Breakpoint at foo"))) (do-test "pre eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"Not yet evaluated.\""))) (do-test "type eval" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the EVAL command. " "You should see \"hello\""))) (do-test "menu eval" (do-test-menu-message dtmw 'low (concatenate 'string "Select EVAL from the middle button menu in the break window. " "You should see \"hello\""))) (do-test "type ub" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the UB command. " "You should see (foo)"))) (do-test "post eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"hello\""))) (do-test "menu OK" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, select the OK command. " "The break window should disappear and " "you should see \"hello\" in the exec.")))) (do-test-group ("proceed comands") (do-test "create break window" (defun foo nil (restart-case (break) (use-value (x) (or x (il:promptforword "Use a different value"))) (nil nil :report "Just return NIL"))) (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "You should then see a break window containing " "Break"))) (do-test "use value PROCEED command from menu" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, " "select the PROCEED command. " "You should then see a menu pop up. " " Select \"Use a different value\" from the menu. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PROCEED command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PROCEED command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Use a different value. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PR command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PR command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Use a different value. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window.")))) (do-test-group ("RETURN") (do-test "RETURN T command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN command. " "The break window should go away and " "you should see a NIL result in the exec."))) (do-test "RETURN command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN T command. " "The break window should go away and " "you should see a T result in the exec.")))) (do-test-group ("?= uparrow") (do-test "?= create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Type (foo) to the exec " "You should then see a break window "))) (do-test "type ?=" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the ?= command. " "You should see the two parameters: (break) and a Lexical Environment."))) (do-test "menu ?=" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ?= command. " "You should see the same two parameters."))) (do-test "BREAKDELIMITER correct default" (do-test-menu-message dtmw 'low (concatenate 'string "Enter IL:BREAKDELIMITER " "You should see some representation of a " "carriage return character such as a quoted new line."))) (do-test "menu ^" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ^ command. " "The break window should disappear " "and the caret should be back in the exec " "with no value returned.")))) (do-test-group "BREAK WINDOW" (do-test "create break window" (do-test-menu-message dtmw 'low (concatenate 'string "In an exec type control B to cause a break. " "You should see a break window pop up."))) (do-test "type BT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT command. " "You should see a backtrace scroll by. " "(If the window turns black, just hit a space.)"))) (do-test "type DBT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "menu BT" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window," "choose the BT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "type BT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT! command. " "You should see a longer backtrace scroll by."))) (do-test "menu DBT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT! command. " "You should see the detailed backtrace in a " "window appended to the side of the break window. "))) (do-test "menu BT!" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window, " "choose the BT! command. " "You should see a more detailed backtrace window appear " "appended to the side of the break window. "))) (do-test "scroll BT!" (do-test-menu-message dtmw 'low (concatenate 'string " You should be able to scroll up and down in the backtrace window."))) (do-test "BTV command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV command. " "You should see an even more detailed " "backtrace scroll by. " "Terminate scrolling by hitting CTRLe. "))) (do-test "BTV! command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV! command. " "You should see an even more detailed backtrace window appear " "scroll by. Terminate scrolling by hitting CTRLe. ")))) (do-test-group ("@ REVERT STOP") (do-test "@" (do-test-menu-message dtmw 'low (concatenate 'string "Enter an at-sign command. " "@ " "You should see @ = il:interrupt."))) (do-test "@ foo" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ foo " "[Note: space between the @ and foo.] " "You should see FOO not found."))) (do-test "@ exec-read" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read " "You should see @ = il:exec-read."))) (do-test "@ exec-read / 1 (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read / 1 " "You should see @ = il:exec-read again."))) (do-test "@ = exec-read (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ = exec-read " "You should see @ = il:exec-read again."))) (do-test "@ number (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ 3 " "You should see the name of the third stack item."))) (do-test "frame window" (do-test-menu-message dtmw 'low (concatenate 'string "In the backtrace window attached to the break window " "find IL:TTYIN and select it with the left mouse button. " "You should see the frame window for ttyin pop up. "))) (do-test "menu revert" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button In the break window " "(not the frame window) , " "select REVERT from the menu.. " "You should see the break window re-initialize as " "Breakpoint at IL:TTYIN. "))) (do-test "STOP" (do-test-menu-message dtmw 'low (concatenate 'string "Enter STOP " "The break window should disappear " "and the carot should be back in the exec.")))) (do-test-group ("*short-backtrace-filter*") (do-test "*short-backtrace-filter*" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec enter: il:*short-backtrace-filter* " "You should see an appropriate predicate name " "such as xcl::interesting-frame-p.")))) (do-test-group ("EDIT") (do-test "EDIT search for editable fn (AR 8137)" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "Enter EDIT in the resulting break window. " "An editor window for foo should appear. " "Close the editor window."))) (do-test "EDIT selected fn (AR 6231)" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the DBT command. " "Select the foo frame from the BT menu window with the mouse. " "Type EDIT in the break window. " "An editor window should appear."))) (do-test "EDIT OK (AR 8139)" (do-test-menu-message dtmw 'low (concatenate 'string "In the editor window, change the (BREAK) to \"hi\"." " Close the edit window. " "Type OK in the break window. " "\"hi\" should be returned in the exec.")))) (do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" (do-test-menu-message dtmw 'low (concatenate 'string "Open a new INTERLISP exec from the background menu. " "In that exec type control B to cause a break. " "See that *PACKAGE* is bound to # " "Uparrow out of the break window and close the exec."))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  ,Š,v,A,l,P,<,X,(,,9,,,G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) 5  ² g   ) & -1 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # 3& .1  / B5%2'*', + ./;'*', & .*;'*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 !  0&   -&#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 H1#°zº \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u.~1~ b/internal/test/env/Debugger/hand/debugger.u.~1~ deleted file mode 100644 index e35c5ef4..00000000 --- a/internal/test/env/Debugger/hand/debugger.u.~1~ +++ /dev/null @@ -1,14 +0,0 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Erinyes}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test-group ("il:break" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "il:break" (and (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) (and (il:break il:ourfn) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:advisedfns updating il:brokenfns" (and (il:defineq (il:ourfn nil nil)) (not (il:ourfn)) (il:advise 'il:ourfn 'il:around nil t) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (car (unbreak il:ourfn)))) (do-test "AR 7618 BREAK :IN broken" (il:defineq (foo nil (print "foo")) (bar nil (foo) (print "bar"))) (il:break (foo :in bar)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter (foo). " "You should see a break window.")) (unbreak (foo :in bar))))) (do-test-group ("xcl:break-function" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "simple il:break-function" (unbreak) (and (break-function 'il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break-function :trace" (and (break-function 'floor :trace t) (floor 20 3) (and (do-test-menu-message dtmw 'low (concatenate 'string "You should see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2.")) (eq 'our-fn (car (untrace 'our-fn)))))) (do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor))) (do-test "il:break-function :when t" (break-function 'floor :when t) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at flo0r. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace nil" (break-function 'floor :trace nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at floor. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace :when nil" (and (break-function 'floor :trace t :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " "You should not see a new call to floor" " in the *Trace-Output* window ")) (untrace 'our-fn)))) (do-test "il:break-function :when exp (AR 8162)" (break-function 'floor :when (when nil t)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor)))) (do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) (setq il:helpdepth 7))) (do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) (setq *test-mode* :interactive)) (do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" t))) (do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) (prog1 (not (ignore-errors (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" nil)))) (setq il:helpflag t))) (do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) (do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) (and (not (il:gettopval il:helpflag)) (il:settopval il:helpflag t) (eq t (il:gettopval il:helpflag))))) (do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) (do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) (do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) (do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" ;; nlsetq should not trap serious-conditions (expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) (do-test-group ("unbreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple unbreak" (and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) (not (unbreak)))) (do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak (our-fn il:in super-fn)))) (do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) (and (il:break (our-fn in super-fn)) (unbreak (our-fn in super-fn)))) ;; the following commented out due to ignore-errors causing ;; do-test-file to abort.: (do-test "unbreak of (sub-fn in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn in ;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test ;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and ;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in ;; super-fn)))) (do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak '(our-fn il:in super-fn)))) ;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak ;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak ;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in ;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) ) (do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple il:rebreak" (and (il:break our-fn) (unbreak our-fn) (il:rebreak our-fn)))) (do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) (do-test "simple untrace" (and (trace our-fn) (untrace) (not (untrace)) (not (member 'our-fn il:brokenfns)))) (do-test "(untrace) with broken fns" (and (il:break our-fn) (not (untrace)) (member 'our-fn il:brokenfns))) (do-test "(untrace (sub-fn in super-fn))" (and (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t) (trace (our-fn il:in super-fn)) (untrace (our-fn il:in super-fn))))) (do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) (do-test "trace il:brokenfns check" (trace our-fn) (prog1 (member 'our-fn il:brokenfns) (untrace 'our-fn))) (do-test "il:broken prop check" (trace our-fn) (prog1 (get 'our-fn 'il:broken) (untrace 'our-fn))) (do-test "simple interpreted trace" (trace our-fn) (our-fn t) (and (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a t " "and returning a t nil?")) (eq 'our-fn (car (untrace 'our-fn))))) (do-test "simple compiled trace" (trace floor) (floor 20 3) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2?")) (untrace 'floor))) (do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) (and (trace (our-fn il:in super-fn)) (super-fn) (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a nil " "and returning a nil and a t?")) (untrace (our-fn il:in super-fn))))) (do-test-group ("advise") (do-test "simple il:advise il:around of defun" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn))) (do-test "il:advise redefined broken defun" (defun our-fun nil nil) (il:break our-fun) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (unbreak our-fun) (il:unadvise our-fun))) (do-test "il:advise redefined advised defun (AR 8172)" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn)))) (do-test-group ("il:unadvise" :before (defun our-fun nil nil) (il:unadvise our-fun)) (do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) (not (our-fun)))) (do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise t))) (not (our-fun))))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) STOP (do-test "Error List condition correspondence" (dotimes (i 52) (ignore-errors (il:seterrorn i))) (print "Select Inspect from the menu that will be appearing.") (let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 il:|collect| (ignore-errors (il:seterrorn i))) nil (il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) (result (do-test-menu-message dtmw 'low (concatenate 'string "Does the inspect window have conditions " "correctly corresponding to error number + 1 " "in the Lyric release notes section 14.10?")))) (il:closew iw) result)) (~(N(:(&(S(k(K(c(Q(4(7((Œ(™(x(d((’(€(P(<(L(((C(1(n((9((M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10)) - HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5²g)&4-.<!O!;%'!$$ 0#8(. !$& %(*(S  (E  !)"K  !)".0  )1+  (>P!9-*'2 - **BM&%XFE/*N9%E@($=%!;:86;6 A(%6:@;4 K % - S - .& -%   -* +$ %G3%/ 3 %9"'/  9*D0 9$!% -G " ) -J ! ' -D   " # -7  "  " ) -I !  ! (>  -@ ; -; 5H/ -"?  ' 4 )-0 (&°zº \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u.~2~ b/internal/test/env/Debugger/hand/debugger.u.~2~ deleted file mode 100644 index 0b21b726..00000000 --- a/internal/test/env/Debugger/hand/debugger.u.~2~ +++ /dev/null @@ -1,14 +0,0 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Eris}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test-group ("il:break" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "il:break" (and (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) (and (il:break il:ourfn) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:advisedfns updating il:brokenfns" (and (il:defineq (il:ourfn nil nil)) (not (il:ourfn)) (il:advise 'il:ourfn 'il:around nil t) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (car (unbreak il:ourfn)))) (do-test "AR 7618 BREAK :IN broken" (il:defineq (foo nil (print "foo")) (bar nil (foo) (print "bar"))) (il:break (foo :in bar)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter (foo). " "You should see a break window.")) (unbreak (foo :in bar))))) (do-test-group ("xcl:break-function" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "simple il:break-function" (unbreak) (and (break-function 'il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break-function :trace" (and (break-function 'floor :trace t) (floor 20 3) (and (do-test-menu-message dtmw 'low (concatenate 'string "You should see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2.")) (eq 'our-fn (car (untrace 'our-fn)))))) (do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor))) (do-test "il:break-function :when t" (break-function 'floor :when t) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at flo0r. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace nil" (break-function 'floor :trace nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at floor. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace :when nil" (and (break-function 'floor :trace t :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " "You should not see a new call to floor" " in the *Trace-Output* window ")) (untrace 'our-fn)))) (do-test "il:break-function :when exp (AR 8162)" (break-function 'floor :when (when nil t)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor)))) (do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) (setq il:helpdepth 7))) (do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) (setq *test-mode* :interactive)) (do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" t))) (do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) (prog1 (not (ignore-errors (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" nil)))) (setq il:helpflag t))) (do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) (do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) (and (not (il:gettopval il:helpflag)) (il:settopval il:helpflag t) (eq t (il:gettopval il:helpflag))))) (do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) (do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) (do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) (do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" ;; nlsetq should not trap serious-conditions (expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) (do-test-group ("unbreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple unbreak" (and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) (not (unbreak)))) (do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak (our-fn il:in super-fn)))) (do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) (and (il:break (our-fn in super-fn)) (unbreak (our-fn in super-fn)))) ;; the following commented out due to ignore-errors causing ;; do-test-file to abort.: (do-test "unbreak of (sub-fn in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn in ;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test ;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and ;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in ;; super-fn)))) (do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak '(our-fn il:in super-fn)))) ;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak ;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak ;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in ;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) ) (do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple il:rebreak" (and (il:break our-fn) (unbreak our-fn) (il:rebreak our-fn)))) (do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) (do-test "simple untrace" (and (trace our-fn) (untrace) (not (untrace)) (not (member 'our-fn il:brokenfns)))) (do-test "(untrace) with broken fns" (and (il:break our-fn) (not (untrace)) (member 'our-fn il:brokenfns))) (do-test "(untrace (sub-fn in super-fn))" (and (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t) (trace (our-fn il:in super-fn)) (untrace (our-fn il:in super-fn))))) (do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) (do-test "trace il:brokenfns check" (trace our-fn) (prog1 (member 'our-fn il:brokenfns) (untrace 'our-fn))) (do-test "il:broken prop check" (trace our-fn) (prog1 (get 'our-fn 'il:broken) (untrace 'our-fn))) (do-test "simple interpreted trace" (trace our-fn) (our-fn t) (and (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a t " "and returning a t nil?")) (eq 'our-fn (car (untrace 'our-fn))))) (do-test "simple compiled trace" (trace floor) (floor 20 3) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2?")) (untrace 'floor))) (do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) (and (trace (our-fn il:in super-fn)) (super-fn) (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a nil " "and returning a nil and a t?")) (untrace (our-fn il:in super-fn))))) (do-test-group ("advise") (do-test "simple il:advise il:around of defun" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn))) (do-test "il:advise redefined broken defun" (defun our-fun nil nil) (il:break our-fun) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (unbreak our-fun) (il:unadvise our-fun))) (do-test "il:advise redefined advised defun (AR 8172)" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn)))) (do-test-group ("il:unadvise" :before (defun our-fun nil nil) (il:unadvise our-fun)) (do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) (not (our-fun)))) (do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise t))) (not (our-fun))))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) STOP (do-test "Error List condition correspondence" (dotimes (i 52) (ignore-errors (il:seterrorn i))) (print "Select Inspect from the menu that will be appearing.") (let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 il:|collect| (ignore-errors (il:seterrorn i))) nil (il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) (result (do-test-menu-message dtmw 'low (concatenate 'string "Does the inspect window have conditions " "correctly corresponding to error number + 1 " "in the Lyric release notes section 14.10?")))) (il:closew iw) result)) ,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10)) - HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5²g)&1-.<!O!;%'!$$ 0#8(. !$& %(*(S  (E  !)"K  !)".0  )1+  (>P!9-*'2 - **BM&%XFE/*N9%E@($=%!;:86;6 A(%6:@;4 K % - S - .& -%   -* +$ %G3%/ 3 %9"'/  9*D0 9$!% -G " ) -J ! ' -D   " # -7  "  " ) -I !  ! (>  -@ ; -; 5H/ -"?  ' 4 )-0 (#°zº \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ deleted file mode 100644 index d884b711..00000000 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ +++ /dev/null @@ -1,44 +0,0 @@ -;;; Test results for sysout of 10-Apr-87 10:19:34 -;;; Tests run on 14-Apr-87 07:07:47 -;;; Running tests from ({Eris}Test>Debugger>debugger.u;) - -il:ourfn is not broken. -il:ourfn is not broken. -Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" -Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;14" -il:ourfn is not broken. -il:ourfn is not broken. -Test "il:break-function :trace" failed in file "DEBUGGER.U;14" -our-fn is not broken. -il:ourfn is not broken. -Testing... "IL:HELPFLAG BREAK!" -Testing... "IL:HELPFLAG NIL" -Testing... "restore *test-mode*" -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;14" -Test "simple unbreak" failed in file "DEBUGGER.U;14" -super-fn is not broken. -Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" -super-fn is not broken. -Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;14" -super-fn is not broken. -Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" -Test "simple il:rebreak" failed in file "DEBUGGER.U;14" -Test "simple untrace" failed in file "DEBUGGER.U;14" -Test "(untrace) with broken fns" failed in file "DEBUGGER.U;14" -Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;14" -Test "trace il:brokenfns check" failed in file "DEBUGGER.U;14" -Test "il:broken prop check" failed in file "DEBUGGER.U;14" -Test "simple interpreted trace" failed in file "DEBUGGER.U;14" -Test "simple compiled trace" failed in file "DEBUGGER.U;14" -Test "trace of subfunction" failed in file "DEBUGGER.U;14" -Test "trace of recursive subfunction" failed in file "DEBUGGER.U;14" -udffn is not a function. -our-fn is not broken. -Test "trace of undefined subfunction" failed in file "DEBUGGER.U;14" -Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;14" -Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;14" -Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;14" -Test "simple il:unadvise" failed in file "DEBUGGER.U;14" -Test "il:unadvise t" failed in file "DEBUGGER.U;14" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ deleted file mode 100644 index 17edb1ce..00000000 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ +++ /dev/null @@ -1,38 +0,0 @@ -;;; Test results for sysout of 3-Mar-88 16:23:58 -;;; Tests run on 7-Apr-87 20:01:15 -;;; Running tests from ({eris}env>debugger>hand>debugger.u;1) - -il:ourfn is not broken. -il:ourfn is not broken. -Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;1" -il:ourfn is not broken. -il:ourfn is not broken. -Test "il:break-function :trace" failed in file "DEBUGGER.U;1" -our-fn is not broken. -il:ourfn is not broken. -Testing... "IL:HELPFLAG BREAK!" -Testing... "IL:HELPFLAG NIL" -Testing... "restore *test-mode*" -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;1" -Test "simple unbreak" failed in file "DEBUGGER.U;1" -super-fn is not broken. -Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" -super-fn is not broken. -Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;1" -super-fn is not broken. -Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" -Test "simple il:rebreak" failed in file "DEBUGGER.U;1" -Test "simple untrace" failed in file "DEBUGGER.U;1" -Test "(untrace) with broken fns" failed in file "DEBUGGER.U;1" -Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;1" -Test "trace il:brokenfns check" failed in file "DEBUGGER.U;1" -Test "il:broken prop check" failed in file "DEBUGGER.U;1" -Test "simple interpreted trace" failed in file "DEBUGGER.U;1" -Test "trace of subfunction" failed in file "DEBUGGER.U;1" -Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;1" -Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;1" -Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;1" -Test "simple il:unadvise" failed in file "DEBUGGER.U;1" -Test "il:unadvise t" failed in file "DEBUGGER.U;1" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ deleted file mode 100644 index 2addbdbc..00000000 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ +++ /dev/null @@ -1,26 +0,0 @@ -;;; Test results for sysout of 3-Mar-88 16:23:58 -;;; Tests run on 7-Apr-87 20:01:15 -;;; Running tests from ({eris}env>debugger>hand>debugger.u;1) - -Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;1" -Test "il:break-function :trace" failed in file "DEBUGGER.U;1" -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;1" -Test "simple unbreak" failed in file "DEBUGGER.U;1" -Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" -Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;1" -Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;1" -Test "simple il:rebreak" failed in file "DEBUGGER.U;1" -Test "simple untrace" failed in file "DEBUGGER.U;1" -Test "(untrace) with broken fns" failed in file "DEBUGGER.U;1" -Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;1" -Test "trace il:brokenfns check" failed in file "DEBUGGER.U;1" -Test "il:broken prop check" failed in file "DEBUGGER.U;1" -Test "simple interpreted trace" failed in file "DEBUGGER.U;1" -Test "trace of subfunction" failed in file "DEBUGGER.U;1" -Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;1" -Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;1" -Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;1" -Test "simple il:unadvise" failed in file "DEBUGGER.U;1" -Test "il:unadvise t" failed in file "DEBUGGER.U;1" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~1~ b/internal/test/env/Debugger/logs/debugger.log.~1~ deleted file mode 100644 index 4ccaf9e9..00000000 --- a/internal/test/env/Debugger/logs/debugger.log.~1~ +++ /dev/null @@ -1,34 +0,0 @@ -;;; Test results for sysout of 11-Mar-87 13:49:38 -;;; Tests run on 24-Mar-87 11:22:16 -;;; Running tests from ({Eris}Test>Debugger>debugger.u;) - -Non DO-TEST form at top level in "DEBUGGER.U;12" -(in-package "XCL-TEST") -Test "il:break of il:broken fns update of il:brokenfns" failed in file "DEBUGGER.U;12" -Test "il:break of il:advisedfns updating il:brokenfns" failed in file "DEBUGGER.U;12" -Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;12" -Test "il:break-function :trace" failed in file "DEBUGGER.U;12" -Testing... "IL:HELPFLAG BREAK!" -Testing... "IL:HELPFLAG NIL" -Testing... "restore *test-mode*" -Test "IL:HELPFLAG IL:SETTOPVAL" failed in file "DEBUGGER.U;12" -Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;12" -Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;12" -Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;12" -Test "simple il:rebreak" failed in file "DEBUGGER.U;12" -Test "simple untrace" failed in file "DEBUGGER.U;12" -Test "(untrace) with broken fns" failed in file "DEBUGGER.U;12" -Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;12" -Test "trace il:brokenfns check" failed in file "DEBUGGER.U;12" -Test "il:broken prop check" failed in file "DEBUGGER.U;12" -Test "simple interpreted trace" failed in file "DEBUGGER.U;12" -Test "trace of subfunction" failed in file "DEBUGGER.U;12" -Test "trace of recursive subfunction" failed in file "DEBUGGER.U;12" -Test "trace of undefined subfunction" failed in file "DEBUGGER.U;12" -Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;12" -Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;12" -Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;12" -Test "simple il:unadvise" failed in file "DEBUGGER.U;12" -Test "il:unadvise t" failed in file "DEBUGGER.U;12" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~2~ b/internal/test/env/Debugger/logs/debugger.log.~2~ deleted file mode 100644 index 1d6f1487..00000000 --- a/internal/test/env/Debugger/logs/debugger.log.~2~ +++ /dev/null @@ -1,32 +0,0 @@ -;;; Test results for sysout of 11-Mar-87 13:49:38 -;;; Tests run on 24-Mar-87 11:55:56 -;;; Running tests from ({Eris}Test>Debugger>debugger.u;) - -Test "il:break of il:broken fns update of il:brokenfns" failed in file "DEBUGGER.U;13" -Test "il:break of il:advisedfns updating il:brokenfns" failed in file "DEBUGGER.U;13" -Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;13" -Test "il:break-function :trace" failed in file "DEBUGGER.U;13" -Testing... "IL:HELPFLAG BREAK!" -Testing... "IL:HELPFLAG NIL" -Testing... "restore *test-mode*" -Test "IL:HELPFLAG IL:SETTOPVAL" failed in file "DEBUGGER.U;13" -Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;13" -Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;13" -Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;13" -Test "simple il:rebreak" failed in file "DEBUGGER.U;13" -Test "simple untrace" failed in file "DEBUGGER.U;13" -Test "(untrace) with broken fns" failed in file "DEBUGGER.U;13" -Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;13" -Test "trace il:brokenfns check" failed in file "DEBUGGER.U;13" -Test "il:broken prop check" failed in file "DEBUGGER.U;13" -Test "simple interpreted trace" failed in file "DEBUGGER.U;13" -Test "trace of subfunction" failed in file "DEBUGGER.U;13" -Test "trace of recursive subfunction" failed in file "DEBUGGER.U;13" -Test "trace of undefined subfunction" failed in file "DEBUGGER.U;13" -Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;13" -Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;13" -Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;13" -Test "simple il:unadvise" failed in file "DEBUGGER.U;13" -Test "il:unadvise t" failed in file "DEBUGGER.U;13" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~3~ b/internal/test/env/Debugger/logs/debugger.log.~3~ deleted file mode 100644 index 4fa3e0d5..00000000 --- a/internal/test/env/Debugger/logs/debugger.log.~3~ +++ /dev/null @@ -1,51 +0,0 @@ -;;; Test results for sysout of 18-Apr-87 20:24:31 -;;; Tests run on 7-Apr-87 20:01:15 -;;; Running tests from ({eris}test>debugger>*.u;) - -Test "step Debugger (AR 7709)" failed in file "BREAKWINDOW.U;5" -Test "step Finish" failed in file "BREAKWINDOW.U;5" -Test "@ foo" failed in file "BREAKWINDOW.U;5" -Test "@ = exec-read (AR 8062)" failed in file "BREAKWINDOW.U;5" -Test "@ number (AR 8062)" failed in file "BREAKWINDOW.U;5" -Test "EDIT search for editable fn (AR 8137)" failed in file "BREAKWINDOW.U;5" -Test "EDIT selected fn (AR 6231)" failed in file "BREAKWINDOW.U;5" - -il:ourfn is not broken. -il:ourfn is not broken. -Test "il:break of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" -Test "AR 7618 BREAK :IN broken" failed in file "DEBUGGER.U;14" -il:ourfn is not broken. -il:ourfn is not broken. -Test "il:break-function :trace" failed in file "DEBUGGER.U;14" -our-fn is not broken. -il:ourfn is not broken. -Testing... "IL:HELPFLAG BREAK!" -Testing... "IL:HELPFLAG NIL" -Testing... "restore *test-mode*" -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "DEBUGGER.U;14" -Test "simple unbreak" failed in file "DEBUGGER.U;14" -super-fn is not broken. -Test "unbreak of (sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" -super-fn is not broken. -Test "unbreak of (sub-fn in superfn)" failed in file "DEBUGGER.U;14" -super-fn is not broken. -Test "unbreak of '(sub-fn il:in superfn)" failed in file "DEBUGGER.U;14" -Test "simple il:rebreak" failed in file "DEBUGGER.U;14" -Test "simple untrace" failed in file "DEBUGGER.U;14" -Test "(untrace) with broken fns" failed in file "DEBUGGER.U;14" -Test "(untrace (sub-fn in super-fn))" failed in file "DEBUGGER.U;14" -Test "trace il:brokenfns check" failed in file "DEBUGGER.U;14" -Test "il:broken prop check" failed in file "DEBUGGER.U;14" -Test "simple interpreted trace" failed in file "DEBUGGER.U;14" -Test "trace of subfunction" failed in file "DEBUGGER.U;14" -Test "trace of recursive subfunction" failed in file "DEBUGGER.U;14" -udffn is not a function. -our-fn is not broken. -Test "trace of undefined subfunction" failed in file "DEBUGGER.U;14" -Test "simple il:advise il:around of defun" failed in file "DEBUGGER.U;14" -Test "il:advise redefined broken defun" failed in file "DEBUGGER.U;14" -Test "il:advise redefined advised defun (AR 8172)" failed in file "DEBUGGER.U;14" -Test "simple il:unadvise" failed in file "DEBUGGER.U;14" -Test "il:unadvise t" failed in file "DEBUGGER.U;14" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~4~ b/internal/test/env/Debugger/logs/debugger.log.~4~ deleted file mode 100644 index ea84d9e5..00000000 --- a/internal/test/env/Debugger/logs/debugger.log.~4~ +++ /dev/null @@ -1,48 +0,0 @@ -;;; Test results for sysout of 26-Feb-88 11:29:20 -;;; Tests run on 2-Mar-88 13:56:25 -;;; Running tests from ({Eris}Env>Debugger>Hand>*.u;) - -Test "step space" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "use value PROCEED command from menu" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "use value typed PROCEED command" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "use value typed PR command" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "@ exec-read / 1 (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "@ = exec-read (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "@ number (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "EDIT search for editable fn (AR 8137)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "EDIT selected fn (AR 6231)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" - -il:ourfn is not broken. -il:ourfn is not broken. -Test "AR 7618 BREAK :IN broken" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -il:ourfn is not broken. -il:ourfn is not broken. -Test "il:break-function :trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -our-fn is not broken. -il:ourfn is not broken. -Testing... "IL:HELPFLAG BREAK!" -Testing... "IL:HELPFLAG NIL" -Testing... "restore *test-mode*" -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple unbreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -super-fn is not broken. -Test "unbreak of (sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -super-fn is not broken. -Test "unbreak of (sub-fn in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -super-fn is not broken. -Test "unbreak of '(sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple il:rebreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple untrace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "(untrace) with broken fns" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "(untrace (sub-fn in super-fn))" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "trace il:brokenfns check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:broken prop check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple interpreted trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "trace of subfunction" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple il:advise il:around of defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:advise redefined broken defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:advise redefined advised defun (AR 8172)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple il:unadvise" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:unadvise t" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~5~ b/internal/test/env/Debugger/logs/debugger.log.~5~ deleted file mode 100644 index 82f7c9ae..00000000 --- a/internal/test/env/Debugger/logs/debugger.log.~5~ +++ /dev/null @@ -1,32 +0,0 @@ -;;; Test results for sysout of 26-Feb-88 11:29:20 -;;; Tests run on 2-Mar-88 13:56:25 -;;; Running tests from ({Eris}Env>Debugger>Hand>*.u;) - -Test "@ exec-read / 1 (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "@ = exec-read (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "@ number (AR 8062)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "EDIT search for editable fn (AR 8137)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" -Test "EDIT selected fn (AR 6231)" failed in file "{ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U;1" - -Test "AR 7618 BREAK :IN broken" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:break-function :trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple unbreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "unbreak of (sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "unbreak of (sub-fn in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "unbreak of '(sub-fn il:in superfn)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple il:rebreak" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple untrace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "(untrace) with broken fns" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "(untrace (sub-fn in super-fn))" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "trace il:brokenfns check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:broken prop check" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple interpreted trace" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "trace of subfunction" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple il:advise il:around of defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:advise redefined broken defun" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:advise redefined advised defun (AR 8172)" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "simple il:unadvise" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" -Test "il:unadvise t" failed in file "{ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U;1" - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~6~ b/internal/test/env/Debugger/logs/debugger.log.~6~ deleted file mode 100644 index f14df1eb..00000000 --- a/internal/test/env/Debugger/logs/debugger.log.~6~ +++ /dev/null @@ -1,37 +0,0 @@ -;;; Test results for sysout of 26-Feb-88 11:29:20 -;;; Tests run on 2-Mar-88 13:56:25 -;;; Running tests from ({Eris}Env>Debugger>Hand>*.u;) - -The following are in {ERIS}ENV>DEBUGGER>HAND>BREAKWINDOW.U - -Test "@ exec-read / 1 (AR 8062)" failed in file -Test "@ = exec-read (AR 8062)" failed in file -Test "@ number (AR 8062)" failed in file -Test "EDIT search for editable fn (AR 8137)" failed in file -Test "EDIT selected fn (AR 6231)" failed in file - - -The following are in {ERIS}ENV>DEBUGGER>HAND>DEBUGGER.U - -Test "AR 7618 BREAK :IN broken" failed in file -Test "il:break-function :trace" failed in file -Test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" failed in file -Test "simple unbreak" failed in file -Test "unbreak of (sub-fn il:in superfn)" failed in file -Test "unbreak of (sub-fn in superfn)" failed in file -Test "unbreak of '(sub-fn il:in superfn)" failed in file -Test "simple il:rebreak" failed in file -Test "simple untrace" failed in file -Test "(untrace) with broken fns" failed in file -Test "(untrace (sub-fn in super-fn))" failed in file -Test "trace il:brokenfns check" failed in file -Test "il:broken prop check" failed in file -Test "simple interpreted trace" failed in file -Test "trace of subfunction" failed in file -Test "simple il:advise il:around of defun" failed in file -Test "il:advise redefined broken defun" failed in file -Test "il:advise redefined advised defun (AR 8172)" failed in file -Test "simple il:unadvise" failed in file -Test "il:unadvise t" failed in file - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/debugger.log.~7~ b/internal/test/env/Debugger/logs/debugger.log.~7~ deleted file mode 100644 index 6ef6ca1f7cd2238809171be168982b07b8a976a6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1579 zcmbVMU60a06fKE9n8>rQH~S)(bln#DuxKMI12iIRpvyk@V+svrN@hB{>c&6jU-QM= z55Poa<7s+|sKnxVfn^s8#O zUOv7ll4856QW|FaxEg?a5l;!aTYLA46;`_U_ph?)h*{7~tE-5!h z4)e`dm$F;0R_zr<7f}>Hq;!W<2pK$*nKefyncF6rEX+Q+z8wz9%pCP5ee-%odY|sB zNq>5Gd5a2ZLl+-_exaVqspG?I(4f|vLFcNa*DoM&!if5*Zh!~a6W;$u`3E?Y8<%qU zyE5rpHVEo)ZR}=tAS)*65>)A33ohNhPTGXh>ULrHaQypF;KhO`9!ut@o8nXCmr+w>&fye+Awyqz z_viC+AwMS;?|-}eS~|FvET^6@xr0FRC#YH@lfF6~sOc>_uPf>2iBeHsD9`Y1ToBv( W*i)Woe`jA$f2KbbMZrVm+mByx)bd#X diff --git a/internal/test/env/Exec/Hand/DA.U.~1~ b/internal/test/env/Exec/Hand/DA.U.~1~ deleted file mode 100644 index e9f7faa2..00000000 --- a/internal/test/env/Exec/Hand/DA.U.~1~ +++ /dev/null @@ -1,75 +0,0 @@ -;; Function To Be Tested: DA (Programmer's Assistant Command) -;; -;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) -;; Section 20.2 (The Evaluator), Page 28 -;; -;; -;; Section: The Evaluator -;; Page: 9 -;; -;; Created By: John Park -;; -;; Creation Date: Feb 10, 1987 -;; -;; Last Update: Feb 26, 1987 -;; -;; Filed As: {ERIS}integration>exec>da.u -;; -;; -;; Syntax: DA -;; -;; Function Description: Returns current date and time -;; -;; Argument(s): None -;; -;; Returns: See function description -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be accomplished using the interlisp function BKSYSBUF in -;; do-test form . Comments are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "Test "quote" -;; failed in file "unknown". " at the end of testing. -;; The test result will be logged automatically in the following file: -;; {ERIS}test>exec>test.report - - -(DO-TEST 'DA-TEST-SETUP - (PROGN - (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") - (DEFUN R-FORMAT (STATUS) - (FORMAT *OUTPUT* "~%COMMAND: DA ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) - (SETQ DA-COMMAND-STRING - -"(SETQ MESS1 'Printing-current-date&time...) -(SETQ DATE (IL:DATE)) - -(PROGN - (PRINC MESS1) - (SLEEP 2) - (VALUES) - ) -DA -(SETQ TODAY IL:IT) -; Now do-test will determine whether DA actually returns today's date -(DO-TEST 'DA-TEST-RESULT - (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (IF (STRING-EQUAL DATE TODAY :END1 14 :END2 14) - (PROGN (R-FORMAT 'SUCCESS) T) - (PROGN (R-FORMAT 'FAIL) NIL)) - (CLOSE *OUTPUT*) - ) -) - -") - (IL:BKSYSBUF DA-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/Exec/Hand/DA.U.~2~ b/internal/test/env/Exec/Hand/DA.U.~2~ deleted file mode 100644 index c1b8376f..00000000 --- a/internal/test/env/Exec/Hand/DA.U.~2~ +++ /dev/null @@ -1,75 +0,0 @@ -;; Function To Be Tested: DA (Programmer's Assistant Command) -;; -;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) -;; Section 20.2 (The Evaluator), Page 28 -;; -;; -;; Section: The Evaluator -;; Page: 9 -;; -;; Created By: John Park -;; -;; Creation Date: Feb 10, 1987 -;; -;; Last Update: Feb 26, 1987 -;; -;; Filed As: {ERIS}integration>exec>da.u -;; -;; -;; Syntax: DA -;; -;; Function Description: Returns current date and time -;; -;; Argument(s): None -;; -;; Returns: See function description -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be accomplished using the interlisp function BKSYSBUF in -;; do-test form . Comments are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "COMMAND-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "Test "quote" -;; failed in file "unknown". " at the end of testing. -;; The test result will be logged automatically in the following file: -;; {ERIS}test>exec>test.report - - -(DO-TEST 'DA-TEST-SETUP - (PROGN - (SETQ TEST-RESULT "{ERIS}TEST>EXEC>TEST.REPORT") - (DEFUN R-FORMAT (STATUS) - (FORMAT *OUTPUT* "~%COMMAND: DA ~%STATUS: ~A DATE: ~A TESTER: ~A~%" STATUS (IL:DATE) IL:USERNAME)) - (SETQ DA-COMMAND-STRING - -"(SETQ MESS1 'Printing-current-date&time...) -(SETQ DATE (IL:DATE)) - -(PROGN - (PRINC MESS1) - (SLEEP 2) - (VALUES) - ) -DA -(SETQ TODAY IL:IT) -; Now do-test will determine whether DA actually returns today's date -(DO-TEST 'DA-TEST-RESULT - (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND :IF-DOES-NOT-EXIST :CREATE)) - (IF (STRING-EQUAL DATE TODAY :END1 14 :END2 14) - (PROGN (R-FORMAT 'SUCCESS) T) - (PROGN (R-FORMAT 'FAIL) NIL)) - (CLOSE *OUTPUT*) - ) -) - -") - (IL:BKSYSBUF DA-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/Exec/Logs/Exec.log.~1~ b/internal/test/env/Exec/Logs/Exec.log.~1~ deleted file mode 100644 index 5cbf2cf0..00000000 --- a/internal/test/env/Exec/Logs/Exec.log.~1~ +++ /dev/null @@ -1,5 +0,0 @@ -;;; Test results for sysout of 26-Feb-88 11:29:20 -;;; Tests run on 29-Feb-88 10:19:34 -;;; Running tests from ({ERIS}Env>Exec>Hand>do-events.u;1) - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Exec.log.~2~ b/internal/test/env/Exec/Logs/Exec.log.~2~ deleted file mode 100644 index a291f970..00000000 --- a/internal/test/env/Exec/Logs/Exec.log.~2~ +++ /dev/null @@ -1,8 +0,0 @@ -;;; Test results for sysout of 26-Feb-88 11:29:20 -;;; Tests run on 29-Feb-88 10:54:35 -;;; Running tests from ({ERIS}Env>Exec>Hand>*.u;) - - -(Trouble reading {ERIS}ENV>EXEC>HAND>DO-EVENTS.U;2) - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Exec/Logs/Exec.log.~3~ b/internal/test/env/Exec/Logs/Exec.log.~3~ deleted file mode 100644 index 57b378a2..00000000 --- a/internal/test/env/Exec/Logs/Exec.log.~3~ +++ /dev/null @@ -1,5 +0,0 @@ -;;; Test results for sysout of 26-Feb-88 11:29:20 -;;; Tests run on 29-Feb-88 11:25:26 -;;; Running tests from ({ERIS}Env>Exec>Hand>*.u;) - -(END-OF-TESTS) \ No newline at end of file diff --git a/internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ b/internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ deleted file mode 100644 index 10eaf5d8035f275c258a55baed99131ad11f7ff8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 7660 zcmb_h-EP}P6YaI1Vyprc6^E*R>=u>lqVi7z1FqdV2ATjxT#8)T{7R7uNhQ*apZz;C zyA&yDMJuU|grdmZnKLtIW_DM{$Hz3B<;ld$L!ZvBF5mt^xytgay?2aPcaLF4<1kYC zA?1(C3>tfW7=`%)kJ4oJ@JKVOj^xG1PDamaNix*JBVUwI-e%HJ_$#mZyMH zr;GXF@MJMQ_#95c@uF5?g;8P-cqjSQxVbuaFR$+|ZaD|tyG^Q=Ggt4NRC$3rPLqiN zOjYpDp)X|Rt=eD_4T^|lbs`-d)Ti&ZgmvQiX<}lUO_d)atdYuVMSf{KwT_B(azH%fv9@uf~BJH-Jka-2_Invv6L5$;gfaQECqO!X6}WAPWCGFwbW2^h}hIG#n(4jw32wc-h1 zJHZWO6mqfOn6aA`5|pZE*W@8Oakx7;hL-K?0`HwW$Pt<&^lS%sM>tBWZ^z3X&#e|m?3*>?FBahp) z$!=mXX||KC5cK+2$^7SXc$ZQKm4MExrxaajqImg~OjYXTNs7f2-WAIdYFx(Sa83uh zq&w;(a%rVH>GedvgCZkMz1!h>v)+>$&X5l1wAH}NLyWMfa9==$YgAzIU{mqx1ysB; zD*7F}j_+SU$M=N}s}&z!K*I;Ep(OCpPo2Y`I?F$+;uE9z+4vi=Qh-4jI~`7F2s+Se z`>YwwOqSz<^Ha>H>@~H#R_!f|7N` z8yPjvQ_tsWg@@~Y8<01hMxhFL&&Bn68*O=`({wxz$hm&#B zK5d_}t1EU19f7o95-+6kbSBH&)yDTWoJ?_cAPv7dY8#t8>ViDd1F@Us8)T!t3FvT% zp5R^Q5r#Nj>QTQkyC7HH?4QqmsmylzODY4yN{l3xs;0>riT1z3 zLOxhHVw__50^j=7D}%L*(fel=)NQz~5;ZOxAGg`O|8D<14b5bLfWvx-g_*yr(S_C6 zG?*-~t#cfqgG9yHien6Uc1TC`L!p$zWcFaG%4QKZW0p|w?<3fZd&ShMugv78;eoTE zMED@yAu|@d^Hw}3SaL6nru9R(G{i{Oz8Th%gP01mN$Du+W!<(}Fo7!`4%fxDc4Ocdb;PC#A>xT^0T1(mYI?D$X#!}oen-VTx zbHi*?gXpN_DRcW34j7UsaOL1|j>O;2^ml`v0IIme%JQ6R9qU9 zj^>q;fV0SAx6IAkHAOm2D(_1qRlwM<<{y{3HZ%L(!0p{%UtV!)qZDF+x0_Mh1};?@ zqV-?YHf`fJntUNo{sTt_-NI*fua_Ba2`V>-f*_XH+F>%H6t2moV_sphnZC^-oHu%b zvNdxi3k=Xj&$@Uqt$}s&K;V`c72E~eY<=VR_gLC2mp3}oS9eiT=Zr@*7NiXya_5Ad zG5)Wu$#q@afMZRL-9{BBI%YJggE`_UZQbJLD>cRsCv8f@hsPX0rzl?qD)tp6W3tvm zE>-rmR~hNToz^AS@Zj|RjLYR=IiaXKLMkntk3OJkB#S!pg;#jS4qH>SEeJ~;^`P!g z4+PXvIbjXd5xlwt#Y@h0P({1>bC%>dKwfPz{18qxr#{d~XuPiEcfxO* zPUKBSfrsDoyf8KK+yLYFUP>|mBe>1!`+_A+$7!HN9-x!H!V0{Bz1NS$I|K{wI^?3s zelRcHA6DPW%%>CdE1p^j9H#alvX7bADdOExC0)$R9-SbGHYXlJWtVW^!N5d{Wsn4b Rj{*<`QLTZozgv6X{2!^*fC~Ts diff --git a/internal/test/env/code-editor/hand/Command-arglist.u.~1~ b/internal/test/env/code-editor/hand/Command-arglist.u.~1~ deleted file mode 100644 index 3bf52f97..00000000 --- a/internal/test/env/code-editor/hand/Command-arglist.u.~1~ +++ /dev/null @@ -1,289 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 12, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}command-help.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERIS}Integration>do-test-menu.def")) - T) - - -(do-test-group "Help" - :before (progn - (setq window-list (do-test-menu-Setup "Help"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Help: no selection/no caret" - (do-test-menu-Message window-list 'high -" Testing Help -If there is no free Xerox Common Lisp exec, bring up one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq number 3) -(defun temp-double (number) (* 2 number)) -(defun temp-add-five (number) (+ 5 number)) -(defun temp-call-other (number) (+ (temp-add-five number) - (temp-double number))) -(defun temp-garbage (start) (concatenate 'string start 23 5 (4 cd \"hi\") \" more\")) -(il:df temp-call-other) - -Select Help from the popup menu. -Does SEdit display in it's prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Make sure the functions got entered in correctly" - (and - (eq 3 number) - (eq 26 (temp-double 13)) - (eq 50 (temp-double 25)) - (eq 10 (temp-add-five 5)) - (eq 28 (temp-add-five 23)) - (eq 11 (temp-call-other 2)) - (eq 14 (temp-call-other 3)) - )) - - -(do-test "Help: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the function temp-call-other -Want to place the edit caret right after the function call to \"temp-double\" without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of \"temp-double\". -Type meta-H. -Does SEdit display in the SEdit prompt window \"(TEMP-DOUBLE NUMBER)\"? ")) - - -(do-test "Help: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the function temp-call-other -Want to place the structure caret right between the \"temp-add-five\" and \"number\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-H. -Does SEdit display in the SEdit prompt window \"(TEMP-ADD-FIVE NUMBER)\"? ")) - - -(do-test "Help: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the function temp-call-other -Select the last litatom \"number\" as a structure, by pressing the middle button with the cursor over the litatom. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for NUMBER\"? ")) - -; The response to this may change when AR 7703 is answered/fixed. - -(do-test "Help: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the function temp-call-other -Close the SEdit window for temp-call-other -In the exec type: \"(il:df temp-garbage)\" -Select the string \" more\" as a structure, by pressing the middle button, with the cursor over the string. -Type meta-H. -Does it display a message of: - \"Arguments not available for more\"? ")) - - -(do-test "Help: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the function temp-garbage. -Select the number \"5\" as a structure, by pressing the middle button, with the cursor over the number. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for 5\"? ")) - - -(do-test "Help: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the function temp-garbage. -Select the list \"(4 cd \"hi\")\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for (4 cd hi)\"? ")) - - -(do-test "Help: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the function temp-garbage. -Select the \"d\" in the litatom \"cd\". -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for CD\"?")) - - -(do-test "Help: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the function temp-garbage. -Select the \"h\" in the string \"hi\". -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the function temp-garbage. -Select the \"2\" in the number \"23\". -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for 23\"? ")) - - -(do-test "Help: delete a litatom" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a litatom -Assumping SEdit is editing the function temp-garbage. -Close the SEdit window for temp-garbage. -In the exec type: \"(il:df temp-call-other)\" -Place the structure caret after the second litatom \"number\". -Type in the litatom \"ab\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-ADD-FIVE NUMBER)\"? ")) - - -(do-test "Help: delete a string" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a string -Assumping SEdit is editing the function temp-call-other. -Place the structure caret after the third litatom \"number\". -Type in the string \"hello\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-DOUBLE NUMBER)\"? ")) - - -(do-test "Help: delete a number" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a number -Assumping SEdit is editing the function temp-call-other. -Place the structure caret before the third litatom \"number\". -Type in the number \"34\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-DOUBLE NUMBER)\"? ")) - - -(do-test "Help: delete a list" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a list -Assumping SEdit is editing the function temp-call-other. -Place the structure caret before the second litatom \"number\". -Type in the list \"(have a \"nice\" day)\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-ADD-FIVE NUMBER)\"? ")) - - -(do-test "Help: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the function temp-call-other. -Place the edit caret after the second litatom \"number\". -Type \" ef gh\". -Type meta-H -Now select the litatom \"number\" as a structure, and extend the selection to include the next two litatoms. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the function temp-call-other. -Place the edit caret after the litatom \"gh\". -Type \" 12 3.4 5/6 (hi) (bye) \"string\" \"string2\" (list)\". -Now select the first string as a structure, and extend the selection to include the second string. -Type meta-H -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the function temp-call-other. -Select the number \"12\" as a structure, and extend the selection to include the next two numbers. -Type meta-H -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the function temp-call-other. -Select the list \"(hi)\" as a structure, and extend the selection to include the next list. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the function temp-call-other. -Select the litatoms \"ef\" as a structure, and extend the selection to include the next four items. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the function temp-call-other. -Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Help: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the function temp-call-other. -Select the litatom \"ef\" as a structure, and extend the selection to include the rest. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? -Type meta-H a couple times if neccesary to see.")) - - -(do-test "Help: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the function temp-call-other. -Select the entire structure. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for (DEFUN TEMP-CALL-OTHER (NUMBER) (+ (TEMP-ADD-FIVE NUMBER EF GH 12 3.4 5/6 (HI) (BYE) \"string\" \"string2\" (list)) (TEMP-DOUBLE NUMBER)))\"? ")) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-arglist.u.~2~ b/internal/test/env/code-editor/hand/Command-arglist.u.~2~ deleted file mode 100644 index 194acc3d..00000000 --- a/internal/test/env/code-editor/hand/Command-arglist.u.~2~ +++ /dev/null @@ -1,289 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 12, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}command-help.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Arglist" - :before (progn - (setq window-list (do-test-menu-Setup "Arglist"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Arglist: no selection/no caret" - (do-test-menu-Message window-list 'high -" Testing Arglist -If there is no free Xerox Common Lisp exec, bring up one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq number 3) -(defun temp-double (number) (* 2 number)) -(defun temp-add-five (number) (+ 5 number)) -(defun temp-call-other (number) (+ (temp-add-five number) - (temp-double number))) -(defun temp-garbage (start) (concatenate 'string start 23 5 (4 cd \"hi\") \" more\")) -(il:df temp-call-other) - -Select Arglist from the popup menu. -Does SEdit display in its prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Make sure the functions got entered in correctly" - (and - (eq 3 number) - (eq 26 (temp-double 13)) - (eq 50 (temp-double 25)) - (eq 10 (temp-add-five 5)) - (eq 28 (temp-add-five 23)) - (eq 11 (temp-call-other 2)) - (eq 14 (temp-call-other 3)) - )) - - -(do-test "Arglist: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the function temp-call-other -Want to place the edit caret right after the litatom \"temp-double\" without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of \"temp-double\". -Type meta-H. -Does SEdit display in the SEdit prompt window \"(TEMP-DOUBLE NUMBER)\"? ")) - - -(do-test "Arglist: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the function temp-call-other -Want to place the structure caret right between the \"temp-add-five\" and \"number\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-H. -Does SEdit display in the SEdit prompt window \"(TEMP-ADD-FIVE NUMBER)\"? ")) - - -(do-test "Arglist: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the function temp-call-other -Select the last litatom \"number\" as a structure, by pressing the middle button with the cursor over the litatom. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for NUMBER\"? ")) - -; The response to this may change when AR 7703 is answered/fixed. - -(do-test "Arglist: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the function temp-call-other -Close the SEdit window for temp-call-other -In the exec type: \"(il:df temp-garbage)\" -Select the string \" more\" as a structure, by pressing the middle button, with the cursor over the string. -Type meta-H. -Does it display a message of: - \"Arguments not available for more\"? ")) - - -(do-test "Arglist: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the function temp-garbage. -Select the number \"5\" as a structure, by pressing the middle button, with the cursor over the number. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for 5\"? ")) - - -(do-test "Arglist: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the function temp-garbage. -Select the list \"(4 cd \"hi\")\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for (4 cd hi)\"? ")) - - -(do-test "Arglist: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the function temp-garbage. -Select the \"d\" in the litatom \"cd\". -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for CD\"?")) - - -(do-test "Arglist: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the function temp-garbage. -Select the \"h\" in the string \"hi\". -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the function temp-garbage. -Select the \"2\" in the number \"23\". -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for 23\"? ")) - - -(do-test "Arglist: delete a litatom" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a litatom -Assuming SEdit is editing the function temp-garbage. -Close the SEdit window for temp-garbage. -In the exec type: \"(il:df temp-call-other)\" -Place the structure caret after the second litatom \"number\". -Type in the litatom \"ab\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-ADD-FIVE NUMBER)\"? ")) - - -(do-test "Arglist: delete a string" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a string -Assuming SEdit is editing the function temp-call-other. -Place the structure caret after the third litatom \"number\". -Type in the string \"hello\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-DOUBLE NUMBER)\"? ")) - - -(do-test "Arglist: delete a number" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a number -Assuming SEdit is editing the function temp-call-other. -Place the structure caret before the third litatom \"number\". -Type in the number \"34\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-DOUBLE NUMBER)\"? ")) - - -(do-test "Arglist: delete a list" - (do-test-menu-Message window-list 'low -" Testing: try after deleting a list -Assuming SEdit is editing the function temp-call-other. -Place the structure caret before the second litatom \"number\". -Type in the list \"(have a \"nice\" day)\" -Type control-W, meta-H. -Does SEdit display in the SEdit prompt window: - \"(TEMP-ADD-FIVE NUMBER)\"? ")) - - -(do-test "Arglist: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the function temp-call-other. -Place the edit caret after the second litatom \"number\". -Type \" ef gh\". -Now select the litatom \"number\" as a structure, and extend the selection to include the next two litatoms. -Type meta-H -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the function temp-call-other. -Place the edit caret after the litatom \"gh\". -Type \" 12 3.4 5/6 (hi) (bye) \"string\" \"string2\" (list)\". -Now select the first string as a structure, and extend the selection to include the second string. -Type meta-H -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the function temp-call-other. -Select the number \"12\" as a structure, and extend the selection to include the next two numbers. -Type meta-H -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the function temp-call-other. -Select the list \"(hi)\" as a structure, and extend the selection to include the next list. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the function temp-call-other. -Select the litatoms \"ef\" as a structure, and extend the selection to include the next four items. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the function temp-call-other. -Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? ")) - - -(do-test "Arglist: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the function temp-call-other. -Select the litatom \"ef\" as a structure, and extend the selection to include the rest. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Select function you want the arguments for.\"? -Type meta-H a couple times if neccesary to see.")) - - -(do-test "Arglist: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the function temp-call-other. -Select the entire structure. -Type meta-H. -Does SEdit display in the SEdit prompt window: - \"Arguments not available for (DEFUN TEMP-CALL-OTHER (NUMBER) (+ (TEMP-ADD-FIVE NUMBER EF GH 12 3.4 5/6 (HI) (BYE) \"string\" \"string2\" (list)) (TEMP-DOUBLE NUMBER)))\"? ")) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-extract.u.~1~ b/internal/test/env/code-editor/hand/Command-extract.u.~1~ deleted file mode 100644 index 59046a1a..00000000 --- a/internal/test/env/code-editor/hand/Command-extract.u.~1~ +++ /dev/null @@ -1,336 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 19, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-extract.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Extract" - :before (progn - (setq window-list (do-test-menu-Setup "Extract"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Extract: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Extract -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Select Extract from the pop up menu. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-/. -Were you able to get this far ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) "hi" (b) cd 4) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4) -Type meta-U. -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Nothing to extract.\"? ")) - - -(do-test "Extract: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Nothing to extract.\"? ")) - - -(do-test "Extract: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Nothing to extract.\"? ")) - - -(do-test "Extract: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-/. -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) -Type meta-U. -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"not implemented for comments.\"? ")) - - -(do-test "Extract: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 ; hello 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U twice. -Select the \"d\" in the first litatom \"cd\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"4.5\" in pending delete mode. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U twice. -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-/ -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-/ -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the entire structure. -Type meta-0. -Reselect the enterie structure. -Type meta-/, and control-L -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type control-x. -Select the entire structure in pending delete mode. -Type meta-m. -Pick the extract command on the attached menu. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-extract.u.~2~ b/internal/test/env/code-editor/hand/Command-extract.u.~2~ deleted file mode 100644 index 1d4084b9..00000000 --- a/internal/test/env/code-editor/hand/Command-extract.u.~2~ +++ /dev/null @@ -1,335 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 19, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-extract.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Extract" - :before (progn - (setq window-list (do-test-menu-Setup "Extract"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Extract: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Extract -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Select Extract from the pop up menu. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-/. -Did the parentheses around ("hi" (B) CD 4) disappear? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) "hi" (b) cd 4) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4) -Type meta-U. -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Nothing to extract.\"? ")) - - -(do-test "Extract: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Nothing to extract.\"? ")) - - -(do-test "Extract: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Nothing to extract.\"? ")) - - -(do-test "Extract: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-/. -Did the parentheses around (bye) disappear? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) -Type meta-U. -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-/. -Did the semicolon disappear and \"hello\" become just another atom in the list? ")) - - -(do-test "Extract: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 ; hello 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U three times. -Select the \"d\" in the first litatom \"cd\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"4.5\" in pending delete mode. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U twice. -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-/ -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-/ -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-/. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Extract: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the entire structure. -Type meta-0. -Reselect the entire structure. -Type meta-/, and control-L -Did you get back the original list? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Extract: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type control-x. -Select the entire structure in pending delete mode. -Type meta-m. -Pick the extract command on the attached menu. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-find.u.~1~ b/internal/test/env/code-editor/hand/Command-find.u.~1~ deleted file mode 100644 index 3308900d..00000000 --- a/internal/test/env/code-editor/hand/Command-find.u.~1~ +++ /dev/null @@ -1,324 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 10, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-find.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Find" - :before (progn - (setq window-list (do-test-menu-Setup "Find"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Find: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Find -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4))) -(il:dv tempx) - -Select Find from the popup menu. Type in \"cd\". -Does it find the litatom \"cd\" and select it? ")) - (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Type control-x. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-F. Type in \"6/7\". -Does it find the number \"6/7\" and select it? ")) - - -(do-test "Find: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-F. Enter the string \"hello\". -Does it find the number \"hello\" and select it? ")) - - -(do-test "Find: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. -Press the find key. -Does it find the second occurance of the litatom and select it? ")) - - -(do-test "Find: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. -Type meta-F. -Does it display a message of \"\"hello\" - Not found.\"? ")) - - -(do-test "Find: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Place the structure caret right after the string \"BYE\". -Type \" 4.5 (bye) (bye)\", and then control-x -Select the first number \"4.5\" as a structure, by pressing the middle button, with the cursor over the number. -Type meta-F. -Does it find the second occurance of the number and select it?")) - (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the first list \"(bye)\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. -Type meta-F. -Does it find the second occurance of the list and select it?")) - - -(do-test "Find: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-F. -Does it display a message of \"(il:* il:\\; \" hello\") - Not found.\"? ")) - - -(do-test "Find: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 ; hello 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-F. Enter the litatom \"bye\" - (If it doesn't ask what to find indicate failure to the prompter.) -Does it find the first litatom \"bye\" and underline only it?")) - - -(do-test "Find: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-F. Enter the number \"4\" - (If it doesn't ask what to find indicate failure to the prompter.) -Does it find the number \"4\" and underline only it?")) - - -(do-test "Find: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-F. Enter the list \"(\"hi\" b cd 4)\" - (If it doesn't ask what to find indicate failure to the prompter.) -Does it find the list \"(\"hi\" b cd 4)\" and underline only it?")) - (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the edit caret after the litatom \"a\". -Type control-W, meta-F. Enter the number \"4.5\". -Does it find the second \"4.5\"? ")) - (good-value (equal '(1 4.5 6/7 cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the structure caret after the string \"hello\". -Type control-W, meta-F. Enter the litatom \"bye\". -Does it find the first litatom \"bye\"? ")) - (good-value (equal '(1 4.5 6/7 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the edit caret right after the number \"6/7\" with no selection. -Type control-W, meta-F. Just press the carriage return. -Does it find the first litatom \"bye\"? ")) - (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Pick the first list of \"(bye)\" as a structure and press the delete key. -Type meta-F. And press the carriage return. -Does it find the litatom \"bye\"? ")) - (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. -Press the delete key, type meta-F, and press the carriage return. -Does it find the litatom \"bye\"? ")) - (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Place the edit caret after the litatom \"cd\". -Type \" ef gh\", and control-x. -Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. -Type meta-m, in the Find field type in the string \"BYE\", then left button the Find item on the menu. -Does it find the string \"BYE\"? ")) - (good-value (equal '(1 4.5 cd ef gh "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Place the edit caret after the litatom \"gh\". -Type \"(hi) (bye) \"string\" \"string2\" (list)\". -Now select the first string as a structure, and extend the selection to include the second string. -In the attach menu, left button the Find item on the menu. -Does it find the string \"BYE\"? ")) - (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -In the attach menu, left button the Find item on the menu. -Does it find the litatom \"BYE\"? ")) - - -(do-test "Find: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the list \"(hi)\" as a structure, and extend the selection to include the next list. -In the attach menu, change the Find field to be \"4.5\", then left button the Find item on the menu. -Does it find the second number \"4.5\"? ")) - - -(do-test "Find: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next four items. -In the attach menu, left button the Find item on the menu. -Does it find the second number \"4.5\"? ")) - - -(do-test "Find: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. -In the attach menu, left button the Find item on the menu. -Does it find the second number \"4.5\"? ")) - - -(do-test "Find: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -In the attach menu, left button the Find item on the menu. -Does it say \"4.5 - Not found\"? ")) - - -(do-test "Find: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the entire structure. -In the attach menu, left button the Find item on the menu. -Does it say \"4.5 - Not found\"? ")) - (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-find.u.~2~ b/internal/test/env/code-editor/hand/Command-find.u.~2~ deleted file mode 100644 index 3eca1ae2..00000000 --- a/internal/test/env/code-editor/hand/Command-find.u.~2~ +++ /dev/null @@ -1,324 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 10, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-find.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Find" - :before (progn - (setq window-list (do-test-menu-Setup "Find"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Find: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Find -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4))) -(il:dv tempx) - -Select Find from the popup menu. Type in \"cd\". -Does it find the litatom \"cd\" and select it? ")) - (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Type control-x. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-F. Type in \"6/7\". -Does it find the number \"6/7\" and select it? ")) - - -(do-test "Find: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and pressing the middle button. -Type meta-F. Enter the string \"hello\". -Does it find the string \"hello\" and select it? ")) - - -(do-test "Find: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the middle button with the cursor over the litatom. -Press the find key. -Does it find the second occurance of the litatom and select it? ")) - - -(do-test "Find: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, by pressing the middle button, with the cursor over the string. -Type meta-F. -Does it display a message of \"\"hello\" - Not found.\"? ")) - - -(do-test "Find: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" (\"hi\" b cd 4)) -Place the structure caret right after the string \"BYE\". -Type \" 4.5 (bye) (bye)\", and then control-x -Select the first number \"4.5\" as a structure, by pressing the middle button, with the cursor over the number. -Type meta-F. -Does it find the second occurance of the number and select it?")) - (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the first list \"(bye)\" as a structure, by pressing the middle button, with the cursor over one of the parentheses. -Type meta-F. -Does it find the second occurance of the list and select it?")) - - -(do-test "Find: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-F. -Does it display a message of \"(il:* il:\\; \" hello\") - Not found.\"? ")) - - -(do-test "Find: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 ; hello 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-F. Enter the litatom \"bye\" - (If it doesn't ask what to find indicate failure to the prompter.) -Does it find the first litatom \"bye\" and underline only it?")) - - -(do-test "Find: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-F. Enter the number \"4\" - (If it doesn't ask what to find indicate failure to the prompter.) -Does it find the number \"4\" and underline only it?")) - - -(do-test "Find: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-F. Enter the list \"(\"hi\" b cd 4)\" - (If it doesn't ask what to find indicate failure to the prompter.) -Does it find the list \"(\"hi\" b cd 4)\" and underline only it?")) - (good-value (equal '(1 4.5 6/7 a cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the edit caret after the litatom \"a\". -Type control-W, meta-F. Enter the number \"4.5\". -Does it find the second \"4.5\"? ")) - (good-value (equal '(1 4.5 6/7 cd "hello" "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 cd \"hello\" \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the structure caret after the string \"hello\". -Type control-W, meta-F. Enter the litatom \"bye\". -Does it find the first litatom \"bye\" (and not the string)? ")) - (good-value (equal '(1 4.5 6/7 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the edit caret right after the number \"6/7\" with no selection. -Type control-W, meta-F. Just press the carriage return. -Does it find the first litatom \"bye\" (and not the string)? ")) - (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Pick the first list of \"(bye)\" as a structure and press the delete key. -Type meta-F. And press the carriage return. -Does it find the litatom \"bye\"? ")) - (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: delete a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd \"BYE\" 4.5 (bye) (bye) (\"hi\" b cd 4)) -Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. -Press the delete key, type meta-F, and press the carriage return. -Does it find the litatom \"bye\"? ")) - (good-value (equal '(1 4.5 cd "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Place the edit caret after the litatom \"cd\". -Type \" ef gh\", and control-x. -Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. -Type meta-m, in the Find field type in the string \"BYE\", then left button the Find item on the menu. -Does it find the string \"BYE\"? ")) - (good-value (equal '(1 4.5 cd ef gh "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Place the edit caret after the litatom \"gh\". -Type \"(hi) (bye) \"string\" \"string2\" (list)\". -Now select the first string as a structure, and extend the selection to include the second string. -In the attach menu, left button the Find item on the menu. -Does it find the string \"BYE\"? ")) - (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Find: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -In the attach menu, left button the Find item on the menu. -Does it find the string \"BYE\"? ")) - - -(do-test "Find: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the list \"(hi)\" as a structure, and extend the selection to include the next list. -In the attach menu, change the Find field to be \"4.5\", then left button the Find item on the menu. -Does it find the second number \"4.5\"? ")) - - -(do-test "Find: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next four items. -In the attach menu, left button the Find item on the menu. -Does it find the second number \"4.5\"? ")) - - -(do-test "Find: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the litatom \"hi\" as a structure, and extend the selection to include the next four items. -In the attach menu, left button the Find item on the menu. -Does it find the second number \"4.5\"? ")) - - -(do-test "Find: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -In the attach menu, left button the Find item on the menu. -Does it say \"4.5 - Not found\"? ")) - - -(do-test "Find: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 cd ef gh (hi) (bye) \"string\" \"string2\" (list) \"BYE\" 4.5 (bye) (\"hi\" b cd 4)) -Select the entire structure. -In the attach menu, left button the Find item on the menu. -Does it say \"At end; no more structure to search.\"? ")) - (good-value (equal '(1 4.5 cd ef gh (hi) (bye) "string" "string2" (list) "BYE" 4.5 (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-high.u.~1~ b/internal/test/env/code-editor/hand/Command-high.u.~1~ deleted file mode 100644 index 7da93658..00000000 --- a/internal/test/env/code-editor/hand/Command-high.u.~1~ +++ /dev/null @@ -1,175 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 4, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-high.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "High level, high priority test" - :before (progn - (setq window-list (do-test-menu-Setup "High-level"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Trouble typing with parentheses" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing parentheses -If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" -Then in the exec type: - -(setq tempx '(5)) -(il:SEdit tempx) - -Put the edit caret after the five in the SEdit window. -Type:\"(()6 7 8\" -Now complete the edit by typing control x. -Were you able to get this far?")) - (good-value (equal '(5 (nil 6 7 8)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble creating dotted pairs" - (let* (( user-result (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (5 (nil 6 7 8)) - Testing dotted pairs. -Put the edit caret after the 8. -Type: \" .9\" -Put the edit caret after the smaller list. -Type: \" .10\" -Now complete the edit by selecting DONE from the pop-up menu. -Were you able to get this far?")) - (good-value (equal '(5 (nil 6 7 8 . 9) . 10) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with single quote" - (let* (( user-result (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (5 (nil 6 7 8 . 9) . 10) - Testing single quotes. -Pick the smaller list as a structure by holding both keys down over the open parenthensis. -Press the delete key. -Type: \"'(5 6 7\" -Now complete the edit by selecting DONE from the pop-up menu. -Were you able to get this far?")) - (good-value (equal '(5 (quote (5 6 7)) . 10) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with control x" - (let* (( user-result (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (5 (quote (5 6 7)) . 10) - Testing control-w. -Pick the smaller list as a structure by holding both keys down over the close parenthensis. -Type control W. -Now complete the edit by typing control x. -Were you able to get this far?")) - (good-value (equal '(5 . 10) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with control (" - (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (5 . 10) - Testing meta-(. -Select 10 as a structure. -Pick meta-( from the pop menu. -Check to see if the caret is in front of the ten. -Now complete the edit by typing control x. -Was the caret in front of the ten?")) - - -(do-test "Trouble with control (" - (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (5 10) - Testing meta-A. -Place the edit caret after the ten. -Type: \" 11 12 13\" -Pick control-A from the pop-up menu. -Confirm yes it is ok to abort. -Were you able to get this far?")) - - -(do-test "Trouble with control-B" - (do-test-menu-Message window-list 'high -"Assumping tempx is currently equals (5 10) - Testing meta-B. -Type: \"(il:dv tempx)\" -Pick control-B from the pop menu and enter 3. -Now complete the edit by selecting DONE from the pop-up menu. -Do you see (#3r12 #3r101)?")) - - -(do-test "Trouble with control-J" - (let* (( user-result (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (5 10) - Testing meta-J. -First restore the base by picking control-B from the popup menu and entering 10. -Delete everything inside the big list. -Type: \"x x x\" -Then select these three elements. -Pick control-J from the pop menu. -Now complete the edit by selecting DONE from the pop-up menu. -Were you able to get this far?")) - (good-value (equal '(xxx) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with control-M" - (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (xxx) - Testing meta-M. -Pick control-M from the pop menu. -Now complete the edit by selecting DONE from the pop-up menu. -Does the menu come up and stay up?")) - - -(do-test "Trouble with control-U" - (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (xxx) - Testing meta-U. -Place the edit structure caret after the symbol xxx. -Type: \" yyy\" -Select Undo from the menu. -Were you able to get this far?")) - - -(do-test "Trouble with control-R" - (let* (( user-result (do-test-menu-Message window-list 'high -"Assumping SEdit is editing tempx which currently equals (xxx) - Testing meta-R. -Place the edit structure caret after the symbol xxx. -Type: \" yyy\" -Select Undo, Redo, and Exit from the menu. -Were you able to get this far?")) - (good-value (equal '(xxx yyy) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -) ; end of do-test-group - - - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-high.u.~2~ b/internal/test/env/code-editor/hand/Command-high.u.~2~ deleted file mode 100644 index bcdf95f2..00000000 --- a/internal/test/env/code-editor/hand/Command-high.u.~2~ +++ /dev/null @@ -1,175 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 4, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-high.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "High level, high priority test" - :before (progn - (setq window-list (do-test-menu-Setup "High-level"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Trouble typing with parentheses" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing parentheses -If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" -Then in the exec type: - -(setq tempx '(5)) -(il:dv tempx) - -Put the edit caret after the five in the SEdit window. -Type \"(() 6 7 8)\" -Now complete the edit by typing control x. -Were you able to get this far?")) - (good-value (equal '(5 (nil 6 7 8)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble creating dotted pairs" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing dotted pairs. -Assuming SEdit is editing tempx which currently equals (5 (nil 6 7 8)) -Put the edit caret after the 8. -Type \" .9\". -Put the edit caret after the smaller list. -Type \" .10\". -Now complete the edit by selecting DONE from the pop-up menu. -Were you able to get this far?")) - (good-value (equal '(5 (nil 6 7 8 . 9) . 10) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with single quote" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing single quotes. -Assuming SEdit is editing tempx which currently equals (5 (nil 6 7 8 . 9) . 10) -Pick the smaller list as a structure by pressing the middle button down over the open parenthensis. -Press the delete key. -Type \"'(5 6 7)\". -Now complete the edit by selecting DONE from the pop-up menu. -Were you able to get this far?")) - (good-value (equal '(5 (quote (5 6 7)) . 10) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with control-w" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing control-w. -Assuming SEdit is editing tempx which currently equals (5 '(5 6 7) . 10) -Pick the smaller list as a structure by pressing the middle button down over the close parenthensis. -Type control W. -Now complete the edit by typing control x. -Do you now have "(5 . 10)?")) - (good-value (equal '(5 . 10) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with meta-(" - (do-test-menu-Message window-list 'high -" Testing meta-(. -Assuming SEdit is editing tempx which currently equals (5 . 10) -Select 10 as a structure. -Pick meta-( from the pop menu. -Check to see if the caret is in front of the ten. -Now complete the edit by typing control x. -Was the caret in front of the ten? ")) - - -(do-test "Trouble with meta-A" - (do-test-menu-Message window-list 'high -" Testing meta-A. -Assuming SEdit is editing tempx which currently equals (5 10) -Place the edit caret after the ten. -Type \" 11 12 13\". -Pick meta-A from the pop-up menu. -Confirm yes it is ok to abort. -Were you able to get this far?")) - - -(do-test "Trouble with meta-B" - (do-test-menu-Message window-list 'high -" Testing meta-B. -Assuming tempx is currently equals (5 10) -Type: \"(il:dv tempx)\" -Pick meta-B from the pop menu and enter 3. -Now complete the edit by selecting DONE from the pop-up menu. -Do you see (#3r12 #3r101)?")) - - -(do-test "Trouble with meta-J" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing meta-J. -Assuming SEdit is editing tempx which currently equals (5 10) -First restore the base by picking meta-B from the popup menu and entering 10. -Delete everything inside the big list. -Type \"x x x\". -Then select these three elements. -Pick meta-J from the pop menu. -Now complete the edit by selecting DONE from the pop-up menu. -Did the three X's become one atom, XXX?")) - (good-value (equal '(xxx) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Trouble with meta-M" - (do-test-menu-Message window-list 'high -" Testing meta-M. -Assuming SEdit is editing tempx which currently equals (xxx) -Pick meta-M from the pop menu. -Now complete the edit by selecting DONE from the pop-up menu. -Does the menu come up and stay up?")) - - -(do-test "Trouble with meta-U" - (do-test-menu-Message window-list 'high -" Testing meta-U. -Assuming SEdit is editing tempx which currently equals (xxx) -Place the edit structure caret after the symbol xxx. -Type \" yyy\". -Select Undo from the menu. -Were you able to get this far?")) - - -(do-test "Trouble with meta-R" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing meta-R. -Assuming SEdit is editing tempx which currently equals (xxx) -Place the edit structure caret after the symbol xxx. -Type \" yyy\". -Select Undo, Redo, and Exit from the menu. -Were you able to get this far?")) - (good-value (equal '(xxx yyy) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -) ; end of do-test-group - - - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-join.u.~1~ b/internal/test/env/code-editor/hand/Command-join.u.~1~ deleted file mode 100644 index 84d09970..00000000 --- a/internal/test/env/code-editor/hand/Command-join.u.~1~ +++ /dev/null @@ -1,330 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 10, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-join.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Join" - :before (progn - (setq window-list (do-test-menu-Setup "Join"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Join: no selection/no caret" - (let* (( user-result(do-test-menu-Message window-list 'high -" Testing Join -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(il:dv tempx) - -Select Join from the popup menu. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" in pending delete mode. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Delete the comment. -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-J -Were the litatoms joined together to form \"abcd\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-J -Were the strings joined together to form the string \"helloBYE\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-J. - (If a break window pops up, uparrow out of it and indicate failure.) -Does SEdit display in the SEdit prompt window: - \"Can't join numbers.\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-J. -Were the lists joined together to form the list \"(bye \"hi\" b cd 4)\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-J. - (If a break window pops up, uparrow out of it and indicate failure.) -Does SEdit display in the SEdit prompt window: - \"Can't join numbers.\"? ")) - - -(do-test "Join: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the string \"helloBYE\" as a structure, and extend the selection to include the next item. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Each item to join must be of the same type.\"? ")) - - -(do-test "Join: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Each item to join must be of the same type.\"? ")) - - -(do-test "Join: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the entire structure. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-join.u.~2~ b/internal/test/env/code-editor/hand/Command-join.u.~2~ deleted file mode 100644 index 5ad7394a..00000000 --- a/internal/test/env/code-editor/hand/Command-join.u.~2~ +++ /dev/null @@ -1,330 +0,0 @@ -; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 10, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-join.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Join" - :before (progn - (setq window-list (do-test-menu-Setup "Join"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Join: no selection/no caret" - (let* (( user-result(do-test-menu-Message window-list 'high -" Testing Join -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(il:dv tempx) - -Select Join from the popup menu. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structuret, by pressing the left mouse button twice with the cursor over the string. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" in pending delete mode. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - - -(do-test "Join: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Delete the comment. -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-J -Were the litatoms joined together to form \"abcd\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-J -Were the strings joined together to form the string \"helloBYE\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-J. - (If a break window pops up, uparrow out of it and indicate failure.) -Does SEdit display in the SEdit prompt window: - \"Can't join numbers.\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-J. -Were the lists joined together to form the list \"(bye \"hi\" b cd 4)\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Join: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-J. - (If a break window pops up, uparrow out of it and indicate failure.) -Does SEdit display in the SEdit prompt window: - \"Can't join numbers.\"? ")) - - -(do-test "Join: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the string \"helloBYE\" as a structure, and extend the selection to include the next item. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Each item to join must be of the same type.\"? ")) - - -(do-test "Join: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Each item to join must be of the same type.\"? ")) - - -(do-test "Join: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 abcd efg \"helloBYE\" (bye \"hi\" b cd 4)) -Select the entire structure. -Type meta-J. -Does SEdit display in the SEdit prompt window: - \"Select items to join.\"? ")) - (good-value (equal '(1 2 4.5 6/7 abcd efg "helloBYE" (bye "hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Done&Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-menu.u.~1~ b/internal/test/env/code-editor/hand/Command-menu.u.~1~ deleted file mode 100644 index a8793150..00000000 --- a/internal/test/env/code-editor/hand/Command-menu.u.~1~ +++ /dev/null @@ -1,315 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 13, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-menu.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Menu" - :before (progn - (setq window-list (do-test-menu-Setup "Menu"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -;;; Since each command is tested in its own test suite, -;;; only worry about if can bring up the menu. - -(do-test "Menu: no selection/no caret" - (let* (( user-result(do-test-menu-Message window-list 'high -" Testing Menu -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(il:dv tempx) - -Select Menu from the popup menu. -Does the attached menu come up? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Menu: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select DONE from the SEdit popup menu. -If the attached menu is up, close it. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -If the attached menu is up, close it. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the \"h\" in the string \"hello\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the \"7\" in the number \"6/7\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button with the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"4.5\" in pending delete mode. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the list \"(bye)\" in pending delete mode. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Delete the comment. -If the attached menu is up, close it. -Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. -Type meta-M -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-M -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-M -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"1\" as a structure, and extend the selection to include the next seven items. -Type meta-m. -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the three item. -Type meta-M. -Does SEdit display in the SEdit prompt window: - \"This SEdit already has a menu\"? ")) - - -(do-test "Menu: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the entire structure. -Type meta-M. -Does the attached menu come up? ")) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-menu.u.~2~ b/internal/test/env/code-editor/hand/Command-menu.u.~2~ deleted file mode 100644 index 165967f5..00000000 --- a/internal/test/env/code-editor/hand/Command-menu.u.~2~ +++ /dev/null @@ -1,315 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 13, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-menu.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Menu" - :before (progn - (setq window-list (do-test-menu-Setup "Menu"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -;;; Since each command is tested in its own test suite, -;;; only worry about if can bring up the menu. - -(do-test "Menu: no selection/no caret" - (let* (( user-result(do-test-menu-Message window-list 'high -" Testing Menu -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(il:dv tempx) - -Select AttachMenu from the popup menu. -Does the attached menu come up? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Menu: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select DONE from the SEdit popup menu. -If the attached menu is up, close it. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -If the attached menu is up, close it. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the \"h\" in the string \"hello\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the \"7\" in the number \"6/7\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button with the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"4.5\" in pending delete mode. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the list \"(bye)\" in pending delete mode. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 ; hello 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Delete the comment. -If the attached menu is up, close it. -Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. -Type meta-M -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-M -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-M -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"1\" as a structure, and extend the selection to include the next seven items. -Type meta-m. -Does the attached menu come up? ")) - - -(do-test "Menu: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the three items. -Type meta-M. -Does SEdit display in the SEdit prompt window: - \"This SEdit already has a menu\"? ")) - - -(do-test "Menu: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-M. -Does the attached menu come up? ")) - - -(do-test "Menu: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -If the attached menu is up, close it. -Select the entire structure. -Type meta-M. -Does the attached menu come up? ")) - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Done&Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ b/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ deleted file mode 100644 index 9098aeea..00000000 --- a/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ +++ /dev/null @@ -1,367 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 16, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-meta-o.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "See/Change Definition" - :before (progn - (setq window-list (do-test-menu-Setup "See/Change Definition"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -;;; some different things to look at: -;;; optimizers: defoptimiziers -;;; structures: defstruct -;;; setfs: defsetf define-setf-method -;;; types: deftype -;;; variable: defglobalparameter, def-blobalvar, defconstant, defparameter, defvar -;;; functions: define-modify-macro, defmacro, definline, defun, -;;; define-type: def-define-type - -;;; Have AR 7699 on the next three expected responses from meta-o -(do-test "See/Change Definition: no selection/no caret" - (do-test-menu-Message window-list 'high -" Testing See/Change Definition -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq number 3) -(setq cd '(a b wer)) -(setq efg '(1 2 3 4 5)) -(defoptimizer temp-add-five (number) (number) (+ 5 number)) -(define-modify-macro my-restf (list) cdr) -(defmacro temp-double (number) `(+ ,number ,number)) -(define-modify-macro my-doublef (number) my-double) -(defstruct temp-silly \"silly\" sing (in 0.0) (long \"ab\") low yeast) -(defun temp-double (number) (declare (optimize speed)) (* 2 number)) -(defun temp-add-five (number) (+ 5 number)) -(defun temp-call-other (number) - (let ((silly-temp (make-temp-silly))) - (+ (temp-add-five number) (temp-double number)))) -(defun temp-garbage (x) '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(ed 'temp-call-other) - -Select Edit from the popup menu. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: Test get right definiton" - (do-test-menu-Message window-list 'high -" Testing: get the FNS definition -Assumping SEdit is editing the function temp-call-other. -Select \"make-temp-silly\" -Type meta-O. -Does the FNS definition for \"make-temp-silly\" popup in an SEdit window? ")) - - -(do-test "See/Change Definition: Test get structures definiton" - (do-test-menu-Message window-list 'high -" Testing: get the structures definition -Assumping SEdit is editing the function temp-call-other & make-temp-silly. -Select \"temp-silly\" in the SEdit window for \"make-temp-silly\" about eight lines down the window. -Type meta-O. -Does the STRUCTURES definition for \"temp-silly\" popup in an SEdit window? ")) - - -(do-test "See/Change Definition: Test get defoptimizer definiton" - (do-test-menu-Message window-list 'high -" Testing: get the defoptimizer definition -Assumping SEdit is editing the function temp-call-other & make-temp-silly, and the structure definition for temp-silly. -Close the SEdit window for temp-silly, and make-temp-silly. -Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". -Type meta-O. -SEdit should ask \"Edit which definition of temp-add-five\". -Select \"optimizes\". -Did it ask and does the SEdit display in another SEdit window: - \"(defoptimizer temp-add-five (number) (number) (+ 5 number))\"? ")) - - -(do-test "See/Change Definition: Test get optimizers definiton" - (do-test-menu-Message window-list 'high -" Testing: get the optimizers definition -Assumping SEdit is editing the function temp-call-other, and the optimizers definition for temp-add-five. -Close the SEdit window for temp-add-five. -Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". -Type meta-O. -SEdit should ask \"Edit which definition of temp-add-five\". -Select \"functions\". -Did it ask and does the SEdit display in another SEdit window: - \"(defun temp-add-five (number) (+ 5 number))\"? ")) - - -(do-test "See/Change Definition: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the function temp-call-other & temp-add-five. -Close both windows. -Type \"(ed 'temp-garbage)\" -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the function temp-garbage. -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the function temp-garbage. -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-O. - (If asked to select a type of dummy definition to install, pick VARS.) -Does a second SEdit window pop up editing the var CD with a value o: - \"(a b wer)\"? ")) - - -(do-test "See/Change Definition: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the function temp-garbage and the veariable CD. -Close the SEdit window for the variable CD. -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-O. -Select VARIABLE, then DEFVAR -Does SEdit display in the SEdit prompt window: - \"\"hello\" not editable.\"? ")) - - -(do-test "See/Change Definition: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the function temp-garbage. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-O. -Select OPTIMIZERS, DEFOPTIMIZER -Does SEdit display in the SEdit prompt window: - \"4.5 not editable.\"? ")) - - -(do-test "See/Change Definition: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the function temp-garbage. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-O. -Select DEFINE-TYPES, DEF-DEFINE-TYPE -Does SEdit display in the SEdit prompt window: - \"(bye) not editable.\"? ")) - - -(do-test "See/Change Definition: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the function temp-garbage. -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-O. -Select FUNCTIONS, DEFUN -Does SEdit display in the SEdit prompt window: - \"(il:* il:\\; \" hello\") not editable.\"? ")) - - -(do-test "See/Change Definition: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the function temp-garbage. -Select the comment as a structure and press the delete key. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the function temp-garbage and the variable cd. -Close the SEdit window for the variable \"cd\". -Select the \"h\" in the string \"hello\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the function temp-garbage. -Select the \"7\" in the number \"6/7\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the function temp-garbage. -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the function temp-garbage and the variable efg. -Close the SEdit window for efg. -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assumping SEdit is editing the function temp-garbage. -Select the number \"4.5\" in pending delete mode. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the function temp-garbage. -Select the list \"(bye)\" in pending delete mode. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assumping SEdit is editing the function temp-garbage. -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the function temp-garbage. -Delete the comment. -Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. -Type meta-O -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the function temp-garbage. -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-O -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the function temp-garbage. -Select the number \"1\" as a structure, and extend the selection to include the next three numbers. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the function temp-garbage. -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the function temp-garbage. -Select the number \"1\" as a structure, and extend the selection to include the next seven items. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the function temp-garbage. -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the function temp-garbage. -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the function temp-garbage. -Select the entire structure. -Type meta-O. -Select FNS, NLAMBDA. -Does SEdit display in the SEdit prompt window: - \"(defun temp-garbage (x) (quote (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (BYE) (\"hi\" b cd 4)))) not editable.\"? ")) - - -;;; After testing the enter points test the command some. - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ b/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ deleted file mode 100644 index e8736c75..00000000 --- a/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ +++ /dev/null @@ -1,365 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 16, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-meta-o.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "See/Change Definition" - :before (progn - (setq window-list (do-test-menu-Setup "See/Change Definition"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -;;; some different things to look at: -;;; optimizers: defoptimiziers -;;; structures: defstruct -;;; setfs: defsetf define-setf-method -;;; types: deftype -;;; variable: defglobalparameter, def-blobalvar, defconstant, defparameter, defvar -;;; functions: define-modify-macro, defmacro, definline, defun, -;;; define-type: def-define-type - -;;; Have AR 7699 on the next three expected responses from meta-o -(do-test "See/Change Definition: no selection/no caret" - (do-test-menu-Message window-list 'high -" Testing See/Change Definition -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq number 3) -(setq cd '(a b wer)) -(setq efg '(1 2 3 4 5)) -(defoptimizer temp-add-five (number) (number) (+ 5 number)) -(define-modify-macro my-restf (list) cdr) -(defmacro temp-double (number) `(+ ,number ,number)) -(define-modify-macro my-doublef (number) my-double) -(defstruct temp-silly \"silly\" sing (in 0.0) (long \"ab\") low yeast) -(defun temp-double (number) (declare (optimize speed)) (* 2 number)) -(defun temp-add-five (number) (+ 5 number)) -(defun temp-call-other (number) - (let ((silly-temp (make-temp-silly))) - (+ (temp-add-five number) (temp-double number)))) -(defun temp-garbage (x) '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(ed 'temp-call-other) - -Select Edit from the popup menu. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: Test get right definiton" - (do-test-menu-Message window-list 'high -" Testing: get the FNS definition -Assuming SEdit is editing the function temp-call-other. -Select \"make-temp-silly\" -Type meta-O. -Does the FNS definition for \"make-temp-silly\" popup in an SEdit window? ")) - - -(do-test "See/Change Definition: Test get structures definiton" - (do-test-menu-Message window-list 'high -" Testing: get the structures definition -Assuming SEdit is editing the function temp-call-other & make-temp-silly. -Select \"temp-silly\" in the SEdit window for \"make-temp-silly\" about eight lines down the window. -Type meta-O. -Does the STRUCTURES definition for \"temp-silly\" popup in an SEdit window? ")) - - -(do-test "See/Change Definition: Test get defoptimizer definiton" - (do-test-menu-Message window-list 'high -" Testing: get the defoptimizer definition -Assuming SEdit is editing the function temp-call-other & make-temp-silly, and the structure definition for temp-silly. -Close the SEdit window for temp-silly, and make-temp-silly. -Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". -Type meta-O. -SEdit should ask \"Edit which definition of temp-add-five\". -Select \"optimizers\". -Did it ask and does the SEdit display in another SEdit window: - \"(defoptimizer temp-add-five (number) (number) (+ 5 number))\"? ")) - - -(do-test "See/Change Definition: Test get optimizers definiton" - (do-test-menu-Message window-list 'high -" Testing: get the optimizers definition -Assuming SEdit is editing the function temp-call-other, and the optimizers definition for temp-add-five. -Close the SEdit window for temp-add-five. -Select \"temp-add-five\" in the SEdit window for \"temp-call-other\". -Type meta-O. -SEdit should ask \"Edit which definition of temp-add-five\". -Select \"functions\". -Did it ask and does the SEdit display in another SEdit window: - \"(defun temp-add-five (number) (+ 5 number))\"? ")) - - -(do-test "See/Change Definition: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the function temp-call-other & temp-add-five. -Close both windows. -Type \"(ed 'temp-garbage)\" -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the function temp-garbage. -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the function temp-garbage. -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-O. - (If asked to select a type of dummy definition to install, pick VARS.) -Does a second SEdit window pop up editing the var CD with a value of: - \"(a b wer)\"? ")) - - -(do-test "See/Change Definition: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the function temp-garbage and the variable CD. -Close the SEdit window for the variable CD. -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-O. -Select VARIABLES, then DEFVAR -Does SEdit display in the SEdit prompt window: - \"\"hello\" has no VARIABLES definition.\"? ")) - - -(do-test "See/Change Definition: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the function temp-garbage. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-O. -Select OPTIMIZERS, DEFOPTIMIZER -Does SEdit display in the SEdit prompt window: - \"4.5 not editable.\"? ")) - - -(do-test "See/Change Definition: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the function temp-garbage. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-O. -Select DEFINE-TYPES, DEF-DEFINE-TYPE -Does SEdit display in the SEdit prompt window: - \"(BYE) has no DEFINE-TYPES definition.\"? ")) - - -(do-test "See/Change Definition: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the function temp-garbage. -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-O. -Select FUNCTIONS, DEFUN -Does SEdit display in the SEdit prompt window: - \"(il:* il:\\; \" hello\") has no FUNCTIONS definition.\"? ")) - - -(do-test "See/Change Definition: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the function temp-garbage. -Select the comment as a structure and press the delete key. -Type control-x. -Select the \"d\" in the first litatom \"cd\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the function temp-garbage and the variable cd. -Close the SEdit window for the variable \"cd\". -Select the \"h\" in the string \"hello\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the function temp-garbage. -Select the \"7\" in the number \"6/7\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the function temp-garbage. -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the function temp-garbage. -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete a number" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the function temp-garbage. -Select the number \"4.5\" in pending delete mode. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the function temp-garbage. -Select the list \"(bye)\" in pending delete mode. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: pending delete of a comment" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a comment -Assuming SEdit is editing the function temp-garbage. -Place the structure caret the number \"1\". -Type in \"; hello\" -Select the comment in pending delete mode. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the function temp-garbage. -Delete the comment. -Select the litatom \"a\" as a structure, and extend the selection to include the next three litatoms. -Type meta-O -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the function temp-garbage. -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-O -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the function temp-garbage. -Select the number \"1\" as a structure, and extend the selection to include the next three numbers. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the function temp-garbage. -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the function temp-garbage. -Select the number \"1\" as a structure, and extend the selection to include the next seven items. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the function temp-garbage. -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the function temp-garbage. -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-O. -Does SEdit display in the SEdit prompt window: - \"Select name of object to edit.\"? ")) - - -(do-test "See/Change Definition: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the function temp-garbage. -Select the entire structure. -Type meta-O. -Select FNS, NLAMBDA. -Does SEdit display in the SEdit prompt window: - \"(defun temp-garbage (x) (quote (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (BYE) (\"hi\" b cd 4)))) not editable.\"? ")) - - - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Done&Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-mutate.u.~1~ b/internal/test/env/code-editor/hand/Command-mutate.u.~1~ deleted file mode 100644 index 8a586fc7..00000000 --- a/internal/test/env/code-editor/hand/Command-mutate.u.~1~ +++ /dev/null @@ -1,313 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 23, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-mutate.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Mutate" - :before (progn - (setq window-list (do-test-menu-Setup "Mutate"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Mutate: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Mutate -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(defun temp-double (number) (* 2 number)) -(defun temp-build-string (string) - (concatenate 'string string \" more\")) -(defun temp-car (list) (car list)) -(defun temp-return-value () '(a list)) -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Select Mutate from the pop up menu. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-Z. -Enter \"temp-return-value\". -Does SEdit display in the SEdit prompt window: - \"Error during mutation. No changes made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-Z. -Enter \"temp-build-string\". -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello more" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello more\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-Z. -Enter \"temp-double\" -Were you able to get this far? ")) - (good-value (equal '(1 9.0 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 9.0 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-Z. -Enter \"temp-car\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) -Type meta-U. -Select the \"d\" in the first litatom \"cd\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-Z -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-Z -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate\"? ")) - - -(do-test "Mutate: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) -Select the entire structure. -Type meta-Z. -Enter \"temp-car\" -Were you able to get this far? ")) - (good-value (equal 1 tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - - -(do-test "Mutate: Pending delete of whole structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the entire structure in pending delete mode. -Type meta-z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-mutate.u.~2~ b/internal/test/env/code-editor/hand/Command-mutate.u.~2~ deleted file mode 100644 index 34893fa6..00000000 --- a/internal/test/env/code-editor/hand/Command-mutate.u.~2~ +++ /dev/null @@ -1,313 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 23, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-mutate.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Mutate" - :before (progn - (setq window-list (do-test-menu-Setup "Mutate"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Mutate: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Mutate -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(defun temp-double (number) (* 2 number)) -(defun temp-build-string (string) - (concatenate 'string string \" more\")) -(defun temp-car (list) (car list)) -(defun temp-return-value () '(a list)) -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Select Mutate from the pop up menu. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-Z. -Enter \"temp-return-value\". -Does SEdit display in the SEdit prompt window: - \"Error during mutation. No changes made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-Z. -Enter \"temp-build-string\". -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello more" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello more\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-Z. -Enter \"temp-double\" -Were you able to get this far? ")) - (good-value (equal '(1 9.0 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 9.0 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-Z. -Enter \"temp-car\" -Were you able to get this far? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" bye ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Mutate: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" bye (\"hi\" (b) cd 4)) -Type meta-U. -Select the \"d\" in the first litatom \"cd\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-Z -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-Z -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate\"? ")) - - -(do-test "Mutate: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-Z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Mutate: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) -Select the entire structure. -Type meta-Z. -Enter \"temp-car\" -Were you able to get this far? ")) - (good-value (equal 1 tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - - -(do-test "Mutate: Pending delete of whole structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the entire structure in pending delete mode. -Type meta-z. -Does SEdit display in the SEdit prompt window: - \"Select whole structure to mutate.\"? ")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Done&Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-paren.u.~1~ b/internal/test/env/code-editor/hand/Command-paren.u.~1~ deleted file mode 100644 index 08c26d6d..00000000 --- a/internal/test/env/code-editor/hand/Command-paren.u.~1~ +++ /dev/null @@ -1,337 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 5, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>SEdit-command-low-paren.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Parenthesize current selection" - :before (progn - (setq window-list (do-test-menu-Setup "Parenthesize"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Parenthesize: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing parentheses -If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" -Then in the exec type: - -(setq tempx '(1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4))) -(il:dv tempx) - -Type meta-(. -Were you able to get this far?")) - (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) - Testing: no selection/edit caret -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-(. -Were you able to get this far?")) - (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) - Testing: no selection/structure caret -Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-(. -Were you able to get this far?")) - (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) - Testing: select a litatom -Select the litatom \"ab\" as a structure, by pressing the middle button with the cursor over the litatom. -Type meta-). -Were you able to get this far?")) - (good-value (equal '(1 23 (ab) cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (1 23 (ab) cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) - Testing: select a string -Select the string \"how\" as a structure, by pressing the middle button, with the cursor over the string. -Type meta-). -Were you able to get this far?")) - (good-value (equal '(1 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (1 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) - Testing: select a number -Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. -Select PAREN from the popup menu. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) - Testing: select a list -Select the list (\"hi\" \"bye\" a 23 4) as a structure. -Type meta-9, and then control-x. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Parenthesize: select a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: select a comment -Place the edit caret after the number 23 and type \"; hello\", then select this as a structure, and type meta-0. -Check to see if it has parenthesis around it, then select Abort from the pop-up menu. -Was the parenthesis around the comment?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: select part of a litatom -Type: \"(il:dv tempx)\" -Select the \"d\" in the litatom \"cd\" and type meta-0. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: select part of a string -Select the \"h\" in the string \"how\" and type meta-0. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: select part of a number -Select the \"2\" in the number \"23\" and type meta-0. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: try after deleting a litatom -Place the edit caret after the litatom \"ab\" with in the list. -Type \" ef\", then control-W and meta-0. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a string" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: try after deleting a string -Place the structure caret after the string \"hi\" with in the list. -Type a double quote, and then the word \"there\", put the structure caret right after this string, and type control-W and meta-0. -Were you able to get this far?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: try after deleting a number -Place the edit caret right after the number \"23\" with no selection. -Type control-W, and meta-(, control-x. -Were you able to get this far?")) - (good-value (equal '((1) (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a list" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) - Testing: try after deleting a number -Place the structure caret right after the list \"((\"hi\" \"bye\" a 23 4))\" with no selection. -Type control-W, and meta-(, control-x. -Were you able to get this far?")) - (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") - Testing: try after deleting a comment -Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. -Press the delete key and type meta-(, control-x. -Were you able to get this far?")) - (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") - Testing: try extended selection of litatoms -Place the edit caret after the litatom \"cd\". -Type \" ef gh\". -Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. -Type meta-(. -Were you able to get this far?")) - (good-value (equal '((1) (ab) (cd ef gh) ("how") "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") \"are\" \"you\") - Testing: extended selection of strings -Select the string \"are\" as a structure, and extend the selection to include the next string. -Type meta-(. -Were you able to get this far?")) - (good-value (equal '((1) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) - Testing: extended selection of numbers -Place the structure caret after the list \"(1)\". -Type \" 2 3 4\". -Now select the number \"2\" as a structure, and extend the selection to include the next two numbers. -Type meta-). -Were you able to get this far?")) - (good-value (equal '((1) (2 3 4) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (2 3 4) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) - Testing: extended selection of lists -Select the list \"(2 3 4)\" as a structure, and extend the selection to include the next two lists. -Type meta-). -Were you able to get this far?")) - (good-value (equal '((1) ((2 3 4) (ab) (cd ef gh)) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) ((2 3 4) (ab) (cd ef gh)) (\"how\") (\"are\" \"you\")) - Testing: extended selection of litatoms and numbers -Select the list \"((2 3 4) (ab) (cd ef gh))\" as a structure and press the delete key. -Now type \" ab 23 cd 45\" -Select the litatom \"ab\" as a structure, and extend the selection to include the next three items. -Type meta-). -Were you able to get this far?")) - (good-value (equal '((1) (ab 23 cd 45) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) - Testing: extended selection of strings and lists -Place the structure caret after the list \"(1)\". -Type \" (hi) \"hi\" (bye) \"bye\" (list-string)\" -Select the list \"(hi)\" as a structure, and extend the selection to include the next four items. -Select Paren from the popup menu. -Were you able to get this far?")) - (good-value (equal '((1) ((hi) "hi" (bye) "bye" (list-string)) (ab 23 cd 45) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) ((hi) \"hi\" (bye) \"bye\" (list-string)) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) - Testing: extended selection of several things -Select the second list as a structure, extend the select to include the rest of the items, and press the delete key. -Type \"23 a-litatom 45 \"hi\" bye (my small list)\" -Select the number \"23\" as a structure, and extend the selection to include the next six items. -Select Paren from the popup menu. -Were you able to get this far?")) - (good-value (equal '((1) (23 a-litatom 45 "hi" bye (my small list))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals ((1) (23 a-litatom 45 \"hi\" bye (my small list))) - Testing: selection of entire structure -Select the entire structure. -Select Paren from the popup menu. -Were you able to get this far?")) - (good-value (equal '(((1) (23 a-litatom 45 "hi" bye (my small list)))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -) ; end of do-test-group - - - - - - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-paren.u.~2~ b/internal/test/env/code-editor/hand/Command-paren.u.~2~ deleted file mode 100644 index 33720b26..00000000 --- a/internal/test/env/code-editor/hand/Command-paren.u.~2~ +++ /dev/null @@ -1,342 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 5, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>SEdit-command-low-paren.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Parenthesize current selection" - :before (progn - (setq window-list (do-test-menu-Setup "Parenthesize"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Parenthesize: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing parentheses -If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" -Then in the exec type: - -(setq tempx '(1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4))) -(il:dv tempx) - -Type meta-(. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-(. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) -Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-(. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '(1 23 ab cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing tempx which currently equals (1 23 ab cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) -Select the litatom \"ab\" as a structure, by pressing the middle button with the cursor over the litatom. -Type meta-). -Is the litatom AB now parenthesized?")) - (good-value (equal '(1 23 (ab) cd "how" "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing tempx which currently equals (1 23 (ab) cd \"how\" \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) -Select the string \"how\" as a structure, by pressing the middle button, with the cursor over the string. -Type meta-). -Is the string \"how\" now parenthesized?")) - (good-value (equal '(1 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing tempx which currently equals (1 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) -Select the number \"1\" as a structure, by pressing the middle button, with the cursor over the number. -Select PARENTHESIZE from the popup menu. -Is the number \"1\" now parenthesized?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" ("hi" "bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" (\"hi\" \"bye\" a 23 4)) -Select the list (\"hi\" \"bye\" a 23 4) as a structure. -Type meta-9, and then control-x. -Is the list now parenthesized?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Parenthesize: select a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Place the edit caret after the number 23 and type \"; hello\", then select this as a structure, and type meta-0. -Check to see if it has parenthesis around it, then select Abort from the pop-up menu, clicking the left button to confirm the abort. -Was the parenthesis around the comment?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming tempx currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Type: \"(il:dv tempx)\" -Select the \"d\" in the litatom \"cd\" and type meta-0. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Select the \"h\" in the string \"how\" and type meta-0. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Select the \"2\" in the number \"23\" and type meta-0. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a litatom -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Place the edit caret after the litatom \"ab\" with in the list. -Type \" ef\", then control-W and meta-0. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a string -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Place the structure caret after the string \"hi\" with in the list. -Type a double quote, and then the word \"there\", put the structure caret right after this string, and type control-W and meta-0. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) 23 (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a number -Assuming SEdit is editing tempx which currently equals ((1) 23 (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Place the edit caret right after the number \"23\" with no selection. -Type control-W, and meta-(, control-x. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) (ab) cd ("how") "are" "you" (("hi" "bye" a 23 4))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a list -Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\" ((\"hi\" \"bye\" a 23 4))) -Place the structure caret right after the list \"((\"hi\" \"bye\" a 23 4))\" with no selection. -Type control-W, and meta-(, control-x. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: delete a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try after deleting a comment -Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") -Place the structure caret after the litatom \"cd\" and type \"; hello\", then select this as a structure with the caret to the right. -Press the delete key and type meta-(, control-x. -Does the SEdit prompt window say \"Select structure to parenthesize.\"?")) - (good-value (equal '((1) (ab) cd ("how") "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing tempx which currently equals ((1) (ab) cd (\"how\") \"are\" \"you\") -Place the edit caret after the litatom \"cd\". -Type \" ef gh\". -Now select the litatom \"cd\" as a structure, and extend the selection to include the next two litatoms. -Type meta-(. -Are the three litatoms now parenthesized?")) - (good-value (equal '((1) (ab) (cd ef gh) ("how") "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") \"are\" \"you\") -Select the string \"are\" as a structure, and extend the selection to include the next string. -Type meta-(. -Are the two strings now parenthesized?")) - (good-value (equal '((1) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing tempx which currently equals ((1) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) -Place the structure caret after the list \"(1)\". -Type \" 2 3 4\". -Now select the number \"2\" as a structure, and extend the selection to include the next two numbers. -Type meta-). -Are the three numbers now parenthesized?")) - (good-value (equal '((1) (2 3 4) (ab) (cd ef gh) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing tempx which currently equals ((1) (2 3 4) (ab) (cd ef gh) (\"how\") (\"are\" \"you\")) -Select the list \"(2 3 4)\" as a structure, and extend the selection to include the next two lists. -Type meta-). -Are the three lists now parenthesized?")) - (good-value (equal '((1) ((2 3 4) (ab) (cd ef gh)) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing tempx which currently equals ((1) ((2 3 4) (ab) (cd ef gh)) (\"how\") (\"are\" \"you\")) -Select the list \"((2 3 4) (ab) (cd ef gh))\" as a structure and press the delete key. -Now type \" ab 23 cd 45\" -Select the litatom \"ab\" as a structure, and extend the selection to include the next three items. -Type meta-). -Is the selection now parenthesized?")) - (good-value (equal '((1) (ab 23 cd 45) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing tempx which currently equals ((1) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) -Place the structure caret after the list \"(1)\". -Type \" (hi) \"hi\" (bye) \"bye\" (list-string)\" -Select the list \"(hi)\" as a structure, and extend the selection to include the next four items. -Select Parenthesize from the popup menu. -Is the selection now parenthesized?")) - (good-value (equal '((1) ((hi) "hi" (bye) "bye" (list-string)) (ab 23 cd 45) ("how") ("are" "you")) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing tempx which currently equals ((1) ((hi) \"hi\" (bye) \"bye\" (list-string)) (ab 23 cd 45) (\"how\") (\"are\" \"you\")) -Select the second list as a structure, extend the select to include the rest of the items, and press the delete key. -Type \"23 a-litatom 45 \"hi\" bye (my small list)\" -Select the number \"23\" as a structure, and extend the selection to include the next five items. -Select Parenthesize from the popup menu. -Is the selection now parenthesized?")) - (good-value (equal '((1) (23 a-litatom 45 "hi" bye (my small list))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Parenthesize: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assuming SEdit is editing tempx which currently equals ((1) (23 a-litatom 45 \"hi\" bye (my small list))) - Testing: selection of entire structure -Select the entire structure. -Select Parenthesize from the popup menu. -Is the entire structure inside an extra set of parentheses?")) - (good-value (equal '(((1) (23 a-litatom 45 "hi" bye (my small list)))) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Parenthesize: clean-up" - (let* ((user-result (do-test-menu-Message window-list 'low -"Close the SEdit window."))) - )) - - -) ; end of do-test-group - - - - - - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-substitute.u.~1~ b/internal/test/env/code-editor/hand/Command-substitute.u.~1~ deleted file mode 100644 index de2c415d..00000000 --- a/internal/test/env/code-editor/hand/Command-substitute.u.~1~ +++ /dev/null @@ -1,384 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 21, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-substitute.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Substitute" - :before (progn - (setq window-list (do-test-menu-Setup "Substitute"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Substitute: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Substitute -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Select Substitute from the pop up menu. -Does SEdit display in the SEdit prompt window: - \"Select structure to substitue within.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Select structure to substitute within.\"? ")) - - -(do-test "Substitute: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Select structure to substitute within.\"? ")) - - -(do-test "Substitute: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-S. -Enter the litatom \"cd\" then the litatom \"cde\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cde efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cde efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-S. -Enter the string \"hello\" then the string \"HELLO\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "HELLO" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"HELLO\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-S. -Enter the number \"4.5\" then the number \"5.4\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 5.4 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 5.4 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-S. -Enter the list \"(bye)\" then the list \"(bye now)\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye now) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye now) (\"hi\" (b) cd 4)) -Type meta-U. -Select the \"d\" in the first litatom \"cd\". -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Select structure to substitue within.\"? ")) - - -(do-test "Substitute: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Select structure to substitue within.\"? ")) - - -(do-test "Substitute: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Select structure to substitue within.\"? ")) - - -(do-test "Substitute: pending delete of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-S. -First enter the litatom \"efg\" then the number \"999\". -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd 999 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: pending delete of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd 999 \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-S. -First enter the string \"hello\" then the litatom \"we-2\". -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg we-2 "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -;Have an AR on this -;(do-test "Substitute: pending delete a number" -; (let* ((user-result (do-test-menu-Message window-list 'low -;" Testing: pending delete of a number -;Assumping SEdit is editing the variable tempx which currently equals: -; (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) -;Type meta-U. -;Select the number \"4.5\" in pending delete mode. -;Type meta-S. -;Enter the number \"4.5\", then the list \"(a b c d)\". -;Does SEdit display in the SEdit prompt window: -; \"Select structure to extract.\"? ")) -; (good-value (equal '(1 (a b c d) 6/7 a cd efg "hello" "BYE" (bye) ("hi" ;(b) cd 4)) tempx))) -; (and user-result (if (eq t user-result) good-value T)) -; )) - - -(do-test "Substitute: pending delete of a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" in pending delete mode. -Type meta-S. -Enter the list \"(bye)\", then the number \"2\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" 2 ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" 2 (\"hi\" (b) cd 4)) -Type meta-U. -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-S -Enter the litatom \"a\", then the string \"Wedding song\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 "Wedding song" cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 \"Wedding song\" cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-S -First enter the string \"hello\", then the number \"12\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg 12 "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg 12 \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-S. -First enter the number \"6/7\", then the list \"(56 65)\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 (56 65) a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 (56 65) a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-S. -First enter the list \"(b)\", then the litatom \"bcd\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" bcd cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" bcd cd 4)) -Type meta-U. -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-S. -First enter the number \"1\", then the litatom \"qw\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(qw 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (qw 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-S. -First enter the string \"BYE\", then the number \"7878\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" 7878 (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" 7878 (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-S. -First enter the litatom \"cd\", then the litatom \"gh\" -Does SEdit display in the SEdit prompt window: - \"2 substitutions made.\"? ")) - (good-value (equal '(1 4.5 6/7 a gh efg "hello" "BYE" (bye) ("hi" (b) gh 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a gh efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) -Type meta-U. -Select the entire structure. -Type meta-S. -First enter the string \"Should not change value\", then the litatom \"not-there\" -Does SEdit display in the SEdit prompt window: - \"No substitutions made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: Pending delete of whole structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the entire structure in pending delete mode. -Type meta-m. -Enter the number 4 in the FIND field. and the number 5 in the SUBSTITUE field. -Pick the substitute command on the attached menu. -Does SEdit display in the SEdit prompt window: - \"Select structure to extract.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 5)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-substitute.u.~2~ b/internal/test/env/code-editor/hand/Command-substitute.u.~2~ deleted file mode 100644 index 444cdbc2..00000000 --- a/internal/test/env/code-editor/hand/Command-substitute.u.~2~ +++ /dev/null @@ -1,383 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 21, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-substitute.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Substitute" - :before (progn - (setq window-list (do-test-menu-Setup "Substitute"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Substitute: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Substitute -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(il:dv tempx) - -Select Substitute from the pop up menu. -Does SEdit display in the SEdit prompt window: - \"Please select a structure to substitute within.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Please select a structure to substitute within.\"? ")) - - -(do-test "Substitute: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Want to place the structure caret right between \"(b)\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Please select a structure to substitute within.\"? ")) - - -(do-test "Substitute: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-S. -Enter the litatom \"cd\" then the litatom \"cde\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cde efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cde efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-S. -Enter the string \"hello\" (with quotes) then the string \"HELLO\" (with quotes). -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "HELLO" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"HELLO\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-S. -Enter the number \"4.5\" then the number \"5.4\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 5.4 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 5.4 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-S. -Enter the list \"(bye)\" then the list \"(bye now)\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye now) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye now) (\"hi\" (b) cd 4)) -Type meta-U. -Select the \"d\" in the first litatom \"cd\". -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Please select a structure to substitute within.\"? ")) - - -(do-test "Substitute: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Please select a structure to substitute within.\"? ")) - - -(do-test "Substitute: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-S. -Does SEdit display in the SEdit prompt window: - \"Please select a structure to substitute within.\"? ")) - - -(do-test "Substitute: pending delete of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-S. -First enter the litatom \"efg\" then the number \"999\". -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd 999 "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: pending delete of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd 999 \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-S. -First enter the string \"hello\" (with quotes) then the litatom \"we-2\" (without quotes). -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg we-2 "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: pending delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"4.5\" in pending delete mode. -Type meta-S. -Enter the number \"4.5\", then the list \"(a b c d)\". -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 (a b c d) 6/7 a cd efg "hello" "BYE" (bye) ("hi" ;(b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: pending delete of a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg we-2 \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" in pending delete mode. -Type meta-S. -Enter the list \"(bye)\", then the number \"2\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" 2 ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" 2 (\"hi\" (b) cd 4)) -Type meta-U. -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-S -Enter the litatom \"a\", then the string \"Wedding song\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 "Wedding song" cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 \"Wedding song\" cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-S -First enter the string \"hello\", then the number \"12\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg 12 "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg 12 \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-S. -First enter the number \"6/7\", then the list \"(56 65)\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 (56 65) a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 (56 65) a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-S. -First enter the list \"(b)\", then the litatom \"bcd\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" bcd cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" bcd cd 4)) -Type meta-U. -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-S. -First enter the number \"1\", then the litatom \"qw\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(qw 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (qw 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-S. -First enter the string \"BYE\", then the number \"7878\" -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" 7878 (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" 7878 (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-S. -First enter the litatom \"cd\", then the litatom \"gh\" -Does SEdit display in the SEdit prompt window: - \"2 substitutions made.\"? ")) - (good-value (equal '(1 4.5 6/7 a gh efg "hello" "BYE" (bye) ("hi" (b) gh 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a gh efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) -Type meta-U. -Select the entire structure. -Type meta-S. -First enter the string \"Should not change value\", then the litatom \"not-there\" -Does SEdit display in the SEdit prompt window: - \"No substitutions made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Substitute: Pending delete of whole structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Type meta-U. -Select the entire structure in pending delete mode. -Type meta-m. -Enter the number 4 in the FIND field. and the number 5 in the SUBSTITUTE field. -Pick the substitute command on the attached menu. -Does SEdit display in the SEdit prompt window: - \"1 substitution made.\"? ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 5)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting EXIT from the attached menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ deleted file mode 100644 index 4e014e94..00000000 --- a/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ +++ /dev/null @@ -1,645 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 17, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-undo-redo.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Undo/Redo" - :before (progn - (setq window-list (do-test-menu-Setup "Undo/Redo"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Undo: no selection/no caret" - (let* (( user-result(do-test-menu-Message window-list 'high -" Testing Undo -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(ed 'tempx) - -Select Undo from the popup menu. -Does it respond with: - \"Nothing to Undo\"? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: no selection/no caret" - (do-test-menu-Message window-list 'high -" Testing Redo -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select DONE from the popup menu. -Select Redo from the popup menu. -Does it respond with: - \"No Undo to Undo\"? ")) - - -(do-test "Undo: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" and press the delete key. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the structure caret between \"b\" and \"cd\". -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the third litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the fourth litatom \"efg\" as a structure. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"6/7\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure. -Type meta-R. -Select the string \"BYE\" and press the delete key. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-U three times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 2 and type \"; bye\", then select this as a structure. -Type meta-R. -Does SEdit display in the SEdit prompt window: - \"No Undo to Undo\"? ")) - - -(do-test "Undo: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 ; bye 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -Type control-x. -Place the strcuture caret after the litatom \"efg\" -Type: \"(Have a nice day please)\" -Select the \"d\" in the first litatom \"cd\". -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"f\" in the litatom \"efg\". -Type meta-R twice. -Does SEdit display in the SEdit prompt window: - \"No Undo to Undo.\"? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-U three times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"B\" in the string \"BYE\". -Type meta-R twice. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-U four times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"6\" in the number \"6/7\". -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"cd\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"c\" and then pressing the right button withe the cursor on the \"d\". This should create a box around the litatom \"cd\". -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"efg\" in pending delete mode. -Type meta-R four times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" in pending delete mode bye. -Type meta-R twice. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"6/7\" in pending delete mode. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"6/7\" in pending delete mode. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete of a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete of a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(Have a nice day please)\" and press the delete key. -Type control-x. -Select the litatom \"cd\" as a structure, and extend the selection to include the next litatom, type \"defgh\". -Select the litatom \"a\" and extend the selection to include the next two litatoms. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-R -Were the litatoms joined together to form \"abcd\"? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-U -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-R -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hi\" as a structure, and extend the selection to include the previous list. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the entire structure. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Redo: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) -Select the entire structure. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ deleted file mode 100644 index 7c6b2e0a..00000000 --- a/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ +++ /dev/null @@ -1,645 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 17, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-undo-redo.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Undo/Redo" - :before (progn - (setq window-list (do-test-menu-Setup "Undo/Redo"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Undo: no selection/no caret" - (let* (( user-result(do-test-menu-Message window-list 'high -" Testing Undo -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4))) -(ed 'tempx) - -Select Undo from the popup menu. -Does it respond with: - \"Nothing to Undo\"? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: no selection/no caret" - (do-test-menu-Message window-list 'high -" Testing Redo -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select DONE from the popup menu. -Select Redo from the popup menu. -Does it respond with: - \"No Undo to Undo\"? ")) - - -(do-test "Undo: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" and press the delete key. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Want to place the structure caret right between \"b\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the structure caret between \"b\" and \"cd\". -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the third litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the fourth litatom \"efg\" as a structure. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"6/7\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 4.5 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 4.5 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure. -Type meta-R. -Select the string \"BYE\" and press the delete key. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select a comment" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 1 and type \"; hello\", then select this as a structure. -Type meta-U three times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select a comment" - (do-test-menu-Message window-list 'low -" Testing: select a comment -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Place the edit caret after the number 2 and type \"; bye\", then select this as a structure. -Type meta-R. -Does SEdit display in the SEdit prompt window: - \"No Undo to Undo\"? ")) - - -(do-test "Undo: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 ; bye 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the comment as a structure and press the delete key. -Type control-x. -Place the strcuture caret after the litatom \"efg\" -Type: \"(Have a nice day please)\" -Select the \"d\" in the first litatom \"cd\". -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"f\" in the litatom \"efg\". -Type meta-R twice. -Does SEdit display in the SEdit prompt window: - \"No Undo to Undo.\"? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-U three times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"B\" in the string \"BYE\". -Type meta-R twice. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-U four times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the \"6\" in the number \"6/7\". -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"cd\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"c\" and then pressing the right button withe the cursor on the \"d\". This should create a box around the litatom \"cd\". -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg () "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg () \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"efg\" in pending delete mode. -Type meta-R four times. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" in pending delete mode. -Type meta-R twice. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"6/7\" in pending delete mode. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete a number" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"6/7\" in pending delete mode. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: pending delete of a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: pending delete of a list" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg (Have a nice day please) "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg (Have a nice day please) \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(Have a nice day please)\" and press the delete key. -Type control-x. -Select the litatom \"cd\" as a structure, and extend the selection to include the next litatom, type \"defgh\". -Select the litatom \"a\" and extend the selection to include the next two litatoms. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of litatoms" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-R -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-U -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of strings" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-R -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next number. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the list \"(bye)\" as a structure, and extend the selection to include the next list. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hi\" as a structure, and extend the selection to include the previous list. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of litatoms and numbers" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of strings and lists" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Redo: extended selection of several things" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Undo: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b defgh \"hello\" \"BYE\" (bye) (\"hi\" b cd 4)) -Select the entire structure. -Type meta-U. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b cd efg "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - -(do-test "Redo: selection of entire structure" - (let* ((user-result (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 2 6/7 a b cd efg \"hello\" \"BYE\" (bye) (\"hi\" b cd 4) -Select the entire structure. -Type meta-R. -Were you able to get this far? ")) - (good-value (equal '(1 2 6/7 a b defgh "hello" "BYE" (bye) ("hi" b cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/Control.u.~1~ b/internal/test/env/code-editor/hand/Control.u.~1~ deleted file mode 100644 index 00c2e184..00000000 --- a/internal/test/env/code-editor/hand/Control.u.~1~ +++ /dev/null @@ -1,362 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 6, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-control.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -;;; ----------------------------------------------------- -;;; -;;; The following are the complete tests, a do-test-group per command -;;; From keyboard, popup menu, attached menu. Test for all possible -;;; combinations of selection and caret point: -;;; no selection/no caret -;;; no selection/edit caret -;;; no selection/structure caret -;;; selection of each lisp type: litatom, string, list, comment, gap -;;; selection of part of each type above -;;; pending delete selection of each type above -;;; extended selection ofobjects of the same type -;;; extended selection of objects of mixed type -;;; selection of entire structure -;;; pending delete selection of entire structure -;;; -;;; ----------------------------------------------------- - -(do-test-group "Redisplay, test against standard set" - :before (progn - (setq window-list (do-test-menu-Setup "Redisplay"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Redisplay:no selection/no caret" - (do-test-menu-Message window-list 'high -"If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" - Testing: no selection/no caret -In the exec type: - -(setq tempx '(1 xy \"hi\" (\"bye\" a 23 4))) -(il:dv tempx) - -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: no selection/edit caret" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: no selection/edit caret -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: no selection/structure caret" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: no selection/structure caret -Want to place the structure caret right between xy and \"hi\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select a litatom" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select a litatom -Select the litatom \"xy\" as a structure, by pressing the middle button. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select a string" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select a string -Select the string \"hi\" as a structure. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select a number" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select a number -Select the number \"1\" as a structure. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select a list" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select a list -Select the list (\"bye\" a 23 4) as a structure. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select part of a litatom" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select part of a litatom -Select the \"x\" in the litatom \"xy\" by pressing the left button. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select part of a string" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select part of a string -Select the \"h\" in the string \"hi\". -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: select part of a number" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: select part of a number -Select the \"2\" in the number \"23\". -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: delete a litatom" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) - Testing: delete a litatom -Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: delete a string" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 \"hi\" (\"bye\" a 23 4)) - Testing: delete a string -Delete the string \"hi\". -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: delete of a number" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (1 (\"bye\" a 23 4)) - Testing: delete a number -Delete the number \"1\". -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: extended selection of objects of same type" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals ((\"bye\" a 23 4)) - Testing: extended selection of objects of same type -Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. -Type control-L. -Was the SEdit window redisplayed?")) - - -(do-test "Redisplay: extended selection of objects of different types" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals ((\"bye\" a 23 4)) - Testing: extended selection of objects of different types -Select all items in the smaller list. -Type control-L. -Was the SEdit window redisplayed?")) - -) ; End of do-test-group - - - - -(do-test-group "Delete previous and done, test against standard set" - :before (progn - (setq window-list (do-test-menu-Setup "Delete previous"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "Delete previous & done:no selection/no caret" - (let* (( user-result (do-test-menu-Message window-list 'high -" Testing parentheses -If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" -Then in the exec type: - -(setq tempx '(1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4))) -(il:dv tempx) - -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(1 2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: no selection/edit caret" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) - Testing: no selection/edit caret -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: no selection/structure caret" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) - Testing: no selection/structure caret -Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(2 34 cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (2 34 cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) - Testing: select a litatom -Select the litatom \"gh\" as a structure, by pressing the middle button with the cursor over the \"h\". The structure caret should end up to the right of \"gh\". -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(2 34 cd ef "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select a string" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (2 34 cd ef \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) - Testing: select a string -Select the string \"hi\" as a structure, with the structure caret to the right of the string. -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(2 34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select a number" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (2 34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) - Testing: select a number -Select the number \"2\" as a structure, with the structure caret to the right of the number. -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select a list" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) - Testing: select a list -Select the list (\"bye\" a 23 4) as a structure, with the structure caret to the right of the list. -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(34 cd ef "how" "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select part of a litatom" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (34 cd ef \"hi\" \"how\" \"are\" \"you\") - Testing: select part of a litatom -ÿÿPlace the edit caret in the middle of the litatom \"cd\".ÿ -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(34 d ef "how" "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select part of a string" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (2 3 d ef \"how\" \"are\" \"you\") - Testing: select part of a string -ÿÿPlace the edit caret ÿafter the \"h\" in the string \"how\"ÿÿ.ÿ -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(34 d ef "ow" "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: select part of a number" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (34 d ef \"ow\" \"are\" \"you\") - Testing: select part of a number -ÿÿPlace the edit caret in the middle of the ÿnumberÿÿ \"ÿ34ÿÿ\".ÿ -Type control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(4 d ef "ow" "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: delete a litatom after a delete" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (4 d ef \"ow\" \"are\" \"you\") - Testing: delete a litatom after a delete -Place the structure caret after the string \"ow\" with no selection. -Type control-W, control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(4 d "are" "you") tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: delete a string after a delete" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (4 d \"are\" \"you\") - Testing: delete a string -Place the structure caret after the string \"you\" with selection of the string. -Type control-W, control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal '(4 d) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Delete previous & done: delete of a number after a delete" - (let* ((user-result (do-test-menu-Message window-list 'low -"Assumping SEdit is editing tempx which currently equals (4 d) - Testing: delete a number after a delete -Place the edit caret after the litatom \"d\" with no selection. -Type control-W, control-W, and a control-X. -Were you able to get this far?")) - (good-value (equal nil tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -) ; end of do-test-group - - - -STOP diff --git a/internal/test/env/code-editor/hand/Control.u.~2~ b/internal/test/env/code-editor/hand/Control.u.~2~ deleted file mode 100644 index 638908c1..00000000 --- a/internal/test/env/code-editor/hand/Control.u.~2~ +++ /dev/null @@ -1,2 +0,0 @@ -;; Being tested: SEdit ;; ;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT ;; ;; Created By: Henry Cate III ;; ;; Creation Date: February 6, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}test>SEdit>command-control.u ;; ;; ;; (do-test "load the functions for the prompter for interactive tests" (if (not (fboundp 'do-test-menu-setup)) (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) T) ;;; ----------------------------------------------------- ;;; ;;; The following are the complete tests, a do-test-group per command ;;; From keyboard, popup menu, attached menu. Test for all possible ;;; combinations of selection and caret point: ;;; no selection/no caret ;;; no selection/edit caret ;;; no selection/structure caret ;;; selection of each lisp type: litatom, string, list, comment, gap ;;; selection of part of each type above ;;; pending delete selection of each type above ;;; extended selection ofobjects of the same type ;;; extended selection of objects of mixed type ;;; selection of entire structure ;;; pending delete selection of entire structure ;;; ;;; ----------------------------------------------------- (do-test-group "Redisplay, test against standard set" :before (progn (setq window-list (do-test-menu-Setup "Redisplay"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Redisplay:no selection/no caret" (do-test-menu-Message window-list 'high "If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Testing: no selection/no caret In the exec type: (setq tempx '(1 xy \"hi\" (\"bye\" a 23 4))) (il:dv tempx) Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: no selection/edit caret" (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: no selection/structure caret" (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Want to place the structure caret right between xy and \"hi\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a litatom" (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the litatom \"xy\" as a structure, by pressing the middle button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a string" (do-test-menu-Message window-list 'low " Testing: select a string Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the string \"hi\" as a structure. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a number" (do-test-menu-Message window-list 'low " Testing: select a number Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the number \"1\" as a structure. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select a list" (do-test-menu-Message window-list 'low " Testing: select a list Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the list (\"bye\" a 23 4) as a structure. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select part of a litatom" (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the \"x\" in the litatom \"xy\" by pressing the left button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select part of a string" (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the \"h\" in the string \"hi\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: select part of a number" (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Select the \"2\" in the number \"23\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: delete a litatom" (do-test-menu-Message window-list 'low " Testing: delete a litatom Assuming tempx currently equals (1 xy \"hi\" (\"bye\" a 23 4)) Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: delete a string" (do-test-menu-Message window-list 'low " Testing: delete a string Assuming tempx currently equals (1 \"hi\" (\"bye\" a 23 4)) Delete the string \"hi\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: delete of a number" (do-test-menu-Message window-list 'low " Testing: delete a number Assuming tempx currently equals (1 (\"bye\" a 23 4)) Delete the number \"1\". Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: extended selection of objects of same type" (do-test-menu-Message window-list 'low " Testing: extended selection of objects of same type Assuming tempx currently equals ((\"bye\" a 23 4)) Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. Type control-L. Was the SEdit window redisplayed?")) (do-test "Redisplay: extended selection of objects of different types" (do-test-menu-Message window-list 'low " Testing: extended selection of objects of different types Assuming tempx currently equals ((\"bye\" a 23 4)) Select all items in the smaller list. Type control-L. Was the SEdit window redisplayed?")) ) ; End of do-test-group (do-test-group "Delete previous and done, test against standard set" :before (progn (setq window-list (do-test-menu-Setup "Delete previous"))) :after (progn (do-test-menu-Cleanup window-list)) (do-test "Delete previous & done:no selection/no caret" (let* (( user-result (do-test-menu-Message window-list 'high " Testing parentheses If needed, bring up a second exec and type: \"(cl:in-package 'xcl-test)\" Then in the exec type: (setq tempx '(1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4))) (il:dv tempx) Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(1 2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: no selection/edit caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/edit caret Assuming SEdit is editing tempx which currently equals (1 2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 ab cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: no selection/structure caret" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: no selection/structure caret Assuming SEdit is editing tempx which currently equals (2 34 ab cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Want to place the structure caret right between \"ab\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 cd ef gh "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a litatom Assuming SEdit is editing tempx which currently equals (2 34 cd ef gh \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Select the litatom \"gh\" as a structure, by pressing the middle button with the cursor over the \"h\". The structure caret should end up to the right of \"gh\". Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 cd ef "hi" "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a string Assuming SEdit is editing tempx which currently equals (2 34 cd ef \"hi\" \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Select the string \"hi\" as a structure, with the structure caret to the right of the string. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(2 34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a number Assuming SEdit is editing tempx which currently equals (2 34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Select the number \"2\" as a structure, with the structure caret to the right of the number. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 cd ef "how" "are" "you" ("bye" a 23 4)) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select a list" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select a list Assuming SEdit is editing tempx which currently equals (34 cd ef \"how\" \"are\" \"you\" (\"bye\" a 23 4)) Select the list (\"bye\" a 23 4) as a structure, with the structure caret to the right of the list. Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 cd ef "how" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select part of a litatom" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a litatom Assuming SEdit is editing tempx which currently equals (34 cd ef \"hi\" \"how\" \"are\" \"you\") ÿÿPlace the edit caret in the middle of the litatom \"cd\".ÿ Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 d ef "how" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select part of a string" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a string Assuming SEdit is editing tempx which currently equals (2 3 d ef \"how\" \"are\" \"you\") ÿÿPlace the edit caret ÿafter the \"h\" in the string \"how\"ÿÿ.ÿ Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(34 d ef "ow" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: select part of a number" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: select part of a number Assuming SEdit is editing tempx which currently equals (34 d ef \"ow\" \"are\" \"you\") ÿÿPlace the edit caret in the middle of the ÿnumberÿÿ \"ÿ34ÿÿ\".ÿ Type control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(4 d ef "ow" "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: delete a litatom after a delete" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: delete a litatom after a delete Assuming SEdit is editing tempx which currently equals (4 d ef \"ow\" \"are\" \"you\") Place the structure caret after the string \"ow\" with no selection. Type control-W, control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(4 d "are" "you") tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: delete a string after a delete" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: delete a string Assuming SEdit is editing tempx which currently equals (4 d \"are\" \"you\") Place the structure caret after the string \"you\" with selection of the string. Type control-W, control-W, and a control-X. Were you able to get this far?")) (good-value (equal '(4 d) tempx))) (and user-result (if (eq t user-result) good-value T)) )) (do-test "Delete previous & done: delete of a number after a delete" (let* ((user-result (do-test-menu-Message window-list 'low " Testing: delete a number after a delete Assuming SEdit is editing tempx which currently equals (4 d) Place the edit caret after the litatom \"d\" with no selection. Type control-W, control-W, and a control-X. Were you able to get this far?")) (good-value (equal nil tempx))) (and user-result (if (eq t user-result) good-value T)) )) ) ; end of do-test-group STOP ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) -*6u¿-'¼W  É5½ zº \ No newline at end of file diff --git a/internal/test/env/code-editor/hand/Interrupt.u.~1~ b/internal/test/env/code-editor/hand/Interrupt.u.~1~ deleted file mode 100644 index a22d4f23..00000000 --- a/internal/test/env/code-editor/hand/Interrupt.u.~1~ +++ /dev/null @@ -1,191 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 5, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>interrupts.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Interrupts" - :before (progn - (setq window-list (do-test-menu-Setup "Interrupts"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "no selection/no caret" - (do-test-menu-Message window-list 'high -"If you are not in the XCL-TEST package. Stop this assistant and change packages. -Create a second EXEC if needed. - Testing no selection/no caret -Type: - -(setq tempx '(xy \"hi\" 5 (a 23 4 \"bye\"))) -(il:SEdit tempx) - -Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. -Type control-B. A break window for SEdit should pop up. Continue on. -Did both interrupts go correctly?")) - - -(do-test "no selection/edit caret" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing no selection/edit caret -Type: \"(il:dv tempx)\" -Want to place the edit caret right after the 5 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 5. -Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. -Type control-B. A break window for SEdit should pop up. Continue on. -Did both interrupts go correctly?")) - - -(do-test "no selection/structure caret" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing no selection/structure caret -Type: \"(il:dv tempx)\" -Want to place the structure caret right between \"hi\" and the 5 without selecting either \"hi\" or the 5. Do this by positioning the mouse cursor between the two items and press the middle button. -Type control-G, control-B. -Do both perform as specified before?")) - - -(do-test "select a litatom" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select a litatom -Type: \"(il:dv tempx)\" -Select the litatom \"xy\" as a structure, by pressing the middle button. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "select a string" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select a string -Type: \"(il:dv tempx)\" -Select the string \"hi\" as a structure. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "select a number" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select a number -Type: \"(il:dv tempx)\" -Select the number \"5\" as a structure. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "select a list" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select a list -Type: \"(il:dv tempx)\" -Select the list (a 23 4 \"bye\") as a structure. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "select part of a litatom" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select part of a litatom -Type: \"(il:dv tempx)\" -Select the \"x\" in the litatom \"xy\" by pressing the left button. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "select part of a string" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select part of a string -Type: \"(il:dv tempx)\" -Select the \"h\" in the string \"hi\". -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "select part of a number" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing select part of a number -Type: \"(il:dv tempx)\" -Select the \"2\" in the number \"23\". -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "delete a litatom" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) - Testing delete a litatom -Type: \"(il:dv tempx)\" -Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "delete a string" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (\"hi\" 5 (a 23 4 \"bye\")) - Testing delete a string -Type: \"(il:dv tempx)\" -Delete the string \"hi\". -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "delete of a number" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals (5 (a 23 4 \"bye\")) - Testing delete a number -Type: \"(il:dv tempx)\" -Delete the number \"5\". -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "extended selection of objects of same type" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals ((a 23 4 \"bye\")) - Testing extended selection of objects of same type -Type: \"(il:dv tempx)\" -Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. -Type control-G and control-B -Do both perform as specified before?")) - - -(do-test "extended selection of objects of different types" - (do-test-menu-Message window-list 'low -"Assumping tempx currently equals ((a 23 4 \"bye\")) - Testing extended selection of objects of different types -Type: \"(il:dv tempx)\" -Select all items in the smaller list. -Type control-G and control-B -Do both perform as specified before?")) - - -) ; end of do-test-group - - - - -STOP diff --git a/internal/test/env/code-editor/hand/Interrupt.u.~2~ b/internal/test/env/code-editor/hand/Interrupt.u.~2~ deleted file mode 100644 index 368043df..00000000 --- a/internal/test/env/code-editor/hand/Interrupt.u.~2~ +++ /dev/null @@ -1,191 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 5, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>interrupts.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Interrupts" - :before (progn - (setq window-list (do-test-menu-Setup "Interrupts"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - -(do-test "no selection/no caret" - (do-test-menu-Message window-list 'high -"If you are not in the XCL-TEST package. Stop this assistant and change packages. -Create a second EXEC if needed. - Testing no selection/no caret -Type: - -(setq tempx '(xy \"hi\" 5 (a 23 4 \"bye\"))) -(il:dv tempx) - -Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. -Type control-B. A break window for SEdit should pop up. Continue on by typing \"ok\". -Did both interrupts go correctly?")) - - -(do-test "no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing no selection/edit caret -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Want to place the edit caret right after the 5 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 5. -Type control-G. A menu should come up asking \"Interrupt which possess?\" just click outside of the menu. -Type control-B. A break window for SEdit should pop up. Continue on by typing \"ok\". -Did both interrupts go correctly?")) - - -(do-test "no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing no selection/structure caret -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Want to place the structure caret right between \"hi\" and the 5 without selecting either \"hi\" or the 5. Do this by positioning the mouse cursor between the two items and press the middle button. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select a litatom" - (do-test-menu-Message window-list 'low -" Testing select a litatom -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the litatom \"xy\" as a structure, by pressing the middle button. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select a string" - (do-test-menu-Message window-list 'low -" Testing select a string -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the string \"hi\" as a structure. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select a number" - (do-test-menu-Message window-list 'low -" Testing select a number -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the number \"5\" as a structure. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select a list" - (do-test-menu-Message window-list 'low -" Testing select a list -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the list (a 23 4 \"bye\") as a structure. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing select part of a litatom -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the \"x\" in the litatom \"xy\" by pressing the left button. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select part of a string" - (do-test-menu-Message window-list 'low -" Testing select part of a string -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the \"h\" in the string \"hi\". -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "select part of a number" - (do-test-menu-Message window-list 'low -" Testing select part of a number -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the \"2\" in the number \"23\". -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "delete a litatom" - (do-test-menu-Message window-list 'low -" Testing delete a litatom -Assuming tempx currently equals (xy \"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Delete the litatom \"xy\" by selecting it as a structure and pressing the delete key. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "delete a string" - (do-test-menu-Message window-list 'low -" Testing delete a string -Assuming tempx currently equals (\"hi\" 5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Delete the string \"hi\". -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "delete of a number" - (do-test-menu-Message window-list 'low -" Testing delete a number -Assuming tempx currently equals (5 (a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Delete the number \"5\". -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "extended selection of objects of same type" - (do-test-menu-Message window-list 'low -" Testing extended selection of objects of same type -Assuming tempx currently equals ((a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select the numbers 23 and 4, by picking the 23 with the left button, and the 4 with the right button. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -(do-test "extended selection of objects of different types" - (do-test-menu-Message window-list 'low -" Testing extended selection of objects of different types -Assuming tempx currently equals ((a 23 4 \"bye\")) -If needed, type: \"(il:dv tempx)\" -Select all items in the smaller list. -Type control-G, click outside the menu, then type control-B, and \"ok\". -Do both perform as specified before?")) - - -) ; end of do-test-group - - - - -STOP diff --git a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ deleted file mode 100644 index a1073ca2..00000000 --- a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~1~ +++ /dev/null @@ -1,21 +0,0 @@ -Command-abort.u failed -Command-base.u failed -Command-comment.u passed -Command-eval.u passed -Command-expand.u failed -Command-extract.u passed -Command-find.u failed -Command-help.u failed -Command-high.u passed -Command-join.u passed -Command-menu.u passed -Command-meta-o.u slow -Command-mutate.u passed -command-package.u passed -Command-paren.u passed -command-skip-next.u failed -Command-substitute.u failed -Command-undo-redo.u passed -Control.u passed -Interrupt.u -report.tedit diff --git a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ deleted file mode 100644 index 2b7f2029..00000000 --- a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log.~2~ +++ /dev/null @@ -1,20 +0,0 @@ -Command-abort.u failed -Command-base.u failed -Command-comment.u passed -Command-eval.u passed -Command-expand.u failed -Command-extract.u passed -Command-find.u failed -Command-help.u failed -Command-high.u passed -Command-join.u passed -Command-menu.u passed -Command-meta-o.u slow -Command-mutate.u passed -command-package.u passed -Command-paren.u passed -command-skip-next.u failed -Command-substitute.u failed -Command-undo-redo.u passed -Control.u passed -Interrupt.u passed diff --git a/internal/test/env/code-editor/hand/command-package.u.~1~ b/internal/test/env/code-editor/hand/command-package.u.~1~ deleted file mode 100644 index 9dad10ab..00000000 --- a/internal/test/env/code-editor/hand/command-package.u.~1~ +++ /dev/null @@ -1,400 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 25, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-package.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Change Package" - :before (progn - (setq window-list (do-test-menu-Setup "Change Package"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Change Package: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Change Package -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-packge 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ed 'tempx) - -Select Change Package from the pop up menu. -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Change Package: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Want to place the structure caret right between \"xcl-test::a\" and \"xcl-test::cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-P. -Enter: \"xcl-test\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-P twice. -Enter: \"INTERLISP\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the list \"(xcl-test::bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-P. -Enter: \"interlisp\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the \"d\" in the first litatom \"xcl-test::cd\". -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-P. -Enter: \"XEROX-COMMON-LISP\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-P. -Enter: \"ZZZXXXYYY-SHOULD-NOT-EXIST\" -Check for two things. -First did SEdit display in the SEdit prompt window: - \"No such package: ZZZXXXYYY-SHOULD-NOT-EXIST\"? -Second does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -If it does both please indicate sucess. ")) - - -(do-test "Change Package: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the litatom \"xcl-test::efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"xcl-test::efg\". -Type meta-P. -Enter: \"IL\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-P. -Just press the carriage return. -Check for two things. -First does the SEdit banner still read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-P -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-P -Enter: \"IL\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the list \"(xcl-test::bye)\" as a structure, and extend the selection to include the next list. -Type meta-P. -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) -Select the entire structure. -Type meta-P. -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - - -(do-test "Change Package: Pending delete of whole structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the entire structure in pending delete mode. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess.")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP - - diff --git a/internal/test/env/code-editor/hand/command-package.u.~2~ b/internal/test/env/code-editor/hand/command-package.u.~2~ deleted file mode 100644 index d7eda921..00000000 --- a/internal/test/env/code-editor/hand/command-package.u.~2~ +++ /dev/null @@ -1,401 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 25, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-package.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Change Package" - :before (progn - (setq window-list (do-test-menu-Setup "Change Package"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Change Package: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Change Package -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ed 'tempx) - -Select Change Package from the pop up menu. -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Change Package: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Want to place the structure caret right between \"xcl-test::a\" and \"xcl-test::cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-P. -Enter: \"xcl-test\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) \"hi\" (b) cd 4)) -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-P. -Enter: \"xcl\" -Check for three things. -First, does the SEdit prompt window say \"Already editing in package XEROX-COMMON-LISP\."? -Does the SEdit banner still read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And third, does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does all these, please indicate sucess. ")) - - -(do-test "Change Package: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-P twice. -Enter: \"INTERLISP\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the list \"(xcl-test::bye)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-P. -Enter: \"interlisp\" -Check for two things. -First does the SEdit banner still read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the \"d\" in the first litatom \"xcl-test::cd\". -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-P. -Enter: \"XEROX-COMMON-LISP\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-P. -Enter: \"ZZZXXXYYY-SHOULD-NOT-EXIST\" -Check for two things. -First did SEdit display in the SEdit prompt window: - \"No such package: ZZZXXXYYY-SHOULD-NOT-EXIST\"? -Second does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -If it does both please indicate sucess. ")) - - -(do-test "Change Package: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the litatom \"xcl-test::efg\" in pending delete mode by first pressing the middle button of the mouse with the cursor on the litatom and then pressing the right button with the cursor. This should create a box around the litatom \"xcl-test::efg\". -Type meta-P. -Enter: \"IL\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the list \"(bye)\" in pending delete mode. -Type meta-P. -Just press the carriage return. -Check for two things. -First does the SEdit banner still read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit still display tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-P -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-P -Enter: \"IL\" -Check for two things. -First does the SEdit banner still read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit still display tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the list \"(xcl-test::bye)\" as a structure, and extend the selection to include the next list. -Type meta-P. -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-P. -Enter: \"XCL-TEST\" -Check for two things. -First does the SEdit banner still read: - \"Sedit TEMPX Package: XCL-TEST\" -And second does SEdit still display tempx like this: - \"(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))\"? -If it does both please indicate sucess. ")) - - -(do-test "Change Package: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) gh 4)) -Select the entire structure. -Type meta-P. -Enter: \"il\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: INTERLISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess. ")) - - - -(do-test "Change Package: Pending delete of whole structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4)) -Select the entire structure in pending delete mode. -Type meta-P. -Enter: \"xcl\" -Check for two things. -First does the SEdit banner now read: - \"Sedit TEMPX Package: XEROX-COMMON-LISP\" -And second does SEdit redisplay tempx to look like this: - \"(1 4.5 6/7 xcl-test::a xcl-test::cd xcl-test::efg \"hello\" \"BYE\" (xcl-test::bye) (\"hi\" (xcl-test::b) xcl-test::cd 4))\"? -If it does both please indicate sucess.")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Done&Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP - - diff --git a/internal/test/env/code-editor/hand/command-skip-next.u.~1~ b/internal/test/env/code-editor/hand/command-skip-next.u.~1~ deleted file mode 100644 index 305142aa..00000000 --- a/internal/test/env/code-editor/hand/command-skip-next.u.~1~ +++ /dev/null @@ -1,273 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 23, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-mutate.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Skip-Next" - :before (progn - (setq window-list (do-test-menu-Setup "Skip-Next"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Skip-Next: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Skip-Next -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ed 'tempx) - -Select Skip-Next from the pop up menu. -Does SEdit either do nothing, or display a message complaing? - (AR 7699 is on it doing nothing.) ")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Skip-Next: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-N. -Does SEdit either do nothing, or display a message complaing? - (AR 7699 is on it doing nothing.) ")) - - -(do-test "Skip-Next: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Place the edit caret after the litatom \"bye\" within the list and type: \" .\" -Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye . -x-) \"hi\" (b) cd 4)) -Place the structure caret after the litatom \"efg\" and type \"'\" -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-N twice. -Does SEdit first place a box around the \"-x-\" with the quote, and then place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 9.0 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the list \"(bye . -x-)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the \"d\" in the first litatom \"cd\". -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the list \"(bye . -x-)\" in pending delete mode. -Type meta-N. -Does SEdit place a box around the \"-x-\" in this list? - (AR 7907 was written for case where nothing happens.) ")) - - -(do-test "Skip-Next: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-N -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-N -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the list \"(bye . -x-)\" as a structure, and extend the selection to include the next list. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? - (AR 7907 was written for case where nothing happens.) ")) - - -(do-test "Skip-Next: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) gh 4)) -Select the entire structure. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - - -(do-test "Skip-Next: Pending delete of whole structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assumping SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the entire structure in pending delete mode. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? - (AR 7907 was written for case where nothing happens.)")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/code-editor/hand/command-skip-next.u.~2~ b/internal/test/env/code-editor/hand/command-skip-next.u.~2~ deleted file mode 100644 index ccb8e337..00000000 --- a/internal/test/env/code-editor/hand/command-skip-next.u.~2~ +++ /dev/null @@ -1,268 +0,0 @@ -;; Being tested: SEdit -;; -;; Source: {ERIS}DOC>SEDIT>SEDIT.TEDIT -;; -;; Created By: Henry Cate III -;; -;; Creation Date: February 23, 1987 -;; -;; Last Update: -;; -;; Filed As: {eris}test>SEdit>command-mutate.u -;; -;; -;; - - -(do-test "load the functions for the prompter for interactive tests" - (if (not (fboundp 'do-test-menu-setup)) - (load "{ERINYES}TOOLS>DO-TEST-MENU.dfasl")) - T) - - -(do-test-group "Skip-Next" - :before (progn - (setq window-list (do-test-menu-Setup "Skip-Next"))) - - :after (progn - (do-test-menu-Cleanup window-list)) - - -(do-test "Skip-Next: no selection/no caret" - (let* ((user-result (do-test-menu-Message window-list 'high -" Testing Skip-Next -If there is no free Xerox Common Lisp exec, bring up a another one and type: \"(cl:in-package 'xcl-test)\" -In the exec type: - -(setq tempx '(1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4))) -(ed 'tempx) - -Select Skip-Next from the pop up menu. -Does SEdit display the message \"Select point from which to start search for blanks.\"?")) - (good-value (equal '(1 4.5 6/7 a cd efg "hello" "BYE" (bye) ("hi" (b) cd 4)) tempx))) - (and user-result (if (eq t user-result) good-value T)) - )) - - -(do-test "Skip-Next: no selection/edit caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/edit caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Select DONE from the SEdit popup menu. -Want to place the edit caret right after the 1 without selecting it. Do this by pressing the left mouse button with the mouse cursor just to the right of the 1. -Type meta-N. -Does SEdit say \"No more blanks to fill in.\"?")) - - -(do-test "Skip-Next: no selection/structure caret" - (do-test-menu-Message window-list 'low -" Testing: no selection/structure caret -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye) (\"hi\" (b) cd 4)) -Place the edit caret after the litatom \"bye\" within the list and type: \" .\" -Want to place the structure caret right between \"a\" and \"cd\" without selecting either item. Do this by positioning the mouse cursor between the two items and press the middle button. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select a litatom" - (do-test-menu-Message window-list 'low -" Testing: select a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg \"hello\" \"BYE\" (bye . -x-) \"hi\" (b) cd 4)) -Place the structure caret after the litatom \"efg\" and type \"'\" -Select the first litatom \"cd\" as a structure, by pressing the left mouse button twice with the cursor over the litatom. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: select a string" - (do-test-menu-Message window-list 'low -" Testing: select a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, by pressing the left mouse button twice with the cursor over the string. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list (after the \"BYE . \")? ")) - - -(do-test "Skip-Next: select a number" - (do-test-menu-Message window-list 'low -" Testing: select a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"4.5\" as a structure, by pressing the left mouse button twice with the cursor over the number. -Type meta-N twice. -Does SEdit first place a box around the \"-x-\" with the quote, and then place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select a list" - (do-test-menu-Message window-list 'low -" Testing: select a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 9.0 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the list \"(bye . -x-)\" as a structure, by pressing the left mouse button three times with the cursor over the \"y\". -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select part of a litatom" - (do-test-menu-Message window-list 'low -" Testing: select part of a litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the \"d\" in the first litatom \"cd\". -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: select part of a string" - (do-test-menu-Message window-list 'low -" Testing: select part of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the \"h\" in the string \"hello\". -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: select part of a number" - (do-test-menu-Message window-list 'low -" Testing: select part of a number -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the \"7\" in the number \"6/7\". -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: pending delete of a litatom" - (do-test-menu-Message window-list 'low -" Testing: pending delete of litatom -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the litatom \"efg\" in pending delete mode by first pressing the left button of the mouse with the cursor on the \"e\" and then pressing the right button withe the cursor on the \"g\". This should create a box around the litatom \"efg\". -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: pending delete of a string" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a string -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the string \"hello\" in pending delete mode bye clicking on the \"h\", then pressing the right mouse button with the cursor to the right of the string. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: pending delete of a list" - (do-test-menu-Message window-list 'low -" Testing: pending delete of a list -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the list \"(bye . -x-)\" in pending delete mode. -Type meta-N. -Does SEdit say \"No more blanks to fill in.\"?")) - - -(do-test "Skip-Next: extended selection of litatoms" - (do-test-menu-Message window-list 'low -" Testing: try extended selection of litatoms -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the litatom \"a\" as a structure, and extend the selection to include the next two litatoms. -Type meta-N -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: extended selection of strings" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Now select the string \"hello\" as a structure, and extend the selection to include the second string. -Type meta-N -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: extended selection of numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next two numbers. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: extended selection of lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the list \"(bye . -x-)\" as a structure, and extend the selection to include the next list. -Type meta-N. -Does SEdit say \"No more blanks to fill in.\"?")) - - -(do-test "Skip-Next: extended selection of litatoms and numbers" - (do-test-menu-Message window-list 'low -" Testing: extended selection of litatoms and numbers -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the next five items. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: extended selection of strings and lists" - (do-test-menu-Message window-list 'low -" Testing: extended selection of strings and lists -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the string \"hello\" as a structure, and extend the selection to include the next three items. -Type meta-N. -Does SEdit place a box around the \"-x-\" in the first list? ")) - - -(do-test "Skip-Next: extended selection of several things" - (do-test-menu-Message window-list 'low -" Testing: extended selection of several things -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the number \"1\" as a structure, and extend the selection to include the rest. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - -(do-test "Skip-Next: selection of entire structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) gh 4)) -Select the entire structure. -Type meta-N. -Does SEdit place a box around the \"-x-\" with the quote? ")) - - - -(do-test "Skip-Next: Pending delete of whole structure" - (do-test-menu-Message window-list 'low -" Testing: selection of entire structure -Assuming SEdit is editing the variable tempx which currently equals: - (1 4.5 6/7 a cd efg '-x- \"hello\" \"BYE\" (bye . -x-) (\"hi\" (b) cd 4)) -Select the entire structure in pending delete mode. -Type meta-N. -Does SEdit say \"No more blanks to fill in.\"?")) - - -(do-test "Clean up" - (do-test-menu-message window-list 'high -"Close the SEdit window by selecting Done&Close from the window popup menu.")) - -) ; end of do-test-group - - -STOP diff --git a/internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ b/internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ deleted file mode 100644 index bb7a0730001a05dd325676bdd7ceaa4c45462223..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9188 zcmcIpU2Ggz6&^b#bxXE&pen6olAC?W8e+G0n$|L*b(%kd@`H*4JXl2I-PzsA&hBh? z#&JRsSyio+w~9AjkX(2`sw~ViD5e7XYO4{>Y6KO zclMimzI)EOckbLT=lj*3-;Gs0?5Ws`V!zW+HLo7Uz2$1G+)ho!O;7oqsOwc@^jY!a zX5OJxaieItO-9w_UeD{q!3}g)C&P9-?5Oj8)K!-wucx|hwdFRviPGdwS}DHK_2x>I z+_9clRTWp2n_duv^(!n>YEJyAlIl^?6987>Dk)$_XW z1Q{!(d5pZcPQbLPwB43BN!gt9C;<~NPLiF>Irr0)E@r<|3s;bDH&#IywjveyEsvK- zJ;Y4lenYw4uIKimQpp)|sJ-F*${BjsXnp6h(dGvrhS9ry$40Jf7u$woBkRR3+kI#K z{d?Qn_}ij8_~<)V?%*f>QUpBjz4h#CZ{45X`t^rr-+tQt%Z9W5!C%)qoB#Oj)-V6? zt!wu``V)AzHa`tF?|-~?`@`4wZhdqQJpX3o)2-Y8di`fWz;kEwlg{R!KiRs?RzTL@ z|J!G;{eAK?Se}1KMae#hi&tH0L_3LIhdBZs zSUs8n4wz{j7N2h3X+>qihs+zXAIptctteqJ^vhG4?|s_)8n**+6zT zE;%~p3*#E|W$eZS{eg#acEDpGm@go5^=cl8ATE(Eas)j4(nRq0e_e+lr$%(JqIC#= z`uO#xMra*M1pZ*G(Q)T@LmPYFpg!>DNg%_{ABWYWjDY89AP1aV!_H`etWlqGjwC$g z+zLFjRu3?9GCHk8j82Wdl65G31`prPKFFW!2VYQJ79vh@d`>Hz>k`B`_FmrUx!2|? zl_D>IOoKFFnMTSj@ap)z9LHg&RLan{U#kUPf~&*|sz4w9)%0^DA;|oi8!US)4wsZ4 zsSXbRbThH2?|d9h-|dBMh|fe;WO~J|sq#s;a~KlFg9wELN%d3|gmF0=-}@Zn2hgKd zpf66%vREpH3cagC<=eZI)0wGb1BT+P&SU|#K1V=<;yDaa+E7g`*Ycpkx@x5{nLT=5 zv>e24$D9R{cdYK_QXTi^ARV`AskZM8Kup!PYU#LDOWoWZfSAwMs-@$=bLU<`$AQPt zad#~p2OdMmfydBs;4yR@cnlo}9)8OC<0gF;;$mb_T;^`GYVAL()^2l`5vk+uvX#_v z;KBPs>NxPw3q|NS@EAG{JlHdxa<1dR!$_{~uiafXI{K#_){Gs_u zy+IW42VsgAF~tRki-@V?zym9p4e%Hzhh2;dD@y7e#05m^9r$DDIQV1exOBegmCP-h zuN(o7q2s_~=(t^s3vL*30Wso2R;7;9^Ck5u{4sQ#Ue8j;>G_g6PS2Oral07TBM3w2 zIQT;+HHCk=Vbz&B4*pP|<7pRuzJN#_m+<7vj(EtboLeP4<2ka6ab=`@LF)$>g3Q8f-?QlWs&eqS$M5_!Ui1r7|D6F)>+z_yvx}EVNm9U59Y0VNs>wa4a&&?Uag#1pP@(S=sZ2ymYKFQc z)y>?PQC-|5%O$p~N=qt(!jk&rW(=jJL>{xsmNjXqi=||nlu2{@7c8G^Y>zbRawPez zORA~87=6~V=9;mpOKUE?!dR4CW1X;RJ7aYoy&>%z3eN!f?lyA2r#WARz#DAZl%`a- zg(+8Tg{_@5XmDEH($>dBQB_yi*~#+R?y9uAs;7xd%h}SHwlj5=Ohzftm(MSpxpZ+s zp{RWJ#L4fRz<(5>R;@2*akX&z)eGk?o;a^&Cni!#9&CX=_uwCn9{MFcPZxyn=>TI4 zeIrG_Mi;c-^PVsJ=ofwgVPQwe(ZuS@UD)k=<-(;`zB_gH^un2oe1l(b)Q!%?{OZWa zajG&9E&`AR8Sn>pCM2`^65S#sW48Nzo%#@L4|ZG1>&Gd=Ll9yu&f(vfebkuqgP;8VKW70fHvj+t diff --git a/internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ b/internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ deleted file mode 100644 index b6fecabc3f20bac2fea4d0d21a969dea9c9a0335..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9251 zcmc&(&2J<}6>n$FvIHja0t#7aNh))p2Qf?5yMdMSv2M?_y@vVl&Ww|_WU;ho+V~nm)6-E#|M=tljl`cGCyXowmOo zGh}qj^R_lgsJZ33cGvH0gP9ea%}uAvN^P&l7CqZ#J*&B4t=YLu{(f4<-|pE{8NJz= zYIpMi7RxTy&002>VPSWyw`(_U zL#uNc1c9}E=B+zhofdQL9yEc+GNB(m+g~NZWu|Xh8+M+&Ic1Xrau5z;5u^m?6Oa~? zquX-sz~7e7I*zm9u}*u#<{7l=AQI?bV^*(cTdtSMXk!|+UuwV6#@PjJ^1H)hrj;Av#;Fy=+D48JowBxxcAB7-49>}w6yUsn@M-tpFP|RXdAG>&~ z_x7%~OwpVyPGs5mg>36h!g&;w><&@RzcBqTP~JUHlxa?3)4QY(r*NrXWvAZ+MMx3y zne!K?dx1WX3mf5t&*FPjyP*4%u_WPuLIwqma2`uimM>`96CsDDkv`Cw)D9Zq;HOAt zP9q#h$vm(N$Z%TN2q%0N--MH(04GIBOA+O4%opH1EKz_%@lq&c#n&YY^noi>3i(I& z7;qr4Hq=h2iYR863_=3CG!A>XI&^nD~ZU%m;xL~eI+7jK&CuYXE$GIB_7})rcxt) zq@Q>soCF2>@Y$WCJzXzW^9{4!U_0KX<*j3z&bKVzqOE=>!_f4)*|^DSW}#Xua?ZSX zzRGkIRE3&pG)$$tVw6qBMM)ey^|DdFF<+TexCF>#E+<%Zqf%sgWwBJ^u(M{PaDy48 zg&PJTRA>9kMx!v@?5E>oAF-?4?98($ZKx#Um7(Rj*0vxh9_^Xzy-uWy^W;>^E%TDRq_aa7mdbZ znKhuc8m}gbN#9n~3w${sVo^{Cbw`Nrq_mGTWwHNn<8jtt!XOCWW_97kID5#C*ZV0$ zWAV=PP|DcCnTm;lpYkMbxt6;f*oRn?2|6E0BX{*p-(29s*o9P%TTL~hJQ|8_HFKe46wEj{ebJ>Ta`WO3IPRtS#tn>4 ze=#4;Ao6O6KU{lBFoqUS;Q*8}VF;9k#wh|CynK{|e+2aeAx zk^NERTpTh}q5Hxk*T=69FnT;a)VV{`aINF4Se;iaw{5L-)Km>ZNYSe=m1nA@{DM*V zu`y@zv|3)Kb#1OxoiR!;8nt<2rewzICvr%?xmfM9tI(Pga_Y15m0~nP_Ew?9H>a$+ zNUq^L+qOF`dWYf3(_T`xVAQyVb7o_9-YgaC3ud9t2CERKzFshj#aOy%)(f@yg+{eD zOkD9PVoF}^TAPY5CGEgLj^q1^SR&<3Sn`K(8IJpWzv`)e2nSJiGvP~`^Wg{!eOBbq z6DqP)H*9%SG^BUQ0lUzZ*neWbJGO*~mX*bN|0+W4v9u5Hjfw11mdsJAiP)1goV2|R z-2~{hh)@qQ%DQ#j;uDF5;?kJIWe1PROO1isAzmbZ8PZPE{O^yv2O?zq5G@agda@q`c{G_b&NgQ9OE-dw*H)`>1-dr@~ z>U+3Ja_JDH@TlHE(I02OUa2-tJ#|K&I~bZTj8Y_`V~@Oo4G+c8qfclWLiFGcK5{N# z*-38C)90cejBxfgH1Jl7L?vxHb^?DU^o=$_xu!9ahk*1U#$%9YmE9wi5 zJv<%o(`Z!7I0RvL#SeZ2;-O2-qTmRWP;}6dm8Z!F2cM|s9R1vr&_IktyYBUqAA7v* zuG8J#l>Hy%qq4&cJ{gBqw;a--mNW~jl~oH*B~fTj zbLvU!9>Nb_^J2MZ(+(bxqx?{H{F!ICnIlyy{m*UxzcWv45_gcYkB5#O9=B+bNcxq( zKT3L5;tn_OaG2A^Z^TniZ1IjXGe3 zgX+0NIUaaOp3S4BxjfwcmE`}s!a^>}6QiD@D!-5L@ttRc_+eY!a(tWa%Ef(gj!9R= ztlRD|oo;_8pO)!4y7bL&U>D}^l*hF*+BdbcsuPYttHp0A)1y_U;`kbJNPeV)NTUZ#tSr)hd13V%yZ zw*-%e6uOY0%c-&NhLms719TJDb&3?f=u#+nKQ553&;z8t+QaA9X3Eu>A6=ps1r^>w zLvjVe;bL&y`3WUyNY2AA2}puQ;vc+=C=t(>sEa5Oa+>Gc#6#rtpwCd(F+)60JR}|s zn#TD7@hCVE&k*IgfyW@HH5>(*hxNqB{0@e!;6sq&++?Cewm*d*syBGTpg$e)vD4>p zmxd!vBC8`!_=BR`bHuDrqCBVjb&kV5quBTobrD#U)jtU-(O9YEeCT&c9`?L;>*v4! EFX>+L>;M1& diff --git a/internal/test/env/inspector/hand/inspect-macro.tedit.~1~ b/internal/test/env/inspector/hand/inspect-macro.tedit.~1~ deleted file mode 100644 index f8c28fff3bef66428a759c453515df2ecc365047..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5950 zcmdT|UrbwN6hH0QsB?weiit61eqE}x4>PclNN~a1(gIzeEp0LJ!Gwmf1)Xq#>i(pI zcGILaMw~BZiCZ?dMCHNoG?PsV3rqAx7oXHDumZlAjI~2DwjrzMySKf)y_Z{>h$enX zd%xc~zweyicfNabPwVd2SbPj)6w1`j&Q;5cY;TH^!m^VuBSn7aX6b@Zf6IvI6N(WFR|F%u6A3Sl~_DJ zVsUnK+S>5)27c!p)ksA5hOR^XN31yX7H?<3>+^X1#AkCm-Xv|#7C)&YPMgn9_K|?i z)kbPbtIg#jZ60?E^8L<0N0!US*IQg}zt`CmAk};Xt6sl%?}`5R$g$p|N6AnRDhCbV z&{RVkXfh>?aTqUUKxYXfP$H`YS((RB8f%27Jt<0Ff#J$bW-61QELG|XtglkmR8iJr zSbws#|ME=Y=f%t4e_ZniB`e2c7~XyN$MchkpJvZre?QfuWKhcrjHKS0ot#X}El!>p zPW7v?GOGe>eR4{bg}PQJXEEa(pHU?i>Z+WaMfG#2ezYc~mT^R=0xgH?Sb@xw5y3m9 zN-FsryXbAZ$*6;_O&HW&2gwpx4Uml4tEZ7^N!zPqA8ov(0lI#;e2DrivCHOG6&C7} zu$((Lj)l6u8v8Oro$0YF&W%Zcy1q7E;hmR^SL~{+u5-%*>+JF&H5TeRmyH!S7GWjh zM!ph&*VC#QlPVsm8S5p5D)TKr$1+a@;5e65$p=`~uGm;vEBYOAMwNxSN@69wV`Uyb zmTD+^jvdBqMoyK6x;mCi(PhfTDyBYZdS-DnvRNgPs%r9%f9D)^`2@L{Xu^8k*UV7$ zO!WRtWCw&z^V8+f$P6I0EJsIOarl7V?@Ux{W_JSHVI;bU&SH|X@Eo%&qGV}vvG93} z!x;)mbYUA9;dsYx2TyPs4FVy;xoPo?4v!T z40K_tON@oOq%1AQLiK#C0#*_$KtnT+uo7Ab#|_h!5uIZoT~LW6pBY)%tK=fBSJo^R zI!_Z#Tl_qxZ8z-|jZkGs0-s```ql+fKd_L`EIg0q4-EvWOpL&4GU*J2i5ny={&{?9 zJFWVI#N6!-Y%ceE&H0)u)9@H687ew;0=s6nAt;q74v}TuqW(@M` zHF*+!4@C_(TR&+8uR*gI8%6aCrpmL8^#kG!fo#+zStGd(3as+y@r43!4s7u`=E4@a zHbAxmP;UUxgMCg>zu;Ucu@fz&T^%p66D^^s?F@ik9}s>O@cnqU1#h=C`8?sPW=Tpl;!e=%4IZS>u?cBh}TIQg!hWV?SWDTqLS7nIo5LkQxaDct`>S=BDe zcJ5VR`TD7Xvq{U&N{JKYsl<)c6yH0hGHFPxr7p~^j)-`8?U!%v92;5M-EiReOvR^w z`0AaLnY&BB-Tt=kffo|x*RS3=m07y?+OMzPdqCHpxkhp7_U%=Qhu2PhH@BWy68Jn$ z+(3K}qjK&QFVb#{IKVBPoJ8_P!<} z@pEjHVG_2veu~9cA=L2qiyVt|^izI*C^5~K z9~h5zGNOUjAA6P}n4^7&#Lv-=LxLx0Z&84;i;!TB_6t%h&gn#{SH2&Geq2>A#t_y! zieS24UOz_0Co;@RFkLS_AGw|hkxM7a{mA)Tm`GX=X+)pChK(Bm13jMg45d#SOt&w4`1k?3Wz8p`;{BlhBTUvhyS)9h0!a)5Fubt!| zt%nSAVQpEBb}P9?7fd zH;Q*h4xggk;gy%cHmHIf?H-5I=Z5TGCfGhJY+8WVp_cw3YwK(aG<)0uQcEl?wx(7a zsjb1kT!m>p&H_$fyUUG#%GO)0xsZIaI{Lj0KTpvKMiji%vLk01rxR*n=meEK9l-Bh s_I8i`;49d|HM{p~{<#vGo6jQVeLH8#<<))hpX9Y>^FBKcl_#(L4ZnrgYybcN diff --git a/internal/test/env/inspector/hand/inspect-macro.tedit.~2~ b/internal/test/env/inspector/hand/inspect-macro.tedit.~2~ deleted file mode 100644 index 2865e5de11354e5a8683ad12e2e17438055867b6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6003 zcmdT|U2Icj7=Bv@tH{`C#l#rJugi327nt#rxJ-iQ^oOn3wP$T-;)ThUF~}6z*{Jf9 zvbCT|YmA6DhC~Q%Bq|qXSD1k7MnT=b&-cF1_kQQ3Z%?>quuqJVUHyY3+Pg2>w|6)3?cFE#_C(3M-93Z-q;GGucW_sC zPj5{)+C3OWESvW9?GuUE-SbZO?%tZ3=s~f!rG|C;TYP~H0`GpEZ}pNoUm)TQ`F&xb zu2G?QyxV;NZwFyL!Pc-qSU%uu=lzX@4TcEo?datFczFZAi;e~)qI*%-&i>tvIBHm- zGa`h7LYRd3fagu(_qK+~7UJbYVX}!tc%PqaByGGeMEt=(EAqqMNJoJy#jjy~fw16p zM@WMd0rhU!aIpV9vcGT79O;qy@Tu9NkHMY;v@|&4h)zR4ni6#bcqauSdR$Q)h1EjCXMopssHmXC&vB zjx#P(R@aF;GVA!Aon|c5b)pa}5(l zto7V#;5r<{7PqlZH4D$Nz#>MLwHOPZ#}pi;kR)bSfCCP6+=yF1j-{}uE{GqISk_G3 z0bGjXtYGsvq529nO9OQ!WL;9m7l6B8N2w>s7uYVVk}fI#nP}cSOFTExsR2w zLM&yUtc}||13674GE!z_6|Sm_x?TmdQs@#*F)j1+nByte{Vts{&*qhWO=?$jSUPT()zTEE&} z$APQc=0IH#FU6wg=%{Z)mf*D3`|LDhx1`=uBGKQWg#A+6C)+@PU9_tWj@DZ*fQ4^D0Bek4FGzu&nfGdo%0oTqLs9(XDjSP zD`;vvBT!Qlk^eYI{dl1TZ|B{iV3@G(U?5BySay47z#Z`g14R1A&`4;bAK=@)VbbcA zx_(mV{u_xV0{vf5VOI}PNP$JW|I@mvo!0GKFkt=q3C-E$bZ2G6>FR9yVs=969kcly zq#tHaO)m^9cw&4Yp911@*AL}y&i!`vyS;Y>NLODtcl~gF?$)cn zzH;j>U4QgE#o4P@7bqTjc=-G2NBKFKFX8k>#J4cspKEiV=zU0q8}TqTDi3K~KhD`QnC5F! z`SqBdUrgnvSotZ0Ch30BV}*`>$}bHgruj+(`!VRpRn1BadA+9$rt9_fV|09?!<-7!_3HD{>lstHbYk3( zo-f9Ts`WrVBe+T-j9Aq9MJB1^-_v2OANjKxC4qcDDR2?J`u!O6<6=e$An&(HhXoa; z>(zWc9@F{tnDUpk{vI+ri81AY`aOb+6d|pL4vR6tJ*o1Go}??T!egF$E>44!ns~^c zAu2!JPie^YD~I)bin)Q}BPFlrQlAkyh7n8rRH%?bK7TG1%4qqUh#98qW2$_5J!A61 z!nbihdcGb{D8G$#qWb-m>^VcfpzVXr_{vqDHscImHTArs9jpc07!q5q7doqIGYh3L?*N&I5soNgdZ29Nfs2XkFw~Lly UUfUP{N#4dn-ls2v{m}Wp0XR$G!~g&Q diff --git a/internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ b/internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ deleted file mode 100644 index b2f258abc300b2b7bdb1302f4a4dc3522d618c50..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3044 zcmchZO-~zF6o#*j6DFj#2dPpw2yO`ywnQUnxGi+a%$=67wn?YFSy)3FKweA(;M^? zD{YnoknAH7T&6>jk?1s?3`QS>M`&>Ps{k{<9}0v=CaLK2w@^Pj_PbrZB3vlvUO~Pd zay!J{7TWC-MPFYF9gd7pkKh!qQ}>jbG#rhN(Qs%?$s7%bqu@Gv(@1m#M<01ebgSxk zI;al63WI)09fvANWy+PZ2LwBfI(R z8|mBUQgj?BE6vnP(MK@5pPz+TWV@JsQIOVgwumMr`0e6B!pm(0HV)&gXgI`9pB4=T7L@gcValp-;O zpaO-!H~E5l!e)aB9k;0HDyW*5v&7-V##z2E7iv2-UrzG{f)#;V0}xg5s=u=hw*BO9)l z#p3WDyi6D%3w{;ne7=e5on??>J_Ba}`U3LFv;tI}##ni_l2jc9-&fnHyMS*T#9QfK#PuiJBx4t<^$P5;AAJU~9L=)|ilL|faS?F6rBTe3nbc}R5pP*ealAH z_BS?4xo=AAMT$JTcMS1opwDhp9~|eIW+;nhdH8`IPZ9<|kI2RfxuZT!-R23-Xz>-2 z;Tk$;;5x1YJ;zgMfVw#9W!58SxcUxkjHt=T@k%|gre~ZnFJqpn-%wxSb*_3$rp}ph zUbl($T&d;w$3N*Q=C9z48RLFpWA!XCj-wu0E5vn#)x%hioH3g?ew_bj^>E*H%%mU- z%Rk@9r-)on4P%0}WsnQ9hH(l$PSjsApq^1}L(7P-4AneT8+1N#8`DKqRL)Q>q+HhDiU`n)RiC*FVcHH7zH z>lW}$Rr23`UuSm`(aLNMq>8*xF8BEyLcf>P$ffAXUt{oBtBbT*9D>t6=nBVfdZfRQ-_sKl@f t@%Os>eBHOMy9Ckcy`lT}l|bHid~d0dAOg%+E&eaQb&79|pO_#1{3jLUO{o9? diff --git a/internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ b/internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ deleted file mode 100644 index aa6048bbfdd54af5936429c9b1e3638cc6bf430d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3097 zcmchZ&rcgi6vxNL2^&(IMXJ;bg{gytEs+SC9uTEq<6k&2wu6^&>7gh%*uu39CPhtY zFg6m-rG`JCfvT5?gXy^ufheuu2LAw}5{Gc8WLJ@DE5>Z!oAs_uN(8i3NAm7x-+cFd z-^}hl*>`U;7@eZ`Ba_tW_IYg-%XLmWYhLKq8!I#1C7!8K$RKQQ2;VJ)Q zC>V><=*YeCkukqfs};VE`n$9Si>u4&zV0 zT0_~N8Z3i0Gu&%)I6ZFKK|iK9=_f|oDg_|fbpZ;Q4u(e~(=--{JP3`_z{ppAR^R=g zKQtPng2&rNz3e#Xbo2{wQ9k$Er0Zd)Rp@V{eI7yZ47Aaa@F;cJ?7|J|oRX7UVip7 zpu=K)Nqn>}2L9O2XG=%N&&9FuZa({3{PwvRnE=X)GfiUT5zOxAXCW5eE@od8#C4o4 zqDcvUyLb@savOn-!#FD%4$)I6kUU7^e1Qbw^Zh7@gYIq0;j9OBDW*f>m`;jC^qe7?qZf!Mz3hqdJ#4Q1(NVH5)L7Bie`GR}GW&;Tow^-IyQ7tcJiNlGFvwUAJ zH1sIGoZ<@vD+0G>AgpTc>Jp0u5@t>!R#o|qYYPpME?%}hd%X)f{S0Y`%q@KldY*V; zl@)4D@I5?Pg!TTa{s3ly5}E|+3ZT=lJ9s3A4q|+j+ZpRkv~DTBYQmQ z?8H8DyQ&kft`KEyL#7kFrfkUysperNzDb7j8|j0iEVR%~vX)oXX{t6)a7Kx*kPO${GXvLg73evhLIYIAQ7^F?Im0z|V`D^3 zMv7PKffYUDO#L$Esre1{RbJ<+N2lwVnc!8MSkILPj(_}-iLs>ZxN)u(k|xLDDcz!N-aEOB&QO zO_|xfnM=BEh_jp*-XCtcvGZ|`NcAjo)|5$QV(YDNrv3?MDwxzJwm*y9=P8Nra!dpJ z0Q)I1>><>TIa4NSKQH>cs`Mw`fB7|p_h0E2@J&_oyS}fpJBeUqwi;4H-Y1s_JXYJF zo773AsL9`B@K>vsbQr8QyLreZ*gb9m{t_A-W=p@BcC;I1>;!`Ui~~-$*+n~zMmZ%* z+>XZ@_+3GOjN~c;MlK^@eyP$lpZ@|-c>xRQ7*xff(|GqZJ`8Yi=*fwcrjn6lCad-J5hlqN#4{wSo&xFk zSYNY13sqSajWmmr=x{voag}MK$;?i=c2(BGv60k7MjLH*4E;)o${^BC4%Mud%Bab4 z9#b-Y%7>Liv#JIF3F!SltOa2PcWOKfssXEjLrpsaD_X=z!QWXqM9XhNE4?k833$_- zC@sC&Y4^}~NRlk3#NM1?;({Z)IPb*Zt^zn)!Qn;8egNbxvVgHE(E@auSS_qDzxgm* z$hq2?v=HTv;=x59XO**-;WM7Z!|gtN;-@pI^l<6~iNY-c`HdG-bJmk+Mm?owvMPU3 zhzAJn4^%^W$x=p;E!zC+>=KPR(iLs=EqiW^|flmT>PN*a`;wmE=7l2+i^}yn!Mv?#p*iEI? zjCNXq1sF7U)gdbl8|7{ir!MN;e(v_UYv9g13Ao~mrZ*ZV$H*{&s~VI!j9e1mGz`Sy zj2egcOfQvpUO2?Pt{@V)<%xHUNU!)3>*a1=RNvoE@>O^rnl*jeA`7Kz!B`;qT20T_ z%}yyK;WHs=Qs`Coydq7oCoRxSE-4}8^`2l;T@V_{he$*%lYKt8nL%fmeQ6Yl8l@nm>gybnCh%jDXBdZ{O|5xV8* zAMI8O%OT?E_vu`Fm#k>Zq1zynla?LY^#^3emK`6igngRobmeLA5HBTBKSvAxbo}Yk z(4r*a+AE>Ri%J4x2YHUpg}PoGf_Vx3f%&LMqs-x!@{vo5r<1qE`@qw@4D46;(0MoZ zE8)mxMW*rkbgpCh@{oMb*`plDL>(F2-^k^|t>nWU`%%v)!iV7o`e`0w{&V!lJzsl~ z?=>z>xijO8`Z)QxK>N`0x{}j#+a*H#Xh(>tfEtgm-QKoJU3@q zMis^2_N~=*({y;1QlU`RJuc}do(WU82AtX(>vFKCFOd0sc}@rAb!VL`rxysgRMD%} z5dvO-LlxlWEl0#%FkQ@7XLWO+vr~go-n&kXsw1H<>eK9ks}@MrfKCA#1gZgg0gDv# zCUKP%K#AKAJoI~)^m>&5+`klq&kW`PLXs9Si^g2J;9cwlf`qpt08qqc2xBhdm0#5h zAe}bMl2!6Rs~B_e-h*wy7RxGGxO@3JF=m_z@wIWp+i7@%xbiz}cU_;+t?43|(m<)R zaVBbvJ3HWc`kYSc`n+B@!Ka6_nZsoRLdloQ^lb;p<-YIC&u*ucQFUxAg~dfib&AB} z6KXa~a-*qd71HY!a=om$QbzOhxFsWVRpirJ$a(uaNdw(yXFrcU3nH+^3q`%Iljn^& zQY%9rTyWMnXP6jOeSl$=5P^bCDOo}Sl?~%8DVNUT(vnG{ z>=5bBv2`+}?`c{%ydh0WA^)-oP+aK{cDZJ1_6RSzWrZzWz?5@$!3tHTLS#AJ^AEXx#s9P@6r4qG){! z3GQ)md!L)3em^E~q)9np$Ks$ZEeAN)<@2tc(PfbXb`s13L7P1p zN!)w?HA(JC)WA31>&Xc9Q<9j=Fx4(y4>OKiT6;r?hcQF~aP!wlZ5)%~w*Q&IbC13z zbub>-adGP=iHkowB%tHr=5UD3BkJMy$WZKJ1~{BH54Seb#PM)LZQm5NdAPOUc(}Fj zn#YZYN5D4m%8iG7<^DV3lUJQ86tN!7q=<;_6q*or9SY> zivYDt9nwiVC)23tZiPKlH?URF2{uRl(4!Qffho^bs!+`3X#uuSf{M%i=7m^#xr}un z)^7{gpdi7zAYAXXEhURU5thf_ebn^2^*ppJJ2hKgJ#S(!=PH5{A8W}xsX%)MzyBbC zT9s9*3V7(d=Jf(#vQnd880{8vy);|IzDkUl+H9fOanbuC%8Am&1WVWjgP4|HGoc5W zKHCfug~5T^Z3qS2p3}=lbrxDt1HSVLKA=_@rv2psYUNt+RMGLu6s3Yc*N}4|IE&-8Yd4W|ziazJfWLwqr&QfqMZ$kprfz!Zh4{aK{ertEib%vR4o{?9uX0-S3%@BYOwV9mco#x~e_a|h1U&3Eq@)upXB z?*!JYP2K$9j&W}3L4Q!&nu88ne-K#X;sQ5bOYl+_JmELr)OG zy;Z?ZM2Qi2orj|lk+XIt@{DWeZ~{1-wzaFUhI&AF-&U@MmGiaRc4WUYDEbER&cvni8o|{LveFBF)mVy+r9%N@oQP&c({dRhvWMI z@p!m_wx7!}oZW7zkAa4E&ar3RM8@@XiycTc+ zui5h%)#Avq@GwU=+* z$|!L7oum2Yc)+irxJCB&pl_Tu0k?;cZwz;lfO9HNuo2+KXpz`8uSHQd`rHoQ2Rl~* zJ9GTgzKFfB(k2mAV{N=NY!ezwEEFCu}r$(ND9nSDsW%)XD1z?sL9 z08iTQ!{;N%PNa@~Yv8!5jf_7P`t+VScLG}Z16n~(*i52nhWaLb4_UZsi^@ciz@7&-6&^~g#kP?}wK?>l*yDu@QK%#&4NwTNkdPKv78{wQsg)_WE>uQZiG)cm zO|E`YSoO9EQ2FAPet2Uags|9O)d8#x3sLjx4Sbt zv!qldac)`L;+uJI-p@C0X5XW%={2)Zo~349rOJl4=8F~mnfA!g=rf6AUphAQeC(J? zl|)igGoy*IwBm`x)!{@^JwYSGsx~w-oJk!A0gXmtqcojK_q0>@i43KZaT?$|)RQ0`8|`TnXrgLNMI()(G%^&6e_UnSNFuY7u3eQi zacnp>p3z1c9Yeq3vNDLYy* zok^vKQpafoZV||Dyt^8+o<=h2Ni{R3iWh}^fZ+Z>H8g@3iJ(i^821P@RVIqD>$5+j z#^Dkijh#ZTs1t$cyOz*K;VJ^>kq@_*haS?6*C_r`PNl|aIx+OT8mEeUH`7RAhQe}qdz6KMQ7u=X&{T$IV%mtB>80?K z0-ob4O$|HBs3ruU7i+q2aYCaBfCB8M(rQLKrN9CVTDaReY43EcA3Jw~)!eu;Gp zw=b&i>!Z0cyfSMQeafT@h4QqqKy#Ifo~zc{Nr2!pPBapDoj^6JWh)7>%)7$?bm$x?SFIn5?w}H+Ay|jrm$p3eP`HhA87SKOj2l>0d!?i~F9gx5K+aoWb%q@^-w%!AIPW$|^;lUpu zFVI;|gM8bY2fEG?5+$HN*wU$l30XmTfzG!5_`uifd5{mbJRS^_K-iK03djdGJb9Q0 ze}ZkDU9OC1OY}jcMVV~tPcL@GHv%_p{Ue>q^m2gO`aL?^+7VW?<-i?~$&zK8cKiXE z(Pi6*%R!H3IvsfyJjBaL)GyGIKW%@yIJig%uDu)xy{yDBc90k7Y@p-iL6|4#56nkg z8f6YQl@DE1T%DpV(Fc(hWnjNL2hTaNUk-*YDPb0`M`zoXFAaw8+k2D+nTRce`y0A+ zxS4#gZ9nSyMEG#rKtIbv%zuIYxaVsx^6fRfh*v_6mUAVz`eq8%n%P^^r;PG+FI=mI z>NGW~bjFygn)x2MIn2CWsu%SclfE!#nnoGL;P$Ol^;*s5l?v0-Mcw7nKI)pN>1MxO zo@40__VfihpDWJkpuB3YbL8}C3NDrOve`?)3vj3e+?;8PI18rox$>-D>u+z@pxSq@ zQ=@E4=!^Okzu?N#v}`~#0X+oM0PTWF^SK&zluUyXr)7BL_b%;rD*?EF83vyj%>9%m zOj^qubH!=*Vy6%!yd436JoZZ%a~`k!vOW#cX`@y!3od9SV-DVXur1hynFSMfFIT0; zj6EU0HhSHihBt^Kzr%J{^%>oq%7ZBll-e6tLya+e2V75I&}mhl*Q+(~>CtTFP|<); za>XKh+d*b!?1gM^euzwA(G@x_NP>jO6BVONQsl z$Y-^X{r0z$2D;DoJ`sB!gl~%%@_JRLFB)^SQiN7{+FoOyVQQ51emVv_j>)gHBT+MK z=_#lN<_mBF5h&P{f+;0X(J;=?V&M!fE!1d)A0pj8wswZ}Ji`iyx5xwuc$bZj5=sX@ z$15Iul;sYLz03pfw?NF=PuCFI;cxcxw!2ATi|o;v(J51+zA zR+rwKzx6@A{8V;k&z_?z|hdj0RWeH^g!>JFUMrR(eK z@7C+DzUNzGtuFm>ef@*_gYWvaS(7M=*0+!l9tXGgg&9Wfg4;Fzx{`@jYeJsjqgFBz z3R~~LdGlb`;@J(0bO@Ylp@?<#5DACk%TbGjEXHcJu7y2LRN_nkC-x(9Ahh`XsKg-? z;kXrzfwpwm$GH|h=hzupmN{T2&OMN{Srei7{rBG>;jVZEd=tH%2r)ki;V#2eE4dcr z9H+E)hY$~E$OPc#tsyM}ljFAk*@3fPeS@@d9@uek>!k4uKRYC$s3jum;`Z2J z^g;$Wf;Jbo7TUmZaYJq2l(o6IHQ~6pHSt=+O@v3nO~znvxQWVO7g)Y21NZJ&&2S4U z;S1rW`DSw<4?J`%7q{TE;d|kzoCi+6!J1zHN5Go6xB=&q%whS)>{!eYnbE?EQhVFfhi0+1)r%a+C z-=wiO06X45qCU5S+52d5n`Cb<|K~3CfmdGms9oxicGfx7jFRqD*fUiFTNRyRbJPbt z$}}`E#ko=$in$ysz!nNnaXH_-P*X1!u@1!gZ2=n;BzPBu>+QCsU{WZ;a`@|!ie5Ee zgqCHeX3MSTYuL*c(+CoS!G_vt2qoNJ(2GWS7FtmQzVq@y zXp4UW{BT#@7RK#Y(0U0Vp4VY(W^)BVIX&kzsXKI2=*$lL1`T4L=9$Rn=A9PC?NKol z=#c z=jx4ne=!VL^DmjP4R+q%firpI_FbdAwDtB~-&N2UPTJ-&{LhB7q$z-QyK~8F2{-VXKc7*)b-*{<{|Q^(K5*PZok|=Ii;z_e zH-{r-6+5S$%Hp97iNnrmr;G5TjAdqk-*#J%ShnNJ|uAF2_(dseIKzIn+3kLJ|F?|*wN#uqu=g7rfS2RH_UKvzlSVbwZ&v2NZ`^uoB0(IDDz7ski|5I8UjHHv~A0OgN>Lx uN#TsBf%G@X9BYv2ZIF4jL8ej9*BfMxH0XKSm1zv*)9=XPZ;{>~{QiHEKb|N6 diff --git a/internal/test/env/inspector/hand/userdef.test.~1~ b/internal/test/env/inspector/hand/userdef.test.~1~ deleted file mode 100644 index a26c5522..00000000 --- a/internal/test/env/inspector/hand/userdef.test.~1~ +++ /dev/null @@ -1,34 +0,0 @@ -(DO-TEST "USER DEFINED RECORD TYPES -SET UP" - (SETQ IL::CLISPRECORDTYPES (CONS 'IL:TESTRECORD - IL::CLISPRECORDTYPES)) - (IL:MOVD 'IL:RECORD 'IL:TESTRECORD) - (IL:DEFINEQ (TESTRECORDMANIP(DECL) - `(IL:RECORD ,@(CDR DECL)))) - (IL:PUTPROP 'IL:TESTRECORD 'IL:USERRECORDTYPE - 'TESTRECORDMANIP)) - -(DO-TEST "USER DEFINED RECORD TYPES - CREATION" - (IL:TESTRECORD FOO (A B C)) - (SETQ FOO1 (IL:CREATE FOO B IL:_ 2)) - (IL:REPLACE (FOO A) IL:OF FOO1 IL:WITH 1) - (AND (EQ (IL:FETCH (FOO B) IL:OF FOO1) 2) - (EQ (IL:FETCH (FOO A) IL:OF FOO1) 1))) - -(DO-TEST "USER DEFINED RECORDS - CLEANUP" - (SETQ IL::CLISPRECORDTYPES (CDR IL::CLISPRECORDTYPES))) - -(DO-TEST "SUBRECORDS" - (IL:RECORD FOO ( X Y Z)) - (IL:RECORD BAR (L M FOO) (IL:SUBRECORD FOO)) - (SETQ BAR1 (IL:CREATE BAR X IL:_ 5)) - (IL:REPLACE (BAR M) IL:OF BAR1 IL:WITH 2) - (AND (EQ (IL:FETCH (BAR X) IL:OF BAR1) 5) - (EQ (IL:FETCH (BAR M) IL:OF BAR1) 2))) - -(DO-TEST "RECURSIVE RECORDS" - (IL:RECORD FOOBAR (FOO BAR)(IL:RECORD FOO (A B C)) - (IL:RECORD BAR (D E F))) - (SETQ FOOBAR1 (IL:CREATE FOOBAR A IL:_ 1)) - (IL:REPLACE (FOOBAR D) IL:OF FOOBAR1 IL:WITH 5) - (AND (EQ (IL:FETCH (FOOBAR A) IL:OF FOOBAR1) 1) - (EQ (IL:FETCH (FOOBAR D) IL:OF FOOBAR1) 5))) \ No newline at end of file diff --git a/internal/test/env/inspector/hand/userdef.test.~2~ b/internal/test/env/inspector/hand/userdef.test.~2~ deleted file mode 100644 index 8e02f1cd..00000000 --- a/internal/test/env/inspector/hand/userdef.test.~2~ +++ /dev/null @@ -1,37 +0,0 @@ -;; WARNING!! This test file will report spurious errors if run twice -;; in the same sysout!! You have been warned... - -(DO-TEST "USER DEFINED RECORD TYPES -SET UP" - (SETQ IL::CLISPRECORDTYPES (CONS 'IL:TESTRECORD - IL::CLISPRECORDTYPES)) - (IL:MOVD 'IL:RECORD 'IL:TESTRECORD) - (IL:DEFINEQ (TESTRECORDMANIP(DECL) - `(IL:RECORD ,@(CDR DECL)))) - (IL:PUTPROP 'IL:TESTRECORD 'IL:USERRECORDTYPE - 'TESTRECORDMANIP)) - -(DO-TEST "USER DEFINED RECORD TYPES - CREATION" - (IL:TESTRECORD FOO (A B C)) - (SETQ FOO1 (IL:CREATE FOO B IL:_ 2)) - (IL:REPLACE (FOO A) IL:OF FOO1 IL:WITH 1) - (AND (EQ (IL:FETCH (FOO B) IL:OF FOO1) 2) - (EQ (IL:FETCH (FOO A) IL:OF FOO1) 1))) - -(DO-TEST "USER DEFINED RECORDS - CLEANUP" - (SETQ IL::CLISPRECORDTYPES (CDR IL::CLISPRECORDTYPES))) - -(DO-TEST "SUBRECORDS" - (IL:RECORD FOO ( X Y Z)) - (IL:RECORD BAR (L M FOO) (IL:SUBRECORD FOO)) - (SETQ BAR1 (IL:CREATE BAR X IL:_ 5)) - (IL:REPLACE (BAR M) IL:OF BAR1 IL:WITH 2) - (AND (EQ (IL:FETCH (BAR X) IL:OF BAR1) 5) - (EQ (IL:FETCH (BAR M) IL:OF BAR1) 2))) - -(DO-TEST "RECURSIVE RECORDS" - (IL:RECORD FOOBAR (FOO BAR)(IL:RECORD FOO (A B C)) - (IL:RECORD BAR (D E F))) - (SETQ FOOBAR1 (IL:CREATE FOOBAR A IL:_ 1)) - (IL:REPLACE (FOOBAR D) IL:OF FOOBAR1 IL:WITH 5) - (AND (EQ (IL:FETCH (FOOBAR A) IL:OF FOOBAR1) 1) - (EQ (IL:FETCH (FOOBAR D) IL:OF FOOBAR1) 5))) \ No newline at end of file diff --git a/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ b/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ deleted file mode 100644 index c232d458..00000000 --- a/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ +++ /dev/null @@ -1,3 +0,0 @@ -Testing: Inspect-defstruct.tedit - -Bug: changing the value of an integer typed slot to a floating point number worked. \ No newline at end of file diff --git a/internal/test/env/inspector/logs/inspect-defstruct.log.~2~ b/internal/test/env/inspector/logs/inspect-defstruct.log.~2~ deleted file mode 100644 index 9522f98211dbb0d8dc1a86568392621b511119e4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 607 zcma)&!A`ZlOkm z1AEx~GxPm3vpb}I4>+50*B^lEPshyRqlsg<-60 zyZ%(@`fL%1xh6p^5SBqwAjk*;0kKdx#|+du#SrpDDo_#vh!Po?){sh#fG9rRG_{i1 zJBDpNnJqC}tA!yj$#GkOC>BV}IU^RiE!Fn2PX9)GdY3)ftN%~bNR3>P`jC0AjJpmc z7aPJN2h+N^Ltp;VkEGM=u|9qAcz@(`=sUvXIzDVQq`v?C|QzHNX diff --git a/internal/test/env/process-controls/hand/PSW.U.~1~ b/internal/test/env/process-controls/hand/PSW.U.~1~ deleted file mode 100644 index caf88684..00000000 --- a/internal/test/env/process-controls/hand/PSW.U.~1~ +++ /dev/null @@ -1,182 +0,0 @@ -;; Function To Be Tested: Process Control Window (Process Controls) -;; -;; Source: IRM VOLUME 2 -;; Section 23.8. PSW,Lyric Release Notes -;; -;; Section: Program Support -;; -;; Created By: John Park -;; -;; Creation Date: April 9, 1987 -;; -;; Last Update: April 23, 1987 -;; -;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U -;; -;; -;; -;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. -;; (SEE IRM Volume 2, Section 23.8) -;; -;; -;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) -;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that -;; allows the user to examine and manipulate all of the existing processes. -;; The window consists of two menus. The top menu lists all the processes at the -;; moment. Commands in the bottom menu operate on the process selected in the -;; top menu. -;; -;; Argument(s): WHERE: position of Process Status Window -;; (SEE IRM Volume 2, Section 23.8) -;; -;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) -;; -;; Constraints/Limitations: The test for PSW is not automated. The user is -;; expected to have tested this system through the operational use of PSW from -;; the background menu. This test will focus on the creation of the PSW only. -;; The user is encourged to either test this system operationally or explicitly -;; by following the functional description of PSW as outlined in IRM Volume 2, -;; section 23.8. Any problems should be reported as ARs and logged in -;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U -;; -;; -;; -(DO-TEST "PSW-TEST-SETUP" - (PROGN - (IL:PAGEHEIGHT 0) - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR PSW: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) - (DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) - (SETQ PSW-MESS "Shortly a PSW will be created programatically. -If it is created, please anwser y or n otherwise...") - - (SETQ PSW-MESS1 "Please click PSW from the background menu to create -the Process Status Window") - (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") - (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") - (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") - (SETQ PSW-MESS5 "Would you like to see the test result? ") - (IL:SHAPEW IL:PROMPTWINDOW '(10 720 550 100)) - (DEFUN PSW-TEST NIL - (PROGN - (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) - (SETQ PSW-DESCRIPTION-LIST - '("Displays a backtrace of function names starting at LASTPOS" - "Displays a backtrace of function names with variables beginning - at LASTPOS" - "Displays a backtrace of functions names and prints arguments to - local variables and eval blips" - "Displays a backtrace of functions and prints everything - on the stack" - "Changes the selection to the tty process (the one currently - in control of the keyboard)" - "Associates the keyboard with the selected process: - (makes the selected process be the tty process)" - "If the selected process has an INFOHOOK property, calls it. -The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" - "Enter a break under the selected process. This has the side - effect of waking the process with the value returned from the break" - "Deletes the selected process" - "Restarts the selected process" - "Wakes the selected process. Prompts for a value to wake it with" - "Suspends the selected process (causes it to block indefinitely)")) - (SETQ COLON ": ") - (SETQ MESS "Is the selected process examined or manupulated successfully -by the command ~A ? ") - (IL:FOR ITEM IL:IN PSW-ITEM-LIST IL:DO - (PROGN (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) - (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) - (IL:PROMPTPRINT PSW-ITEM COLON PSW-DESCRIPTION) - (PAUSE) - (IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:Y - (FORMAT T MESS PSW-ITEM))) - (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) T) - (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) NIL)) - (IL:CLEARW) - (SLEEP 1))) - (IL:CLRPROMPT) - ) - ) - - (SETQ PSW-STRING -"; Creating the PSW programmatically... -(IL:PROMPTPRINT PSW-MESS) -(IL:PROCESS.STATUS.WINDOW '(930 . 240)) -(IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) - (SETQ PSW-CREATED-FLG T) (SETQ PSW-CREATED-FLG NIL)) -(IL:FOR X IL:IN (IL:OPENWINDOWS) - IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) - IL:DO (IL:CLOSEW X)) -; Creating the PSW from the background menu... -(IL:PROMPTPRINT PSW-MESS1) -(PAUSE) -(IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) - (SETQ PSW-BACKGROUND-FLG T) (SETQ PSW-BACKGROUND-FLG NIL)) - -; Start PSW Component Test -(SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) -(IL:PROMPTPRINT PSW-MESS3) -(IF (EQ (IL:ASKUSER NIL 'IL:N PSW-MESS4) 'IL:Y) - (PROGN (PSW-TEST) - (SETQ PSW-COMPONENT-TESTED T)) - (SETQ PSW-COMPONENT-TESTED NIL)) - -(IL:FOR X IL:IN (IL:OPENWINDOWS) - IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) - IL:DO (IL:CLOSEW X)) - -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (ABS (- TEST-END TEST-START)) 60000))) - -; Wrinting the test results to -; {eris}test>program-support>clisp.u.... -(DO-TEST 'PSW-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY PSW-CREATED-FLG) - (PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU PSW-BACKGROUND-FLG) - (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) - (IF (EQ PSW-COMPONENT-TESTED T) - (IL:FOR X IL:IN PSW-ITEM-LIST IL:DO - (PROGN - (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) - (PASS-FAIL X (EVAL (PACK* PSW-ITEM '-EXAMINED-FLG))) - ) - ) - ) - - (T-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) -(IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:N PSW-MESS5)) - (PROGN (IL:PAGEHEIGHT 15) - (IL:SEE '{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT))) - -") - (IL:BKSYSBUF PSW-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/process-controls/hand/PSW.U.~2~ b/internal/test/env/process-controls/hand/PSW.U.~2~ deleted file mode 100644 index a49581e1..00000000 --- a/internal/test/env/process-controls/hand/PSW.U.~2~ +++ /dev/null @@ -1,182 +0,0 @@ -;; Function To Be Tested: Process Control Window (Process Controls) -;; -;; Source: IRM VOLUME 2 -;; Section 23.8. PSW,Lyric Release Notes -;; -;; Section: Program Support -;; -;; Created By: John Park -;; -;; Creation Date: April 9, 1987 -;; -;; Last Update: April 23, 1987 -;; -;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U -;; -;; -;; -;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. -;; (SEE IRM Volume 2, Section 23.8) -;; -;; -;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) -;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that -;; allows the user to examine and manipulate all of the existing processes. -;; The window consists of two menus. The top menu lists all the processes at the -;; moment. Commands in the bottom menu operate on the process selected in the -;; top menu. -;; -;; Argument(s): WHERE: position of Process Status Window -;; (SEE IRM Volume 2, Section 23.8) -;; -;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) -;; -;; Constraints/Limitations: The test for PSW is not automated. The user is -;; expected to have tested this system through the operational use of PSW from -;; the background menu. This test will focus on the creation of the PSW only. -;; The user is encourged to either test this system operationally or explicitly -;; by following the functional description of PSW as outlined in IRM Volume 2, -;; section 23.8. Any problems should be reported as ARs and logged in -;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U -;; -;; -;; -(DO-TEST "PSW-TEST-SETUP" - (PROGN - (IL:PAGEHEIGHT 0) - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR PSW: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%SYSTEM: PSW COMMAND: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) - (DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) - (SETQ PSW-MESS "Shortly a PSW will be created programatically. -If it is created, please anwser y or n otherwise...") - - (SETQ PSW-MESS1 "Please click PSW from the background menu to create -the Process Status Window") - (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") - (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") - (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") - (SETQ PSW-MESS5 "Would you like to see the test result? ") - (IL:SHAPEW IL:PROMPTWINDOW '(10 720 550 100)) - (DEFUN PSW-TEST NIL - (PROGN - (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) - (SETQ PSW-DESCRIPTION-LIST - '("Displays a backtrace of function names starting at LASTPOS" - "Displays a backtrace of function names with variables beginning - at LASTPOS" - "Displays a backtrace of functions names and prints arguments to - local variables and eval blips" - "Displays a backtrace of functions and prints everything - on the stack" - "Changes the selection to the tty process (the one currently - in control of the keyboard)" - "Associates the keyboard with the selected process: - (makes the selected process be the tty process)" - "If the selected process has an INFOHOOK property, calls it. -The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" - "Enter a break under the selected process. This has the side - effect of waking the process with the value returned from the break" - "Deletes the selected process" - "Restarts the selected process" - "Wakes the selected process. Prompts for a value to wake it with" - "Suspends the selected process (causes it to block indefinitely)")) - (SETQ COLON ": ") - (SETQ MESS "Is the selected process examined or manupulated successfully -by the command ~A ? ") - (IL:FOR ITEM IL:IN PSW-ITEM-LIST IL:DO - (PROGN (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) - (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) - (IL:PROMPTPRINT PSW-ITEM COLON PSW-DESCRIPTION) - (PAUSE) - (IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:Y - (FORMAT T MESS PSW-ITEM))) - (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) T) - (IL:SET (PACK* PSW-ITEM '-EXAMINED-FLG) NIL)) - (IL:CLEARW) - (SLEEP 1))) - (IL:CLRPROMPT) - ) - ) - - (SETQ PSW-STRING -"; Creating the PSW programmatically... -(IL:PROMPTPRINT PSW-MESS) -(IL:PROCESS.STATUS.WINDOW '(800 . 240)) -(IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) - (SETQ PSW-CREATED-FLG T) (SETQ PSW-CREATED-FLG NIL)) -(IL:FOR X IL:IN (IL:OPENWINDOWS) - IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) - IL:DO (IL:CLOSEW X)) -; Creating the PSW from the background menu... -(IL:PROMPTPRINT PSW-MESS1) -(PAUSE) -(IF (EQ (IL:ASKUSER NIL 'Y PSW-MESS2) 'IL:Y) - (SETQ PSW-BACKGROUND-FLG T) (SETQ PSW-BACKGROUND-FLG NIL)) - -; Start PSW Component Test -(SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) -(IL:PROMPTPRINT PSW-MESS3) -(IF (EQ (IL:ASKUSER NIL 'IL:N PSW-MESS4) 'IL:Y) - (PROGN (PSW-TEST) - (SETQ PSW-COMPONENT-TESTED T)) - (SETQ PSW-COMPONENT-TESTED NIL)) - -(IL:FOR X IL:IN (IL:OPENWINDOWS) - IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) - IL:DO (IL:CLOSEW X)) - -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (ABS (- TEST-END TEST-START)) 60000))) - -; Wrinting the test results to -; {eris}test>program-support>clisp.u.... -(DO-TEST 'PSW-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY PSW-CREATED-FLG) - (PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU PSW-BACKGROUND-FLG) - (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) - (IF (EQ PSW-COMPONENT-TESTED T) - (IL:FOR X IL:IN PSW-ITEM-LIST IL:DO - (PROGN - (SETQ PSW-ITEM (POP PSW-ITEM-LIST)) - (PASS-FAIL X (EVAL (PACK* PSW-ITEM '-EXAMINED-FLG))) - ) - ) - ) - - (T-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) -(IF (EQ 'IL:Y (IL:ASKUSER NIL 'IL:N PSW-MESS5)) - (PROGN (IL:PAGEHEIGHT 15) - (IL:SEE '{ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.REPORT))) - -") - (IL:BKSYSBUF PSW-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/process-controls/hand/PSW.U.~3~ b/internal/test/env/process-controls/hand/PSW.U.~3~ deleted file mode 100644 index c1303b3d..00000000 --- a/internal/test/env/process-controls/hand/PSW.U.~3~ +++ /dev/null @@ -1,127 +0,0 @@ -;; Function To Be Tested: Process Control Window (Process Controls) -;; -;; Source: IRM VOLUME 2 -;; Section 23.8. PSW,Lyric Release Notes -;; -;; Section: Program Support -;; -;; Created By: John Park -;; -;; Creation Date: April 9, 1987 -;; -;; Last Update: April 23, 1987 -;; -;; Filed As: {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U -;; -;; -;; -;; Syntax: (PROCESS.STATUS.WINDOW WHERE) or PSW from background menu. -;; (SEE IRM Volume 2, Section 23.8) -;; -;; -;; Function Description: The background menu command PSW (IRM Vol 2, Section 28.6) -;; and the function PROCESS.STATUS.WINDOW create a "Process Status Window", that -;; allows the user to examine and manipulate all of the existing processes. -;; The window consists of two menus. The top menu lists all the processes at the -;; moment. Commands in the bottom menu operate on the process selected in the -;; top menu. -;; -;; Argument(s): WHERE: position of Process Status Window -;; (SEE IRM Volume 2, Section 23.8) -;; -;; Returns: Process Status Window (SEE IRM Volume 2, Section 23.8) -;; -;; Constraints/Limitations: The test for PSW is not automated. The user is -;; expected to have tested this system through the operational use of PSW from -;; the background menu. This test will focus on the creation of the PSW only. -;; The user is encourged to either test this system operationally or explicitly -;; by following the functional description of PSW as outlined in IRM Volume 2, -;; section 23.8. Any problems should be reported as ARs and logged in -;; {ERINYES}LISP>LYRIC>PROCESS-CONTROLS>PSW.U -;; -;; -;; -(DO-TEST "PSW-TEST-SETUP" - (IL:PAGEHEIGHT 0) - (SETQ TEST-SUCCEEDED T) - - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Wunnerful!") - ) ; close DEFUN PASS-FAIL - (SETQ PSW-MESS "Shortly a PSW will be created programatically. -If it is created, please anwser y or n otherwise...") - - (SETQ PSW-MESS1 "Please click PSW from the background menu to create -the Process Status Window") - (SETQ PSW-MESS2 "Is the PSW is invoked successfully (yes or no)? ") - (SETQ PSW-MESS3 "Normally, a lisp user is expected to have used the PSW to examine or control various processes from the background menu in the course of running other interlisp funtions, programs, processes, etc. Therefore, it's reasonable to judge the performance of the Process controls based on his or her operational use. If one wants to test it explicitly, please enter Yes and answer each question after testing each component of the PSW") - (SETQ PSW-MESS4 "Do you want to run the PSW subsystem test explicitly? ") - (DEFUN PSW-TEST NIL - (SETQ PSW-ITEM-LIST '(BT BTV BTV* BTV! WHO? KBD_ INFO BREAK KILL - RESTART WAKE SUSPEND)) - (SETQ PSW-DESCRIPTION-LIST - '("Displays a backtrace of function names starting at LASTPOS" - "Displays a backtrace of function names with variables beginning - at LASTPOS" - "Displays a backtrace of functions names and prints arguments to - local variables and eval blips" - "Displays a backtrace of functions and prints everything - on the stack" - "Changes the selection to the tty process (the one currently - in control of the keyboard)" - "Associates the keyboard with the selected process: - (makes the selected process be the tty process)" - "If the selected process has an INFOHOOK property, calls it. -The hook may be a function, which is then applied to two arguments,the process and the button (LEFT or MIDDLE) used to invoke INFO, or a form, which is simply EVAL'ed. The APPLY or EVAL happens in the context ofthe selected process, using PROCESS.APPLY or PROCESS.EVAL. The INFOHOOK process property can be set using PROCESSPROP" - "Enter a break under the selected process. This has the side - effect of waking the process with the value returned from the break" - "Deletes the selected process" - "Restarts the selected process" - "Wakes the selected process. Prompts for a value to wake it with" - "Suspends the selected process (causes it to block indefinitely)")) - (SETQ COLON ": ") - (SETQ MESS "Is the selected process examined or manipulated successfully by the command ~A ? ") - (IL:FOR PSW-ITEM IL:IN PSW-ITEM-LIST IL:DO - (SETQ PSW-DESCRIPTION (POP PSW-DESCRIPTION-LIST)) - (FORMAT T "~a~a~a~%" PSW-ITEM COLON PSW-DESCRIPTION) - (PASS-FAIL PSW-ITEM (Y-OR-N-P (FORMAT T MESS PSW-ITEM))) - (IL:CLRPROMPT) - - ) ; close FOR - ) ; close DEFUN PSW-TEST - -; Creating the PSW programmatically... -(IL:PRIN1 PSW-MESS) -(IL:PROCESS.STATUS.WINDOW '(800 . 240)) -(PASS-FAIL 'PSW-INVOKED-PROGRAMMATICALLY (Y-OR-N-P PSW-MESS2)) -(IL:FOR X IL:IN (IL:OPENWINDOWS) - IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) - IL:DO (IL:CLOSEW X)) -; Creating the PSW from the background menu... -(IL:PRIN1 PSW-MESS1) -(PASS-FAIL 'PSW-INVOKED-FROM-BACKGROUND-MENU (Y-OR-N-P PSW-MESS2)) - -; Start PSW Component Test -(IL:PRIN1 PSW-MESS3) -(IL:IF (Y-OR-N-P PSW-MESS4) - IL:THEN (PSW-TEST) -) - - - -(IL:FOR X IL:IN (IL:OPENWINDOWS) - IL:WHEN (EQUAL (IL:WINDOWPROP X 'IL:CLOSEFN) 'IL:PROCESS.STATUS.WINDOWA0020) - IL:DO (IL:CLOSEW X)) - - - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ deleted file mode 100644 index 998a0d61..00000000 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ +++ /dev/null @@ -1,137 +0,0 @@ -;; Function To Be Tested: BROWSER-2 (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 10, 1987 -;; -;; Last Update: March 11, 1987 -;; -;; Filed As: {ERIS}test>program-analysis>browser-part2.u -;; -;; -;; Syntax: (BROWSER T/NIL) -;; -;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. -;; -;; Argument(s): T or NIL (SEE Browser documentation) -;; -;; Returns: IL:MSPATHS -;; -;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is -;; to determine if masterscope is unaffected when the BROWSER is not enabled or -;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded -;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test -;; determines if BROWSER modified masterscope in such a way that paths are displayed -;; grahically in a display window. -;; -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-GFuntion -;; | -;; GFun-A------------------------GFun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 -;; | -;; -------------- -;; | | -;; GFun-C1 GFun-A1 -;; -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "BROWSER2-TEST-SETUP" - (PROGN - (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>BROWSER.REPORT") - (DEFUN BROWSER-FAILED NIL (PROGN - (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'BROWSER-DISPLAY NIL) - (CLOSE *OUTPUT*) - (IL:CLOSEW BROWSERW) - (IL:CLRPROMPT))) - (DEFUN BROWSER-SUCCEEDED NIL (PROGN - (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'BROWSER-DISPLAY T) - (CLOSE *OUTPUT*) - (IL:CLOSEW BROWSERW) - (IL:CLRPROMPT))) - (SETQ MESSAGE " Please enter (BROWSER-SUCCEEDED) if test has succeeded - or (BROWSER-FAILED) if test has failed.") - (SETQ BROWSER2-COMMAND-STRING -"; Reinitialize and Define functions to be analyzed.... -(PAUSE) -. ERASE -(DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) -(DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) -(DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) -(DEFUN GFUN-A1 NIL T) -(DEFUN GFUN-A2 NIL NIL) -(DEFUN GFUN-A3 NIL T) -(DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) -(DEFUN GFUN-B2 NIL NIL) -(DEFUN GFUN-B3 NIL T) -(DEFUN GFUN-C1 NIL NIL) - -; Start analyzing functions in gtop-function and others... -(PAUSE) -. ANALYZE TOP-GFUNTION -. ANALYZE GFUN-A -. ANALYZE GFUN-B -. ANALYZE GFUN-A1 -. ANALYZE GFUN-A2 -. ANALYZE GFUN-A3 -. ANALYZE GFUN-B1 -. ANALYZE GFUN-B2 -. ANALYZE GFUN-B3 -. ANALYZE GFUN-C1 -; Browser is now loaded and activated by Part 1 test of browser -; Part 2 of this test is to determine if masterscope is modified by enabling -; the BROWSER or (IL:BROWSER T) -(IL:BROWSER T) -(PAUSE) -; show paths should display the following path graphically in a display window -; 1.gfun-a1 gfun-a top-gfuntion -; 2. gfun-b1 gfun-b top-gfuntion -; show paths should display the above path graphically in a display window -; as being shown on the lower left from -; {eris}test>program-analysis>browser.graph. -; Loading the graph....... -(PAUSE) -(IL:TEDIT '{eris}test>program-analysis>browser.graph BROWSERW) -(IL:TTY.PROCESS 'EXEC) -; -; The graph returned from BROWSER should look like the one that is being -; displayed on the lower right. If they are identical, please enter -; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) -; at the end of the test. If it breaks, enter ^ in the break -; window to return to exec. The result will automatically be logged -; in {eris}test>program-analysis>browser.report. -(PAUSE) -(IL:PROMPTPRINT MESSAGE) -. SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION -") - (IL:BKSYSBUF BROWSER2-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ deleted file mode 100644 index c07b1d12..00000000 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ +++ /dev/null @@ -1,131 +0,0 @@ -;; Function To Be Tested: BROWSER-2 (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 10, 1987 -;; -;; Last Update: March 11, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>browser-part2.u -;; -;; -;; Syntax: (BROWSER T/NIL) -;; -;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. -;; -;; Argument(s): T or NIL (SEE Browser documentation) -;; -;; Returns: IL:MSPATHS -;; -;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is -;; to determine if masterscope is unaffected when the BROWSER is not enabled or -;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded -;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test -;; determines if BROWSER modified masterscope in such a way that paths are displayed -;; grahically in a display window. -;; -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-GFuntion -;; | -;; GFun-A------------------------GFun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 -;; | -;; -------------- -;; | | -;; GFun-C1 GFun-A1 -;; -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "BROWSER2-TEST-SETUP" - (PROGN - (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>BROWSER.REPORT") - (DEFUN BROWSER-FAILED NIL (PROGN - (PASS-FAIL 'BROWSER-DISPLAY NIL) - (IL:CLOSEW BROWSERW) - (IL:CLRPROMPT))) - (DEFUN BROWSER-SUCCEEDED NIL (PROGN - (PASS-FAIL 'BROWSER-DISPLAY T) - (IL:CLOSEW BROWSERW) - (IL:CLRPROMPT))) - (SETQ MESSAGE " Please enter (BROWSER-SUCCEEDED) if test has succeeded - or (BROWSER-FAILED) if test has failed.") -; Reinitialize and Define functions to be analyzed.... -(PAUSE) -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) -(DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) -(DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) -(DEFUN GFUN-A1 NIL T) -(DEFUN GFUN-A2 NIL NIL) -(DEFUN GFUN-A3 NIL T) -(DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) -(DEFUN GFUN-B2 NIL NIL) -(DEFUN GFUN-B3 NIL T) -(DEFUN GFUN-C1 NIL NIL) - -; Start analyzing functions in gtop-function and others... -(PAUSE) -(IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-C1)) - -; Browser is now loaded and activated by Part 1 test of browser -; Part 2 of this test is to determine if masterscope is modified by enabling -; the BROWSER or (IL:BROWSER T) -(IL:BROWSER T) -(PAUSE) -; show paths should display the following path graphically in a display window -; 1.gfun-a1 gfun-a top-gfuntion -; 2. gfun-b1 gfun-b top-gfuntion -; show paths should display the above path graphically in a display window -; as being shown on the lower left from -; {eris}test>program-analysis>browser.graph. -; Loading the graph....... -(PAUSE) -; -; The graph returned from BROWSER should look like the one that is being -; displayed on the lower right. If they are identical, please enter -; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) -; at the end of the test. If it breaks, enter ^ in the break -; window to return to exec. The result will automatically be logged -; in {eris}test>program-analysis>browser.report. -(PAUSE) -(IL:PROMPTPRINT MESSAGE) -(IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) -(PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) - - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ deleted file mode 100644 index 377e9c12..00000000 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ +++ /dev/null @@ -1,118 +0,0 @@ -;; Function To Be Tested: BROWSER-2 (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 10, 1987 -;; -;; Last Update: March 11, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>browser-part2.u -;; -;; -;; Syntax: (BROWSER T/NIL) -;; -;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. -;; -;; Argument(s): T or NIL (SEE Browser documentation) -;; -;; Returns: IL:MSPATHS -;; -;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is -;; to determine if masterscope is unaffected when the BROWSER is not enabled or -;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded -;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test -;; determines if BROWSER modified masterscope in such a way that paths are displayed -;; grahically in a display window. -;; -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-GFuntion -;; | -;; GFun-A------------------------GFun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 -;; | -;; -------------- -;; | | -;; GFun-C1 GFun-A1 -;; -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "BROWSER2-TEST-SETUP" - - (IL:FILESLOAD (IL:SYSLOAD) MASTERSCOPE BROWSER GRAPHER) - (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - -; Reinitialize and Define functions to be analyzed.... -(PAUSE) -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) -(DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) -(DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) -(DEFUN GFUN-A1 NIL T) -(DEFUN GFUN-A2 NIL NIL) -(DEFUN GFUN-A3 NIL T) -(DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) -(DEFUN GFUN-B2 NIL NIL) -(DEFUN GFUN-B3 NIL T) -(DEFUN GFUN-C1 NIL NIL) - -; Start analyzing functions in gtop-function and others... -(PAUSE) -(IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-C1)) - -; Browser is now loaded and activated by Part 1 test of browser -; Part 2 of this test is to determine if masterscope is modified by enabling -; the BROWSER or (IL:BROWSER T) -(IL:BROWSER T) -; show paths should display the following path graphically in a display window -; 1.gfun-a1 gfun-a top-gfuntion -; 2. gfun-b1 gfun-b top-gfuntion -; show paths should display the above path graphically in a display window -; as being shown on the lower left from -; {eris}test>program-analysis>browser.graph. -; Loading the graph....... -; -; The graph returned from BROWSER should look like the one that is being -; displayed on the lower right. If they are identical, please enter -; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) -; at the end of the test. If it breaks, enter ^ in the break -; window to return to exec. The result will automatically be logged -; in {eris}test>program-analysis>browser.report. -(IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) -(PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) - - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ deleted file mode 100644 index b62a0d26..00000000 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ +++ /dev/null @@ -1,115 +0,0 @@ -;; Function To Be Tested: BROWSER-2 (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 10, 1987 -;; -;; Last Update: March 11, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>browser-part2.u -;; -;; -;; Syntax: (BROWSER T/NIL) -;; -;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. -;; -;; Argument(s): T or NIL (SEE Browser documentation) -;; -;; Returns: IL:MSPATHS -;; -;; Constraints/Limitations: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is -;; to determine if masterscope is unaffected when the BROWSER is not enabled or -;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded -;; by browser. Make sure that Part 1 is run before Part 2. Part 2 of BROWSER test -;; determines if BROWSER modified masterscope in such a way that paths are displayed -;; grahically in a display window. -;; -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-GFuntion -;; | -;; GFun-A------------------------GFun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 -;; | -;; -------------- -;; | | -;; GFun-C1 GFun-A1 -;; -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "BROWSER2-TEST-SETUP" - - (IL:FILESLOAD (IL:SYSLOAD) MASTERSCOPE BROWSER GRAPHER) - (SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - -; Reinitialize and Define functions to be analyzed.... -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) -(DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) -(DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) -(DEFUN GFUN-A1 NIL T) -(DEFUN GFUN-A2 NIL NIL) -(DEFUN GFUN-A3 NIL T) -(DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) -(DEFUN GFUN-B2 NIL NIL) -(DEFUN GFUN-B3 NIL T) -(DEFUN GFUN-C1 NIL NIL) - -(IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-C1)) - -; Browser is now loaded and activated by Part 1 test of browser -; Part 2 of this test is to determine if masterscope is modified by enabling -; the BROWSER or (IL:BROWSER T) -(IL:BROWSER T) -; show paths should display the following path graphically in a display window -; 1.gfun-a1 gfun-a top-gfuntion -; 2. gfun-b1 gfun-b top-gfuntion -; show paths should display the above path graphically in a display window -; as being shown on the lower left from -; {eris}test>program-analysis>browser.graph. -; Loading the graph....... -; -; The graph returned from BROWSER should look like the one that is being -; displayed on the lower right. If they are identical, please enter -; (BROWSER-SUCCEEDED) else enter (BROWSER-FAILED) -; at the end of the test. If it breaks, enter ^ in the break -; window to return to exec. The result will automatically be logged -; in {eris}test>program-analysis>browser.report. -(IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) -(PASS-FAIL 'BROWSER-DISPLAY (Y-OR-N-P "Did the browser work? ")) - - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ deleted file mode 100644 index 9f00b4f8..00000000 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ +++ /dev/null @@ -1,190 +0,0 @@ -;; Function To Be Tested: DATABASEFNS (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 18, 1987 -;; -;; Last Update: March 20, 1987 -;; -;; Filed As: {ERIS}test>program-analysis>databasefns.u -;; -;; -;; Syntax: (DUMPDB FILE) & (LOADDB FILE) -;; -;; Function Description: DATABASEFNS is a very small package whose purpose is to make -;; the construction and maintenance of masterscope data bases an essentially automatic -;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. -;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. -;; The user can dump and restore data bases explicitly via the following functions: -;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, -;; so that data base maintenance for FILE will subsequently be automatic. -;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is -;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be -;; thereafter automatic. -;; -;; Argument(s): (SEE Databasefns documentation) -;; -;; Returns: (SEE Databasefns documentation) -;; -;; Constraints/Limitations: The primary emphasis of this testing is the explicit -;; dumpting and restoration of data bases. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>databasefns.report. This test requires -;; DATABASEFNS, TEDIT, and MASTERSCOPE. -;; -;; -;; -(DO-TEST "DATABASEFNS-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DATABASEFNS: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - (SETQ DATABASEFNS-COMMAND-STRING -"; Loading databasefns and other required files from {erinyes}library>.... -(PAUSE) -(IL:PAGEHEIGHT 0) -(IL:LOAD? '{ERINYES}LIBRARY>TEDIT.LCOM 'IL:SYSLOAD) -(IL:LOAD? '{ERINYES}LIBRARY>MASTERSCOPE.LCOM 'IL:SYSLOAD) -(IL:LOAD '{ERINYES}LIBRARY>DATABASEFNS.LCOM 'IL:SYSLOAD) - -; Copy the necessary source file (data) to {core} -(IL:COPYFILE '{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.DATA -'{CORE}NEW-FUNCTION) -CONN {CORE} -(PAUSE) -; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially -; set to ASK -(IF (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK)) - (SETQ DB-VARIABLES-FLG T) - (SETQ DB-VARIABLES-FLG NIL)) - - - -; This part of the test loads the initial data file for masterscope analysis -(IL:PROMPTPRINT '(Please enter Y when masterscope asks for loading)) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) -(LOAD '{CORE}NEW-FUNCTION) -. ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION -. WHO IS CALLED BY IL:NEW-FUNCTION -(SETQ OLD-CALL-LIST *) -(IL:CLRPROMPT) - -; New-function is redefined; it also utilized times function ... -(IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) -. WHO IS CALLED BY IL:NEW-FUNCTION -(SETQ NEW-CALL-LIST *) -(IF (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES)) - (SETQ DB-UPDATE-FLG T) - (SETQ DB-UPDATE-FLG NIL)) -(IL:DUMPDB '{CORE}NEW-FUNCTION) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) -(IF (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE) - (SETQ DB-CREATED-FLG T) - (SETQ DB-CREATED-FLG NIL)) -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(IL:LOADDB '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) - (SETQ DB-FLG-RESET T) - (SETQ DB-FLG-RESET NIL)) - -; Loading the database file will reset the property database with 'YES values -; and make masterscope database maintenance automatic.. -; Cleanup will do recompilation and generate the updated database -(PAUSE) -(IL:PROMPTPRINT '(enter n it the system asks you to save any variables: -enter y if the system asks you if you want a masterscope database)) -(IL:CLEANUP) - -; Now new souce and compiles files and corresponding database should have been -; created -(IF (AND (PROBE-FILE '{CORE}NEW-FUNCTION) - (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) - (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) - (SETQ DB-CREATED-MAKEFILE T) - (SETQ DB-CREATED-MAKEFILE NIL)) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) - -; Displaying the database that has been created in a tedit window... -(IL:PROMPTPRINT '(Displaying the database in a tedit window...)) -(PAUSE) -(SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) -(SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE - DATA-WINDOW )) -(SLEEP 4) -(CLOSE DATA-STREAM) -(IL:CLOSEW DATA-WINDOW) - -; Erasing masterscope record for NEW-FUNCTION.... -. ERASE IL:NEW-FUNCTION -(IL:PROMPTPRINT '(. who calls who should now return nil)) -(PAUSE) -. WHO IS CALLED BY IL:NEW-FUNCTION - -; Setting the variable LOADDBFLG to NO will not load the database file... -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(SETQ IL:LOADDBFLG 'IL:NO) -(IL:LOAD '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) - (SETQ DB-NOT-LOADED T) (SETQ DB-NOT-LOADED NIL)) - -; Setting the variable LOADDBFLG to YES will load the database file... -(SETQ IL:LOADDBFLG 'IL:YES) -(IL:LOAD '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) - (SETQ DB-LOADED T) (SETQ DB-LOADED NIL)) - - -; Now delete all the files except for the original file for new-function -(MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) - -CONN {DSK} -(IL:CLRPROMPT) -(SETQ IL:LOADDBFLG 'IL:ASK) -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - -(DO-TEST 'DATABASEFNS-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'DABASEFNS-VARIABLES DB-VARIABLES-FLG) - (PASS-FAIL 'DATABASE-UPDATE DB-UPDATE-FLG) - (PASS-FAIL 'DATABASE-CREATED DB-CREATED-FLG) - (PASS-FAIL 'DATABASE-PROP-RESET DB-FLG-RESET) - (PASS-FAIL 'DATABASE-CREATED-BY-MAKEFILE DB-CREATED-MAKEFILE) - (PASS-FAIL 'LOADDB-FLG-NO DB-NOT-LOADED) - (PASS-FAIL 'LOADDB-FLG-YES DB-LOADED) - (T-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) - -") - (IL:BKSYSBUF DATABASEFNS-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ deleted file mode 100644 index 4de6c1e5..00000000 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ +++ /dev/null @@ -1,187 +0,0 @@ -;; Function To Be Tested: DATABASEFNS (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 18, 1987 -;; -;; Last Update: March 20, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>databasefns.u -;; -;; -;; Syntax: (DUMPDB FILE) & (LOADDB FILE) -;; -;; Function Description: DATABASEFNS is a very small package whose purpose is to make -;; the construction and maintenance of masterscope data bases an essentially automatic -;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. -;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. -;; The user can dump and restore data bases explicitly via the following functions: -;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, -;; so that data base maintenance for FILE will subsequently be automatic. -;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is -;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be -;; thereafter automatic. -;; -;; Argument(s): (SEE Databasefns documentation) -;; -;; Returns: (SEE Databasefns documentation) -;; -;; Constraints/Limitations: The primary emphasis of this testing is the explicit -;; dumpting and restoration of data bases. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>databasefns.report. This test requires -;; DATABASEFNS, TEDIT, and MASTERSCOPE. -;; -;; -;; -(DO-TEST "DATABASEFNS-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DATABASEFNS: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (NOT TEST-ITEM) (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - )) -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) -; Loading databasefns and other required files from {erinyes}library>.... -(PAUSE) -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) - -; Copy the necessary source file (data) to {core} -(IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA -'{CORE}NEW-FUNCTION) -(IL:CNDIR '{CORE}) -(PAUSE) -; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially -; set to ASK -(IF (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK)) - (SETQ DB-VARIABLES-FLG T) - (SETQ DB-VARIABLES-FLG NIL)) - - - -; This part of the test loads the initial data file for masterscope analysis -(IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) -(LOAD '{CORE}NEW-FUNCTION) -(IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) -(IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) - -(SETQ OLD-CALL-LIST *) -(IL:CLRPROMPT) - -; New-function is redefined; it also utilized times function ... -(IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) -(IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) - -(SETQ NEW-CALL-LIST *) -(IF (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES)) - (SETQ DB-UPDATE-FLG T) - (SETQ DB-UPDATE-FLG NIL)) -(IL:DUMPDB '{CORE}NEW-FUNCTION) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) -(IF (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE) - (SETQ DB-CREATED-FLG T) - (SETQ DB-CREATED-FLG NIL)) -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(IL:LOADDB '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) - (SETQ DB-FLG-RESET T) - (SETQ DB-FLG-RESET NIL)) - -; Loading the database file will reset the property database with 'YES values -; and make masterscope database maintenance automatic.. -; Cleanup will do recompilation and generate the updated database -(PAUSE) -(IL:PROMPTPRINT "enter n it the system asks you to save any variables: -enter y if the system asks you if you want a masterscope database") -(IL:CLEANUP) - -; Now new souce and compiles files and corresponding database should have been -; created -(IF (AND (PROBE-FILE '{CORE}NEW-FUNCTION) - (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) - (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) - (SETQ DB-CREATED-MAKEFILE T) - (SETQ DB-CREATED-MAKEFILE NIL)) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) - -; Displaying the database that has been created in a tedit window... -(IL:PROMPTPRINT "Displaying the database in a tedit window...") -(PAUSE) -(SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) -(SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE - DATA-WINDOW )) -(SLEEP 4) -(CLOSE DATA-STREAM) -(IL:CLOSEW DATA-WINDOW) - -; Erasing masterscope record for NEW-FUNCTION.... -(IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) -(IL:PROMPTPRINT ". who calls who should now return nil") -(PAUSE) -(IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) - -; Setting the variable LOADDBFLG to NO will not load the database file... -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(SETQ IL:LOADDBFLG 'IL:NO) -(IL:LOAD '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) - (SETQ DB-NOT-LOADED T) (SETQ DB-NOT-LOADED NIL)) - -; Setting the variable LOADDBFLG to YES will load the database file... -(SETQ IL:LOADDBFLG 'IL:YES) -(IL:LOAD '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) - (SETQ DB-LOADED T) (SETQ DB-LOADED NIL)) - - -; Now delete all the files except for the original file for new-function -(MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) - -(IL:CNDIR '{DSK}) -(IL:CLRPROMPT) -(SETQ IL:LOADDBFLG 'IL:ASK) -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - - - - ) -) -(DO-TEST 'DATABASEFNS-TEST-RESULT - (PROGN - (PASS-FAIL 'DABASEFNS-VARIABLES DB-VARIABLES-FLG) - (PASS-FAIL 'DATABASE-UPDATE DB-UPDATE-FLG) - (PASS-FAIL 'DATABASE-CREATED DB-CREATED-FLG) - (PASS-FAIL 'DATABASE-PROP-RESET DB-FLG-RESET) - (PASS-FAIL 'DATABASE-CREATED-BY-MAKEFILE DB-CREATED-MAKEFILE) - (PASS-FAIL 'LOADDB-FLG-NO DB-NOT-LOADED) - (PASS-FAIL 'LOADDB-FLG-YES DB-LOADED) - (T-FORMAT TOTAL-TEST-TIME) - (IDENTITY T) - ) -) -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ deleted file mode 100644 index 0cd7fc26..00000000 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ +++ /dev/null @@ -1,185 +0,0 @@ -;; Function To Be Tested: DATABASEFNS (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 18, 1987 -;; -;; Last Update: March 20, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>databasefns.u -;; -;; -;; Syntax: (DUMPDB FILE) & (LOADDB FILE) -;; -;; Function Description: DATABASEFNS is a very small package whose purpose is to make -;; the construction and maintenance of masterscope data bases an essentially automatic -;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. -;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. -;; The user can dump and restore data bases explicitly via the following functions: -;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, -;; so that data base maintenance for FILE will subsequently be automatic. -;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is -;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be -;; thereafter automatic. -;; -;; Argument(s): (SEE Databasefns documentation) -;; -;; Returns: (SEE Databasefns documentation) -;; -;; Constraints/Limitations: The primary emphasis of this testing is the explicit -;; dumpting and restoration of data bases. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>databasefns.report. This test requires -;; DATABASEFNS, TEDIT, and MASTERSCOPE. -;; -;; -;; -(DO-TEST "DATABASEFNS-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>DATABASEFNS.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR DATABASEFNS: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: DATABASEFNS TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (NOT TEST-ITEM) (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - )) -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) -; Loading databasefns and other required files from {erinyes}library>.... -(PAUSE) -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) - -; Copy the necessary source file (data) to {core} -(IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA -'{CORE}NEW-FUNCTION) -(IL:CNDIR '{CORE}) -(PAUSE) -; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially -; set to ASK -(IF (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK)) - (SETQ DB-VARIABLES-FLG T) - (SETQ DB-VARIABLES-FLG NIL)) - - - -; This part of the test loads the initial data file for masterscope analysis -(IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) -(LOAD '{CORE}NEW-FUNCTION) -(IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) -(SETQ OLD-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) - -(IL:CLRPROMPT) - -; New-function is redefined; it also utilized times function ... -(IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) -(SETQ NEW-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) - -(IF (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES)) - (SETQ DB-UPDATE-FLG T) - (SETQ DB-UPDATE-FLG NIL)) -(IL:DUMPDB '{CORE}NEW-FUNCTION) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) -(IF (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE) - (SETQ DB-CREATED-FLG T) - (SETQ DB-CREATED-FLG NIL)) -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(IL:LOADDB '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) - (SETQ DB-FLG-RESET T) - (SETQ DB-FLG-RESET NIL)) - -; Loading the database file will reset the property database with 'YES values -; and make masterscope database maintenance automatic.. -; Cleanup will do recompilation and generate the updated database -(PAUSE) -(IL:PROMPTPRINT "enter n it the system asks you to save any variables: -enter y if the system asks you if you want a masterscope database") -(IL:CLEANUP) - -; Now new souce and compiles files and corresponding database should have been -; created -(IF (AND (PROBE-FILE '{CORE}NEW-FUNCTION) - (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) - (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) - (SETQ DB-CREATED-MAKEFILE T) - (SETQ DB-CREATED-MAKEFILE NIL)) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) - -; Displaying the database that has been created in a tedit window... -(IL:PROMPTPRINT "Displaying the database in a tedit window...") -(PAUSE) -(SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) -(SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE - DATA-WINDOW )) -(SLEEP 4) -(CLOSE DATA-STREAM) -(IL:CLOSEW DATA-WINDOW) - -; Erasing masterscope record for NEW-FUNCTION.... -(IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) -(IL:PROMPTPRINT ". who calls who should now return nil") -(PAUSE) -(IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) - -; Setting the variable LOADDBFLG to NO will not load the database file... -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(SETQ IL:LOADDBFLG 'IL:NO) -(IL:LOAD '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) - (SETQ DB-NOT-LOADED T) (SETQ DB-NOT-LOADED NIL)) - -; Setting the variable LOADDBFLG to YES will load the database file... -(SETQ IL:LOADDBFLG 'IL:YES) -(IL:LOAD '{CORE}NEW-FUNCTION) -(IF (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) - (SETQ DB-LOADED T) (SETQ DB-LOADED NIL)) - - -; Now delete all the files except for the original file for new-function -(MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) - -(IL:CNDIR '{DSK}) -(IL:CLRPROMPT) -(SETQ IL:LOADDBFLG 'IL:ASK) -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - - - - ) -) -(DO-TEST 'DATABASEFNS-TEST-RESULT - (PROGN - (PASS-FAIL 'DABASEFNS-VARIABLES DB-VARIABLES-FLG) - (PASS-FAIL 'DATABASE-UPDATE DB-UPDATE-FLG) - (PASS-FAIL 'DATABASE-CREATED DB-CREATED-FLG) - (PASS-FAIL 'DATABASE-PROP-RESET DB-FLG-RESET) - (PASS-FAIL 'DATABASE-CREATED-BY-MAKEFILE DB-CREATED-MAKEFILE) - (PASS-FAIL 'LOADDB-FLG-NO DB-NOT-LOADED) - (PASS-FAIL 'LOADDB-FLG-YES DB-LOADED) - (T-FORMAT TOTAL-TEST-TIME) - (IDENTITY T) - ) -) -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ deleted file mode 100644 index 0bb077cc..00000000 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ +++ /dev/null @@ -1,145 +0,0 @@ -;; Function To Be Tested: DATABASEFNS (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 18, 1987 -;; -;; Last Update: March 20, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>databasefns.u -;; -;; -;; Syntax: (DUMPDB FILE) & (LOADDB FILE) -;; -;; Function Description: DATABASEFNS is a very small package whose purpose is to make -;; the construction and maintenance of masterscope data bases an essentially automatic -;; process. It modifies MAKEFILE, LOAD, and LOADFROM to update database for masterscope. -;; For more info, refer to Lisp Library Modules Manual, Lyric beta release. -;; The user can dump and restore data bases explicitly via the following functions: -;; (DUMPDB file) - Dumps a data base for FILE then sets the DATABASE property to YES, -;; so that data base maintenance for FILE will subsequently be automatic. -;; (LOADDB file) - Loads the file FILE.DATABASE if one exists. After the data base is -;; loaded, the DATABASE property for FILE is set to YES, so that maintenance will be -;; thereafter automatic. -;; -;; Argument(s): (SEE Databasefns documentation) -;; -;; Returns: (SEE Databasefns documentation) -;; -;; Constraints/Limitations: The primary emphasis of this testing is the explicit -;; dumpting and restoration of data bases. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>databasefns.report. This test requires -;; DATABASEFNS, TEDIT, and MASTERSCOPE. -;; -;; -;; -(DO-TEST "DATABASEFNS-TEST-SETUP" - -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - - (SETQ TEST-SUCCEEDED T) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Good one!" - )) - -(SETQ DATABASEFNSW (IL:CREATEW '(100 100 325 90) NIL NIL T)) -; Loading databasefns and other required files from {erinyes}library>.... -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT MASTERSCOPE DATABASEFNS) - -; Copy the necessary source file (data) to {core} -(IL:COPYFILE '{ERIS}ENV>PROGRAM-ANALYSIS>HAND>DATABASEFNS.DATA -'{CORE}NEW-FUNCTION) -(IL:CNDIR '{CORE}) -; This tests to see if the global variable LOADDBFLG and SAVEDBFLG are initially -; set to ASK -(PASS-FAIL "DATABASEFNS VARIABLES" (AND (EQ IL:LOADDBFLG 'IL:ASK) (EQ IL:SAVEDBFLG 'IL:ASK))) - - -; This part of the test loads the initial data file for masterscope analysis -(IL:PROMPTPRINT "Please enter Y when masterscope asks for loading") -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES) -(LOAD '{CORE}NEW-FUNCTION) -(IL:MASTERSCOPE '(ANALYZE FUNCTIONS ON {CORE}NEW-FUNCTION)) -(SETQ OLD-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) - -(IL:CLRPROMPT) - -; New-function is redefined; it also utilized times function ... -(IL:DEFINEQ (IL:NEW-FUNCTION (X Y) (IL:PLUS (IL:PLUS X Y) (IL:TIMES X Y)))) -(SETQ NEW-CALL-LIST (IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION))) - -(PASS-FAIL "DATABASE UPDATE" (EQUAL (SET-DIFFERENCE NEW-CALL-LIST OLD-CALL-LIST) '(IL:TIMES))) - -(IL:DUMPDB '{CORE}NEW-FUNCTION) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) -(PASS-FAIL "DATABASE CREATED" (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE)) - -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(IL:LOADDB '{CORE}NEW-FUNCTION) -(PASS-FAIL "DATABASE PROP RESET" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES)) - -; Loading the database file will reset the property database with 'YES values -; and make masterscope database maintenance automatic.. -(IL:PROMPTPRINT "enter n it the system asks you to save any variables: -enter y if the system asks you if you want a masterscope database") -(IL:CLEANUP) - -; Now new souce and compiles files and corresponding database should have been -; created -(PASS-FAIL "DATABASE CREATED BY MAKEFILE" (AND (PROBE-FILE '{CORE}NEW-FUNCTION) - (PROBE-FILE '{CORE}NEW-FUNCTION.DFASL) - (PROBE-FILE '{CORE}NEW-FUNCTION.DATABASE))) -(SETF (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NO) - -; Displaying the database that has been created in a tedit window... -(IL:PROMPTPRINT "Displaying the database in a tedit window...") -(SETQ DATA-WINDOW (IL:CREATEW '(750 50 400 500) 'DATABASE-WINDOW)) -(SETQ DATA-STREAM (IL:OPENTEXTSTREAM '{CORE}NEW-FUNCTION.DATABASE - DATA-WINDOW )) -(SLEEP 4) -(CLOSE DATA-STREAM) -(IL:CLOSEW DATA-WINDOW) - -; Erasing masterscope record for NEW-FUNCTION.... -(IL:MASTERSCOPE '(ERASE IL:NEW-FUNCTION)) -(IL:PROMPTPRINT ". who calls who should now return nil") -(IL:MASTERSCOPE '(WHO IS CALLED BY IL:NEW-FUNCTION)) - -; Setting the variable LOADDBFLG to NO will not load the database file... -(IL:REMPROP 'IL:NEW-FUNCTION 'IL:DATABASE) -(SETQ IL:LOADDBFLG 'IL:NO) -(IL:LOAD '{CORE}NEW-FUNCTION) -(PASS-FAIL "LOADDBFLG SET TO NO" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:NONE) ) - -; Setting the variable LOADDBFLG to YES will load the database file... -(SETQ IL:LOADDBFLG 'IL:YES) -(IL:LOAD '{CORE}NEW-FUNCTION) -(PASS-FAIL "LOADDBFLG SET TO YES" (EQ (GET 'IL:NEW-FUNCTION 'IL:DATABASE) 'IL:YES)) - - -; Now delete all the files except for the original file for new-function -(MAPCAR #'DELETE-FILE (IL:DIRECTORY '{CORE})) - -(IL:CNDIR '{DSK}) -(IL:CLRPROMPT) -(SETQ IL:LOADDBFLG 'IL:ASK) - -TEST-SUCCEEDED -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~1~ b/internal/test/env/program-analysis/hand/INSPECT.U.~1~ deleted file mode 100644 index 802291f7..00000000 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~1~ +++ /dev/null @@ -1,265 +0,0 @@ -;; Function To Be Tested: INSPECTOR (Program Analysis) -;; -;; Source: IRM VOLUME 3 (Lyric Beta Release 2) -;; Section 26. User Input/Output Packages -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: March 21, 1987 -;; -;; Last Update: March 30, 1987 -;; -;; Filed As: {ERIS}test>program-analysis>inspector.u -;; -;; -;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function -;; -;; Function Description: The inspector provides a display-oriented and window-based -;; facility for looking at and changing arbitrary Interlisp-D data structures. -;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. -;; The inspector displays the field names and values of an arbitrary object in -;; a window that allows setting of the properties and further inpection of the values. -;; This latter feature makes it possible to "walk" around all of the data structures -;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 -;; pages 26.1 through 26.9 -;; -;; Argument(s): The primary function for inspector is INSPECT whose arguments are -;; described here. -;; OBJECT: object to be inspected -;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be -;; used to determine its property names in the inspect window. -;; WHERE: speccifies the location of the inspect window. If NIL, the user will be -;; prompted for location -;; -;; Returns: Inspection Window -;; -;; Constraints/Limitations: The primary emphasis of this testing will be focused -;; on the function INSPECT. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>inspect.report. This test requires -;; TEDIT package. -;; -;; -;; -(DO-TEST "INSPECTOR-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>INSPECT.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR INSPECTOR: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) - (DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) - (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) - (SETQ INSPECTOR "INSPECTOR") - (SETQ INSPECTCODE-TITLE "CODE FOR COS") -; Creating various objects to be inspected.... - (PAUSE) - (SETQ INSPECT-ITEM-LIST - (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array - (gentemp) ; atom - (1- most-negative-fixnum) ; bignum - 0 ; bit - '#*1001 ; bit-vector - #\backspace ; character - 'common ; common - #'cons ; compiled-function - #c( 6/7 3.00) ; complex - '( a b c . d) ; cons - 5.00 ; double-float - (random most-positive-fixnum) ; fixnum - (coerce most-negative-fixnum 'float) ; float - #'(lambda nil nil) ; function - (setq hash - (make-hash-table 7)) ; hash-table - 4761 ; integer - :mot-de-clef ; keyword - '(a b c d) ; list - 37e5 ; long-float - (= 1 2) ; null - 3.1415926535897932384d0 ; number - (car(list-all-packages)) ; package - (pathname) ; pathname - ;*random-state* ; random state - inspecting this hangs - 27/60 ; ratio - 5 ; rational - (copy-readtable) ; readtable - '(A 'B "C") ; sequence -;; Breaks; see AR 6494 - (coerce 6 'short-float) ; short-float - (make-array '(2 2)) ; simple-array - '#*1001 ; simple-bit-vector - "twine" ; simple-string - (make-array 50 :initial-element 0) ; simple-vector - .001 ; single-float - #\* ; standard-char - (make-synonym-stream) ; stream - (make-array 20 :element-type 'string-char :initial-element #\0) ; string - #\. ; string-char - (gentemp) ; symbol - (not (equal 2 3)) ; t - '#( 5 4 3 2 1) ; vector - IL:promptwindow ; window - )) - (SETF (GETHASH 'COLOR HASH) 'BROWN - (GETHASH 'NAME HASH) 'FRED - (GETHASH 'AGE HASH) 29 - (GETHASH 'PHONE HASH) '777-6551 - (GETHASH 'HEIGHT HASH) '6-FEET - (GETHASH 'WEIGHT HASH) '170) - (SETQ SPACE ": ") - (SETQ MESS0 "In this part of test, various lisp objects will be inspected. -Numbers except for complex and fraction types, and characters -are not inspectable and an appropriate message will be printed. -If a inspect menu pops up, select the item INSPECT -To create an inspector window, simply click the left mouse button -Please respond with y or n after an inspector window is created. ") - (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") - (SETQ MESS2 "Please indicate a position for inspecting -the compiled function COS with left mouse button") - (SETQ MESS3 "Is the inspector window displayed for -the compiled function COS (Yes or NO?)") - (SETQ MESS4 "Is the inspection information displayed -in the specified inspector window?") - (SETQ MESS5 "The inspector window should have been created -for inspecting the compiled function COS") - (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) -Please run this test after this test is completed by entering -(INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. -If it still fails the test, please update the log file accordingly: -{eris}test>program-analysis>inspect.report.") - (SETQ MESS7 "Are you ready to start testing(y or n)? ") - (SETQ PROMPT-MESS "Item being inspected: ") - (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") - -; Inspector test string... - (SETQ INSPECTOR-COMMAND-STRING -"; Load TEDIT if not already loaded.... -(IL:PAGEHEIGHT 0) -(IL:LOAD? '{ERINYES}LIBRARY>TEDIT.LCOM 'IL:SYSLOAD) - -; Check the intial value of inspector variables... -(IF (AND (= IL:MAXINSPECTCDRLEVEL 50) - (= IL:MAXINSPECTARRAYLEVEL 300) - (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) - (EQ IL:INSPECTALLFIELDSFLG T)) - (SETQ VARIABLES-SET-CORRECT T) - (SETQ VARIABLES-SET-CORRECT NIL)) - -; Create various objects to be inspected... -; Trying to inspect random state object will hang the system (never returns) -; A number or character cannot be inspected and an appropriate message should be -; generated for these objects... -(SETQ INSPECT-ITEM-NAMES - '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER -COMMON COMPILED-FUNCTION COMPLEX CONS -DOUBLE-FLOAT FIXNUM FLOAT FUNCTION -HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT -NULL NUMBER PACKAGE PATHNAME -RATIO RATIONAL READTABLE SEQUENCE -SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR -SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT -STANDARD-CHAR STREAM STRING STRING-CHAR -SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) - -(IL:PROMPTPRINT MESS0) -(PAUSE) -(IL:ASKUSER 15 'IL:Y MESS7) -(SETQ INSPECT-WINDOWS NIL) -(IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO - (PROGN (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) - (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) - (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) - (PAUSE) - (INSPECT ITEM) - (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) - (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y - (FORMAT T MESS1 POP-ITEM POP-ITEM))) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) T) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) NIL)) - (IL:CLEARW) - (SLEEP 1))) - - -; Inspecting the compiled code of the function... -(PAUSE) -(IL:PROMPTPRINT MESS5) -(IL:INSPECTCODE 'COS) -(IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS3)) - (SETQ INSPECTCODE-FLG T) - (SETQ INSPECTCODE-FLG NIL)) - -(SLEEP 2) -; Closing the inspector window... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) - -; Testing to see if an object could be displayed in a specified window... -(PAUSE) -(SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) -(IL:OPENW INSPECTORW) -(INSPECT INSPECT-ARRAY NIL INSPECTORW) -(IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS4)) - (SETQ INSPECT-WHERE-FLG T) - (SETQ INSPECT-WHERE-FLG NIL)) - -; Delete all inspect windows that have been created... -(PAUSE) -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN - (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) - (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR :start1 0 :end1 9) - (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR - :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) - :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) - ) -) - -; Test for AR8203 -(IL:PROMPTPRINT MESS6) -(PAUSE) - -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - -(DO-TEST 'INSPECTOR-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES VARIABLES-SET-CORRECT) - (IL:FOR X IL:IN ITEM-NAMES IL:DO - (PROGN - (SETQ PF-ITEM (POP ITEM-NAMES)) - (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG))))) - (PASS-FAIL 'INSPECTCODE INSPECTCODE-FLG) - (PASS-FAIL 'INSPECT-WHERE INSPECT-WHERE-FLG) - (T-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) - -") - (IL:BKSYSBUF INSPECTOR-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~2~ b/internal/test/env/program-analysis/hand/INSPECT.U.~2~ deleted file mode 100644 index ed5aaf0c..00000000 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~2~ +++ /dev/null @@ -1,263 +0,0 @@ -;; Function To Be Tested: INSPECTOR (Program Analysis) -;; -;; Source: IRM VOLUME 3 (Lyric Beta Release 2) -;; Section 26. User Input/Output Packages -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: March 21, 1987 -;; -;; Last Update: March 30, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>inspector.u -;; -;; -;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function -;; -;; Function Description: The inspector provides a display-oriented and window-based -;; facility for looking at and changing arbitrary Interlisp-D data structures. -;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. -;; The inspector displays the field names and values of an arbitrary object in -;; a window that allows setting of the properties and further inpection of the values. -;; This latter feature makes it possible to "walk" around all of the data structures -;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 -;; pages 26.1 through 26.9 -;; -;; Argument(s): The primary function for inspector is INSPECT whose arguments are -;; described here. -;; OBJECT: object to be inspected -;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be -;; used to determine its property names in the inspect window. -;; WHERE: speccifies the location of the inspect window. If NIL, the user will be -;; prompted for location -;; -;; Returns: Inspection Window -;; -;; Constraints/Limitations: The primary emphasis of this testing will be focused -;; on the function INSPECT. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>inspect.report. This test requires -;; TEDIT package. -;; -;; -;; -(DO-TEST "INSPECTOR-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>INSPECT.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR INSPECTOR: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) - (DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) - (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) - (SETQ INSPECTOR "INSPECTOR") - (SETQ INSPECTCODE-TITLE "CODE FOR COS") -; Creating various objects to be inspected.... - (PAUSE) - (SETQ INSPECT-ITEM-LIST - (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array - (gentemp) ; atom - (1- most-negative-fixnum) ; bignum - 0 ; bit - '#*1001 ; bit-vector - #\backspace ; character - 'common ; common - #'cons ; compiled-function - #c( 6/7 3.00) ; complex - '( a b c . d) ; cons - 5.00 ; double-float - (random most-positive-fixnum) ; fixnum - (coerce most-negative-fixnum 'float) ; float - #'(lambda nil nil) ; function - (setq hash - (make-hash-table 7)) ; hash-table - 4761 ; integer - :mot-de-clef ; keyword - '(a b c d) ; list - 37e5 ; long-float - (= 1 2) ; null - 3.1415926535897932384d0 ; number - (car(list-all-packages)) ; package - (pathname) ; pathname - ;*random-state* ; random state - inspecting this hangs - 27/60 ; ratio - 5 ; rational - (copy-readtable) ; readtable - '(A 'B "C") ; sequence -;; Breaks; see AR 6494 - (coerce 6 'short-float) ; short-float - (make-array '(2 2)) ; simple-array - '#*1001 ; simple-bit-vector - "twine" ; simple-string - (make-array 50 :initial-element 0) ; simple-vector - .001 ; single-float - #\* ; standard-char - (make-synonym-stream) ; stream - (make-array 20 :element-type 'string-char :initial-element #\0) ; string - #\. ; string-char - (gentemp) ; symbol - (not (equal 2 3)) ; t - '#( 5 4 3 2 1) ; vector - IL:promptwindow ; window - )) - (SETF (GETHASH 'COLOR HASH) 'BROWN - (GETHASH 'NAME HASH) 'FRED - (GETHASH 'AGE HASH) 29 - (GETHASH 'PHONE HASH) '777-6551 - (GETHASH 'HEIGHT HASH) '6-FEET - (GETHASH 'WEIGHT HASH) '170) - (SETQ SPACE ": ") - (SETQ MESS0 "In this part of test, various lisp objects will be inspected. -Numbers except for complex and fraction types, and characters -are not inspectable and an appropriate message will be printed. -If a inspect menu pops up, select the item INSPECT -To create an inspector window, simply click the left mouse button -Please respond with y or n after an inspector window is created. ") - (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") - (SETQ MESS2 "Please indicate a position for inspecting -the compiled function COS with left mouse button") - (SETQ MESS3 "Is the inspector window displayed for -the compiled function COS (Yes or NO?)") - (SETQ MESS4 "Is the inspection information displayed -in the specified inspector window?") - (SETQ MESS5 "The inspector window should have been created -for inspecting the compiled function COS") - (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) -Please run this test after this test is completed by entering -(INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. -If it still fails the test, please update the log file accordingly: -{eris}test>program-analysis>inspect.report.") - (SETQ MESS7 "Are you ready to start testing(y or n)? ") - (SETQ PROMPT-MESS "Item being inspected: ") - (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") - -; Load TEDIT if not already loaded.... -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT) - -; Check the intial value of inspector variables... -(IF (AND (= IL:MAXINSPECTCDRLEVEL 50) - (= IL:MAXINSPECTARRAYLEVEL 300) - (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) - (EQ IL:INSPECTALLFIELDSFLG T)) - (SETQ VARIABLES-SET-CORRECT T) - (SETQ VARIABLES-SET-CORRECT NIL)) - -; Create various objects to be inspected... -; Trying to inspect random state object will hang the system (never returns) -; A number or character cannot be inspected and an appropriate message should be -; generated for these objects... -(SETQ INSPECT-ITEM-NAMES - '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER -COMMON COMPILED-FUNCTION COMPLEX CONS -DOUBLE-FLOAT FIXNUM FLOAT FUNCTION -HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT -NULL NUMBER PACKAGE PATHNAME -RATIO RATIONAL READTABLE SEQUENCE -SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR -SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT -STANDARD-CHAR STREAM STRING STRING-CHAR -SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) - -(IL:PROMPTPRINT MESS0) -(PAUSE) -(IL:ASKUSER 15 'IL:Y MESS7) -(SETQ INSPECT-WINDOWS NIL) -(IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO - (PROGN (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) - (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) - (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) - (PAUSE) - (INSPECT ITEM) - (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) - (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y - (FORMAT T MESS1 POP-ITEM POP-ITEM))) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) T) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) NIL)) - (IL:CLEARW) - (SLEEP 1))) - - -; Inspecting the compiled code of the function... -(PAUSE) -(IL:PROMPTPRINT MESS5) -(IL:INSPECTCODE 'COS) -(IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS3)) - (SETQ INSPECTCODE-FLG T) - (SETQ INSPECTCODE-FLG NIL)) - -(SLEEP 2) -; Closing the inspector window... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) - -; Testing to see if an object could be displayed in a specified window... -(PAUSE) -(SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) -(IL:OPENW INSPECTORW) -(INSPECT INSPECT-ARRAY NIL INSPECTORW) -(IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS4)) - (SETQ INSPECT-WHERE-FLG T) - (SETQ INSPECT-WHERE-FLG NIL)) - -; Delete all inspect windows that have been created... -(PAUSE) -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN - (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) - (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR :start1 0 :end1 9) - (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR - :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) - :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) - ) -) - -; Test for AR8203 -(IL:PROMPTPRINT MESS6) -(PAUSE) - -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - - - - ) -) -(DO-TEST 'INSPECTOR-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES VARIABLES-SET-CORRECT) - (IL:FOR X IL:IN ITEM-NAMES IL:DO - (PROGN - (SETQ PF-ITEM (POP ITEM-NAMES)) - (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG))))) - (PASS-FAIL 'INSPECTCODE INSPECTCODE-FLG) - (PASS-FAIL 'INSPECT-WHERE INSPECT-WHERE-FLG) - (T-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~3~ b/internal/test/env/program-analysis/hand/INSPECT.U.~3~ deleted file mode 100644 index 83e3456f..00000000 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~3~ +++ /dev/null @@ -1,261 +0,0 @@ -;; Function To Be Tested: INSPECTOR (Program Analysis) -;; -;; Source: IRM VOLUME 3 (Lyric Beta Release 2) -;; Section 26. User Input/Output Packages -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: March 21, 1987 -;; -;; Last Update: March 30, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>inspector.u -;; -;; -;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function -;; -;; Function Description: The inspector provides a display-oriented and window-based -;; facility for looking at and changing arbitrary Interlisp-D data structures. -;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. -;; The inspector displays the field names and values of an arbitrary object in -;; a window that allows setting of the properties and further inpection of the values. -;; This latter feature makes it possible to "walk" around all of the data structures -;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 -;; pages 26.1 through 26.9 -;; -;; Argument(s): The primary function for inspector is INSPECT whose arguments are -;; described here. -;; OBJECT: object to be inspected -;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be -;; used to determine its property names in the inspect window. -;; WHERE: speccifies the location of the inspect window. If NIL, the user will be -;; prompted for location -;; -;; Returns: Inspection Window -;; -;; Constraints/Limitations: The primary emphasis of this testing will be focused -;; on the function INSPECT. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>inspect.report. This test requires -;; TEDIT package. -;; -;; -;; -(DO-TEST "INSPECTOR-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>INSPECT.REPORT") - (DEFUN T-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR INSPECTOR: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: INSPECTOR TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (NOT TEST-ITEM) (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - )) - (DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) - (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) - (SETQ INSPECTOR "INSPECTOR") - (SETQ INSPECTCODE-TITLE "CODE FOR COS") -; Creating various objects to be inspected.... - (PAUSE) - (SETQ INSPECT-ITEM-LIST - (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array - (gentemp) ; atom - (1- most-negative-fixnum) ; bignum - 0 ; bit - '#*1001 ; bit-vector - #\backspace ; character - 'common ; common - #'cons ; compiled-function - #c( 6/7 3.00) ; complex - '( a b c . d) ; cons - 5.00 ; double-float - (random most-positive-fixnum) ; fixnum - (coerce most-negative-fixnum 'float) ; float - #'(lambda nil nil) ; function - (setq hash - (make-hash-table 7)) ; hash-table - 4761 ; integer - :mot-de-clef ; keyword - '(a b c d) ; list - 37e5 ; long-float - (= 1 2) ; null - 3.1415926535897932384d0 ; number - (car(list-all-packages)) ; package - (pathname) ; pathname - ;*random-state* ; random state - inspecting this hangs - 27/60 ; ratio - 5 ; rational - (copy-readtable) ; readtable - '(A 'B "C") ; sequence -;; Breaks; see AR 6494 - (coerce 6 'short-float) ; short-float - (make-array '(2 2)) ; simple-array - '#*1001 ; simple-bit-vector - "twine" ; simple-string - (make-array 50 :initial-element 0) ; simple-vector - .001 ; single-float - #\* ; standard-char - (make-synonym-stream) ; stream - (make-array 20 :element-type 'string-char :initial-element #\0) ; string - #\. ; string-char - (gentemp) ; symbol - (not (equal 2 3)) ; t - '#( 5 4 3 2 1) ; vector - IL:promptwindow ; window - )) - (SETF (GETHASH 'COLOR HASH) 'BROWN - (GETHASH 'NAME HASH) 'FRED - (GETHASH 'AGE HASH) 29 - (GETHASH 'PHONE HASH) '777-6551 - (GETHASH 'HEIGHT HASH) '6-FEET - (GETHASH 'WEIGHT HASH) '170) - (SETQ SPACE ": ") - (SETQ MESS0 "In this part of test, various lisp objects will be inspected. -Numbers except for complex and fraction types, and characters -are not inspectable and an appropriate message will be printed. -If a inspect menu pops up, select the item INSPECT -To create an inspector window, simply click the left mouse button -Please respond with y or n after an inspector window is created. ") - (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") - (SETQ MESS2 "Please indicate a position for inspecting -the compiled function COS with left mouse button") - (SETQ MESS3 "Is the inspector window displayed for -the compiled function COS (Yes or NO?)") - (SETQ MESS4 "Is the inspection information displayed -in the specified inspector window?") - (SETQ MESS5 "The inspector window should have been created -for inspecting the compiled function COS") - (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) -Please run this test after this test is completed by entering -(INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. -If it still fails the test, please update the log file accordingly: -{eris}test>program-analysis>inspect.report.") - (SETQ MESS7 "Are you ready to start testing(y or n)? ") - (SETQ PROMPT-MESS "Item being inspected: ") - (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") - -; Load TEDIT if not already loaded.... -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT) - -; Check the intial value of inspector variables... -(IF (AND (= IL:MAXINSPECTCDRLEVEL 50) - (= IL:MAXINSPECTARRAYLEVEL 300) - (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) - (EQ IL:INSPECTALLFIELDSFLG T)) - (SETQ VARIABLES-SET-CORRECT T) - (SETQ VARIABLES-SET-CORRECT NIL)) - -; Create various objects to be inspected... -; Trying to inspect random state object will hang the system (never returns) -; A number or character cannot be inspected and an appropriate message should be -; generated for these objects... -(SETQ INSPECT-ITEM-NAMES - '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER -COMMON COMPILED-FUNCTION COMPLEX CONS -DOUBLE-FLOAT FIXNUM FLOAT FUNCTION -HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT -NULL NUMBER PACKAGE PATHNAME -RATIO RATIONAL READTABLE SEQUENCE -SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR -SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT -STANDARD-CHAR STREAM STRING STRING-CHAR -SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) - -(IL:PROMPTPRINT MESS0) -(PAUSE) -(IL:ASKUSER 15 'IL:Y MESS7) -(SETQ INSPECT-WINDOWS NIL) -(IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO - (PROGN (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) - (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) - (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) - (PAUSE) - (INSPECT ITEM) - (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) - (IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y - (FORMAT T MESS1 POP-ITEM POP-ITEM))) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) T) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) NIL)) - (IL:CLEARW) - (SLEEP 1))) - - -; Inspecting the compiled code of the function... -(PAUSE) -(IL:PROMPTPRINT MESS5) -(IL:INSPECTCODE 'COS) -(IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS3)) - (SETQ INSPECTCODE-FLG T) - (SETQ INSPECTCODE-FLG NIL)) - -(SLEEP 2) -; Closing the inspector window... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) - -; Testing to see if an object could be displayed in a specified window... -(PAUSE) -(SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) -(IL:OPENW INSPECTORW) -(INSPECT INSPECT-ARRAY NIL INSPECTORW) -(IF (EQ 'IL:Y (IL:ASKUSER IL:DWIMWAIT 'IL:Y MESS4)) - (SETQ INSPECT-WHERE-FLG T) - (SETQ INSPECT-WHERE-FLG NIL)) - -; Delete all inspect windows that have been created... -(PAUSE) -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN - (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) - (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR :start1 0 :end1 9) - (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR - :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) - :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) - ) -) - -; Test for AR8203 -(IL:PROMPTPRINT MESS6) -(PAUSE) - -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - - - - ) -) -(DO-TEST 'INSPECTOR-TEST-RESULT - (PROGN - (PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES VARIABLES-SET-CORRECT) - (IL:FOR X IL:IN ITEM-NAMES IL:DO - (PROGN - (SETQ PF-ITEM (POP ITEM-NAMES)) - (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG))))) - (PASS-FAIL 'INSPECTCODE INSPECTCODE-FLG) - (PASS-FAIL 'INSPECT-WHERE INSPECT-WHERE-FLG) - (T-FORMAT TOTAL-TEST-TIME) - (IDENTITY T) - ) -) -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~4~ b/internal/test/env/program-analysis/hand/INSPECT.U.~4~ deleted file mode 100644 index 4013941b..00000000 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~4~ +++ /dev/null @@ -1,228 +0,0 @@ -;; Function To Be Tested: INSPECTOR (Program Analysis) -;; -;; Source: IRM VOLUME 3 (Lyric Beta Release 2) -;; Section 26. User Input/Output Packages -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: March 21, 1987 -;; -;; Last Update: March 30, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>inspector.u -;; -;; -;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function -;; -;; Function Description: The inspector provides a display-oriented and window-based -;; facility for looking at and changing arbitrary Interlisp-D data structures. -;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. -;; The inspector displays the field names and values of an arbitrary object in -;; a window that allows setting of the properties and further inpection of the values. -;; This latter feature makes it possible to "walk" around all of the data structures -;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 -;; pages 26.1 through 26.9 -;; -;; Argument(s): The primary function for inspector is INSPECT whose arguments are -;; described here. -;; OBJECT: object to be inspected -;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be -;; used to determine its property names in the inspect window. -;; WHERE: speccifies the location of the inspect window. If NIL, the user will be -;; prompted for location -;; -;; Returns: Inspection Window -;; -;; Constraints/Limitations: The primary emphasis of this testing will be focused -;; on the function INSPECT. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>inspect.report. This test requires -;; TEDIT package. -;; -;; -;; -(DO-TEST "INSPECTOR-TEST-SETUP" - - (SETQ TEST-SUCCEEDED T) - -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Woo! It worked!" - )) - - (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) - (SETQ INSPECTOR "INSPECTOR") - (SETQ INSPECTCODE-TITLE "CODE FOR COS") - -; Creating various objects to be inspected.... - (SETQ INSPECT-ITEM-LIST - (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array - (gentemp) ; atom - (1- most-negative-fixnum) ; bignum - 0 ; bit - '#*1001 ; bit-vector - #\backspace ; character - 'common ; common - #'cons ; compiled-function - #c( 6/7 3.00) ; complex - '( a b c . d) ; cons - 5.00 ; double-float - (random most-positive-fixnum) ; fixnum - (coerce most-negative-fixnum 'float) ; float - #'(lambda nil nil) ; function - (setq hash - (make-hash-table 7)) ; hash-table - 4761 ; integer - :mot-de-clef ; keyword - '(a b c d) ; list - 37e5 ; long-float - (= 1 2) ; null - 3.1415926535897932384d0 ; number - (car(list-all-packages)) ; package - (pathname) ; pathname - ;*random-state* ; random state - inspecting this hangs - 27/60 ; ratio - 5 ; rational - (copy-readtable) ; readtable - '(A 'B "C") ; sequence -;; Breaks; see AR 6494 - (coerce 6 'short-float) ; short-float - (make-array '(2 2)) ; simple-array - '#*1001 ; simple-bit-vector - "twine" ; simple-string - (make-array 50 :initial-element 0) ; simple-vector - .001 ; single-float - #\* ; standard-char - (make-synonym-stream) ; stream - (make-array 20 :element-type 'string-char :initial-element #\0) ; string - #\. ; string-char - (gentemp) ; symbol - (not (equal 2 3)) ; t - '#( 5 4 3 2 1) ; vector - IL:promptwindow ; window - )) - (SETF (GETHASH 'COLOR HASH) 'BROWN - (GETHASH 'NAME HASH) 'FRED - (GETHASH 'AGE HASH) 29 - (GETHASH 'PHONE HASH) '777-6551 - (GETHASH 'HEIGHT HASH) '6-FEET - (GETHASH 'WEIGHT HASH) '170) - (SETQ SPACE ": ") - (SETQ MESS0 "In this part of test, various lisp objects will be inspected. -Numbers except for complex and fraction types, and characters -are not inspectable and an appropriate message will be printed. -If a inspect menu pops up, select the item INSPECT -To create an inspector window, simply click the left mouse button -Please respond with y or n after an inspector window is created. ") - (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") - (SETQ MESS2 "Please indicate a position for inspecting -the compiled function COS with left mouse button") - (SETQ MESS3 "Is the inspector window displayed for -the compiled function COS (Yes or NO?)") - (SETQ MESS4 "Is the inspection information displayed -in the specified inspector window?") - (SETQ MESS5 "The inspector window should have been created -for inspecting the compiled function COS") - (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) -Please run this test after this test is completed by entering -(INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. -If it still fails the test, please update the log file accordingly: -{eris}test>program-analysis>inspect.report.") - (SETQ MESS7 "Are you ready to start testing(y or n)? ") - (SETQ PROMPT-MESS "Item being inspected: ") - (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") - -; Load TEDIT if not already loaded.... -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT) - -; Check the intial value of inspector variables... -(PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES (AND (= IL:MAXINSPECTCDRLEVEL 50) - (= IL:MAXINSPECTARRAYLEVEL 300) - (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) - (EQ IL:INSPECTALLFIELDSFLG T))) - -; Create various objects to be inspected... -; Trying to inspect random state object will hang the system (never returns) -; A number or character cannot be inspected and an appropriate message should be -; generated for these objects... -(SETQ INSPECT-ITEM-NAMES - '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER -COMMON COMPILED-FUNCTION COMPLEX CONS -DOUBLE-FLOAT FIXNUM FLOAT FUNCTION -HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT -NULL NUMBER PACKAGE PATHNAME -RATIO RATIONAL READTABLE SEQUENCE -SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR -SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT -STANDARD-CHAR STREAM STRING STRING-CHAR -SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES)) - - - -(Y-OR-N-P MESS7) -(SETQ INSPECT-WINDOWS NIL) -(IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO - (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) - (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) - (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) - (INSPECT ITEM) - (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) - (Y-OR-N-P (FORMAT T MESS1 POP-ITEM POP-ITEM))) - ) - -(IL:FOR X IL:IN ITEM-NAMES IL:DO - (SETQ PF-ITEM (POP ITEM-NAMES)) - (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG)))) - - -; Inspecting the compiled code of the function... -(IL:PROMPTPRINT MESS5) -(IL:INSPECTCODE 'COS) -(PASS-FAIL 'INSPECTCODE (Y-OR-N-P MESS3)) - -; Closing the inspector window... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) - -; Testing to see if an object could be displayed in a specified window... -(SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) -(IL:OPENW INSPECTORW) -(INSPECT INSPECT-ARRAY NIL INSPECTORW) -(PASS-FAIL 'INSPECT-WHERE (Y-OR-N-P MESS4)) - -; Delete all inspect windows that have been created... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN - (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) - (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR :start1 0 :end1 9) - (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR - :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) - :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) - ) -) - -; Test for AR8203 -(IL:PROMPTPRINT MESS6) - - - -TEST-SUCCEEDED -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~5~ b/internal/test/env/program-analysis/hand/INSPECT.U.~5~ deleted file mode 100644 index 47b1aefc..00000000 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~5~ +++ /dev/null @@ -1,228 +0,0 @@ -;; Function To Be Tested: INSPECTOR (Program Analysis) -;; -;; Source: IRM VOLUME 3 (Lyric Beta Release 2) -;; Section 26. User Input/Output Packages -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: March 21, 1987 -;; -;; Last Update: March 30, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>inspector.u -;; -;; -;; Syntax: (INSPECT OBJECT ASTYPE WHERE) - primary inspector function -;; -;; Function Description: The inspector provides a display-oriented and window-based -;; facility for looking at and changing arbitrary Interlisp-D data structures. -;; The inspector can be used to inspect all ser datatypes and many sysem datatypes. -;; The inspector displays the field names and values of an arbitrary object in -;; a window that allows setting of the properties and further inpection of the values. -;; This latter feature makes it possible to "walk" around all of the data structures -;; in the system at the touch of a buttton. For more information, refer to IRM, vol 2 -;; pages 26.1 through 26.9 -;; -;; Argument(s): The primary function for inspector is INSPECT whose arguments are -;; described here. -;; OBJECT: object to be inspected -;; ASTYPE: Record type of OBJECT. If ASTYPE is NIL, the data type of OJECT will be -;; used to determine its property names in the inspect window. -;; WHERE: speccifies the location of the inspect window. If NIL, the user will be -;; prompted for location -;; -;; Returns: Inspection Window -;; -;; Constraints/Limitations: The primary emphasis of this testing will be focused -;; on the function INSPECT. Instructions will be given in the prompt -;; window for the user action to be taken during testing and appropriate messages -;; will be displayed to explain each test process. Test result is logged on -;; {eris}test>program-analysis>inspect.report. This test requires -;; TEDIT package. -;; -;; -;; -(DO-TEST "INSPECTOR-TEST-SETUP" - - (SETQ TEST-SUCCEEDED T) - -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Woo! It worked!" - )) - - (SETQ INSPECTORW (IL:CREATEW '(100 100 325 90) "TEST WINDOW FOR INSPECTION" NIL T)) - (SETQ INSPECTOR "INSPECTOR") - (SETQ INSPECTCODE-TITLE "CODE FOR COS") - -; Creating various objects to be inspected.... - (SETQ INSPECT-ITEM-LIST - (LIST (make-array '(3 3) :displaced-to (make-array '(4 3))) ; array - (gentemp) ; atom - (1- most-negative-fixnum) ; bignum - 0 ; bit - '#*1001 ; bit-vector - #\backspace ; character - 'common ; common - #'cons ; compiled-function - #c( 6/7 3.00) ; complex - '( a b c . d) ; cons - 5.00 ; double-float - (random most-positive-fixnum) ; fixnum - (coerce most-negative-fixnum 'float) ; float - #'(lambda nil nil) ; function - (setq hash - (make-hash-table 7)) ; hash-table - 4761 ; integer - :mot-de-clef ; keyword - '(a b c d) ; list - 37e5 ; long-float - (= 1 2) ; null - 3.1415926535897932384d0 ; number - (car(list-all-packages)) ; package - (pathname) ; pathname - ;*random-state* ; random state - inspecting this hangs - 27/60 ; ratio - 5 ; rational - (copy-readtable) ; readtable - '(A 'B "C") ; sequence -;; Breaks; see AR 6494 - (coerce 6 'short-float) ; short-float - (make-array '(2 2)) ; simple-array - '#*1001 ; simple-bit-vector - "twine" ; simple-string - (make-array 50 :initial-element 0) ; simple-vector - .001 ; single-float - #\* ; standard-char - (make-synonym-stream) ; stream - (make-array 20 :element-type 'string-char :initial-element #\0) ; string - #\. ; string-char - (gentemp) ; symbol - (not (equal 2 3)) ; t - '#( 5 4 3 2 1) ; vector - IL:promptwindow ; window - )) - (SETF (GETHASH 'COLOR HASH) 'BROWN - (GETHASH 'NAME HASH) 'FRED - (GETHASH 'AGE HASH) 29 - (GETHASH 'PHONE HASH) '777-6551 - (GETHASH 'HEIGHT HASH) '6-FEET - (GETHASH 'WEIGHT HASH) '170) - (SETQ SPACE ": ") - (SETQ MESS0 "In this part of test, various lisp objects will be inspected. -Numbers except for complex and fraction types, and characters -are not inspectable and an appropriate message will be printed. -If a inspect menu pops up, select the item INSPECT -To create an inspector window, simply click the left mouse button -Please respond with y or n after an inspector window is created. ") - (SETQ MESS1 "Is an inspector window created for ~A? ~%or a message displayed if ~A is not inspectable?") - (SETQ MESS2 "Please indicate a position for inspecting -the compiled function COS with left mouse button") - (SETQ MESS3 "Is the inspector window displayed for -the compiled function COS (Yes or NO?)") - (SETQ MESS4 "Is the inspection information displayed -in the specified inspector window?") - (SETQ MESS5 "The inspector window should have been created -for inspecting the compiled function COS") - (SETQ MESS6 "Inspecting *random-state* never returns (AR 8203) -Please run this test after this test is completed by entering -(INSPECT *RANDOM-STATE*) and return Cont-E if it never returns. -If it still fails the test, please update the log file accordingly: -{eris}test>program-analysis>inspect.report.") - (SETQ MESS7 "Are you ready to start testing(y or n)? ") - (SETQ PROMPT-MESS "Item being inspected: ") - (SETQ PROMPT-MESS1 "Item just inspected: ~A: ~A~2%") - -; Load TEDIT if not already loaded.... -(IL:PAGEHEIGHT 0) -(IL:FILESLOAD (IL:SYSLOAD) TEDIT) - -; Check the intial value of inspector variables... -(PASS-FAIL 'INITIAL-VALUES-OF-VARIABLES (AND (= IL:MAXINSPECTCDRLEVEL 50) - (= IL:MAXINSPECTARRAYLEVEL 300) - (EQUAL IL:INSPECTPRINTLEVEL '(2 . 5)) - (EQ IL:INSPECTALLFIELDSFLG T))) - -; Create various objects to be inspected... -; Trying to inspect random state object will hang the system (never returns) -; A number or character cannot be inspected and an appropriate message should be -; generated for these objects... -(SETQ INSPECT-ITEM-NAMES - '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER -COMMON COMPILED-FUNCTION COMPLEX CONS -DOUBLE-FLOAT FIXNUM FLOAT FUNCTION -HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT -NULL NUMBER PACKAGE PATHNAME -RATIO RATIONAL READTABLE SEQUENCE -SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR -SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT -STANDARD-CHAR STREAM STRING STRING-CHAR -SYMBOL T VECTOR WINDOW) ITEM-NAMES INSPECT-ITEM-NAMES) - - - -(Y-OR-N-P MESS7) -(SETQ INSPECT-WINDOWS NIL) -(IL:FOR ITEM IL:IN INSPECT-ITEM-LIST IL:DO - (SETQ POP-ITEM (POP INSPECT-ITEM-NAMES)) - (SETQ ITEM-VALUE (POP INSPECT-ITEM-LIST)) - (IL:PROMPTPRINT PROMPT-MESS POP-ITEM SPACE ITEM-VALUE) - (INSPECT ITEM) - (FORMAT T PROMPT-MESS1 POP-ITEM ITEM-VALUE) - (IL:SET (PACK* POP-ITEM '-INSPECTED-FLG) - (Y-OR-N-P (FORMAT T MESS1 POP-ITEM POP-ITEM))) - ) - -(IL:FOR X IL:IN ITEM-NAMES IL:DO - (SETQ PF-ITEM (POP ITEM-NAMES)) - (PASS-FAIL X (EVAL (PACK* PF-ITEM '-INSPECTED-FLG)))) - - -; Inspecting the compiled code of the function... -(IL:PROMPTPRINT MESS5) -(IL:INSPECTCODE 'COS) -(PASS-FAIL 'INSPECTCODE (Y-OR-N-P MESS3)) - -; Closing the inspector window... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) INSPECTCODE-TITLE)) - -; Testing to see if an object could be displayed in a specified window... -(SETQ INSPECT-ARRAY (MAKE-ARRAY '(2 2) :INITIAL-CONTENTS '((1 2) (3 4)))) -(IL:OPENW INSPECTORW) -(INSPECT INSPECT-ARRAY NIL INSPECTORW) -(PASS-FAIL 'INSPECT-WHERE (Y-OR-N-P MESS4)) - -; Delete all inspect windows that have been created... -(IL:FOR WINDOW IL:IN (IL:OPENWINDOWS) - IL:DO (IL:CLOSEW WINDOW) - IL:WHEN - (AND (NOT (EQ (IL:WINDOWPROP WINDOW 'IL:TITLE) NIL)) - (OR (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR :start1 0 :end1 9) - (STRING-EQUAL (IL:WINDOWPROP WINDOW 'IL:TITLE) - INSPECTOR - :start1 (- (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)) 9) - :end1 (LENGTH (IL:WINDOWPROP WINDOW 'IL:TITLE)))) - ) -) - -; Test for AR8203 -(IL:PROMPTPRINT MESS6) - - - -TEST-SUCCEEDED -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/SPY.U.~1~ b/internal/test/env/program-analysis/hand/SPY.U.~1~ deleted file mode 100644 index e664e979..00000000 --- a/internal/test/env/program-analysis/hand/SPY.U.~1~ +++ /dev/null @@ -1,264 +0,0 @@ -;; Function To Be Tested: SPY (Part I) (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 187 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 12, 1987 -;; -;; Last Update: March 18, 1987 -;; -;; Filed As: {ERIS}test>program-analysis>spy.u -;; -;; -;; Syntax: (See Spy documentation) -;; -;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: -;; a "sampler" that one runs while running his program, which monitors what the program -;; is doing, anda "displayer" that displays the data gathered by the sampler. -;; The "displayer" uses the grapher package to display the data gathered by the sampler. -;; In the graph, the height of each node is adjusted to be proportional to the amount -;; of time. Just as Masterscope and Browser give an interactive picture of the static -;; structure of the program, Spy give an interactive picture of the dynamic structure. -;; -;; Required packages: Grapher, readnumber, imageobj, and tedit -;; -;; Functions: (SPY.BUTTON) - Turns spy on and off. -;; (SPY.START) - Reinitializes the internal Spy data structure and turns on -;; Sampling. -;; (SPY.END) - Turns off sampling, and cleans up the data structure -;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, -;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). -;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls -;; (SPY.END), and another one will turn it off. -;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results -;; of the last "spy" in a grapher window. For argument description, -;; see SPY documentation. -;; (SPY.LEGEND) - This brings up a window that shows what they mean -;; (SPY.BORDER) - This brings up a window that shows the interpretation of -;; SPY.BORDERS -;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. -;; Max: 60 -;; SPY.NOMERGEFNS - Functions on this list are not merged under -;; MergeDefault -;; SPY.TREE - This holds the data from the last sampling. One can save -;; and restore it using UGLYVARS. -;; SPY.BORDERS - This controls the border display on a tree. -;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) -;; SPY.MAXLINES - Maximum height of a node in the graph, measured -;; in multiples of the font height of SPY.FONT. -;; Argument(s): (SEE Spy documentation) -;; -;; Returns: (SEE Spy documentation) -;; -;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the -;; functional tests are written in such a way that many of the top-level functions will be -;; automatically executed and test results will be recorded in the following file -;; {eris}test>program-analysis>browser.report. User interface is necessary for -;; some of the spy functions. Appropriate messages will be printed when user interface is -;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should -;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual -;; vs Cumulative mode). - -(DO-TEST "SPY-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>SPY.REPORT") - (DEFUN S-FORMAT (TIME) - (FORMAT *OUTPUT* "~2%TOTAL TEST RUN TIME FOR SPY: ~F MINUTES ~%" - TIME)) - - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: SPY TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: SPY TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) -(SETQ SPY-COMMAND-STRING -"(IL:PAGEHEIGHT 0) -;Loading spy and other required package -; they are not already loaded... -(PAUSE) -; This part of the test will load spy and other required packages... -(IF (AND (MEMBER 'IL:SPY IL:FILELST) - (MEMBER 'IL:GRAPHER IL:FILELST) - (MEMBER 'IL:READNUMBER IL:FILELST) - (MEMBER 'IL:IMAGEOBJ IL:FILELST)) - (PROGN (IL:PROMPTPRINT '(SPY and other necessary files are already loaded)) - (SLEEP 2) - (IL:CLRPROMPT)) - (PROGN (IL:LOAD? '{ERINYES}LIBRARY>SPY.LCOM 'IL:SYSLOAD) - (IL:LOAD? '{ERINYES}LIBRARY>GRAPHER.LCOM 'IL:SYSLOAD) - (IL:LOAD? '{ERINYES}LIBRARY>READNUMBER.LCOM 'IL:SYSLOAD) - (IL:LOAD? '{ERINYES}LIBRARY>IMAGEOBJ.LCOM 'IL:SYSLOAD))) - -; This part determines if all spy functions are defined and variables bound .... -(PAUSE) - -(IF (AND (NOTANY #'NULL - (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END - IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) - (NOTANY #'NULL - (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS - IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) - ) - (SETQ IL:FUNCTIONS-VARIABLES-FLG T) - (SETQ IL:FUNCTIONS-VARIABLES-FLG NIL)) - -; Test to see if the SPY variables are bound to correct initial values - -(IF (AND (EQ IL:SPY.FREQUENCY 10) - (PROGN (SETQ NOMERGEFNS-FLG NIL) - (DOLIST (Y '(IL:ERRORSET IL:\\\\EVAL IL:\\\\EVALFORM IL:APPLY IL:EVAL)) - (IF (MEMBER Y IL:SPY.NOMERGEFNS) (PUSH T NOMERGEFNS-FLG) - (PUSH NIL NOMERGEFNS-FLG))) - (NOTANY #'NULL NOMERGEFNS-FLG)) - (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) - (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) - (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) - ) - (SETQ IL:SPY-INITIAL-FLG T) - (SETQ IL:SPY-INITIAL-FLG NIL) -) - -; Test for SPY.BUTTON -; (SPY.BUTTON) will turn spy on/off -; -(CL:IN-PACKAGE 'INTERLISP) -(SPY.BUTTON '(90 . 5)) -(CURSORPOSITION '(134 . -145)) -; Clicking the left mouse button will turn it on... -(XCL-TEST::PAUSE) -(APPLY (WINDOWPROP SPY.BUTTON 'BUTTONEVENTFN)) -(IF (EQ \\\\PERIODIC.INTERRUPT '\\\\SPY.INTERRUPT) - then (SETQ SPY-BUTTON-ON T) - else (SETQ SPY-BUTTON-ON NIL)) - -; Clicking it again will turn off the spy and display the results.... -(XCL-TEST::PAUSE) -(PROMPTPRINT '(please indicate the spy.window position with left mouse button)) -(APPLY (WINDOWPROP SPY.BUTTON 'BUTTONEVENTFN)) -(CLOSEW SPY.BUTTON) -(IF (EQ \\\\PERIODIC.INTERRUPT NIL) - then (SETQ SPY-BUTTON-OFF T) - else (SETQ SPY-BUTTON-OFF NIL)) -(SPY.END) -(CLOSEW SPY.WINDOW) -(CLRPROMPT) - -; This part of the test is for (SPY.START) and (SPY.END) -; (SPY.START) will turns on the sampling -(XCL-TEST::PAUSE) -(SPY.START) -; Now SPY should be turned back on. -(If (EQUAL \\\\PERIODIC.INTERRUPT '\\\\SPY.INTERRUPT) - then (SETQ SPY-START T) - else (SETQ SPY-START NIL)) -; (SPY.END) will turn off sampling. -(XCL-TEST::PAUSE) -(SPY.END) -; Now SPY should be turned off. -(If (EQ \\\\PERIODIC.INTERRUPT NIL) - then (SETQ SPY-END T) - else (SETQ SPY-END NIL)) - -; The following will test (SPY.TOGGLE) -; If SPY is off, it will turn it on; otherwise, it will turn it off -; with (SPY.END) and show the results. -(XCL-TEST::PAUSE) -(SETQ \\\\PERIODIC.INTERRUPT NIL) -(SPY.BUTTON '(100 . 100)) -(SPY.TOGGLE) -(If (EQ \\\\PERIODIC.INTERRUPT '\\\\SPY.INTERRUPT) - then (SETQ SPY-TOGGLE-ON T) - else (SETQ SPY-TOGGLE-ON NIL)) -; Invoking (SPY.TOGGLE) again will turn spy off and display the results... -(XCL-TEST::PAUSE) -(PROMPTPRINT '(please indicate the spy.window position with left mouse button)) -(SPY.TOGGLE) -(If (EQ \\\\PERIODIC.INTERRUPT NIL) - then (SETQ SPY-TOGGLE-OFF T) - else (SETQ SPY-TOGGLE-OFF NIL)) -(CLOSEW SPY.BUTTON) -(CLOSEW SPY.WINDOW) -(CLRPROMPT) - - -; The following will test (WITH.SPY form) -; This will evaluate the form with spy on -(XCL-TEST::PAUSE) -(WITH.SPY (FOR X FROM 1 TO 10 COLLECT (ADD1 X))) -(SETQ WITH-SPY-VAL IT) -(IF (EQUAL WITH-SPY-VAL - (PROGN (SPY.START) (PROG1 (FOR X FROM 1 TO 10 COLLECT (ADD1 X)) (SPY.END)))) - then (SETQ WITH-SPY T) - else (SETQ WITH-SPY NIL)) - -; This following will test SPY.TREE, which display the results in a grapher window. -; (SPY.TREE 10) will display the last spy with threshold set to 10 -(XCL-TEST::PAUSE) -(PROMPTPRINT '(please indicate the spy.window position with left mouse button)) -(SPY.TREE 10) -(IF (EQ (NOT (MEMBER SPY.WINDOW (OPENWINDOWS))) NIL) - THEN (SETQ SPY-TREE1 T) - ELSE (SETQ SPY-TREE1 NIL)) -(CLOSEW SPY.WINDOW) - -; (SPY.TREE 10 T) Should display the spy graph in different format -(XCL-TEST::PAUSE) -(PROMPTPRINT '(please indicate the spy.window position with left mouse button)) -(SPY.TREE 10 T) -(IF (EQ (NOT (MEMBER SPY.WINDOW (OPENWINDOWS))) NIL) - THEN (SETQ SPY-TREE2 T) - ELSE (SETQ SPY-TREE2 NIL)) -(CLOSEW SPY.WINDOW) - -; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 -(XCL-TEST::PAUSE) -(PROMPTPRINT '(please indicate the spy.window position with left mouse button)) -(SPY.TREE 10 T 'ALL 2) -(IF (EQ (NOT (MEMBER SPY.WINDOW (OPENWINDOWS))) NIL) - THEN (SETQ SPY-TREE3 T) - ELSE (SETQ SPY-TREE3 NIL)) -(CLRPROMPT) -(CLOSEW SPY.WINDOW) -(CL:IN-PACKAGE 'XCL-TEST) -; Now do-test will analyze the results of testing -(DO-TEST 'SPY-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION IL:FUNCTIONS-VARIABLES-FLG) - (PASS-FAIL 'IL:SPY-INITIAL-VALUES IL:SPY-INITIAL-FLG) - (PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION IL:FUNCTIONS-VARIABLES-FLG) - (PASS-FAIL 'IL:SPY-BUTTON-ON IL:SPY-BUTTON-ON) - (PASS-FAIL 'IL:SPY-BUTTON-OFF IL:SPY-BUTTON-OFF) - (PASS-FAIL 'IL:SPY-START IL:SPY-START) - (PASS-FAIL 'IL:SPY-END IL:SPY-END) - (PASS-FAIL 'IL:SPY-TOGGLE (AND IL:SPY-TOGGLE-ON IL:SPY-TOGGLE-OFF)) - (PASS-FAIL 'IL:WITH-SPY IL:WITH-SPY) - (PASS-FAIL 'IL:SPY-TREE (AND IL:SPY-TREE1 IL:SPY-TREE2 IL:SPY-TREE3)) - (SETQ TEST-END (GET-INTERNAL-RUN-TIME)) - (SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - (S-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) - -") - (IL:BKSYSBUF SPY-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/SPY.U.~2~ b/internal/test/env/program-analysis/hand/SPY.U.~2~ deleted file mode 100644 index bf4eca13..00000000 --- a/internal/test/env/program-analysis/hand/SPY.U.~2~ +++ /dev/null @@ -1,201 +0,0 @@ -;; Function To Be Tested: SPY (Part I) (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 187 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 12, 1987 -;; -;; Last Update: March 18, 1987 -;; -;; Massively munged: Rene P. S. Bane on June 22, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>spy.u -;; -;; -;; Syntax: (See Spy documentation) -;; -;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: -;; a "sampler" that one runs while running his program, which monitors what the program -;; is doing, anda "displayer" that displays the data gathered by the sampler. -;; The "displayer" uses the grapher package to display the data gathered by the sampler. -;; In the graph, the height of each node is adjusted to be proportional to the amount -;; of time. Just as Masterscope and Browser give an interactive picture of the static -;; structure of the program, Spy give an interactive picture of the dynamic structure. -;; -;; Required packages: Grapher, readnumber, imageobj, and tedit -;; -;; Functions: (SPY.BUTTON) - Turns spy on and off. -;; (SPY.START) - Reinitializes the internal Spy data structure and turns on -;; Sampling. -;; (SPY.END) - Turns off sampling, and cleans up the data structure -;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, -;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). -;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls -;; (SPY.END), and another one will turn it off. -;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results -;; of the last "spy" in a grapher window. For argument description, -;; see SPY documentation. -;; (SPY.LEGEND) - This brings up a window that shows what they mean -;; (SPY.BORDER) - This brings up a window that shows the interpretation of -;; SPY.BORDERS -;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. -;; Max: 60 -;; SPY.NOMERGEFNS - Functions on this list are not merged under -;; MergeDefault -;; SPY.TREE - This holds the data from the last sampling. One can save -;; and restore it using UGLYVARS. -;; SPY.BORDERS - This controls the border display on a tree. -;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) -;; SPY.MAXLINES - Maximum height of a node in the graph, measured -;; in multiples of the font height of SPY.FONT. -;; Argument(s): (SEE Spy documentation) -;; -;; Returns: (SEE Spy documentation) -;; -;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the -;; functional tests are written in such a way that many of the top-level functions will be -;; automatically executed and test results will be recorded in the following file -;; {eris}test>program-analysis>browser.report. User interface is necessary for -;; some of the spy functions. Appropriate messages will be printed when user interface is -;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should -;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual -;; vs Cumulative mode). - -(DO-TEST "SPY-TEST-SETUP" - (SETQ SPY-TEST-RESULTS T) ; assume test succeeds, set to nil if something fails - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ SPY-TEST-RESULTS NIL) - )) -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) -(IL:PAGEHEIGHT 0) -;Loading spy and other required package -; they are not already loaded... -(PAUSE) -; This part of the test will load spy and other required packages... -(IL:FILESLOAD (IL:SYSLOAD) SPY GRAPHER READNUMBER IMAGEOBJ) - -; This part determines if all spy functions are defined and variables bound .... -(PAUSE) - -(PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION - (AND (NOTANY #'NULL - (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END - IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) - (NOTANY #'NULL - (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS - IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) - )) - - -; Test to see if the SPY variables are bound to correct initial values - -(PASS-FAIL 'IL:SPY-INITIAL-VALUES - (AND (EQ IL:SPY.FREQUENCY 10) - (PROGN (SETQ NOMERGEFNS-FLG NIL) - (DOLIST (Y '(IL:ERRORSET IL:\\\\EVAL IL:\\\\EVALFORM IL:APPLY IL:EVAL)) - (IF (MEMBER Y IL:SPY.NOMERGEFNS) (PUSH T NOMERGEFNS-FLG) - (PUSH NIL NOMERGEFNS-FLG))) - (NOTANY #'NULL NOMERGEFNS-FLG)) - (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) - (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) - (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) - ) -) - -; Test for SPY.BUTTON -; (SPY.BUTTON) will turn spy on/off -; -(IL:SPY.BUTTON '(90 . 5)) -(IL:CURSORPOSITION '(134 . -145)) -(PASS-FAIL "SPY.BUTTON gets you a Spy Eye" - (Y-OR-N-P "Did a Spy Eye just appear? ")) -; Clicking the left mouse button will turn it on... -(XCL-TEST::PAUSE) -(APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) -(PASS-FAIL 'IL:SPY-BUTTON-ON - (Y-OR-N-P "Did the Spy Eye open? ")) - -; Clicking it again will turn off the spy and display the results.... -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) -(PASS-FAIL 'IL:SPY-BUTTON-OFF (Y-OR-N-P "Did the Spy Eye close? ")) -(IL:SPY.END) -(IL:CLOSEW IL:SPY.WINDOW) -(IL:CLRPROMPT) - -; This part of the test is for (SPY.START) and (SPY.END) -; (SPY.START) will turns on the sampling -(XCL-TEST::PAUSE) -(IL:SPY.START) -; Now SPY should be turned back on. -(PASS-FAIL 'IL:SPY-START - (Y-OR-N-P "Did the Spy Eye open? ")) -; (SPY.END) will turn off sampling. -(XCL-TEST::PAUSE) -(IL:SPY.END) -; Now SPY should be turned off. -(PASS-FAIL 'IL:SPY-END (Y-OR-N-P "Did the Spy Eye close? ")) - -; The following will test (SPY.TOGGLE) -; If SPY is off, it will turn it on; otherwise, it will turn it off -; with (SPY.END) and show the results. -(XCL-TEST::PAUSE) -(IL:SPY.TOGGLE) -(PASS-FAIL 'IL:SPY-TOGGLE-ON (Y-OR-N-P "Did the Spy Eye open? ")) -; Invoking (SPY.TOGGLE) again will turn spy off and display the results... -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TOGGLE) -(PASS-FAIL 'IL:SPY-TOGGLE-OFF (Y-OR-N-P "Did the Spy Eye close? ")) - -(IL:CLOSEW IL:SPY.WINDOW) -(IL:CLRPROMPT) - - -; The following will test (WITH.SPY form) -; This will evaluate the form with spy on -(XCL-TEST::PAUSE) -(IL:WITH.SPY (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X))) -(SETQ IL:WITH-SPY-VAL IL:IT) -(PASS-FAIL 'IL:WITH-SPY (EQUAL IL:WITH-SPY-VAL - (PROGN (IL:SPY.START) (PROG1 (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X)) (IL:SPY.END))))) - -; This following will test SPY.TREE, which display the results in a grapher window. -; (SPY.TREE 10) will display the last spy with threshold set to 10 -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TREE 10) -(SETQ IL:SPY-TREE1 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) -(IL:CLOSEW IL:SPY.WINDOW) - -; (SPY.TREE 10 T) Should display the spy graph in different format -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TREE 10 T) -(SETQ IL:SPY-TREE2 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) -(IL:CLOSEW IL:SPY.WINDOW) - -; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TREE 10 T 'IL:ALL 2) -(SETQ IL:SPY-TREE3 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) -(IL:CLRPROMPT) -(IL:CLOSEW IL:SPY.WINDOW) -(IL:CLOSEW IL:SPY.BUTTON) -SPY-TEST-RESULTS - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/SPY.U.~3~ b/internal/test/env/program-analysis/hand/SPY.U.~3~ deleted file mode 100644 index b7a349c1..00000000 --- a/internal/test/env/program-analysis/hand/SPY.U.~3~ +++ /dev/null @@ -1,195 +0,0 @@ -;; Function To Be Tested: SPY (Part I) (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 187 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 12, 1987 -;; -;; Last Update: March 18, 1987 -;; -;; Massively munged: Rene P. S. Bane on June 22, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>spy.u -;; -;; -;; Syntax: (See Spy documentation) -;; -;; Function Description: Spy is a tool to help programs run faster. Spy has two parts: -;; a "sampler" that one runs while running his program, which monitors what the program -;; is doing, anda "displayer" that displays the data gathered by the sampler. -;; The "displayer" uses the grapher package to display the data gathered by the sampler. -;; In the graph, the height of each node is adjusted to be proportional to the amount -;; of time. Just as Masterscope and Browser give an interactive picture of the static -;; structure of the program, Spy give an interactive picture of the dynamic structure. -;; -;; Required packages: Grapher, readnumber, imageobj, and tedit -;; -;; Functions: (SPY.BUTTON) - Turns spy on and off. -;; (SPY.START) - Reinitializes the internal Spy data structure and turns on -;; Sampling. -;; (SPY.END) - Turns off sampling, and cleans up the data structure -;; (SPY.TOGGLE) - If Spying is off, turn it on with (SPY.START). If it's on, -;; turn it off with (SPY.END) and then show the results with (SPY.TREE 10). -;; (WITH.SPY form) - Macro which calls (SPY.START), evaluates the form, calls -;; (SPY.END), and another one will turn it off. -;; (SPY.TREE threshold individualp mergetype depthlimit) - display the results -;; of the last "spy" in a grapher window. For argument description, -;; see SPY documentation. -;; (SPY.LEGEND) - This brings up a window that shows what they mean -;; (SPY.BORDER) - This brings up a window that shows the interpretation of -;; SPY.BORDERS -;; Variables: SPY.FREQUENCY - How many times per second to sample? Initially 10. -;; Max: 60 -;; SPY.NOMERGEFNS - Functions on this list are not merged under -;; MergeDefault -;; SPY.TREE - This holds the data from the last sampling. One can save -;; and restore it using UGLYVARS. -;; SPY.BORDERS - This controls the border display on a tree. -;; SPY.FONT - Font used to display node labels. Initially (GACHA 10) -;; SPY.MAXLINES - Maximum height of a node in the graph, measured -;; in multiples of the font height of SPY.FONT. -;; Argument(s): (SEE Spy documentation) -;; -;; Returns: (SEE Spy documentation) -;; -;; Constraints/Limitations: Testing of SPY requires much user interface; however, may of the -;; functional tests are written in such a way that many of the top-level functions will be -;; automatically executed and test results will be recorded in the following file -;; {eris}test>program-analysis>browser.report. User interface is necessary for -;; some of the spy functions. Appropriate messages will be printed when user interface is -;; required during testing. Instructions for manually testing SPY (pages 189 - 193), should -;; be read carefully before testing the SPY display results (Using SPY,Merging, and Individual -;; vs Cumulative mode). - -(DO-TEST "SPY-TEST-SETUP" - (SETQ SPY-TEST-RESULTS T) ; assume test succeeds, set to nil if something fails - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) (SETQ SPY-TEST-RESULTS NIL) - )) -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ SPYW (IL:CREATEW '(100 100 325 90) NIL NIL T)) -(IL:PAGEHEIGHT 0) -;Loading spy and other required package -; they are not already loaded... -(PAUSE) -; This part of the test will load spy and other required packages... -(IL:FILESLOAD (IL:SYSLOAD) SPY GRAPHER READNUMBER IMAGEOBJ) - -; This part determines if all spy functions are defined and variables bound .... -(PAUSE) - -(PASS-FAIL 'IL:FUNCTION-VARIABLE-DEFINITION - (AND (NOTANY #'NULL - (MAPCAR #'FBOUNDP '(IL:SPY.BUTTON IL:SPY.START IL:SPY.END - IL:WITH.SPY IL:SPY.TREE IL:SPY.LEGEND))) - (NOTANY #'NULL - (MAPCAR #'BOUNDP '(IL:SPY.FREQUENCY IL:SPY.NOMERGEFNS - IL:SPY.TREE IL:SPY.BORDERS IL:SPY.FONT IL:SPY.MAXLINES))) - )) - - -; Test to see if the SPY variables are bound to correct initial values - -(PASS-FAIL 'IL:SPY-INITIAL-VALUES - (AND (EQ IL:SPY.FREQUENCY 10) - (AND (EQ (IL:FONTPROP IL:SPY.FONT 'IL:FAMILY) 'IL:GACHA) - (= (IL:FONTPROP IL:SPY.FONT 'IL:SIZE) 8)) - (ZEROP (MOD IL:SPY.MAXLINES (IL:FONTPROP IL:SPY.FONT 'IL:HEIGHT))) - ) -) - -; Test for SPY.BUTTON -; (SPY.BUTTON) will turn spy on/off -; -(IL:SPY.BUTTON '(90 . 5)) -(IL:CURSORPOSITION '(134 . -145)) -(PASS-FAIL "SPY.BUTTON gets you a Spy Eye" - (Y-OR-N-P "Did a Spy Eye just appear? ")) -; Clicking the left mouse button will turn it on... -(XCL-TEST::PAUSE) -(APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) -(PASS-FAIL 'IL:SPY-BUTTON-ON - (Y-OR-N-P "Did the Spy Eye open? ")) - -; Clicking it again will turn off the spy and display the results.... -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(APPLY (IL:WINDOWPROP IL:SPY.BUTTON 'IL:BUTTONEVENTFN) NIL) -(PASS-FAIL 'IL:SPY-BUTTON-OFF (Y-OR-N-P "Did the Spy Eye close? ")) -(IL:SPY.END) -(IL:CLOSEW IL:SPY.WINDOW) -(IL:CLRPROMPT) - -; This part of the test is for (SPY.START) and (SPY.END) -; (SPY.START) will turns on the sampling -(XCL-TEST::PAUSE) -(IL:SPY.START) -; Now SPY should be turned back on. -(PASS-FAIL 'IL:SPY-START - (Y-OR-N-P "Did the Spy Eye open? ")) -; (SPY.END) will turn off sampling. -(XCL-TEST::PAUSE) -(IL:SPY.END) -; Now SPY should be turned off. -(PASS-FAIL 'IL:SPY-END (Y-OR-N-P "Did the Spy Eye close? ")) - -; The following will test (SPY.TOGGLE) -; If SPY is off, it will turn it on; otherwise, it will turn it off -; with (SPY.END) and show the results. -(XCL-TEST::PAUSE) -(IL:SPY.TOGGLE) -(PASS-FAIL 'IL:SPY-TOGGLE-ON (Y-OR-N-P "Did the Spy Eye open? ")) -; Invoking (SPY.TOGGLE) again will turn spy off and display the results... -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TOGGLE) -(PASS-FAIL 'IL:SPY-TOGGLE-OFF (Y-OR-N-P "Did the Spy Eye close? ")) - -(IL:CLOSEW IL:SPY.WINDOW) -(IL:CLRPROMPT) - - -; The following will test (WITH.SPY form) -; This will evaluate the form with spy on -(XCL-TEST::PAUSE) - -(PASS-FAIL 'IL:WITH-SPY (EQUAL (IL:WITH.SPY (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X))) - (PROGN (IL:SPY.START) (PROG1 (IL:FOR X IL:FROM 1 IL:TO 10 IL:COLLECT (IL:ADD1 X)) (IL:SPY.END))))) - -; This following will test SPY.TREE, which display the results in a grapher window. -; (SPY.TREE 10) will display the last spy with threshold set to 10 -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TREE 10) -(SETQ IL:SPY-TREE1 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) -(IL:CLOSEW IL:SPY.WINDOW) - -; (SPY.TREE 10 T) Should display the spy graph in different format -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TREE 10 T) -(SETQ IL:SPY-TREE2 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) -(IL:CLOSEW IL:SPY.WINDOW) - -; (SPY.TREE 10 T 'ALL 2) Should display the spy graph in with depthlimit set to 2 -(XCL-TEST::PAUSE) -(IL:PROMPTPRINT "please indicate the spy.window position with left mouse button") -(IL:SPY.TREE 10 T 'IL:ALL 2) -(SETQ IL:SPY-TREE3 (MEMBER IL:SPY.WINDOW (IL:OPENWINDOWS))) -(IL:CLRPROMPT) -(IL:CLOSEW IL:SPY.WINDOW) -(IL:CLOSEW IL:SPY.BUTTON) -SPY-TEST-RESULTS - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~1~ b/internal/test/env/program-analysis/hand/browser-part1.u.~1~ deleted file mode 100644 index e82011d5..00000000 --- a/internal/test/env/program-analysis/hand/browser-part1.u.~1~ +++ /dev/null @@ -1,176 +0,0 @@ -;; Function To Be Tested: BROWSER (Part I) (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 10, 1987 -;; -;; Last Update: March 12, 1987 -;; -;; Filed As: {ERIS}test>program-analysis>browser-part1.u -;; -;; -;; Syntax: (BROWSER T/NIL) -;; -;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is -;; to determine if masterscope is unaffected when the BROWSER is not enabled or -;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded -;; by browser. - -;; -;; Argument(s): T or NIL (SEE Browser documentation) -;; -;; Returns: IL:MSPATHS -;; -;; Constraints/Limitations: ; Part 1 of this test is to determine if masterscope is -;; unaffected when the BROWSER is not enabled or (IL:BROWSER NIL) -;; Part 2 tests masterscope modification by BROWSER. This is test part 2, which -;; is stored in {eris}test>program-analysis>browser-part2.u -;; Part 1 test must be run first before Part 2 test since the former loads functions -;; utilized by the latter. Since Browser calls LAYOUTFOREST module of GRAPHER to -;; display the graph at a user-designated location, user interface is required and -;; testing will not be totally automatic. Instructions will be given for user input -;; during testing. The test will utilize do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within each command file, which will be run -;; by using the function bksysbuf. Each test setup is titled "BROWSER-TEST-SETUP", -;; which executes the command string. The do-test form within the command file will -;; return T or "testfailed" This test file requires MASTERSCOPE, TEDIT, BROWSER, and -;; GRAPHER packages -;; -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-GFuntion -;; | -;; GFun-A------------------------GFun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 -;; | -;; -------------- -;; | | -;; GFun-C1 GFun-A1 -;; -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>browser.report - -(DO-TEST "BROWSER-TEST-SETUP" - (PROGN - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>BROWSER.REPORT") - (DEFUN R-FORMAT (STATUS) - (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" (LISP-IMPLEMENTATION-VERSION) STATUS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: BROWSER TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: BROWSER TEST-ITEM: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) -(SETQ {CORE}PATHS "{CORE}PATHS") -(DEFUN PAUSE NIL (PROGN - (IL:PLAYTUNE '((262 . 15000) (440 . 15000) (349 . 15000))) - (SLEEP 2))) -(SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - (SETQ BROWSER-COMMAND-STRING -";Loading browser will automatically load grapher package. -; This part of the test determines if grapher is loaded. -(PAUSE) -(IL:PAGEHEIGHT 0) -(DELETE 'IL:GRAPHER IL:SYSFILES) -(IL:LOAD? '{ERINYES}LIBRARY>MASTERSCOPE.LCOM 'IL:SYSLOAD) -(IL:LOAD '{ERINYES}LIBRARY>BROWSER.LCOM 'IL:SYSLOAD) -(IF (OR (MEMBER 'IL:GRAPHER IL:SYSFILES) - (MEMBER 'IL:GRAPHER IL:FILELST)) - (SETQ GRAPHER-LDFLG T) - (PROGN (SETQ GRAPHER-LDFLG NIL) - (IL:LOAD '{ERINYES}LIBRARY>GRAPHER.LCOM 'IL:SYSLOAD))) - -; This part of test determines if the variables BROWSERFORMAT and BROWSERBOXING -; are bound. -(PAUSE) -(IF (AND (BOUNDP 'IL:BROWSERFORMAT) (BOUNDP 'IL:BROWSERBOXING)) - (SETQ BROWSER-VARIABLES T) - (SETQ BROWSER-VARIABLES NIL)) - - -; Reinitialize and Define functions to be analyzed.... -(PAUSE) -. ERASE -(DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) -(DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) -(DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) -(DEFUN GFUN-A1 NIL T) -(DEFUN GFUN-A2 NIL NIL) -(DEFUN GFUN-A3 NIL T) -(DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) -(DEFUN GFUN-B2 NIL NIL) -(DEFUN GFUN-B3 NIL T) -(DEFUN GFUN-C1 NIL NIL) - -; Start analyzing functions in gtop-function and others... -(PAUSE) -. ANALYZE TOP-GFUNTION -. ANALYZE GFUN-A -. ANALYZE GFUN-B -. ANALYZE GFUN-A1 -. ANALYZE GFUN-A2 -. ANALYZE GFUN-A3 -. ANALYZE GFUN-B1 -. ANALYZE GFUN-B2 -. ANALYZE GFUN-B3 -. ANALYZE GFUN-C1 -; Browser is now loaded and activated -(PAUSE) -; Part 1 of this test is to determine if masterscope is unaffected when -; the BROWSER is not enabled or (IL:BROWSER NIL) -(IL:BROWSER NIL) -; Browser is now deactivated ... -(PAUSE) -; This will cause masterscope to diaplay graphs in a teletype mode -; or in the exec. -; show paths should display the following path, which should look like; -; 1.gfun-a1 gfun-a top-gfuntion -; 2. gfun-b1 gfun-b top-gfuntion -(PAUSE) -(DRIBBLE '{CORE}PATHS) -. SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION -(DRIBBLE) -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN {CORE}PATHS)) -(DO (( i 0 (1+ i))) - ((= i 5) t) - (READ-LINE PATHS)) -(IF (AND (STRING-EQUAL (READ-LINE PATHS) '|1.gfun-a1 gfun-a top-gfuntion|) - (STRING-EQUAL (READ-LINE PATHS) '|2. gfun-b1 gfun-b top-gfuntion|)) - (SETQ BROWSER-DISABLED-FLG T)(SETQ BROWSER-DISABLED-FLG NIL)) -(CLOSE PATHS) -(DELETE-FILE '{CORE}PATHS) -(DO-TEST 'BROWSER-TEST-RESULT - (PROGN (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (PASS-FAIL 'BROWSER-VARIABLES-BOUND? BROWSER-VARIABLES) - (PASS-FAIL 'GRAGPER-LOADED? GRAPHER-LDFLG) - (PASS-FAIL 'BROWSER-DISABLED BROWSER-DISABLED-FLG) - (CLOSE *OUTPUT*) - (IDENTITY T) - ) -) - -") - (IL:BKSYSBUF BROWSER-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~2~ b/internal/test/env/program-analysis/hand/browser-part1.u.~2~ deleted file mode 100644 index 6598224a..00000000 --- a/internal/test/env/program-analysis/hand/browser-part1.u.~2~ +++ /dev/null @@ -1,151 +0,0 @@ -;; Function To Be Tested: BROWSER (Part I) (Program Analysis) -;; -;; Source: Lisp Library Modules Manual (Lyric Beta Release 2) -;; Browser, Page 11 -;; Section: Program Analysis (Library) -;; -;; Created By: John Park -;; -;; Creation Date: March 10, 1987 -;; -;; Last Update: March 12, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; Munged more: June 24, 1988 by Rene P. S. Bane -;; -;; Filed As: {ERIS}env>program-analysis>hand>browser-part1.u -;; -;; -;; Syntax: (BROWSER T/NIL) -;; -;; Function Description: BROWSER modifies the SHOW PATHS command of Masterscope so that -;; the command's output is displayed as an undirected graph. It creates a new window -;; for each SHOW PATHS command, but will reuse a window if that window has an earlier -;; instance of the same SHOW PATHS command displayed in it. Part 1 of this test is -;; to determine if masterscope is unaffected when the BROWSER is not enabled or -;; (IL:BROWSER NIL). Part I also tests to see if grapher is automatically loaded -;; by browser. - -;; -;; Argument(s): T or NIL (SEE Browser documentation) -;; -;; Returns: IL:MSPATHS -;; -;; Constraints/Limitations: ; Part 1 of this test is to determine if masterscope is -;; unaffected when the BROWSER is not enabled or (IL:BROWSER NIL) -;; Part 2 tests masterscope modification by BROWSER. This is test part 2, which -;; is stored in {eris}test>program-analysis>browser-part2.u -;; Part 1 test must be run first before Part 2 test since the former loads functions -;; utilized by the latter. Since Browser calls LAYOUTFOREST module of GRAPHER to -;; display the graph at a user-designated location, user interface is required and -;; testing will not be totally automatic. Instructions will be given for user input -;; during testing. The test will utilize do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within each command file, which will be run -;; by using the function bksysbuf. Each test setup is titled "BROWSER-TEST-SETUP", -;; which executes the command string. The do-test form within the command file will -;; return T or "testfailed" This test file requires MASTERSCOPE, TEDIT, BROWSER, and -;; GRAPHER packages -;; -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-GFuntion -;; | -;; GFun-A------------------------GFun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; GFun-A1 GFun-A2 GFun-A3 GFun-B1 GFun-B2 GFun-B3 -;; | -;; -------------- -;; | | -;; GFun-C1 GFun-A1 -;; -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>browser.report - -(DO-TEST "BROWSER-TEST-SETUP" - -(SETQ TEST-SUCCEEDED T) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Pair-fect-o" - ) -) - -(SETQ BROWSERW (IL:CREATEW '(100 100 325 90) NIL NIL T)) - -(IL:PAGEHEIGHT 0) -; This part of test determines if the variables BROWSERFORMAT and BROWSERBOXING -; are bound. -(PASS-FAIL "Browser variables bound" (AND (BOUNDP 'IL:BROWSERFORMAT) (BOUNDP 'IL:BROWSERBOXING))) - -; Reinitialize and Define functions to be analyzed.... -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-GFUNTION NIL (AND (GFUN-A) (GFUN-B))) -(DEFUN GFUN-A NIL (OR (GFUN-A1) (GFUN-A2) (GFUN-A3))) -(DEFUN GFUN-B NIL (OR (GFUN-B1) (GFUN-B2) (GFUN-B3))) -(DEFUN GFUN-A1 NIL T) -(DEFUN GFUN-A2 NIL NIL) -(DEFUN GFUN-A3 NIL T) -(DEFUN GFUN-B1 NIL (AND (GFUN-C1)(GFUN-A1))) -(DEFUN GFUN-B2 NIL NIL) -(DEFUN GFUN-B3 NIL T) -(DEFUN GFUN-C1 NIL NIL) - -; Start analyzing functions in gtop-function and others... -(IL:MASTERSCOPE '(ANALYZE TOP-GFUNTION)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-A3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B1)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B2)) -(IL:MASTERSCOPE '(ANALYZE GFUN-B3)) -(IL:MASTERSCOPE '(ANALYZE GFUN-C1)) - -; Browser is now loaded and activated -; Part 1 of this test is to determine if masterscope is unaffected when -; the BROWSER is not enabled or (IL:BROWSER NIL) -(IL:BROWSER NIL) - -; Browser is now deactivated ... -; This will cause masterscope to display graphs in a teletype mode -; or in the exec. -; show paths should display the following path, which should look like; -; 1.gfun-a1 gfun-a top-gfuntion -; 2. gfun-b1 gfun-b top-gfuntion -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO GFUN-A1 FROM TOP-GFUNTION)) -(DRIBBLE) -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-gfuntion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.GFUN-A1GFUN-ATOP-GFUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.GFUN-B1GFUN-BTOP-GFUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - -(CLOSE PATHS) -(DELETE-FILE '{CORE}PATHS) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~3~ b/internal/test/env/program-analysis/hand/browser-part1.u.~3~ deleted file mode 100644 index ab1459aa0b14bc001f55eddce5fd50af37f4d049..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5488 zcmb7ITW=ak7Ivh4VI@DVw2w!OR)&#b4B1P@9%a=HZJQCd(2X)#?MnfLX{G66`Vz*I z$^5YSb^D!D-GH$ZXInOISDnjO=U!Z0(RCirv(Us87;-fQI?eRrlHAGYt?x~!HdaYS zy*geJbC;+!IkAfF(=e@{UR~jbe3K`0eM$W=-QZ)EsN|joW|2oarGbib6;Z8!pM-PB z&lF8`q*bb^%>pVFauc&nb#hK)b*HJ-5}8^sUDB~qNU|DA?VUs`04DeTl8AmZs~B>U z_XRfD<->JBbO|)cd_}E`b83D6>R$y-U!@sMHw&SllBWHD#y4xdU8xMGKkwOC^V*R-0s6~z$z`#4j-6tZfi3xn^5y?$x0ox8g_ zohRXjUBCDC+AP9l2)|`3P5$lZEsdSv)~C5yuc4XD681rWB^_G z>m+yiTE|%}ts`;*)(&k{^F6Q3O znWiLj9PBp}XMBrpkQtU(q=iV6up`s}MaaRVvCwIF7fVTw zj5XxB?7%QkyHvmnViQrv419XoADwpn%T4E61 zg&&YnTq_s@G@xb zUMAK#`=6zj0k%=|_iRtB@v=B9L4mVQ&tc@EWS1sN5h!dn>5v@d>@vCjWyxDLXpLt~06-ICgcZHdm_emBjwETREq~L}ymS`zi z@^2+mv1-*=cr7CP(k@?Kg0o^5-B$V1#-c_1QXt#ILN2S3GnXq^c!;f}x5NVOfCsNu zh)C~1p?wN;V75OrD08C>^$kLf`~FNzA$yP-NR{J|lX_c3uLQ|1!Ph1ZQEerF;a1M* zM5lQqy*M&=JcnWE1CIZ%7B>@(^u;`LTI-G^pPtMvY$MIyAeK4drk#%Gb-gYHb+CEY z(;4U$ z@xTe_TW>NMO&X}p<7x0MRprdTBg`fFe*asQjuk;XM-}(+$53S;6fIug_ozC?P}|_? zq+zPytDn|!Mqs$^^*z5oa=J2%`0wPsewfi^CYKq^jH0oqN^ga;Gx40jdrN1v*2M(| z@C$m`{s(=3QI}DJ$Bm#~s2sycw_fk&HlPbk8n*FD!{y9pSMTNn1c;sAKBy$*(J3v_ z6jtMkUf^&?KlO$;kjM35W-x^|PiuQWRm(QG7bQehs=<3yb4Sx*cT8unNg>dxz`f}4 zmep0~6Y+o)B3MJkJy^P3S1)-&+!rv6Jm>>u0c+wB+aHuo*v*?bz6Xg#gaxB9O4)Q6 z^hQHFt_e(DYB&HTFD^qU80?NE9pPGM|8JF~PJ8$E@|ep#;&OLf?vBfS#O1VvZJ!iY zV_Q}w{vIHE`4qKlWmp#of2UR7K|ea2`x(*hlcGCTv;cvZ{EVk6>jQ2ld+(qy-DPMT z<%;;wpjIX6)1GpMPXFD1kmv_4VyFn6hb}D%tzn)gfjgg-()tRT_E*rrozLk)7(7q& z6}mWdp3?=lOEQ&NiU~3{+u~{?9#I$xKk(oMXUc^9_>%VJtHq;x1q5+ND$<QIklR1i2R0X zk^PIIeAD1pJ48_%Gr4_ae^$`V9@5pilb-ALJv#f?!QJAMToa%2`oT3n7-4?la@L~j z$!PE>p9+!OBldYKhvRWozL%IAd>?|#zBuyGt}^1YCom<{_ND?N>0JVkY8Y6DR6Rgk z_Ep-8y5vcOzB%)Q37TBPdoy+VR?1%kr#ee+)*v%B7ds@LV{N3z;hmfI3p?w4gf zX(6uIRyM3uCw!AIj||cV83EsP`XkIUWq4U^4W43-BJcF!>~>n=iN^;V%zk)I`1#Yx zi<5t!w75+<(>^Z6!+=`ooKEM~!3@ILIBRARY>NEW-FUNCTION.\;1 629 - - |changes| |to:| (VARS NEW-FUNCTIONCOMS) - (FNS NEW-FUNCTION)) - - -; Copyright (c) 1987 by XEROX Corporation. All rights reserved. - -(PRETTYCOMPRINT NEW-FUNCTIONCOMS) - -(RPAQQ NEW-FUNCTIONCOMS ((FNS NEW-FUNCTION))) -(DEFINEQ - -(NEW-FUNCTION - (LAMBDA (X Y) (* \; "Edited 19-Mar-87 10:52 by jpark") - (PLUS X Y))) -) -(PUTPROPS NEW-FUNCTION COPYRIGHT ("XEROX Corporation" 1987)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (390 545 (NEW-FUNCTION 400 . 543))))) -STOP diff --git a/internal/test/env/program-analysis/hand/databasefns.data.~2~ b/internal/test/env/program-analysis/hand/databasefns.data.~2~ deleted file mode 100644 index 45783f48..00000000 --- a/internal/test/env/program-analysis/hand/databasefns.data.~2~ +++ /dev/null @@ -1,22 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "19-Mar-87 10:54:40" {DSK}LIBRARY>NEW-FUNCTION.\;1 629 - - |changes| |to:| (VARS NEW-FUNCTIONCOMS) - (FNS NEW-FUNCTION)) - - -; Copyright (c) 1987 by XEROX Corporation. All rights reserved. - -(PRETTYCOMPRINT NEW-FUNCTIONCOMS) - -(RPAQQ NEW-FUNCTIONCOMS ((FNS NEW-FUNCTION))) -(DEFINEQ - -(NEW-FUNCTION - (LAMBDA (X Y) (* \; "Edited 19-Mar-87 10:52 by jpark") - (PLUS X Y))) -) -(PUTPROPS NEW-FUNCTION COPYRIGHT ("XEROX Corporation" 1987)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (390 545 (NEW-FUNCTION 400 . 543))))) -STOP diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~1~ b/internal/test/env/program-analysis/hand/masterscope.u.~1~ deleted file mode 100644 index 21c69286..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~1~ +++ /dev/null @@ -1,230 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" - (PROGN - (SETQ TEST-START (GET-INTERNAL-RUN-TIME)) - (SETQ MESS1 "Now do-test will determine if correct results have been returned for the analysis of user functions...") - (SETQ TEST-RESULT "{ERIS}TEST>PROGRAM-ANALYSIS>MASTERSCOPE.REPORT") - (DEFUN R-FORMAT (STATUS) - (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" (LISP-IMPLEMENTATION-VERSION) STATUS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-S (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE COMMAND LANGUAGE: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'SUCCESS (IL:DATE) IL:USERNAME)) - (DEFUN ITEM-FORMAT-F (COMMAND-LANGUAGE) - (FORMAT *OUTPUT* "~%COMMAND: MASTERSCOPE COMMAND LANGUAGE: ~A~%LISP VERSION: ~A ~%STATUS: ~A DATE: ~A TESTER: ~A~%" COMMAND-LANGUAGE (LISP-IMPLEMENTATION-VERSION) 'FAIL (IL:DATE) IL:USERNAME)) - (SETQ {CORE}WHO-CALLS "{CORE}WHO-CALLS") - (SETQ {CORE}PATHS "{CORE}PATHS") - (SETQ {CORE}DESCRIBE "{CORE}DESCRIBE") - (SETQ MASTERSCOPE-COMMAND-STRING -"; Reinitialize and Define functions to be analyzed -. ERASE -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -. ANALYZE TOP-FUNTION -. ANALYZE FUN-A -. ANALYZE FUN-B -. ANALYZE FUN-B1 -. WHO CALLS FUN-A1 -(IF (EQUAL * '(FUN-A FUN-B1)) (SETQ FUN-A1-CALL T) (SETQ FUN-A1-CALL NIL)) -. WHO CALLS TOP-FUNTION -(IF (EQUAL * NIL) (SETQ TOP-FUN-CALL T) (SETQ TOP-FUN-CALL NIL)) -. WHO CALLS FUN-A -(IF (EQUAL * '(TOP-FUNTION)) (SETQ FUN-A-CALL T) (SETQ FUN-A-CALL NIL)) -. WHO CALLS FUN-B2 -(IF (EQUAL * '(FUN-B)) (SETQ FUN-B-CALL T) (SETQ FUN-B-CALL NIL)) -(DRIBBLE '{CORE}WHO-CALLS) -. WHO CALLS WHO -(DRIBBLE) -(DRIBBLE '{CORE}PATHS) -. SHOW PATHS TO FUN-A1 FROM TOP-FUNTION -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) - -. WHO CALLS FUN-A1 -. ERASE FUN-A -. WHO CALLS FUN-A1 -(IF (EQUAL * '(FUN-B1)) (SETQ FUN-A-ERASED T) (SETQ FUN-A-ERASED NIL)) -(SETQ ALL-ERASED-FLG NIL) -. ERASE -. WHO CALLS FUN-A -(IF (EQUAL * NIL) (PUSH T ALL-ERASED-FLG) (PUSH NIL ALL-ERASED-FLG)) -. WHO CALLS FUN-B2 -(IF (EQUAL * NIL) (PUSH T ALL-ERASED-FLG) (PUSH NIL ALL-ERASED-FLG)) -. WHO CALLS FUN-B2 -(IF (EQUAL * NIL) (PUSH T ALL-ERASED-FLG) (PUSH NIL ALL-ERASED-FLG)) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -. ANALYZE TOP-FUNTION -. ANALYZE FUN-A -. ANALYZE FUN-B -. ANALYZE FUN-B1 -. ERASE FUN-A -. REANALYZE FUN-A -. WHO CALLS FUN-A1 -(IF (EQUAL * '(FUN-B1 FUN-A)) (SETQ REANALYZED-FLG T) (SETQ REANALYZED-FLG NIL)) - -. ERASE -;SET ARE SET - -. WHO IS CALLED BY TOP-FUNTION -(IF (EQUAL * '(FUN-A FUN-B)) (SETQ CALLED-BY-FLG T) (SETQ CALLED-BY-FLG NIL)) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (PROGN (SETQ X1 (1+ X)) (SETQ Y1 (1- Y)))) -. ANALYZE FUN-DESCRIBE -(DRIBBLE '{CORE}DESCRIBE) -. DESCRIBE FUN-DESCRIBE -(DRIBBLE) -. ERASE -; analyzing the file that contains describe results -(SETQ DESCRIBE-LIST '(| calls: 1+,1-| | binds: x,y| | uses free: y1,x1|)) -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN {CORE}DESCRIBE)) -(DO (( i 0 (1+ i))) - ((= i 4) t) - (READ-LINE DESCRIBE-FILE)) -(DOLIST (Y DESCRIBE-LIST) (IF (STRING-EQUAL Y (READ-LINE DESCRIBE-FILE)) - (PUSH T DESCRIBE-FLG) - (PUSH NIL DESCRIBE-FLG))) -(CLOSE DESCRIBE-FILE) -(DELETE-FILE {CORE}DESCRIBE) - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) -(SETQ CALL-LIST '(|fun-b -- (fun-b1 fun-b2 fun-b3)| - |fun-a -- (fun-a1 fun-a2 fun-a3)| - |top-funtion -- (fun-a fun-b)| - |fun-b1 -- (fun-c1 fun-a1)| - )) - -(SETQ WHO-CALLS-FLG NIL) -(SETQ WHO-CALLS (OPEN {CORE}WHO-CALLS)) -(READ-LINE WHO-CALLS) -(READ-LINE WHO-CALLS) -(READ-LINE WHO-CALLS) -(DOLIST (Y CALL-LIST) (IF (STRING-EQUAL Y (READ-LINE WHO-CALLS)) - (PUSH T WHO-CALLS-FLG) - (PUSH NIL WHO-CALLS-FLG))) -(CLOSE WHO-CALLS) -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN {CORE}PATHS)) -(DO (( i 0 (1+ i))) - ((= i 5) t) - (READ-LINE PATHS)) - -(IF (AND (STRING-EQUAL (READ-LINE PATHS) '|1.fun-a1 fun-a top-funtion|) - (STRING-EQUAL (READ-LINE PATHS) '|2. fun-b1 fun-b top-funtion|)) - (SETQ PATHS-FLG T)(SETQ PATHS-FLG NIL)) -(CLOSE PATHS) -(DELETE-FILE '{CORE}PATHS) -(DELETE-FILE '{CORE}WHO-CALLS) -(FORMAT NIL MESS1) -(DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IF (EQ TEST-ITEM T) (ITEM-FORMAT-S COMMAND-LANGUAGE) - (ITEM-FORMAT-F COMMAND-LANGUAGE))) -(SETQ TEST-END (GET-INTERNAL-RUN-TIME)) -(SETQ TOTAL-TEST-TIME (FLOAT (/ (- TEST-END TEST-START) 60000))) - -(DO-TEST 'MASTERSCOPE-TEST-RESULT - (PROG2 (SETQ *OUTPUT* (OPEN TEST-RESULT :DIRECTION :OUTPUT - :IF-EXISTS :APPEND)) - (IF (AND (EQ FUN-A1-CALL T) - (EQ TOP-FUN-CALL T) - (EQ FUN-A-CALL T) - (EQ FUN-B-CALL T) - (EQ PATHS-FLG T) - (EQ FUN-A-ERASED T) - (NOTANY #'NULL ALL-ERASED-FLG) - (EQ REANALYZED-FLG T) - (EQ CALLED-BY-FLG T) - (NOTANY #'NULL DESCRIBE-FLG) - (NOTANY #'NULL WHO-CALLS-FLG)) - (PROGN (R-FORMAT 'SUCCESS) T) - (PROGN (R-FORMAT 'FAIL) NIL)) - (PASS-FAIL 'WHO-CALLS - (NOTANY #'NULL WHO-CALLS-FLG)) - (PASS-FAIL 'SHOW-PATHS PATHS-FLG) - (PASS-FAIL 'ERASED (AND FUN-A-ERASED - (NOTANY #'NULL ALL-ERASED-FLG))) - (PASS-FAIL 'WHO-IS-CALLED-BY CALLED-BY-FLG) - (PASS-FAIL 'REANALYZE REANALYZED-FLG) - (PASS-FAIL 'DESCRIBE (NOTANY #'NULL DESCRIBE-FLG)) - (T-FORMAT TOTAL-TEST-TIME) - (CLOSE *OUTPUT*) - ) -) - -") - (IL:BKSYSBUF MASTERSCOPE-COMMAND-STRING) - ) -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~2~ b/internal/test/env/program-analysis/hand/masterscope.u.~2~ deleted file mode 100644 index 21f4995d..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~2~ +++ /dev/null @@ -1,220 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Somewhat Repaired: June 16, 1988 -;; -;; Munged (as little as possible) by Rene P. S. Bane June 24, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" -;; If the browser is already loaded, undo what the browser did so this testfile -;; will work properly, then redo it. This is relying on the browser to always -;; affect MSPATHS, because there is no official way of undoing the browser -;; (that I know of) - (IL:IF (IL:GETD 'IL:OLDMSPATHS) - IL:THEN - (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) - (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) - (SETQ TEST-SUCCEEDED T) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Hey, no problem!")) - -; Reinitialize and Define functions to be analyzed -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) - -(PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) - -(DRIBBLE '{CORE}WHO-CALLS) -(IL:MASTERSCOPE '(WHO CALLS WHO)) -(DRIBBLE) - -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) - ))) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) -(IL:MASTERSCOPE '(ERASE FUN-A)) -(IL:MASTERSCOPE '(REANALYZE FUN-A)) - -(PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (PROGN (SETQ X1 (1+ X)) (SETQ Y1 (1- Y)))) -(IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) -(DRIBBLE '{CORE}DESCRIBE) -(IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) -(DRIBBLE) -(IL:MASTERSCOPE '(ERASE)) -; analyzing the file that contains hopefully correct results -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) -;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters -;; expected. At least now it doesn't require the exact number of spaces....Rene -;; p.s. premature EOF will return a NIL so however John Parks meant to determine -;; if the test failed will still work, supposedly. I mean, true or false results -;; are still pushed onto DESCRIBE-FLG, for whatever reason they're supposed to be -;; pushed. -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) - (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Describe" - (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - )) -) ; close let - - -(CLOSE DESCRIBE-FILE) -(DELETE-FILE "{CORE}DESCRIBE") - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) - -(SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) -;; Another test which replaces the previous "throw away the first three lines -;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There -;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Who calls...? (analyzing)" - (AND - (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - )) -) ; close let - - -(CLOSE WHO-CALLS) -(DELETE-FILE "{CORE}WHO-CALLS") - -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - - -(CLOSE PATHS) -(DELETE-FILE "{CORE}PATHS") - -;; if the browser was loaded, reset MSPATHS so it looks loaded again -(IL:IF (IL:GETD 'OLDMSPATHS) - IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~3~ b/internal/test/env/program-analysis/hand/masterscope.u.~3~ deleted file mode 100644 index 79b9ec50..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~3~ +++ /dev/null @@ -1,218 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Massively munged by Rene P. S. Bane June 24, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" -;; If the browser is already loaded, undo what the browser did so this testfile -;; will work properly, then redo it. This is relying on the browser to always -;; affect MSPATHS, because there is no official way of undoing the browser -;; (that I know of) - (IL:IF (IL:GETD 'IL:OLDMSPATHS) - IL:THEN - (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) - (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) - (SETQ TEST-SUCCEEDED T) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Hey, no problem!")) - -; Reinitialize and Define functions to be analyzed -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) - -(PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) - -(DRIBBLE '{CORE}WHO-CALLS) -(IL:MASTERSCOPE '(WHO CALLS WHO)) -(DRIBBLE) - -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) - ))) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) -(IL:MASTERSCOPE '(ERASE FUN-A)) -(IL:MASTERSCOPE '(REANALYZE FUN-A)) - -(PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) -(IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) -(DRIBBLE '{CORE}DESCRIBE) -(IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) -(DRIBBLE) -(IL:MASTERSCOPE '(ERASE)) -; analyzing the file that contains hopefully correct results -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) -;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters -;; expected. At least now it doesn't require the exact number of spaces....Rene -;; p.s. premature EOF will return a NIL so however John Parks meant to determine -;; if the test failed will still work, supposedly. I mean, true or false results -;; are still pushed onto DESCRIBE-FLG, for whatever reason they're supposed to be -;; pushed. -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) - (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Describe" - (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - )) -) ; close let - - -(CLOSE DESCRIBE-FILE) -(DELETE-FILE "{CORE}DESCRIBE") - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) - -(SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) -;; Another test which replaces the previous "throw away the first three lines -;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There -;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Who calls...? (analyzing)" - (AND - (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - )) -) ; close let - - -(CLOSE WHO-CALLS) -(DELETE-FILE "{CORE}WHO-CALLS") - -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - - -(CLOSE PATHS) -(DELETE-FILE "{CORE}PATHS") - -;; if the browser was loaded, reset MSPATHS so it looks loaded again -(IL:IF (IL:GETD 'OLDMSPATHS) - IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~4~ b/internal/test/env/program-analysis/hand/masterscope.u.~4~ deleted file mode 100644 index 8430cac5..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~4~ +++ /dev/null @@ -1,216 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Massively munged by Rene P. S. Bane June 24, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" -;; If the browser is already loaded, undo what the browser did so this testfile -;; will work properly, then redo it. This is relying on the browser to always -;; affect MSPATHS, because there is no official way of undoing the browser -;; (that I know of) - (IL:IF (IL:GETD 'IL:OLDMSPATHS) - IL:THEN - (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) - (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) - (SETQ TEST-SUCCEEDED T) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Hey, no problem!")) - -; Reinitialize and Define functions to be analyzed -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) - -(PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) - -(DRIBBLE '{CORE}WHO-CALLS) -(IL:MASTERSCOPE '(WHO CALLS WHO)) -(DRIBBLE) - -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) - ))) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) -(IL:MASTERSCOPE '(ERASE FUN-A)) -(IL:MASTERSCOPE '(REANALYZE FUN-A)) - -(PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) -(IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) -(DRIBBLE '{CORE}DESCRIBE) -(IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) -(DRIBBLE) -(IL:MASTERSCOPE '(ERASE)) -; analyzing the file that contains hopefully correct results -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) - -;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters -;; expected. At least now it doesn't require the exact number of spaces....Rene -;; p.s. premature EOF will return a NIL, so that will count as failure as well. -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) - (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Describe" - (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - )) -) ; close let - - -(CLOSE DESCRIBE-FILE) -(DELETE-FILE "{CORE}DESCRIBE") - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) - -(SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) -;; Another test which replaces the previous "throw away the first three lines -;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There -;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Who calls...? (analyzing)" - (AND - (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - )) -) ; close let - - -(CLOSE WHO-CALLS) -(DELETE-FILE "{CORE}WHO-CALLS") - -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - - -(CLOSE PATHS) -(DELETE-FILE "{CORE}PATHS") - -;; if the browser was loaded, reset MSPATHS so it looks loaded again -(IL:IF (IL:GETD 'OLDMSPATHS) - IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~5~ b/internal/test/env/program-analysis/hand/masterscope.u.~5~ deleted file mode 100644 index 0e1e5c1a..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~5~ +++ /dev/null @@ -1,233 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Massively munged by Rene P. S. Bane June 24, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" -;; If the browser is already loaded, undo what the browser did so this testfile -;; will work properly, then redo it. This is relying on the browser to always -;; affect MSPATHS, because there is no official way of undoing the browser -;; (that I know of) - (IL:IF (IL:GETD 'IL:OLDMSPATHS) - IL:THEN - (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) - (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) - (SETQ TEST-SUCCEEDED T) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Hey, no problem!")) - -; Reinitialize and Define functions to be analyzed -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) - -(PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) - -(DRIBBLE '{CORE}WHO-CALLS) -(IL:MASTERSCOPE '(WHO CALLS WHO)) -(DRIBBLE) - -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) - ))) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) -(IL:MASTERSCOPE '(ERASE FUN-A)) -(IL:MASTERSCOPE '(REANALYZE FUN-A)) - -(PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) -(IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) -(DRIBBLE '{CORE}DESCRIBE) -(IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) -(DRIBBLE) -(IL:MASTERSCOPE '(ERASE)) -; analyzing the file that contains hopefully correct results -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) - -;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters -;; expected. At least now it doesn't require the exact number of spaces....Rene -;; p.s. premature EOF will return a NIL, so that will count as failure as well. -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) - (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Describe" - (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - )) -) ; close let - - -(CLOSE DESCRIBE-FILE) -(DELETE-FILE "{CORE}DESCRIBE") - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) - -(SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) -;; Another test which replaces the previous "throw away the first three lines -;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There -;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene -;; JRB - a feature of who calls who is that the order in which the calling information -;; comes out is dependent on the order things got analyzed in. Things get reanalyzed -;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. -;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR -'' between two lists of strings; yuck**2. -(LET (ALL-LINES NEXT-LINE) - ;; First suck in the lines - (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) - ;; Then compare them - (PASS-FAIL "Who calls...? (analyzing)" - (NOT (SET-EXCLUSIVE-OR ALL-LINES - '("top-funtion--(fun-afun-b)" - "FUN-B1--(FUN-C1FUN-A1)" - "FUN-B--(FUN-B1FUN-B2FUN-B3)" - "FUN-A--(FUN-A1FUN-A2FUN-A3)") - :TEST #'STRING-EQUAL)))) -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Who calls...? (analyzing)" - (AND - (STRING-EQUAL "top-funtion--(fun-afun-b)" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "FUN-B1--(FUN-C1FUN-A1)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-B--(FUN-B1FUN-B2FUN-B3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - (STRING-EQUAL "FUN-A--(FUN-A1FUN-A2FUN-A3)" (DELETE #\Space (READ-LINE WHO-CALLS NIL NIL))) - )) -) ; close let - - -(CLOSE WHO-CALLS) -(DELETE-FILE "{CORE}WHO-CALLS") - -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - - -(CLOSE PATHS) -(DELETE-FILE "{CORE}PATHS") - -;; if the browser was loaded, reset MSPATHS so it looks loaded again -(IL:IF (IL:GETD 'OLDMSPATHS) - IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~6~ b/internal/test/env/program-analysis/hand/masterscope.u.~6~ deleted file mode 100644 index 4c36136c..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~6~ +++ /dev/null @@ -1,220 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Massively munged by Rene P. S. Bane June 24, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" -;; If the browser is already loaded, undo what the browser did so this testfile -;; will work properly, then redo it. This is relying on the browser to always -;; affect MSPATHS, because there is no official way of undoing the browser -;; (that I know of) - (IL:IF (IL:GETD 'IL:OLDMSPATHS) - IL:THEN - (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) - (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) - (SETQ TEST-SUCCEEDED T) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) - IL:ELSE "Hey, no problem!")) - -; Reinitialize and Define functions to be analyzed -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) - -(PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) - -(DRIBBLE '{CORE}WHO-CALLS) -(IL:MASTERSCOPE '(WHO CALLS WHO)) -(DRIBBLE) - -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) - ))) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) -(IL:MASTERSCOPE '(ERASE FUN-A)) -(IL:MASTERSCOPE '(REANALYZE FUN-A)) - -(PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) -(IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) -(DRIBBLE '{CORE}DESCRIBE) -(IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) -(DRIBBLE) -(IL:MASTERSCOPE '(ERASE)) -; analyzing the file that contains hopefully correct results -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) - -;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters -;; expected. At least now it doesn't require the exact number of spaces....Rene -;; p.s. premature EOF will return a NIL, so that will count as failure as well. -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) - (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Describe" - (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - )) -) ; close let - - -(CLOSE DESCRIBE-FILE) -(DELETE-FILE "{CORE}DESCRIBE") - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) - -(SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) -;; Another test which replaces the previous "throw away the first three lines -;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There -;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene -;; JRB - a feature of who calls who is that the order in which the calling information -;; comes out is dependent on the order things got analyzed in. Things get reanalyzed -;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. -;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR -'' between two lists of strings; yuck**2. -(LET (ALL-LINES NEXT-LINE) - ;; First suck in the lines - (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) - ;; Then compare them - (PASS-FAIL "Who calls...? (analyzing)" - (NOT (SET-EXCLUSIVE-OR ALL-LINES - '("top-funtion--(fun-afun-b)" - "FUN-B1--(FUN-C1FUN-A1)" - "FUN-B--(FUN-B1FUN-B2FUN-B3)" - "FUN-A--(FUN-A1FUN-A2FUN-A3)") - :TEST #'STRING-EQUAL)))) - -(CLOSE WHO-CALLS) -(DELETE-FILE "{CORE}WHO-CALLS") - -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - - -(CLOSE PATHS) -(DELETE-FILE "{CORE}PATHS") - -;; if the browser was loaded, reset MSPATHS so it looks loaded again -(IL:IF (IL:GETD 'OLDMSPATHS) - IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~7~ b/internal/test/env/program-analysis/hand/masterscope.u.~7~ deleted file mode 100644 index e572bb2e..00000000 --- a/internal/test/env/program-analysis/hand/masterscope.u.~7~ +++ /dev/null @@ -1,220 +0,0 @@ -;; Function To Be Tested: . (MASTERSCOPE) (Program Analysis) -;; -;; Source: Lyric Release Overview (Lyric Beta Release) -;; Section 19 (Masterscope), Page 22 -;; Section: Program Analysis -;; -;; Created By: John Park -;; -;; Creation Date: Feb 25, 1987 -;; -;; Last Update: March 26, 1987 -;; -;; Massively munged by Rene P. S. Bane June 24, 1988 -;; -;; Filed As: {ERIS}test>program-analysis>masterscope.u -;; -;; -;; Syntax: . &rest LINE -;; -;; Function Description: Make a MASTERSCOPE query. Masterscope is an interactive -;; program for analyzing and cross referencing user programs. It contains -;; facilities for analyzing user functions to determine what other functions are -;; called, how and where variables are bound, set, or referenced, as well as -;; which functions use particular record declarations. Masterscope is able to -;; analyze definitions directly from a file as well as in-core definitions. -;; This test is almost identical to the masterscope as an exec command, which is -;; located in {eris}test>exec>masterscope.u -;; -;; Argument(s): Masterscope commands (SEE IRM, Vol 3, Section 19) -;; -;; Returns: (SEE IRM, Vol 3, Section 19) -;; -;; Constraints/Limitations: Due to the nature of Programmer's Assistant commands, -;; testing them will be performed using do-test and the interlisp function bksysfuf. -;; Comments or messages are incorporated within -;; each command file, which will be run by using the function bksysbuf. -;; Each test setup is titled "MASTERSCOPE-TEST-SETUP", which executes the command -;; string. The do-test form within the command file will return T or "test -;; failed" This test file requires TEDIT and MASTERSCOPE package -;; The tree structure of the functions being analyzed are as follows: -;; -;; Top-Funtion -;; | -;; Fun-A------------------------Fun-B -;; | | -;; --------------------- -------------------- -;; | | | | | | -;; Fun-A1 Fun-A2 Fun-A3 Fun-B1 Fun-B2 Fun-B3 -;; | -;; -------------- -;; | | -;; Fun-C1 Fun-A1 -;; -;; Messages will be printed before each command in the command files is executed -;; for user monitoring. Test result is logged on -;; {eris}test>program-analysis>masterscope.report - -(DO-TEST "MASTERSCOPE-TEST-SETUP" -;; If the browser is already loaded, undo what the browser did so this testfile -;; will work properly, then redo it. This is relying on the browser to always -;; affect MSPATHS, because there is no official way of undoing the browser -;; (that I know of) - (IL:IF (IL:GETD 'IL:OLDMSPATHS) - IL:THEN - (IL:MOVD 'IL:MSPATHS 'TMP-MSPATHS) - (IL:MOVD 'IL:OLDMSPATHS 'IL:MSPATHS)) - (SETQ TEST-SUCCEEDED T) - (DEFUN PASS-FAIL (COMMAND-LANGUAGE TEST-ITEM) - (IL:IF (NOT TEST-ITEM) - IL:THEN (FORMAT *ERROR-OUTPUT* "Test ~s failed~%" COMMAND-LANGUAGE) - (SETQ TEST-SUCCEEDED NIL) (BREAK "Argh!") - IL:ELSE "Hey, no problem!")) - -; Reinitialize and Define functions to be analyzed -(IL:MASTERSCOPE '(ERASE)) -(DEFUN TOP-FUNTION NIL (AND (FUN-A) (FUN-B))) -(DEFUN FUN-A NIL (OR (FUN-A1) (FUN-A2) (FUN-A3))) -(DEFUN FUN-B NIL (OR (FUN-B1) (FUN-B2) (FUN-B3))) -(DEFUN FUN-A1 NIL T) -(DEFUN FUN-A2 NIL NIL) -(DEFUN FUN-A3 NIL T) -(DEFUN FUN-B1 NIL (AND (FUN-C1)(FUN-A1))) -(DEFUN FUN-B2 NIL NIL) -(DEFUN FUN-B3 NIL T) -(DEFUN FUN-C1 NIL NIL) -; Start analyzing functions in top-function -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) - -(PASS-FAIL "Who calls FUN-A1" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(PASS-FAIL "Who calls TOP-FUNTION" (NOT (IL:MASTERSCOPE '(WHO CALLS TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-A" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) '(TOP-FUNTION)))) - -(PASS-FAIL "Who calls FUN-B2" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) '(FUN-B)))) - -(DRIBBLE '{CORE}WHO-CALLS) -(IL:MASTERSCOPE '(WHO CALLS WHO)) -(DRIBBLE) - -(DRIBBLE '{CORE}PATHS) -(IL:MASTERSCOPE '(SHOW PATHS TO FUN-A1 FROM TOP-FUNTION)) -(DRIBBLE) - -; ERASE (erase all information about the functions in SET from the database) -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "All info erased" (NOT (OR (IL:MASTERSCOPE '(WHO CALLS FUN-A)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B1)) - (IL:MASTERSCOPE '(WHO CALLS FUN-B2)) - ))) - -; REANALYZE (causes masterscope to reanalyze the functions in SET) -(IL:MASTERSCOPE '(ANALYZE TOP-FUNTION)) -(IL:MASTERSCOPE '(ANALYZE FUN-A)) -(IL:MASTERSCOPE '(ANALYZE FUN-B)) -(IL:MASTERSCOPE '(ANALYZE FUN-B1)) -(IL:MASTERSCOPE '(ERASE FUN-A)) -(IL:MASTERSCOPE '(REANALYZE FUN-A)) - -(PASS-FAIL "Reanalyzing" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO CALLS FUN-A1)) '(FUN-A FUN-B1)))) - -(IL:MASTERSCOPE '(ERASE)) - -(PASS-FAIL "Called-by (reanalyzing too)" (NOT (SET-EXCLUSIVE-OR (IL:MASTERSCOPE '(WHO IS CALLED BY TOP-FUNTION)) '(FUN-A FUN-B)))) - - -; DESCRIBE SET (prints out the bind, use freely and call information) - -(DEFUN FUN-DESCRIBE (X Y) (SETQ X1 (1+ X)) (SETQ Y1 (1- Y))) -(IL:MASTERSCOPE '(ANALYZE FUN-DESCRIBE)) -(DRIBBLE '{CORE}DESCRIBE) -(IL:MASTERSCOPE '(DESCRIBE FUN-DESCRIBE)) -(DRIBBLE) -(IL:MASTERSCOPE '(ERASE)) -; analyzing the file that contains hopefully correct results -(SETQ DESCRIBE-FLG NIL) -(SETQ DESCRIBE-FILE (OPEN "{CORE}DESCRIBE")) - -;; Yeeuck. Awful test, relies on Masterscope returning exactly the characters -;; expected. At least now it doesn't require the exact number of spaces....Rene -;; p.s. premature EOF will return a NIL, so that will count as failure as well. -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE DESCRIBE-FILE NIL 'EOF)))) - (NOT (SEARCH "calls" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Describe" - (AND (STRING-EQUAL "calls:1+,1-" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "binds:X,Y" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - (STRING-EQUAL "usesfree:Y1,X1" (DELETE #\Space (READ-LINE DESCRIBE-FILE NIL NIL))) - )) -) ; close let - - -(CLOSE DESCRIBE-FILE) -(DELETE-FILE "{CORE}DESCRIBE") - -; analyzing the file that contains the previous masterscope interactions -; (who calls?) - -(SETQ WHO-CALLS (OPEN "{CORE}WHO-CALLS")) -;; Another test which replaces the previous "throw away the first three lines -;; no matter what" and ignores spaces. See comment for the DESCRIBE test. There -;; MUST be a better way! And >>I<< didn't spell "funtion" that way....Rene -;; JRB - a feature of who calls who is that the order in which the calling information -;; comes out is dependent on the order things got analyzed in. Things get reanalyzed -;; by Masterscope itself all the time, in whatever order Masterscope feels like doing it. -;; What you really have to do here is suck in all the lines and do a SET-EXCLUSIVE-OR -;; between two lists of strings; yuck**2. -(LET (ALL-LINES NEXT-LINE) - ;; First suck in the lines - (IL:WHILE (NOT (EQ 'EOF (SETQ NEXT-LINE (READ-LINE WHO-CALLS NIL 'EOF)))) - IL:DO (PUSH (DELETE #\Space NEXT-LINE) ALL-LINES)) - ;; Then compare them - (PASS-FAIL "Who calls...? (analyzing)" - (NOT (SET-EXCLUSIVE-OR ALL-LINES - '("top-funtion--(fun-afun-b)" - "FUN-B1--(FUN-C1FUN-A1)" - "FUN-B--(FUN-B1FUN-B2FUN-B3)" - "FUN-A--(FUN-A1FUN-A2FUN-A3)") - :TEST #'STRING-EQUAL)))) - -(CLOSE WHO-CALLS) -(DELETE-FILE "{CORE}WHO-CALLS") - -; analyzing the file that contains the masterscope interaction (show paths) -(SETQ PATHS (OPEN "{CORE}PATHS")) - -(LET (NEXT-LINE) - (IL:WHILE (AND (NOT (EQ 'EOF - (SETQ NEXT-LINE (READ-LINE PATHS NIL 'EOF)))) - (NOT (SEARCH "top-funtion" NEXT-LINE :TEST #'STRING-EQUAL)))) - (PASS-FAIL "Show paths (would-be graph)" - (AND - - (STRING-EQUAL "1.FUN-A1FUN-ATOP-FUNTION" (DELETE #\Space NEXT-LINE)) - (STRING-EQUAL "2.FUN-B1FUN-BTOP-FUNTION" (DELETE #\Space (READ-LINE PATHS NIL NIL))) - )) -) ; close let - - -(CLOSE PATHS) -(DELETE-FILE "{CORE}PATHS") - -;; if the browser was loaded, reset MSPATHS so it looks loaded again -(IL:IF (IL:GETD 'OLDMSPATHS) - IL:THEN (IL:MOVD 'TMP-MSPATHS 'IL:MSPATHS)) - -TEST-SUCCEEDED - -) - -STOP - - - - diff --git a/library/.readme b/library/.readme deleted file mode 100644 index 27b19e6c..00000000 --- a/library/.readme +++ /dev/null @@ -1 +0,0 @@ -The directory {ERIS}Library>... is only for modules that Xerox supports and which are released to customers. For internal-use-only modules, see {ERIS}Internal>Library>. \ No newline at end of file diff --git a/library/CASH-FILE.DFASL.~1~ b/library/CASH-FILE.DFASL.~1~ deleted file mode 100644 index 0d23898e67b1066d5cbe49488e2c1a6bb0cdd197..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4831 zcmb7I-E$My72jRS`mm8LgNZ3n5H_|TWfKe@0+bzzj*^#%uJ7RTvFQc`4ZquEcY>9(P{MmBHhisXIV zOup*4S~08HS=B6-%I>RPGdYo3t*xlb)n8VZ35c5tw(ve_#-__f-8HSEw=Or7?_^701~kdiJ0ATcZPHi1QjNC0CSs0M2PSRoq_2QW1(c( z?l`*9l5NeKStALUq5uIuOQ8e!k?80QQ=AASadJx*PI1UdflWOV-4>qk)}uhBzo5+- zYG)4*$OJ2BoX`)(#Rz1H8N=NvvW>zHQLqg!>g$}LmRPVS5ailC7b8cy&ws^Rk9q4o zutF|*>xwwgJqQ+lC|3z9`=2wgbG9Vp*}`Zf{laCPHCZ+Hz-8>lV zc75bU-y^~UYOo$z4)P^d#1C*51lldfSdi$U=-moZ0{3_Y1^XVPAD<_w4)MFf{h~N{ z9KJg+*5Q(xHT1k@8!AFsBb+HVBhDqqH43}H&mp)S{Ine-t9BMe&S7LP%~p{+kcfk! zNhGvH*N9=iF4Cizp6skvt*KdL)!ia3i*)E9B~}DkT7tKuB?}ZbY!)cuI=A6g8xhxs ziGA1o|ERaV5Bn-53Wrad!`o8~IF5aaTAuhF#&}PgdC1Y+RUPxP&rSq(o4SElI7fA& z1P8_12sIiWZPB_kRj^XjkO(q3q+hp6m%5{;AvM^(h*)W0k6zx8?~l7;5eo)_ecJjV z8h=4^qh!I1Vc!)?m^id!Vq1I6uG4I~KHP@*`Sv~AhGEuPL#*8uH^lKqL)?T?3LF*F zblq?q%SJz5vW={%BcV4M4e5b6hMOmr`I^X+l*BPKGT#{#gt#Nwg_5kmZ_M8j=AnNH zy|jx>e%8grgV6bqfm?hEisw{LE-Ep}D!FC>p0S-lOxY7mY3qvHXPdmEcW79ocQL6X z=wE~WcUY4{@|V%Yhl`sZRUR&F29igMk3XtBT6!Evo-987sPbg#X*&$`CfHprA-m?19DGo)ptR#%B#U@M;}hj&s>0Uk|;Lml^1Y>kSMH^hff#~b73^F7?$m$}&>^Y6g? zT;`$gzt$Q5bpi@*C;Eo7cauqc;#robRHVc3Hv0&8+G=8nA0{lV2F z??==QAf@YbDo6daX6D03S&u*L5$S|ThlwH&5FYoX6B_5UOoX6(7V#Ttfmy?kOZUu1 zu9eJ01{GYWg3~Axw#P4E|F==E@&tWKsO5LCRwkH#)@&D zA5%eh7oF=16O1hUHVRQUgnYpg5~w#R{c$3L_c)t`UK6zuC_KQKG{{sjDCQS%9a@Uj zNZO|yS=fVeN6YU6alq0pCc?mWC( zdB~j%KYc22mmgZt4Xo8V)*h9&hg=w>>9V*h*jTa8L@aEJ+BE;zJV91+8QNtfo37b2 zWvWJ0!?rD3RN`~K=^8hWFL3kZ3^z|FxY-yNu@v{bVG3-1N$D3c!e9&-{3@fh$j>M+ z_ZQ^NoFZTT^JvS-Tjo3D(SL1BEgqGXq{)+(sM}r~2^RlY-kek9N154s=5KkK<`)sO z8zwLD_mIR`I3NVz2~j@kF2z4?#>XiGTevyBW)w8n%6T_>Rm|q;dj3gap6;0$VltKI zT~JMe2ywpt5SqqeVGgkUf9r)jin%m3{8OQ4M0#B4bl(FD16UmFm^0<;oSAAVKLrLG zfS`-PFDTsXnb-1VLm3jYeWVptuU%Tnt%JsK(1FfDjN8KJZJ;T`jU&S;tz?7ru=5;c zkC^MF{pk(lh5hL*Z7|>_Z%=7rFI8hGn^W6fWyq_3evtbBPLfgr%|gjCk896RBEpcx z7~x}LW8J4pTlsKs4)<>O^hdtd9(LyJ-^?+;E}M{>FwYEqr+M-bC=x-DZn#GD4Utww zdOz`2x5`C#FFW#alA9-Sk>*SPftZDIKbmSMaaM*cZ;6!ueDjy#RzJ+-m8W=oE0b$G zcr(+Uu>XEx5w#oRIc4Cgh+9ROWXZP~VViC!`y zd6AwH=_4Y&SEPH1%EfX4|S`uXDPqmpZ@l@6I9oDg=)RXJA-`QzaxGlg-}h0#9_?fxV6oh zoC}H9{N8-^)><_+o?58ZYrn=si)wy5i z{Lb&3dv@xu)|va@!upN+ z#g*FS%F4x+E7glD%Qsdp*Xq=HyI!fkcTv}zoH}jhjTe7(W+dTst-oBaR@SOlQX>-+ z>g@V;_1w#;iOKV?ymEeWawIXWIeGt>&NQd8wqCzddGB;;;#|t9uC7(Dy$$WoynN>6 z)2TBPSa$x0XGaoG|LEOQMr#uOu67=M)EgX>SsbSyNlB5t&1OHTrrU<*8ri(1E0TAo znS8-!J*3|l3msPth$#45YkGJB7bB1*W(;??$TkYQM8P(^sIPN|T4KS0K#*(mT#TIPKL0syBj#=N zzzVtKZ7AYM_aIy(4nqoXdM=eM7jBM+lC|3z9`=2wgbG9V`yPunrFYG+a897Yb(Y!$f!i8vUV zL_$k+jTrVzB0Y-f$6jQ6yehaAma)iK}j*@?hzQ#bGm=crDU z;GkF=p+>`_En1hR3Ra355u{(MiQiJV_h}8!6=;aOh{!5N z@s~6=N*2r*_ARlDi9@?4wzbFXI?bl*!)=IP?A)_$7-p?E#QH7qu6VxD5Z9oT0!PI( zT{j%ZveA#1Y$I#xNa&45L%J_c;pT~Dz9RA@C2Qw{`E+PdQQ*&*-f9U2zteM~9| z`q!ZUP1fX?{6%!>!P3_4%7f*tK=N?u(e28^A#a|1x9&*z7 zoUsV3eJ-NY#Y7UbyT}(E-bp+y#JBApQFFj3?_!sDKFTH}0{i4c@uNBl-wVAk+s@vhm( zwUU|0pn?mv&Hy5JXB{FT<1AsTjY`J( zf{}&aMj`5kkS|z50`(@PKTc%u9%qx#i=s9Hg$Fp32AL`b#ry)ULrbw1 zN&A!|3wu!RX!%1RZW!gDyPrC=d%~xq&q|L-a1xd*RNwvPPb2ozEc8X3I}dJE z9&jhaPoE0h<%bq@18cR8wI}7BAr}T|x-9MrHdgFY5ewU*HqAe_PLq{fhIU!Wrfc?0 znW_=hux-m0mH3=*y2j0;3*0<@m76CM+-#1ESc-ezFa^ex1=;KfQtM*`MCh1_N&L_LL?LQZ+M2e}X6Bq=4(ER-zsxb_SsA`DrK z5k4k1)_tn9l@AB!aPM88{>azbgU+18TRG;}8z$r?%risZX`XxnibPPP8?F(3O{7(k zK1{sTt#Z*l$c}uJPP1eP6rP2`d;ISEx|^`!vqUdAoqY0=m^+1^;k@R!1E4FaE!)->=_MnQ z7wIXHJ|WTvMY@-$Tr3wrey3&29BeuJzXIKcS!y|2%)z7IMV>RHB$z`=o?saN5%~ci z=I%eAjW2O(gs)4+ZqG|TOZol&m2ZDLL3NE+sMd?TGsx%tJK{G|2-S2*9LEffTicw; zxsZ6x@6A`QuUAv!sfB92_8WX3;#~+dy;x diff --git a/library/CASH-FILE.DFASL.~3~ b/library/CASH-FILE.DFASL.~3~ deleted file mode 100644 index 7095e6487289d2a504331fe71d65dd0d134dc897..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4831 zcmb7I-E$My72jRS`mm8LgNak1LD<-WlqJ}>2~dV;y;@sqOIl@j`o@xPH5S zX{C0pvT|wVdiB!E^6k}YwK{dK)+_b5FX@_-Q)kS)ar#G-BMGN#{k3|vvR1vG8kv|- z=hknj=g*`jrY@X4dtqv7Br&5odH`&4S;e9Eb=u2pYdg?5u?CeNHo zO-@|+;pBz06C;TyfAk(GqcsVCH#(0#>J1LcERNHUq@>8+X0xAE(``d@jcnf170J8T zOup#2S~08HS=B6-%I=F^GdYo3tF5Xl)n8Rt2#A{sw(ve|#%9Vz-8HSEw;?x_?_o1wCU-NODLZ7O@s z$h*b$m6i7-ASGQ4Kw@whsU7YP6Hb1YA@jRD)JsE22`WtO0p>Q1h!EisdKsoijKz{= zyW{9aOSZLOW{o6ZiUI`uEQJo^N1~%MOmQNR#K|pLIK?3+1vd3ebX$1J+lT^{{(?4d zsGU7LAQP;haY8>B7bB1*W({|*$TkXlM8P(^sIPN|T4KS0K#*(mT#Ov+KL0syBj#=N zzzVtKZ7AY!_aIy(4nYcVdR{AAF5DayqvE(26XPN+PKc9xW)q6G@md+o!AR#!uQ|}^ zpUzV3kn`^~``~=FO_*Kt1Iy_6&1SFT+GX7>+lC|3z9`=2wgbG9Vu^cU8hT!{4HcoR5zZ8w5$Cew8ijq}=MdZue%g+aRXd9!=P`1SW~;~@NW{U= z6cSpZYs9c$66sM)Pj*(T*7O{*>VA=yMLKkZ5-Wl%Ey3H-k_8GIHVYJSgWGVcjffk= z#J(H;f7IJ}9{VaK3WtxH!@E-qIF5aaTAuhF#&}PgdC1Y+RUPw+&rSq(o4SElI7fA& z1P8_12sIiWZPB_kRj^XjkO(q3q+hp6m%F2AK-KmW_VAWE)viM?!Bj8q%lY1a6*K<|`skQW7W7$b4r|5aNzx7fP}MzcGJDn1}u) z^vo_c`FR%;k3i=a4BX<=P&}t{a#4v%R>?IB@Qm#YV#C2_p`*(g< z`EnV}8>Icw*ONQurj^VMNjvjs=Z2J>0^0mgc*p8Tr#KYZv63*h7MGOwpWv^BS`RsC zeBQVWtbHz`)5Sy*v%AO_9o|Vj1$Zs@9dC@APY!VNK;~wX%zp>w z=Q3Nq1Mh!!Xqk=5@pH*fB3GrI&;IUPwV3%@fxj(p? z6FI#EE6FpzmE8gw8*UC$L0HG zBiBl1B7+Jp)Iu-Ron0wGxhTX6Ub81_l-yj1YM022WfwG;h}B!v3Lp-y!`Wf{jFmJu zMXq9|>I~J%wOgs*YL}SDqdr1hJw3a|qBMI1X;!z2RD`;zy*DZu z=a*L~H|ccSLW(sDR0t&~owiq&L_*mwbXn+BUMd)lwTDDS=n2X!I-nZ`bW^NXMq|ae z&yVS#yN}NGg$YI$ejA0T8$!Nd2?^Ajl>Ru8!F!xdLZ?M-1PTvuCJi!G42t;$T!)ro zEt2*rM;7*=+|lySgScUogYJIn(C!JJjy@|rBEfN3vRHlVn?J26OFqP`@C%{OO~7$08QCMQw(EY@Z@4xeV>Hl1I1()WiM&0p$PY7f_stJ@ndTP} zbDJhF@%NC#SU4aA;0aMa>Mq6aHRI!yfi2veUNZ`sYvsHfy(Z@JbUpvHut4|BEHRnN z^Dd~SK!iA7e+W(Es4xfE{=fA?9>rXm8vdEkGa@}Mbh__>g#j#%bj+Fdb9t6SxwdypOZD9O#^xJdJ*|EZXRazCDKCvjGWEpLgG|9tb8;Z{G) zB6*RX7U^RmeNd!(iOR)t0pxdDw#>tpbN?&QZJ4E&qs2Tt`d#FiBqhNdQt}wX_>agB z05Ny}`D}cNQzLv`GImeB`yh62JkwU1ZL*giAaNOGF zY|e$mYkqH`dTYI!8c!`&>$TtDD^q>7RI7#X(uz_kMNM0&iJ8!Lm%76&g8Wn_jk@pS^-X`g_*rq=YE~@ zJHK=8*}W~rmi2r}uU*?%Td&qrwXMyKtY|NJo>0NG$gY)PCt^8B6~Z{0n$ph4b3&Oc}rI$@1th&X~)%y zSX0cRupZ1!`snlj|LtU@_vbs(XTvM=x_i-~eS1#(VX%)R~xuJX?8z!^HoLMy3 zS}dQllGrh9m5id&hXoO<>|)CZy78=O8@yO~(%TM`1bSp$Z8mRs%@DwcC|c6=MQz^j zwnN@0&0cKY7TorlL(7J3Evvd!C|E@`Z#pHf8Sh|COFnLf$_{o5`-8Np>@_3r7q`~e zKahZwbSVId!C|EKxjRZY`CW$0@A6PD4J9S0Fmni)8#E$9gh%Lkm>w~fOP1|Uq8lyQ z){>bul7J}+5b(1UI)NXFj?OT}i9ix3w`AcIhny7H)HBs>;RSCy3RDIP+M=O$_V9pA zu!6=3{a{?2fh;j^xQ9iyQ8*+Dw&6v6oio%D3x)$hu1#@q=5+V@Pk7rgZ@ULp$R%%E z5huC_;UX~xDZuG@wQRX?b5x9rvtmL_inKT<&L5ghDB8xWWiSULoin}WV5k2~mLi9o z|539K&R5%nIWRx4jE>)F_ByUz*4?sgI3n$f;%#m_z$-aXvd!W_$arCVNwZC&EYB)h zE=aF-lmSZH5%G#|6TuF*cVjFj{j+);!<}=)1mZxvf_cXa){>#RmYPFEsMehNYS}0o zjCsG7&C-aj={a9AkTvq^oNbZ!d>M@2X@-ek{`Mop5TcZ76qiifDi(~QizzXZxho|@ zoazH(y-yXddF*H|+G$Sx-)WA6>of;T5HXL9py_XqAmxO3u}{oM;U~IzFx2h($Wh-T z!UJls9$60ZHCDtAa25pGt;bl9=%MJ{4^jg6cm)OfFw&3DlT?TJUEzLNoIDTTotWrw zNzEF1Ub77qp{x7KlnKUw}YRyV`SCNqR2}aIZm@x9l@f)+C(Y4=DFz(JK1D50{0?Khr_DU%Xzr?x`I^s81a_Ocfmb+3b)p0Z#o7op z8Xj%Yx-V6*Qq+(LGB{*Fw@NGB(bJF`Y+podG_Xf6Z^-w@O|gmvgTX#+{Sb}6pt(`9 zVBWBAiZx6eIW)1YJ!aQwHeDZXL;U>Uo^8W0YpWr)Zi;ur`9?!rgHj3{71MOxa2(4< zKVGtptf?cRHyRD;jyQ*#Czkn|$di=BIW#ig85D%LBiV(LtiW%~-!sfZ{}Os^7n}U7 zi-{+p^HT;;Ub+zCN)3yUJH=)4HN5cEo06N8y$i9_?v9-9QeE0}|E!29*Nt27l3b6LM zh)x$1NzCpdUvzjU^%UUIWH{7uKgHI#IP-$|5bAgn+T)zLkSk;G7l9PgeDAo&_rNO4#vDEA8>zgHOXU$+Cijr zeNpA8pVQ2I_$=%3hhdRUh;*1JatGn@nRG$pe3pq2ln*0*BP}y)__1=^Y~)(WOk_~O zg<9x^y0a@KC>MoT!E5$pjgp%SQSB0$v+RQA60v%VS^>ntbvQqYpRtnW=18OrimezJ zLU+jcCB1TERh^>>xpqDE8|^alc-%*btEb1;Sd?Z@BF*Ynk%~|^b@)alro%8`XV zD0j5{lOS#w<)C|vI<$Mjr=!nGk4SJ9mMmA_`Q}gS%Bl}BEBsXG%Q$y-Z&r4>li{aN z1@7`g3%Y@|TF2V6^1+Y`gEUY(60`P<=A9a`FA2s8Xlz}bWoL(~unrr2}8@(bH@^n4_q_9Ny%serf%JVL$Wxn7wv?X*gAG8?#o!|f zH+z<}eA!SllwMb&GUR&wj0NgQ;da}eXU{COK_%5am&a7ruLAUzyDM;R82y|h2Q zfgIVN-qMBwZu0h&CXQ1zhO#+z;8lja>gNZ!58xyzCD1ICEK9id3?(8ASxgWk(07_ApN1k46zPU*L|+hTRiwv=x4Km> zy2sg(_mbS)kBc;4`gg5Y-LIBRARY>COPYFILES.;5| 22454 changes to%: (VARS COPYFILESCOMS) (FNS DOSLINKER SHORTEN) previous date%: "26-Jan-93 20:53:23" |{PELE:MV:ENVOS}LIBRARY>COPYFILES.;4|) (* ; " Copyright (c) 1989, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COPYFILESCOMS) (RPAQQ COPYFILESCOMS ((FNS COPYFILES MAPFILES MAPFILES1 COPIEDFILENAME COPIEDFILEPATTERN COPIEDFILEMATCH COPIEDFROMSPEC COPIEDTOSPEC ESPATTERN NOHOST COMPAREFILES) (COMS (* ;; "For concatenating a list of files into one file.") (FNS CONCATFILES)) (COMS (* ;; "For splitting a big file into several files.") (FNS SPLITFILE)) (COMS (* ;; "For making DOS file systems") (FNS DOSLINKER SHORTEN)) (I.S.OPRS INFILES))) (DEFINEQ (COPYFILES (LAMBDA (FROMSPEC TOSPEC OPTIONS) (DECLARE (SPECVARS FROMSPEC TOSPEC)) (* ; "Edited 27-Sep-89 15:07 by bvm") (* ;; "Copies the files specified in FROMSPEC to the destination in TOSPEC. Which versions get copied, whether to copy old files, etc. is controlled by OPTIONS.") (SETQ TOSPEC (\ADD.CONNECTED.DIR TOSPEC)) (SETQ FROMSPEC (\ADD.CONNECTED.DIR FROMSPEC)) (LET ((*UPPER-CASE-FILE-NAMES* NIL) (COPYFILESOUTPUT T) (COPYFILES.WHENTOSKIP (FUNCTION ILEQ)) (COPYFILESALWAYS T) (COPYFILESVERSIONS NIL) (COPYFILESASK NIL) (COPYFILESASKDEFAULT) (COPYFILESREPLACE NIL) (COPYFILESPURGESOURCE NIL) (COPYFILESPURGE NIL) (COPYFILESTERSE) (COPYFILESTOSPEC (COPIEDTOSPEC TOSPEC)) (SECONDARYSPEC) (COPYFILESFN (QUOTE COPYFILE)) (COPYFILESSKIPFN (QUOTE NILL)) (DONTCOPY) COPYFILESFROMSPEC) (DECLARE (SPECVARS . T)) (for X inside OPTIONS do (* ;; "Run thru the options, turning them into internal flag settings and functional specifications.") (SELECTQ X ((QUIET :QUIET) (* ; "Don't want to hear about files as they're copied. Set the output file to NIL to suppress printing.") (SETQ COPYFILESOUTPUT NIL)) ((TERSE :TERSE) (* ; "Only print a . per file copied. Set the TERSE flag.") (SETQ COPYFILESOUTPUT NIL) (SETQ COPYFILESTERSE T)) ((RENAME MOVE :RENAME :MOVE) (* ; "He wants the files moved, not copied.") (SETQ COPYFILESFN (QUOTE RENAMEFILE))) ((ALWAYS :ALWAYS) (* ; "ALWAYS copy the files specified.") (SETQ COPYFILESALWAYS T) (* ; "Tell it so") (SETQ COPYFILES.WHENTOSKIP (FUNCTION NILL)) (* ; "And say never to skip a potential file")) (> (* ; "Only copy if the source has a newer version than the destination.") (SETQ COPYFILES.WHENTOSKIP (FUNCTION ILEQ)) (SETQ COPYFILESALWAYS NIL)) ((= =A) (* ; "= without ALWAYS doesn't make a lot of sense") (SETQ COPYFILES.WHENTOSKIP (FUNCTION TRUE)) (SETQ COPYFILESALWAYS T)) ((%# /=) (* ; "Skip files that are the same on the destination") (SETQ COPYFILES.WHENTOSKIP (FUNCTION EQUAL)) (SETQ COPYFILESALWAYS NIL)) (ALLVERSIONS (SETQ COPYFILESVERSIONS T)) ((%#A /=A) (SETQ COPYFILES.WHENTOSKIP (FUNCTION EQUAL)) (SETQ COPYFILESALWAYS T)) (>A (SETQ COPYFILES.WHENTOSKIP (FUNCTION ILEQ)) (SETQ COPYFILESALWAYS T)) ((ASK :ASK) (SETQ COPYFILESASK T)) ((PURGE :PURGE) (SETQ COPYFILESPURGE T)) ((PURGESOURCE :PURGESOURCE) (SETQ COPYFILESPURGESOURCE T) (SETQ COPYFILESALWAYS NIL)) ((REPLACE :REPLACE) (SETQ COPYFILESREPLACE T)) (SELECTQ (CAR (LISTP X)) (OUTPUT (SETQ COPYFILESOUTPUT (OPENSTREAM (CADR X) (QUOTE OUTPUT) (QUOTE NEW)))) (ASK (SETQ COPYFILESASK T) (SETQ COPYFILESASKDEFAULT (CADR X))) (DONTCOPY (SETQ DONTCOPY (CDR X))) (COPYFN (* ; "Use this instead of COPYFILE") (SETQ COPYFILESFN (CADR X))) (SECONDARY (* ;; "Use FROMSPECT/TOSPEC to decide what files to copy, but actually do the copying to this secondary spec (if the file's not there already). Also, if we skip a file because the date comparison failed or the destination doesn't exist, we delete the corresponding file(s) on the secondary location. This is pretty strange --bvm.") (SETQ SECONDARYSPEC (COPIEDTOSPEC (CADR X))) (SETQ COPYFILESFN (FUNCTION (LAMBDA (SOURCE DEST) (* ;; "This gets called when we're to %"copy%" from SOURCE to DEST") (LET (DST FULLDST) (if (CAR (ERSETQ (AND (SETQ FULLDST (INFILEP (SETQ DST (COPIEDFILENAME SOURCE COPYFILESFROMSPEC SECONDARYSPEC)))) (= (GETFILEINFO SOURCE (QUOTE ICREATIONDATE)) (GETFILEINFO FULLDST (QUOTE ICREATIONDATE)))))) then (PRINTOUT COPYFILESOUTPUT "[backed up on " FULLDST "]" T) "!" else (COPYFILE SOURCE DST)))))) (SETQ COPYFILESSKIPFN (FUNCTION (LAMBDA (SOURCE) (* ;; "This gets called when we skip SOURCE") (LET ((BACKUP (COPIEDFILENAME SOURCE COPYFILESFROMSPEC SECONDARYSPEC))) (bind BK while (SETQ BK (INFILEP BACKUP)) do (PRINTOUT COPYFILESOUTPUT " [deleting " BK "...") (COND ((NOT (DELFILE BK)) (PRINTOUT COPYFILESOUTPUT "couldn't!]") (RETURN)) (T (PRINTOUT COPYFILESOUTPUT "ok]"))))))))) (ERROR X "unrecognized option")))) (if (AND COPYFILESASK (NOT COPYFILESOUTPUT)) then (SETQ COPYFILESOUTPUT T)) (if (OR (LISTP COPYFILESTOSPEC) (LISTP SECONDARYSPEC)) then (* ; "copiedfilename will want the from spec broken down to do pattern matching.") (SETQ COPYFILESFROMSPEC (COPIEDFROMSPEC FROMSPEC))) (MAPFILES FROMSPEC (FUNCTION (LAMBDA (FILENAME DT1) (PROG (NEWFILENAME NF CF DT2 HELPFLAG) (DECLARE (SPECVARS HELPFLAG)) (* ; "So that errors don't cause breaks") (if DONTCOPY then (if (CL:MEMBER (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)) DONTCOPY :TEST (QUOTE STRING.EQUAL)) then (AND COPYFILESOUTPUT (PRINTOUT COPYFILESOUTPUT FILENAME " ignored." T)) (RETURN))) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT .TAB0 0 FILENAME)) (* ; "List the candidate file's name") (OR (ERSETQ (SETQ NEWFILENAME (COPIEDFILENAME FILENAME COPYFILESFROMSPEC COPYFILESTOSPEC COPYFILESVERSIONS))) (RETURN (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " illegal file name ")))) (* ; "Find out what the file's name would be at the destination.") (if (OR (NOT COPYFILESALWAYS) (NEQ COPYFILES.WHENTOSKIP (QUOTE NILL))) then (* ; "We aren't ALWAYS copying. So have to check this file to see if it meets the copy criteria.") (COND ((SETQ NF (INFILEP NEWFILENAME)) (* ; "There is a file of the same name at the destination. CHeck it out.") (SETQ DT2 (GETFILEINFO NF (QUOTE ICREATIONDATE))) (* ; "The destination file's create date") (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " [" (GDATE DT1) "]" " vs. " NF "[" (if DT2 then (GDATE DT2) else "no date?") "]")) (* ; "Tell the user we're comparing dates") (COND ((AND DT2 (CL:FUNCALL COPYFILES.WHENTOSKIP DT1 DT2)) (* ; "If the file has a create date, and it meets the SKIP criteria, then skip over this file") (CL:FUNCALL COPYFILESSKIPFN FILENAME) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " skipped.")) (RETURN)))) (COPYFILESPURGESOURCE (* ; "We're to purge the source directory of non-corresponding files") (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " (no corresponding " NEWFILENAME "), ")) (COND ((OR (NOT COPYFILESASK) (EQ (QUOTE Y) (ASKUSER DWIMWAIT COPYFILESASKDEFAULT "delete? " NIL T))) ((LAMBDA (STR) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT STR))) (if (DELFILE FILENAME) then " deleted." else " couldn't delete.")))) (RETURN)) ((NOT COPYFILESALWAYS) (* ; "file doesn't exist on destination") (CL:FUNCALL COPYFILESSKIPFN FILENAME) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " does not exist on destination -- skipped")) (RETURN)))) (if (AND COPYFILESREPLACE NF) then (SETQ NEWFILENAME NF)) (if COPYFILESOUTPUT then (* ; "Write out the file's new name, and tell him we're copying or moving it.") (printout COPYFILESOUTPUT (SELECTQ COPYFILESFN (COPYFILE " copy") (RENAMEFILE " rename") " process")) (if (NOT NF) then (printout COPYFILESOUTPUT " to (new file) " NEWFILENAME))) (COND ((AND COPYFILESASK (NEQ (ASKUSER DWIMWAIT COPYFILESASKDEFAULT "? " NIL T) (QUOTE Y))) (RETURN))) (OR (ERSETQ (SETQ CF (CL:FUNCALL COPYFILESFN FILENAME NEWFILENAME))) (RETURN (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " failed.")))) (if COPYFILESOUTPUT then (if (AND (NOT COPYFILESASK) (NOT NF) (STRPOS NEWFILENAME CF 1 NIL 1 NIL (UPPERCASEARRAY))) then (printout COPYFILESOUTPUT (OR (SUBSTRING CF (ADD1 (NCHARS NEWFILENAME))) ".")) else (printout COPYFILESOUTPUT " => " CF)))) (AND COPYFILESTERSE (PRIN1 "." COPYFILESTERSE)))) (QUOTE (ICREATIONDATE)) "*" (if COPYFILESVERSIONS then "*" else "") NIL (SELECTQ (fetch (FDEV GENERATEFILES) of (\GETDEVICEFROMNAME FROMSPEC)) ((\FTP.GENERATEFILES \LEAF.GENERATEFILES \NSFILING.GENERATEFILES \TCPFTP.GENERATEFILES) (* ; "If source is PupFtp, TCP, or NS, enumerate the whole directory first, lest some awkward copy cause the source enumeration stream to die.") T) NIL)) (if COPYFILESPURGE then (* ; "delete from source if doesn't exist on destination") (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT T "Deleting files on destination but not on source" T)) (COPYFILES TOSPEC FROMSPEC (APPEND (if COPYFILESOUTPUT then (LIST (LIST (QUOTE OUTPUT) COPYFILESOUTPUT))) (if COPYFILESASK then (LIST (LIST (QUOTE ASK) COPYFILESASKDEFAULT))) (QUOTE (= PURGESOURCE))))) (COND (COPYFILESOUTPUT (TAB 0 0 COPYFILESOUTPUT) (NEQ COPYFILESOUTPUT T) (CLOSEF COPYFILESOUTPUT))))) ) (MAPFILES (LAMBDA (FILESPEC FN ATTRIBUTES DEFAULTEXT DEFAULTVERS INCLUDE-DIRECTORIES ENUMERATE-FIRST) (* ; "Edited 27-Sep-89 14:51 by bvm") (* ;; "Run thru all the files that match FILESPEC, calling FN on each such file name, with remaining args being the value of each of the ATTRIBUTES of the file") (if (LISTP FILESPEC) then (for X in FILESPEC do (MAPFILES X FN DEFAULTEXT DEFAULTVERS ATTRIBUTES INCLUDE-DIRECTORIES ENUMERATE-FIRST)) elseif (OR (STRPOS "*" FILESPEC) (FMEMB (NTHCHARCODE FILESPEC -1) (CHARCODE (> %) %] } %:)))) then (* ; "Pattern or directory spec") (SETQ FILESPEC (DIRECTORY.FILL.PATTERN FILESPEC DEFAULTEXT DEFAULTVERS)) (if ENUMERATE-FIRST then (* ; "Generate all the files first, then apply fn") (for PAIR in (XCL:WITH-COLLECTION (MAPFILES1 FILESPEC ATTRIBUTES INCLUDE-DIRECTORIES (FUNCTION (CL:LAMBDA (NAME &REST ATTRS) (XCL:COLLECT (CONS NAME ATTRS)))))) do (CL:APPLY FN (CAR PAIR) (CDR PAIR))) else (* ; "Call on each one as we go") (MAPFILES1 FILESPEC ATTRIBUTES INCLUDE-DIRECTORIES FN)) elseif (SETQ FILESPEC (INFILEP FILESPEC)) then (CL:APPLY FN FILESPEC (for ATTR inside ATTRIBUTES collect (GETFILEINFO FILESPEC ATTR))))) ) (MAPFILES1 (LAMBDA (FILESPEC ATTRIBUTES INCLUDE-DIRECTORIES FN) (* ; "Edited 27-Sep-89 14:49 by bvm") (* ;; "Enumerate FILESPEC (pattern must already be filled) and apply FN to each file and its ATTRIBUTES") (RESETLST (LET ((FILEGROUP (\GENERATEFILES FILESPEC (SETQ ATTRIBUTES (MKLIST ATTRIBUTES)) (QUOTE (SORT RESETLST)))) NAME LEN) (while (SETQ NAME (\GENERATENEXTFILE FILEGROUP)) unless (PROGN (* ; "Skip IFS's

.;1 file. Also other dir files unless INCLUDE-DIRECTORIES is true.") (OR (AND (>= (SETQ LEN (NCHARS NAME)) 4) (STRING-EQUAL NAME ".;1" :START1 (- LEN 4))) (AND (NOT INCLUDE-DIRECTORIES) (FMEMB (NTHCHARCODE NAME LEN) (CHARCODE (/ >)))))) do (if (NULL (CDR ATTRIBUTES)) then (* ; "Optimize slightly for the case of one attribute") (CL:FUNCALL FN NAME (\GENERATEFILEINFO FILEGROUP (CAR ATTRIBUTES))) else (CL:APPLY FN NAME (for ATTR in ATTRIBUTES collect (\GENERATEFILEINFO FILEGROUP ATTR)))))))) ) (COPIEDFILENAME (LAMBDA (FILENAME COPIEDFROMSPEC COPIEDTOSPEC PRESERVEVERSION) (* ; "Edited 27-Sep-89 15:03 by bvm") (* ;; "FILENAME is the file produced by the directory enumeration. COPIEDFROMSPEC is the parsed 'FROM' specification, and COPIEDTOSPEC is either a directory specification (string) or else a list, CDR of which is a list of character atoms.") (SETQ FILENAME (COND ((LISTP COPIEDTOSPEC) (* ; "destination is a pattern, so have to be fancy. NOHOST strips off the HOST field") (CONCATLIST (LET ((FROMCHARS (NOHOST (UNPACK FILENAME)))) (if (NOT PRESERVEVERSION) then (* ; "Discard the version") (RPLACD (NLEFT FROMCHARS 1 (FMEMB (QUOTE ;) FROMCHARS)))) (COPIEDFILEPATTERN COPIEDFROMSPEC (CDR COPIEDTOSPEC) FROMCHARS)))) (T (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE DIRECTORY) COPIEDTOSPEC (QUOTE HOST) NIL (QUOTE DEVICE) NIL (QUOTE DIRECTORY) NIL (BQUOTE ((\,@ (AND (NOT PRESERVEVERSION) (QUOTE (VERSION NIL)))) BODY (\, FILENAME))))))) (COND ((EQ (NTHCHARCODE FILENAME -1) (CHARCODE %.)) (* ;; "this is a terrible kludge, to get around the problem that for some devices, (INFILEP 'FOO.') fails while (INFILEP 'FOO') doesn't. This stripping off of a terminal '.' doesn't hurt, but doesn't belong here. Necessary for getting a working version for the harmony release.") (SUBSTRING FILENAME 1 -2 FILENAME)) (T FILENAME))) ) (COPIEDFILEPATTERN (LAMBDA (FRPAT TOPAT CHARS) (* ; "Edited 27-Sep-89 15:58 by bvm") (while (AND FRPAT CHARS (EQ (U-CASE (CAR FRPAT)) (U-CASE (CAR CHARS)))) do (* ; "Skip to the first place where pattern and actual name differ") (pop FRPAT) (pop CHARS)) (NCONC (on old TOPAT while (NEQ (CAR TOPAT) (QUOTE *)) collect (CAR TOPAT)) (COND ((AND FRPAT (NEQ (CAR FRPAT) (QUOTE *))) (* ; "Ran out of pattern before getting to a *") (if (AND (NULL CHARS) (OR (if (AND (EQ (CAR FRPAT) (QUOTE %.)) (EQ (CADR FRPAT) (QUOTE *))) then (NULL (SETQ FRPAT (CDDR FRPAT)))) (EQUAL FRPAT (QUOTE (; *)))) (OR (NULL TOPAT) (EQUAL TOPAT (QUOTE (*))))) then NIL else (ERROR "--From Spec doesn't match generated file"))) (TOPAT (* ; "both TOPAT and FRPAT start with *") (NCONC (LDIFF CHARS (SETQ CHARS (for X on CHARS when (COPIEDFILEMATCH X (CDR FRPAT)) do (* ; "Find the last tail of CHARS that matches the pattern") (SETQ $$VAL X)))) (COPIEDFILEPATTERN (CDR FRPAT) (CDR TOPAT) CHARS))) (T (OR (COPIEDFILEMATCH CHARS FRPAT) (ERROR "file pattern doesn't match")) NIL)))) ) (COPIEDFILEMATCH (LAMBDA (CHARS FRPAT) (* ; "Edited 27-Sep-89 15:44 by bvm") (PROG ((SEMI* (QUOTE (; *)))) LP (if (NULL FRPAT) then (RETURN (NULL CHARS)) elseif (EQ (CAR FRPAT) (QUOTE *)) then (* ; "Match arbitrarily many CHARS") (RETURN (OR (NULL (SETQ FRPAT (CDR FRPAT))) (EQUAL FRPAT SEMI*) (find X on CHARS suchthat (COPIEDFILEMATCH X FRPAT)))) elseif (NULL CHARS) then (RETURN (EQUAL FRPAT SEMI*)) elseif (EQ (U-CASE (pop FRPAT)) (U-CASE (pop CHARS))) then (GO LP) else (RETURN)))) ) (COPIEDFROMSPEC (LAMBDA (FROMSPEC) (* ; "Edited 27-Sep-89 15:52 by bvm") (* ;; "Return something for copiedfilepattern to work on") (SETQ FROMSPEC (MKSTRING FROMSPEC)) (SETQ FROMSPEC (NOHOST (ESPATTERN (LET ((DIREND (for I from (SUB1 (OR (CL:POSITION #\* FROMSPEC) (NCHARS FROMSPEC))) to 0 by -1 do (CASE (CL:CHAR FROMSPEC I) ((#\/ #\> #\}) (RETURN I))))) CAN) (if (AND DIREND (SETQ CAN (DIRECTORYNAME (CL:SUBSEQ FROMSPEC 0 (ADD1 DIREND))))) then (* ; "Canonicalize the directory before we proceed, so that files coming back have a hope of matching") (CONCAT CAN (CL:SUBSEQ FROMSPEC (ADD1 DIREND))) else FROMSPEC))))) (if (NOT (FMEMB (QUOTE ;) FROMSPEC)) then (* ; "Add ;* to match gracefully against real file names like foo.baz;3") (NCONC FROMSPEC (LIST (QUOTE ;) (QUOTE *))) else FROMSPEC)) ) (COPIEDTOSPEC (LAMBDA (SPEC) (* ; "Edited 29-Oct-87 16:23 by jds") (* ;; "Create the spec for what file(s) are to be copied TO: If there's a * in the spec or there's more than just directory specified, then return the pattern for filename matching; if a directory got specified, return that.") (COND ((STRPOS "*" SPEC) (* ; "There are wildcards in the name.") (CONS (QUOTE PATTERN) (ESPATTERN SPEC))) ((UNPACKFILENAME.STRING SPEC (QUOTE NAME)) (* ; "There's more than just a directory spec.") (CONS (QUOTE PATTERN) (ESPATTERN SPEC))) (T (* ; "It's a directory (or had better be!)") (OR (DIRECTORYNAME SPEC NIL T) (ERROR SPEC "not a valid directory"))))) ) (ESPATTERN (LAMBDA (X) (* ; "Edited 27-Sep-89 15:50 by bvm") (SETQ X (UNPACK X)) (for Y on X do (SELECTQ (CAR Y) ((*) (* ; "Turn *.*; into *;") (if (AND (EQ (CADR Y) (QUOTE %.)) (EQ (CADDR Y) (QUOTE *)) (FMEMB (CADDDR Y) (QUOTE (NIL ;)))) then (RPLACD Y (CDDDR Y)))) NIL)) X) ) (NOHOST (LAMBDA (UP) (SELECTQ (CAR UP) (({ %( %[) (do (pop UP) (SELECTQ (CAR UP) (NIL (RETURN)) ((} %) %]) (RETURN (pop UP))) (%' (pop UP)) NIL))) NIL) UP) ) (COMPAREFILES [LAMBDA (OLDFILE NEWFILE OSTART OEND) (* ; "Edited 9-Apr-91 16:42 by jds") (* ;  "Compare two files to see if their contents are the same. ") (* ;; "If OSTART & OEND are specified, they are as for COPYBYTES--I.E., fileptrs into the OLD file to compare the new file to.") [CL:WITH-OPEN-STREAM [OSTREAM (OPENSTREAM OLDFILE 'INPUT 'OLD '(SEQUENTIAL T] (CL:WITH-OPEN-STREAM [NSTREAM (OPENSTREAM NEWFILE 'INPUT 'OLD '(SEQUENTIAL T] (LET (OLEN NLEN NBYTES OBYTE NBYTE) (SETQ OLEN (GETFILEINFO OSTREAM 'LENGTH)) (SETQ NLEN (GETFILEINFO NSTREAM 'LENGTH)) [COND [OSTART (* ;  "He specified a starting fileptr or a char count.") (COND ((NOT OEND) (* ;  "It was a char count (no ending point specified)") (SETQ NBYTES OSTART) (SETQ OSTART 0)) (T (* ; "He specified an ending point.") (SETFILEPTR OSTREAM OSTART) (SETQ NBYTES (IDIFFERENCE OEND OSTART)) (SETQ OSTART 0] (T (* ;  "Nothing specified; run thru the whole file.") (SETQ OSTART 0) (SETQ NBYTES OLEN) (COND ((NOT (EQP OLEN NLEN)) (* ;  "If they files are of different lengths, they aren't the same.") (ERROR "File lengths differ: " (CONCAT OLEN " vs " NLEN] [COND (OLEN (* ;  "FTP returns NIL for the length of an empty file!") (for BYTEPOS from OSTART to (SUB1 NBYTES) do (COND ((NEQ (SETQ OBYTE (BIN OSTREAM)) (SETQ NBYTE (BIN NSTREAM))) (PRINTOUT T "Files differ at byte " BYTEPOS ", old-file has " OBYTE " but new file has " NBYTE "." T) (OR (ASKUSER NIL NIL "Continue comparing?") (RETURN] (CLOSEF? OSTREAM) (CLOSEF? NSTREAM] T]) ) (* ;; "For concatenating a list of files into one file.") (DEFINEQ (CONCATFILES (LAMBDA (INPUT-FILES OUTPUT-FILE) (CL:WITH-OPEN-STREAM (OUT (OPENSTREAM OUTPUT-FILE (QUOTE OUTPUT) (QUOTE NEW) (QUOTE (SEQUENTIAL T)))) (for FILE in INPUT-FILES do (CL:WITH-OPEN-STREAM (IN (OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD) (QUOTE (SEQUENTIAL T)))) (COPYBYTES IN OUT))))) ) ) (* ;; "For splitting a big file into several files.") (DEFINEQ (SPLITFILE [LAMBDA (FILE SPLIT-SIZE) (* ; "Edited 26-Jan-93 20:46 by jds") (CL:WITH-OPEN-STREAM (INSTR (OPENSTREAM FILE 'INPUT 'OLD)) (for I from 1 as START from 0 by SPLIT-SIZE while (ILESSP START (GETEOFPTR INSTR)) do (CL:WITH-OPEN-STREAM (OUTSTR (OPENSTREAM (PACKFILENAME 'VERSION NIL 'NAME (CONCAT (UNPACKFILENAME.STRING FILE 'NAME) I) 'BODY FILE) 'OUTPUT 'NEW)) (COPYBYTES INSTR OUTSTR START (IMIN (GETEOFPTR INSTR) (+ START SPLIT-SIZE]) ) (* ;; "For making DOS file systems") (DEFINEQ (DOSLINKER [LAMBDA (FILES OLDDIR STREAM) (* ; "Edited 23-Mar-93 02:38 by jds") (for FILE in FILES do (PRINTOUT STREAM "ln -s " OLDDIR FILE " " (L-CASE (SHORTEN (UNPACKFILENAME.STRING FILE 'NAME) 8)) "." (L-CASE (SHORTEN (UNPACKFILENAME.STRING FILE 'EXTENSION) 3)) T]) (SHORTEN [LAMBDA (STRING LEN) (SUBSTRING STRING 1 (IMIN LEN (NCHARS STRING]) ) (DECLARE%: EVAL@COMPILE (I.S.OPR 'INFILES NIL '[SUBST (GENSYM) 'GENVAR '(BIND GENVAR _ (\GENERATEFILES BODY NIL '(SORT)) EACHTIME (PROGN (OR (SETQ I.V. (\GENERATENEXTFILE GENVAR)) (GO $$OUT)) (IF (LISTP I.V.) THEN (SETQ I.V. (CONCATCODES I.V.] T) ) (PUTPROPS COPYFILES COPYRIGHT ("Venue & Xerox Corporation" 1989 1990 1991 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1053 19272 (COPYFILES 1063 . 9192) (MAPFILES 9194 . 10352) (MAPFILES1 10354 . 11273) ( COPIEDFILENAME 11275 . 12621) (COPIEDFILEPATTERN 12623 . 13677) (COPIEDFILEMATCH 13679 . 14171) ( COPIEDFROMSPEC 14173 . 14972) (COPIEDTOSPEC 14974 . 15634) (ESPATTERN 15636 . 15917) (NOHOST 15919 . 16080) (COMPAREFILES 16082 . 19270)) (19339 19649 (CONCATFILES 19349 . 19647)) (19712 20889 (SPLITFILE 19722 . 20887)) (20935 21812 (DOSLINKER 20945 . 21722) (SHORTEN 21724 . 21810))))) STOP \ No newline at end of file diff --git a/library/DANDELIONKEYBOARDS.~1~ b/library/DANDELIONKEYBOARDS.~1~ deleted file mode 100644 index 68d06fad..00000000 --- a/library/DANDELIONKEYBOARDS.~1~ +++ /dev/null @@ -1 +0,0 @@ -((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (logic ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) ) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( 61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) ) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( 112 (47 61300 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( 180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( 133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( 61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( 61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( 119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( 120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( 124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( 128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (GREEK ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( 9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) ) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( 154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT ) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) ( 116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( 145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( 151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( 155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (SPANISH ((100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( 97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( 111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 (203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( 143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( 105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( 109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) ( 116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( 120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( 124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( 128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( 121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( 109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (STANDARD-RUSSIAN (( 100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( 10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) ) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( 10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION)) \ No newline at end of file diff --git a/library/DANDELIONKEYBOARDS.~2~ b/library/DANDELIONKEYBOARDS.~2~ deleted file mode 100644 index cb8dba3d..00000000 --- a/library/DANDELIONKEYBOARDS.~2~ +++ /dev/null @@ -1,171 +0,0 @@ -((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( -61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 -LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( -110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (8 8 -NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 -LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) -(122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 -61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( -129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 -LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( -250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT -)) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( -61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 -LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( -246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (logic ((100 ( -53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 -NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) -) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 -177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . -IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( -61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 -NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 -NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 -NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) - (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 - (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 -1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 -NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 -61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 -NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) -) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 -NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 -NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 -(100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 -NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( -112 (47 61300 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 -NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 -NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( -180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 -NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( -133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( -61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 -LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( -144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 -61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 -LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( -156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 -NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( -61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 -61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 -NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 -NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . -IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( -119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 - NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) -(126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 -NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 -NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( -142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 -61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 -NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 -NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 - 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN - . 2SHIFTUP)) DANDELION) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 -NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 -71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 - NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 - (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( -120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( -124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( -128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 -NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 -LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 -1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . -IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 -LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 -LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( -91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (GREEK ((100 ( -53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( -104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 -LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 - 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) - (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 -LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( -9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) -) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 -NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 -LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 -1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . -IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 -9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( -154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT -) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) -DANDELION) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 -NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 - LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 -NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) ( -116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 -LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 -LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 -NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 - 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 -LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN - . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( -145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( -151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( -155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 -NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (SPANISH ((100 (53 -61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) - (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) -(108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) -(112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 -61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( -97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( -111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 -(203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 -(98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( -143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 -82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 - LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 -LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 -NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 -61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( -105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( -109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) -(115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 -87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 -NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 -LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 - (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 -70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 -LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 -13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 -LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 -NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 -NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . -2SHIFTUP)) DANDELION) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 -NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 - LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 -NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) ( -116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( -120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( -124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( -128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 -NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT -)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . -1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 -(95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( -121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( -109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 -LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (STANDARD-RUSSIAN (( -100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 -LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 - (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 -NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . -IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( -10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 -NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) -) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( -10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 -LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( -142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 - 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 -LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 - (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 -NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . -2SHIFTUP)) DANDELION)) \ No newline at end of file diff --git a/library/DATABASEFNS.LCOM.~2~ b/library/DATABASEFNS.LCOM.~2~ deleted file mode 100644 index bcb9314488296da970264da95f0ea040ba899dbb..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 7624 zcma)B-E$jP6_@Nz+oW}{X<9m&P)-B^$&6g>m%d;ct)-Q%c(to&B|C=FR+il$Gcl>@S#`%-_?n)fnUtE#*7_USl1@sYtSIFi#O(`d+h5tFEeLD& zH@EwDNL^5u&4|T^1G=QncCIhX#-tRx4^*E0py@YH}5% zWt+V_*^)*|v8?N54b!GRrP?W|sunfc81!~t?eEe4@N${bSQ5?Dy3JN?F+;a^`>$^e z5B69kw5F(#y?U^nEvb|%l?|*^|J3toLiyE3dkH(|Q2JWe?O0^HW-UV<^L z>bAK=IbwksO1za!B&I4SXC6=Bcet?ms`x)E9G9`BTs4S2D>ILZwi}74^WCQ_ zXGC38lRUX-zAGz#EdOpKHs9q=l?!vp#PWw{D$6|4Y$C0w21#WVQWU8jJlP^8r$AMw z#_NC!V~4P!7Qs1|tWK-#wy2V$S%dS!0;FU!ch6bmuu82{hl2j=?>QI2pR#)tE zp~z#!ydLFqv}(1zhU<`?r$x86PI^?O>118+SPr*C_o~}$VTJ`%B50#FNDX#DiEV?> zMot55GT4RPDeMBCETkS+!j`~i##RqZc_34wx2D9dc*`z=C z-;Jrmf5Ps$yl;1vN;zs<@O6udY{XilO~u@}_4HtyRMOONGt|OZFJVeenk-+WdCF^{ zDUBip07clDm<@AsfTD+eOHtRDwPO}lA7D{9QikgAaj#J>&$lhl>eStK)0>B(tBGV{ zYA8Il!Zu^;+(-;ATxea`NJu|5lNIj4Hs=mWe*U~ND?1F}u~<~qc7d~G=;U?U*0ru_ zlU{@k%^K+%du=vK0vgm=;Wqe(+k)$0jM>C;;O>D3l2#nc7CNQj;!D6JIoA~e;;fo> z*UDrvGXi=-6R6Z`BhS?BB~r+)iT^0bFJisZ6?5?kvG5xSlb3$_hs`ZsR|U&abq2iJ zA{E3OjA~HLAaC9C3vxmMQn5+pOo&lnb2Q)i@%du&DEUv!!>~8wG;9$o0eFQ|Xym!w zc9j8;R9IIo6VoX$V+ZjWpZIA^{0J6WeNwJ8K68O&?x3PrVK7l9m{~TOxf~FO0h8f^ zU8w7<0fMsFijGz7%u^%qt*ULAPPdhn?sZ?ELnW+Z<4^S?4X^MHVX!*sj5v5PXx?WA z^C;zoJ>jkYO+1!JvM){qxWtBz#Nnuo_jltF-kFtaE?emQ}nmJsgchLa8Wn}T^z;}^5+ESLsZ6UBT<=B^kDYD{Qv;=hqOKH zZ3+U{yU|1aP0-uDOP9}HPJwn&+G@Am_N7eb@>$4I^_ekbEau0G4*^O_n@$b5fu(yL zK`GKT%NAyfV=0m}^U4r*K!w3AfT9^{fsw?=qx{L#f?g#O6#x2i!|R}g5Qi07QPg9Y zjQW-UN}EB1)c`=K(a;Pfn@=J~RW?63Lblf`r+<=3=fmkA9wiI%T|Vbh(~Xl$9A_UK zCEi=+w<(#cQ1R2jjj2)No91yv5(SPuj@8qhzmk~;_qWZxax1*`kR$G^KpCn z&ceiN#cM$KjWs8ZyzOo zA{9FR+~oYD!O^`RFg_hW)#QI4{@yvdx6Nf9$yRJa9YzHy3_bMwiF=-h@zfGSj_!Sz zOLzYxRh>>s0e_Teb9(%m|MGio_jym#Jtw&ii+f)x=SYdNpPZaKP2qU<$YDMC4T*Mt z9$k&?=r7rpqsHMseB^xCj(#MiuE>ex#)!iTj;N9y1P)1t0FQULK@kW%32r z2=WEgO1=Q^`83Atk`ubH3t$yc9GXxCFXF_Zlw zJtj2qNQH+8ekM*6{&pjMi&Qk8`Vb7FQY3MiT=;wquYr7AQOZU{KsdL8EEg04ON*qH z#}ZStC34n2^~O2xr4(uK$kYTI9`1toY9$QoZSVGbn|GKl_cw73tHA$KwSYIL#I08f z$#9HG)6L<*&L*C_l$sIOUh!+_LcA0tPDy?RWsR|AL0czN8)$7VVys}Y(Z!-T8v8jB zCJXp*h7!+BgVcI+m*g!MV;Vms7=k#8!yXR%lSHE!k)vP_m>a>UaJcc_sFODcxW)+X zJfV)bV0$}}NF*g~zLD5s1eYa7$`1#z+aS&s7f-s3+EBRpCG7^G@L zx-&eWH+nn5tDC*O{r>LW#_)EZLhlp~xIcjBi{srDcrze9ErQB%GlcjJ-XXJv<9KIX z+@&()29sh!v1D{;x6EtTLS_7VN~hFh&_9$&PoE57k z@G`g>ghXMkwk4W^Pb0xlFPc#vswH%?Xz}Sr+zGUh>~MXz-m=2&L_@=Abo?oq$_unj z`}RVth=oLM>93XR(GY4IsKJ+VusXh;01pHxv0n4k8Pe_k?yaqTKRwWl@QdA>J@$)8 zhwKRN)gNtGmE^vWSWmVJ_C)PZ+_apZ_fese-@B!0#Pb7*AML3>N|;m$Y!n zTM>aEju$mtT24tF5q1(Ha49V8&~c#^(06jz5I_&wFa#g2g0LlC zxF69DHI^LQl=<;@C6)=}TOgzJN(?u~TSL7bwm*T83DZZ_VeS`jF{!bzr7%>xv9yeU rPF?Ts4!=Xy;qL9>E?{A}gUne1%fRV8Cm#6LRKoW{JTzEN+(7>i1MI&j diff --git a/library/DATABASEFNS.~1~ b/library/DATABASEFNS.~1~ deleted file mode 100644 index 18f7dc7d..00000000 --- a/library/DATABASEFNS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Jun-90 14:51:14" {DSK}local>lde>lispcore>library>DATABASEFNS.;3 17357 changes to%: (VARS DATABASEFNSCOMS) previous date%: "23-May-90 16:15:36" {DSK}local>lde>lispcore>library>DATABASEFNS.;2) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DATABASEFNSCOMS) (RPAQQ DATABASEFNSCOMS [ (* ;; "Does automatic Masterscope database maintenance") [DECLARE%: FIRST (P (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE] (FNS DBFILE DBFILE1 DBFILE2 LOAD LOADFROM MAKEFILE) (ADDVARS (LINKEDFNS OLDLOAD)) (P (RELINK 'MAKEFILES)) (FNS DUMPDB LOADDB MAKEDB) (PROP PROPTYPE DATABASE) (INITVARS (LOADDBFLG 'ASK) (SAVEDBFLG 'ASK)) (ADDVARS (MAKEFILEFORMS (MAKEDB FILE))) (* ; "To permit MSHASH interface") (INITVARS (MSHASHFILENAME) (MSFILETABLE)) (LOCALVARS . T) (BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T]) (* ;; "Does automatic Masterscope database maintenance") (DECLARE%: FIRST (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE) ) (DEFINEQ (DBFILE [LAMBDA (FILE ASKFLAG) (* lmm "29-APR-81 20:27") (* Finds a database file that corresponds to the contents of FILE.  Looks in directory of FILE, and also in the directory that file originally came  from, if it was copied. Returns NIL if no database file is found, else  (fulldbfilename . filedates)%, where filedates identifies the name under which  the file that the database corresponds to is currently known.  -  If FILE doesn't have a version, tries to get database for version in core, or  most recent version if it hasn't been loaded) (DECLARE (GLOBALVARS COMPILE.EXT FILERDTBL)) [COND ((NULL FILE) (SETQ FILE (INPUT))) ((EQ (FILENAMEFIELD FILE 'EXTENSION) COMPILE.EXT) (* Map compiled file into symbolic  name) (SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE] (PROG [(FILEDATES (COND [(AND (NULL (FILENAMEFIELD FILE 'VERSION)) (CAR (GETPROP (NAMEFIELD FILE) 'FILEDATES] ([SETQ FILE (COND (ASKFLAG (INFILEP FILE)) (T (FINDFILE FILE] (CONS (FILEDATE FILE) FILE] (AND FILEDATES (RETURN (DBFILE1 FILE FILEDATES]) (DBFILE1 [LAMBDA (F FILEDATES) (* jds "25-Sep-86 20:04") (* Searches databases based on F to find one that matches FILEDATES.  Returns (dbfilename . filedates) if successful.  For efficiency, checks the most likely highest version first, before doing the  directory enumeration) (PROG ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F))) DBF) (RETURN (COND ((NULL HIGHEST) (* ;  "No file matches the name we gave, so punt.") NIL) ((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.") (CONS DBF FILEDATES)) (T (* ;  "Hunt back thru back versions looking for a matching one.") (for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION '* 'BODY F))) when (SETQ DBF (DBFILE2 DBF FILEDATES)) do (RETURN (CONS DBF FILEDATES]) (DBFILE2 [LAMBDA (DBF FILEDATES) (* jds "25-Sep-86 20:01") (* T if DBF is the name of the database file matching FILEDATES) (DECLARE (GLOBALVARS FILERDTBL)) [RESETSAVE (SETQ DBF (OPENSTREAM DBF 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (* The close is done in the LOADDB RESETLST, except when a candidate file isn't  correct) (SKREAD DBF) (* Skip LOAD error message) (COND ((STREQUAL (CAR FILEDATES) (CAR (READ DBF FILERDTBL))) DBF) (T (CLOSEF DBF) NIL]) (LOAD [LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDLOAD FILE LDFLG PRINTFLG)) (COND ((NEQ LDFLG 'SYSLOAD) (LOADDB FILE T))) FILE]) (LOADFROM [LAMBDA (FILE FNS LDFLG) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDLOADFROM FILE FNS LDFLG)) (LOADDB FILE T) FILE]) (MAKEFILE [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDMAKEFILE FILE OPTIONS REPRINTFNS SOURCEFILE)) (DUMPDB FILE T) FILE]) ) (ADDTOVAR LINKEDFNS OLDLOAD) (RELINK 'MAKEFILES) (DEFINEQ (DUMPDB [LAMBDA (FILE PROPFLG) (* ; "Edited 2-Dec-86 07:59 by jds") (* Dumps a Masterscope database for functions in FILE.  Checks the DATABASE property if PROPFLG=T which is how the MAKEFILE advice  calls it. A user-level call would default PROPFLG to NIL.) (* The FILE check is because MAKEFILE returns a list when it doesn't understand  the options) (DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE SAVEDBFLG)) (AND FILE (LITATOM FILE) (PROG (DBFILE (FL (NAMEFIELD FILE)) FNS (FFNS (FILEFNSLST FILE))) (COND (FFNS) ((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE))) (* Always dump if this is a known file) (SETQ PROPFLG NIL)) (T (COND (PROPFLG (/REMPROP FL 'DATABASE)) (T (printout T T FILE " has no functions." T))) (RETURN))) (SETQ FNS FFNS) (COND ([OR (NULL PROPFLG) (EQ (GETPROP FL 'DATABASE) 'YES) (EQ SAVEDBFLG 'YES) (AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE] (* If MSHASH is loaded, only dump functions in the local database) [COND (MSHASHFILENAME (SETQ FNS (for FN in FNS when (PROGN (UPDATEFN FN) (LOCALFNP FN)) collect FN] [RESETLST [RESETSAVE (SETQ DBFILE (OPENSTREAM (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE] (RESETSAVE (OUTPUT DBFILE)) (PRIN1 "(PROGN (PRIN1 %"Use LOADDB to load database files! %" T) (ERROR!)) ") [AND MSFILETABLE (STORETABLE FL MSFILETABLE (PRINT (CAR (GETPROP FL 'FILEDATES] (COND (MSHASHFILENAME (UPDATECONTAINS FL FFNS T))) (* T flag means that the function won't be erased--it might still be  interesting) (printout NIL "FNS " |.P2| FFNS T) (* So the database file knows which functions are on the file) (COND (FNS (DUMPDATABASE FNS)) (T (printout NIL "STOP" T] [COND (PROPFLG (PRINT (FULLNAME DBFILE) T)) (T (/PUT FL 'DATABASEFILENAME DBFILE) (* Remember that we have this file  valid already.) (/PUT FL 'DATABASE 'YES] (* Take future note of the databae on a user call) (RETURN (FULLNAME DBFILE]) (LOADDB [LAMBDA (FILE ASKFLAG) (* ; "Edited 2-Dec-86 08:01 by jds") (* Loads the database file corresponding to FILE, asking for confirmation only  if ASKFLAG is T, which is the case from the advice on LOAD but not from usual  user-level calls. Before asking, it looks around first to see whether a  database file of the appropriate name really exists.) (DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE MSARGTABLE DWIMWAIT FILERDTBL LOADDBFLG)) (RESETLST (PROG* [TEM NEWFNS FORFILE (NF (NAMEFIELD FILE)) (DBSTREAM (DBFILE FILE ASKFLAG)) (DBFILE (FULLNAME (CAR DBSTREAM] (COND (DBSTREAM (SETQ FORFILE (CDR DBSTREAM)) (SETQ DBSTREAM (CAR DBSTREAM))) (T (COND ((NULL ASKFLAG) (printout T "no database file found for " NF T))) (RETURN))) (COND ([COND [ASKFLAG (COND ((EQ (GETPROP NF 'DATABASEFILENAME) DBFILE) (* If the database for this very file has already been loaded, don't bother  doing it again.) (printout T "Database " DBFILE " already loaded." T) NIL) (T (SELECTQ (GETPROP NF 'DATABASE) (YES T) (NO NIL) (SELECTQ LOADDBFLG (YES (/PUT NF 'DATABASE 'YES)) (NO (/PUT NF 'DATABASE 'NONE) NIL) (OR (AND MSFILETABLE (TESTTABLE NF (CADR MSFILETABLE ))) (COND ((EQ (ASKUSER DWIMWAIT 'Y (LIST "load database for" NF)) 'Y) (/PUT NF 'DATABASE 'YES)) (T (/PUT NF 'DATABASE 'NO) NIL] (T (/PUT NF 'DATABASE 'YES] (LISPXPRINT (FULLNAME DBFILE) T) (* DBSTREAM was opened in DBFILE) (RESETSAVE (INPUT DBSTREAM)) [COND ((EQ (SETQ TEM (READ NIL FILERDTBL)) 'FNS) (SETQ NEWFNS (READ NIL FILERDTBL)) (COND ((EQ (SETQ TEM (READ NIL FILERDTBL)) 'ARGS) [COND [MSHASHFILENAME (bind F while (SETQ F (READ NIL FILERDTBL)) do (STORETABLE F MSARGTABLE (READ NIL FILERDTBL] (T (while (READ NIL FILERDTBL] (SETQ TEM (READ NIL FILERDTBL] (COND ((OR (EQ (CAR (LISTP TEM)) 'READATABASE) (EQ TEM 'STOP)) (COND ((NEQ TEM 'STOP) (* It must be (READATABASE)) (READATABASE))) (COND (MSHASHFILENAME (UPDATECONTAINS NF NEWFNS))) (AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE)) (* This is done whether or not there is a hashfile.) (UPDATEFILES) (* Mark any edited fns as needing to  be reanalyzed.) (for FN in (CDR (GETP NF 'FILE)) when (OR (EXPRP FN) (GETP FN 'EXPR)) do (MSMARKCHANGED FN))) (T (printout T T DBFILE " is not a database file!" T) (* So that value of LOADDB is NIL) (SETQ DBFILE NIL))) (/PUT NF 'DATABASEFILENAME DBFILE) (* Remember the name of the database  we just loaded.) (RETURN (FULLNAME DBFILE]) (MAKEDB [LAMBDA (F) (* DECLARATIONS%: UNDOABLE) (* rmk%: " 9-NOV-83 02:56") (DECLARE (GLOBALVARS SAVEDBFLG MSFILETABLE DWIMWAIT)) (SETQ F (NAMEFIELD F)) (* The extension is stripped off for purposes of the DATABASE.  This maps compiled files into the root name, but means that we can't have  multiple-extension files with different database status) (COND ((INFILECOMS? T 'FNS (FILECOMS F)) (OR (FMEMB (GETPROP F 'DATABASE) '(YES NO)) (FMEMB SAVEDBFLG '(YES NO)) (AND MSFILETABLE (TESTTABLE F (CADR MSFILETABLE))) (/PUT F 'DATABASE (COND ((EQ 'Y (ASKUSER DWIMWAIT 'N "Do you want a Masterscope Database for this file? ") ) 'YES) (T 'NO]) ) (PUTPROPS DATABASE PROPTYPE IGNORE) (RPAQ? LOADDBFLG 'ASK) (RPAQ? SAVEDBFLG 'ASK) (ADDTOVAR MAKEFILEFORMS (MAKEDB FILE)) (* ; "To permit MSHASH interface") (RPAQ? MSHASHFILENAME ) (RPAQ? MSFILETABLE ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RESETSAVE DWIMIFYCOMPFLG T) ) (PUTPROPS DATABASEFNS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1742 6250 (DBFILE 1752 . 3400) (DBFILE1 3402 . 4925) (DBFILE2 4927 . 5616) (LOAD 5618 . 5848) (LOADFROM 5850 . 6038) (MAKEFILE 6040 . 6248)) (6306 16783 (DUMPDB 6316 . 10038) (LOADDB 10040 . 15695) (MAKEDB 15697 . 16781))))) STOP \ No newline at end of file diff --git a/library/DATABASEFNS.~2~ b/library/DATABASEFNS.~2~ deleted file mode 100644 index 16bc18e0..00000000 --- a/library/DATABASEFNS.~2~ +++ /dev/null @@ -1,187 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-May-93 18:44:36" "{DSK}lfg>parser>DATABASEFNS.;4" 17283 changes to%: (FNS DUMPDB) previous date%: " 7-Jul-92 09:57:14" "{DSK}lfg>parser>DATABASEFNS.;3") (* ; " Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DATABASEFNSCOMS) (RPAQQ DATABASEFNSCOMS [(* Does automatic Masterscope database maintenance) [DECLARE%: FIRST (P (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE] (FNS DBFILE DBFILE1 DBFILE2 LOAD LOADFROM MAKEFILE) (ADDVARS (LINKEDFNS OLDLOAD)) (P (RELINK 'MAKEFILES)) (FNS DUMPDB LOADDB MAKEDB) (PROP PROPTYPE DATABASE) (INITVARS (LOADDBFLG 'ASK) (SAVEDBFLG 'ASK)) (ADDVARS (MAKEFILEFORMS (MAKEDB FILE))) (* To permit MSHASH interface) (INITVARS (MSHASHFILENAME) (MSFILETABLE)) (LOCALVARS . T) (BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T]) (* Does automatic Masterscope database maintenance) (DECLARE%: FIRST (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE) ) (DEFINEQ (DBFILE - [LAMBDA (FILE ASKFLAG) (* lmm "29-APR-81 20:27") - - (* Finds a database file that corresponds to the contents of FILE. - Looks in directory of FILE, and also in the directory that file originally came - from, if it was copied. Returns NIL if no database file is found, else - (fulldbfilename . filedates)%, where filedates identifies the name under which - the file that the database corresponds to is currently known. - - - If FILE doesn't have a version, tries to get database for version in core, or - most recent version if it hasn't been loaded) - - (DECLARE (GLOBALVARS COMPILE.EXT FILERDTBL)) - [COND - ((NULL FILE) - (SETQ FILE (INPUT))) - ((EQ (FILENAMEFIELD FILE 'EXTENSION) - COMPILE.EXT) (* Map compiled file into symbolic - name) - (SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE] - (PROG [(FILEDATES (COND - [(AND (NULL (FILENAMEFIELD FILE 'VERSION)) - (CAR (GETPROP (NAMEFIELD FILE) - 'FILEDATES] - ([SETQ FILE (COND - (ASKFLAG (INFILEP FILE)) - (T (FINDFILE FILE] - (CONS (FILEDATE FILE) - FILE] - (AND FILEDATES (RETURN (DBFILE1 FILE FILEDATES]) (DBFILE1 - [LAMBDA (F FILEDATES) (* jds "25-Sep-86 20:04") - - (* Searches databases based on F to find one that matches FILEDATES. - Returns (dbfilename . filedates) if successful. - For efficiency, checks the most likely highest version first, before doing the - directory enumeration) - - (PROG ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F))) - DBF) - (RETURN (COND - ((NULL HIGHEST) (* ; - "No file matches the name we gave, so punt.") - NIL) - ((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.") - (CONS DBF FILEDATES)) - (T (* ; - "Hunt back thru back versions looking for a matching one.") - (for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE - 'VERSION - '* - 'BODY F))) - when (SETQ DBF (DBFILE2 DBF FILEDATES)) - do (RETURN (CONS DBF FILEDATES]) (DBFILE2 - [LAMBDA (DBF FILEDATES) (* ; "Edited 28-Nov-90 12:42 by rmk:") - (* T if DBF is the name of the - database file matching FILEDATES) - [RESETSAVE (SETQ DBF (OPENSTREAM DBF 'INPUT)) - '(PROGN (CLOSEF? OLDVALUE] - - (* The close is done in the LOADDB RESETLST, except when a candidate file isn't - correct) - - (SKREAD DBF) (* Skip LOAD error message) - (COND - ([STREQUAL (CAR FILEDATES) - (CAR (READ DBF (FIND-READTABLE "INTERLISP"] - DBF) - (T (CLOSEF DBF) - NIL]) (LOAD - [LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27") - (SETQ FILE (OLDLOAD FILE LDFLG PRINTFLG)) - (COND - ((NEQ LDFLG 'SYSLOAD) - (LOADDB FILE T))) - FILE]) (LOADFROM - [LAMBDA (FILE FNS LDFLG) (* lmm "29-APR-81 20:27") - (SETQ FILE (OLDLOADFROM FILE FNS LDFLG)) - (LOADDB FILE T) - FILE]) (MAKEFILE - [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE) (* lmm "29-APR-81 20:27") - (SETQ FILE (OLDMAKEFILE FILE OPTIONS REPRINTFNS SOURCEFILE)) - (DUMPDB FILE T) - FILE]) ) (ADDTOVAR LINKEDFNS OLDLOAD) (RELINK 'MAKEFILES) (DEFINEQ (DUMPDB [LAMBDA (FILE PROPFLG) (* ; "Edited 3-May-93 18:44 by rmk:") (* Dumps a Masterscope database for functions in FILE.  Checks the DATABASE property if PROPFLG=T which is how the MAKEFILE advice  calls it. A user-level call would default PROPFLG to NIL.) (* The FILE check is because MAKEFILE returns a list when it doesn't understand  the options) (DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE SAVEDBFLG)) (AND FILE (OR (LITATOM FILE) (STRINGP FILE)) (PROG (DBFILE (FL (NAMEFIELD FILE)) FNS (FFNS (FILEFNSLST FILE))) (COND (FFNS) ((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE))) (* Always dump if this is a known  file) (SETQ PROPFLG NIL)) (T (COND (PROPFLG (/REMPROP FL 'DATABASE)) (T (printout T T FILE " has no functions." T))) (RETURN))) (SETQ FNS FFNS) (COND ([OR (NULL PROPFLG) (EQ (GETPROP FL 'DATABASE) 'YES) (EQ SAVEDBFLG 'YES) (AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE] (* If MSHASH is loaded, only dump  functions in the local database) [COND (MSHASHFILENAME (SETQ FNS (for FN in FNS when (PROGN (UPDATEFN FN) (LOCALFNP FN)) collect FN] (RESETLST [RESETSAVE (SETQ DBFILE (OPENSTREAM (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE] (RESETSAVE (OUTPUT DBFILE)) (RESETSAVE (SETREADTABLE (FIND-READTABLE "INTERLISP"))) (RESETSAVE (CL:IN-PACKAGE "INTERLISP") (LIST 'CL:IN-PACKAGE (CL:PACKAGE-NAME *PACKAGE*))) (PRIN1 "(PROGN (PRIN1 %"Use LOADDB to load database files!% -%" T) (ERROR!))% -" ) [AND MSFILETABLE (STORETABLE FL MSFILETABLE (PRINT (CAR (GETPROP FL 'FILEDATES] (COND (MSHASHFILENAME (UPDATECONTAINS FL FFNS T))) (* T flag means that the function  won't be erased--it might still be  interesting) (printout NIL "FNS " .P2 FFNS T) (* So the database file knows which  functions are on the file) (COND (FNS (DUMPDATABASE FNS)) (T (printout NIL "STOP" T)))) [COND (PROPFLG (PRINT (FULLNAME DBFILE) T)) (T (/PUT FL 'DATABASEFILENAME DBFILE) (* Remember that we have this file  valid already.) (/PUT FL 'DATABASE 'YES] (* Take future note of the databae  on a user call) (RETURN (FULLNAME DBFILE]) (LOADDB - [LAMBDA (FILE ASKFLAG) (* ; "Edited 7-Jul-92 09:57 by rmk:") - - (* ;; "Loads the database file corresponding to FILE, asking for confirmation only if ASKFLAG is T, which is the case from the advice on LOAD but not from usual user-level calls. Before asking, it looks around first to see whether a database file of the appropriate name really exists.") - - (DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE MSARGTABLE DWIMWAIT LOADDBFLG)) - (RESETLST - [PROG* [TEM NEWFNS FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP")) - (*PACKAGE* (CL:FIND-PACKAGE "INTERLISP")) - (NF (NAMEFIELD FILE)) - (DBSTREAM (DBFILE FILE ASKFLAG)) - (DBFILE (FULLNAME (CAR DBSTREAM] - (COND - (DBSTREAM (SETQ FORFILE (CDR DBSTREAM)) - (SETQ DBSTREAM (CAR DBSTREAM))) - (T (COND - ((NULL ASKFLAG) - (PRINTOUT T "no database file found for " NF T))) - (RETURN))) - (COND - ([COND - [ASKFLAG (COND - ((EQ (GETPROP NF 'DATABASEFILENAME) - DBFILE) (* ; - "If the database for this very file has already been loaded, don't bother doing it again.") - (PRINTOUT T "Database " DBFILE " already loaded." T) - NIL) - (T (SELECTQ (GETPROP NF 'DATABASE) - (YES T) - (NO NIL) - (SELECTQ LOADDBFLG - (YES (/PUT NF 'DATABASE 'YES)) - (NO (/PUT NF 'DATABASE 'NONE) - NIL) - (OR (AND MSFILETABLE (TESTTABLE NF (CADR MSFILETABLE))) - (COND - ((EQ (ASKUSER DWIMWAIT 'Y (LIST - "load database for" - NF)) - 'Y) - (/PUT NF 'DATABASE 'YES)) - (T (/PUT NF 'DATABASE 'NO) - NIL] - (T (/PUT NF 'DATABASE 'YES] - (LISPXPRINT (FULLNAME DBFILE) - T) (* ; "DBSTREAM was opened in DBFILE") - (RESETSAVE (INPUT DBSTREAM)) - [COND - ((EQ (SETQ TEM (READ)) - 'FNS) - (SETQ NEWFNS (READ)) - (COND - ((EQ (SETQ TEM (READ)) - 'ARGS) - [COND - [MSHASHFILENAME (BIND F WHILE (SETQ F (READ)) - DO (STORETABLE F MSARGTABLE (READ] - (T (WHILE (READ] - (SETQ TEM (READ] - (COND - ((OR (EQ (CAR (LISTP TEM)) - 'READATABASE) - (EQ TEM 'STOP)) - (COND - ((NEQ TEM 'STOP) (* ; "It must be (READATABASE)") - (READATABASE))) - (COND - (MSHASHFILENAME (UPDATECONTAINS NF NEWFNS))) - (AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE)) - (* ; - "This is done whether or not there is a hashfile.") - (UPDATEFILES) (* ; - "Mark any edited fns as needing to be reanalyzed.") - (FOR FN IN (CDR (GETP NF 'FILE)) - WHEN (OR (EXPRP FN) - (GETP FN 'EXPR)) DO (MSMARKCHANGED FN))) - (T (PRINTOUT T T DBFILE " is not a database file!" T) - (* ; "So that value of LOADDB is NIL") - (SETQ DBFILE NIL))) - (/PUT NF 'DATABASEFILENAME DBFILE) (* ; - "Remember the name of the database we just loaded.") - (RETURN (FULLNAME DBFILE])]) (MAKEDB - [LAMBDA (F) (* DECLARATIONS%: UNDOABLE) - (* rmk%: " 9-NOV-83 02:56") - (DECLARE (GLOBALVARS SAVEDBFLG MSFILETABLE DWIMWAIT)) - (SETQ F (NAMEFIELD F)) - - (* The extension is stripped off for purposes of the DATABASE. - This maps compiled files into the root name, but means that we can't have - multiple-extension files with different database status) - - (COND - ((INFILECOMS? T 'FNS (FILECOMS F)) - (OR (FMEMB (GETPROP F 'DATABASE) - '(YES NO)) - (FMEMB SAVEDBFLG '(YES NO)) - (AND MSFILETABLE (TESTTABLE F (CADR MSFILETABLE))) - (/PUT F 'DATABASE (COND - ((EQ 'Y (ASKUSER DWIMWAIT 'N - "Do you want a Masterscope Database for this file? ") - ) - 'YES) - (T 'NO]) ) (PUTPROPS DATABASE PROPTYPE IGNORE) (RPAQ? LOADDBFLG 'ASK) (RPAQ? SAVEDBFLG 'ASK) (ADDTOVAR MAKEFILEFORMS (MAKEDB FILE)) (* To permit MSHASH interface) (RPAQ? MSHASHFILENAME ) (RPAQ? MSFILETABLE ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RESETSAVE DWIMIFYCOMPFLG T) ) (PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1637 6218 (DBFILE 1647 . 3295) (DBFILE1 3297 . 4820) (DBFILE2 4822 . 5584) (LOAD 5586 . 5816) (LOADFROM 5818 . 6006) (MAKEFILE 6008 . 6216)) (6274 16706 (DUMPDB 6284 . 10572) (LOADDB 10574 . 15618) (MAKEDB 15620 . 16704))))) STOP \ No newline at end of file diff --git a/library/DORADOKEYBOARDS.~1~ b/library/DORADOKEYBOARDS.~1~ deleted file mode 100644 index f8dbcc45..00000000 --- a/library/DORADOKEYBOARDS.~1~ +++ /dev/null @@ -1 +0,0 @@ -((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (logic ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) ) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( 61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) ) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( 112 (47 61300 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( 180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( 133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( 61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( 61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( 119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( 120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( 124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( 128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (GREEK ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( 9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) ) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( 154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT ) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( 145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( 151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( 155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (SPANISH ((100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( 97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( 111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 (203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( 143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( 105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( 109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( 120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( 124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( 128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( 121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( 109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (STANDARD-RUSSIAN (( 100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( 10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) ) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( 10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO)) \ No newline at end of file diff --git a/library/DORADOKEYBOARDS.~2~ b/library/DORADOKEYBOARDS.~2~ deleted file mode 100644 index 932aee54..00000000 --- a/library/DORADOKEYBOARDS.~2~ +++ /dev/null @@ -1,171 +0,0 @@ -((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( -61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 -LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( -110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (1 1 -NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 -LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) -(122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 -61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( -129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 -LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( -250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT -)) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( -61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 -LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( -246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (logic ((100 ( -53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 -NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) -) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 -177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . -IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( -61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 -NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 -NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 -NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) - (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 - (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 -1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 -NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 -61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 -NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) -) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 -NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 -NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 -(100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 -NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( -112 (47 61300 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 -NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 -NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( -180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 -NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( -133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( -61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 -LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( -144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 -61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 -LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( -156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 -NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( -61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 -61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 -NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 -NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . -IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( -119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 - NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) -(126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 -NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 -NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( -142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 -61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 -NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 -NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 - 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN - . 2SHIFTUP)) DORADO) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 -NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 -71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 - NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 - (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( -120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( -124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( -128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 -NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 -LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 -1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . -IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 -LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 -LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( -91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (GREEK ((100 ( -53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( -104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 -LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 - 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) - (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 -LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( -9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) -) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 -NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 -LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 -1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . -IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 -9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( -154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT -) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) -DORADO) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 -NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 - LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 -NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( -116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 -LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 -LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 -NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 - 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 -LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN - . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( -145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( -151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( -155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 -NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (SPANISH ((100 (53 -61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) - (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) -(108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) -(112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 -61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( -97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( -111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 -(203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 -(98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( -143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 -82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 - LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 -LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 -NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 -61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( -105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( -109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) -(115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 -87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 -NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 -LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 - (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 -70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 -LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 -13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 -LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 -NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 -NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . -2SHIFTUP)) DORADO) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 -NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 - LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 -NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( -116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( -120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( -124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( -128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 -NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT -)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . -1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 -(95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( -121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( -109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 -LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (STANDARD-RUSSIAN (( -100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 -LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 - (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 -NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . -IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( -10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 -NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) -) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( -10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 -NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 -LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( -142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 - 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 -LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 - (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 -NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . -2SHIFTUP)) DORADO)) \ No newline at end of file diff --git a/library/DOSPRINT.~1~ b/library/DOSPRINT.~1~ deleted file mode 100644 index f4c9cc18..00000000 --- a/library/DOSPRINT.~1~ +++ /dev/null @@ -1,56 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "26-Jul-93 14:01:26" |{DSK}F:sources>FILEBROWSER.;1| 151490 - - |changes| |to:| (VARS FILEBROWSERCOMS) - - |previous| |date:| "22-Nov-94 12:16:46" |{DSK}library>FILEBROWSER.;8|) - - -; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT FILEBROWSERCOMS) - -(RPAQQ FILEBROWSERCOMS - ((COMS (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) - - (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") - - (INITVARS (FB.EXPUNGE?MENU) - (FB.BROWSERFONT DEFAULTFONT) - (FB.BROWSER.DIRECTORY.FONT BOLDFONT) - (FB.PROMPTFONT LITTLEFONT) - (FB.HARDCOPY.FONT) - (FB.HARDCOPY.DIRECTORY.FONT) - (FB.PROMPTLINES 3) - (FB.MENUFONT MENUFONT) - (FB.OVERFLOW.MAXABSOLUTE 30) - (FB.OVERFLOW.MAXFRAC 0.06) - (FB.DEFAULT.EDITOR 'TEDIT) - (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) - (FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ - NIL - (5 5 73 40)))) - (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) - (FB.BROWSERFONT DEFAULTFONT) - (FB.PROMPTFONT LITTLEFONT) - (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) - (P - (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") - - (FONTSET (FONTSET))) - (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) - (VARS FB.MENU.ITEMS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS - FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE - FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) - (COMS (* \; "Entries") - (COMMANDS "fb") - (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER - FB.SELECTEDFILES FB.FETCHFILENAME FB.PROMPTWPRINT FB.PROMPTW.FORMAT - FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) - (* \; "Setup") - (FNS FB.STARTUP FB.MAKERIGIDWINDOW) - (FNS FB.PRINTFN FB.COPYFN)) - (COMS (* \; - "commands and major subfunctions") - (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY - FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) - (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES - FB.DELETE.FILE) - (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) - (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE - FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE - FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) - (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) - (FNS FB.EDITCOMMAND FB.EDITLISPFILE FB.BROWSECOMMAND) - (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) - (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) - (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE - FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES - FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH - FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE - FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) - (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION - FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR - FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) - (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) - (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND - FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN - FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) - (COMS (* \; "window functions") - (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) - (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS - FB.DISPLAY.COUNTERS FB.COUNTER.STRING) - (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN - FB.HEADINGW.DISPLAY) - (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN - FB.CLOSE&EXPUNGE) - (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) - (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) - TBDECLS) - (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) - (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) - (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) - (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT - FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS - FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE - FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS - FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC - FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC - FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) - (LOCALVARS . T)) - (INITRECORDS FILEBROWSER FBFILEDATA) - (SYSRECORDS FILEBROWSER FBFILEDATA) - (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) - (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) - (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) - (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) - - "Opens a filebrowser window; prompts for pattern" - ))) - (VARS (|BackgroundMenu|))) - (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) - (NLAML) - (LAMA FB.PROMPTW.FORMAT - FB.PROMPTWPRINT))) - )) - -(FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) - - - -(* |;;| -"JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." -) - - -(RPAQ? FB.EXPUNGE?MENU ) - -(RPAQ? FB.BROWSERFONT DEFAULTFONT) - -(RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) - -(RPAQ? FB.PROMPTFONT LITTLEFONT) - -(RPAQ? FB.HARDCOPY.FONT ) - -(RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) - -(RPAQ? FB.PROMPTLINES 3) - -(RPAQ? FB.MENUFONT MENUFONT) - -(RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) - -(RPAQ? FB.OVERFLOW.MAXFRAC 0.06) - -(RPAQ? FB.DEFAULT.EDITOR 'TEDIT) - -(RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) - -(RPAQ? FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ - NIL - (5 5 73 40))) - -(APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) - (FB.BROWSERFONT DEFAULTFONT) - (FB.PROMPTFONT LITTLEFONT) - (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) - - -(* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") - - -(FONTSET (FONTSET)) - -(ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) - -(RPAQQ FB.MENU.ITEMS - ((|Delete| FB.DELETECOMMAND - "Marks selected files for deletion. - (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND - "Marks the selected files for deletion." - ) - ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser. -You specify how many versions to keep."))) - (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" - (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND - "Removes deletion mark from all files in the browser"))) - (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" - (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND - "Forces the copying of selected files to be done as TEXT-files") - ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND - "Forces the copying of selected files to be done as BINARY-files"))) - (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)") - (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" - (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) - - "Generates a hardcopy master of selected file; prompts for filename and format" - ) - ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) - "Sends hardcopy of selected files to a printer of your choosing"))) - (|See| FB.FASTSEECOMMAND "Displays selected files one at a time in a separate window" - (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND - "Views file quickly, uses font information, no scrolling backwards") - ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) - "Views file quickly, shows raw characters, no scrolling backwards") - ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) - "Views file with font information in a fully scrollable window") - ("FileBrowse" FB.BROWSECOMMAND - "Recursively call FileBrowser on the selected subdirectory"))) - (|Edit| FB.EDITCOMMAND - "Calls an editor on the selected files (use submenu to specify editor)" - (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) - "Calls TEdit (text editor) on selected files") - ("Lisp Edit" (FB.EDITCOMMAND LISP) - "Calls Lisp editor on selected files"))) - (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND - "LOADs selected files") - ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) - - "Performs CL:LOAD on selected files" - ) - ("Load PROP" (FB.LOADCOMMAND PROP) - - "Loads the selected files with LDFLG = PROP" - ) - ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) - - "System-loads the files (fast but not undoable)" - ) - (LOADFROM (FB.LOADCOMMAND LOADFROM) - - "Performs LOADFROM on selected files" - ) - (LOADCOMP (FB.LOADCOMMAND LOADCOMP) - - "Performs LOADCOMP on selected files" - ))) - (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" - (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) - "Calls TCOMPL on selected files") - (BCOMPL (FB.COMPILECOMMAND BCOMPL) - "Calls BCOMPL on selected files") - (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) - "COMPILE-FILE's selected files"))) - (|Expunge| FB.EXPUNGECOMMAND - "Permanently removes from the file system all files marked for deletion") - (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" - (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND - "Recomputes set of files satisfying current pattern") - ("New Pattern" FB.NEWPATTERNCOMMAND - "Prompts for a new selection pattern and updates browser") - ("New Info" FB.NEWINFOCOMMAND - "Change the set of file attributes that are displayed") - ("Set Depth" FB.DEPTHCOMMAND - "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" - ) - ("Shape to Fit" FB.SHAPECOMMAND - "Widen or narrow the browser so that all information is visible"))) - (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice"))) - -(RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") - ("2" 2 "Keep two versions of the files") - ("3" 3 "Keep three versions of the files") - ("4" 4 "Keep four versions of the files") - ("Other" :NUMBER "Select number of versions to keep"))) - -(RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE - "Erases all files still marked 'deleted'") - ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files. -Your deletions are thus ignored."))) - -(RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL - "Set depth using the global default (FILING.ENUMERATION.DEPTH)" - ) - ("Infinite" T - "Set depth to infinity, i.e., enumerate all levels of directory" - ) - ("1" 1 - "Set depth to 1, i.e., enumerate just the top level of the directory" - ) - ("2" 2 "Set depth to 2") - ("Other" :NUMBER "Set depth to some other finite depth"))) - -(RPAQQ FB.INFO.MENU.ITEMS - ((|Length| LENGTH "Toggles Length display") - (|ByteSize| BYTESIZE "Toggles ByteSize display") - (|Pages| SIZE "Toggles Pages display") - (|Type| TYPE "Toggles Type display") - (|Created| CREATIONDATE "Toggles Created display") - (|Written| WRITEDATE "Toggles Written display") - (|Read| READDATE "Toggles Read display") - (|Author| AUTHOR "Toggles Author display"))) - -(RPAQQ FB.DEFAULT.NAME.WIDTH 140) - -(RPAQQ FB.INFO.FIELDS - ((LENGTH " Length" 70 (FIX 56) - "99999999") - (SIZE "Pages" 50 (FIX 35) - "99999") - (BYTESIZE "Byt" 28 (FIX 14) - "99") - (TYPE "Type" 55 NIL "INTERPRESS") - (CREATIONDATE "Created" 170 DATE) - (READDATE "Read" 170 DATE) - (WRITEDATE "Written" 170 DATE) - (AUTHOR "Author" 120))) - -(RPAQQ FB.INFOSHADE 32800) - -(RPAQQ FB.ITEMUNSELECTEDSHADE 0) - -(RPAQQ FB.ITEMSELECTEDSHADE 4672) - - - -(* \; "Entries") - - -(DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) -(DEFINEQ - -(FB -(NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \; "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, PAT)) (QUOTE (\\\, PROPS)) (QUOTE (\\\, OPTIONS)))) (QUOTE NAME) (QUOTE FB)))) NIL) -) - -(FB.COPYBINARYCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE BINARY)))))) -) - -(FB.COPYTEXTCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE TEXT)))))) -) - -(FILEBROWSER -(LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT (QUOTE HEIGHT))) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \; "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \; "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \; "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \; "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT (QUOTE HEIGHT))))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT (QUOTE HEIGHT)) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC)) (SETQ REGION (GETREGION (PROGN (* \; "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \; "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \; "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER) (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \; "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \; "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \; "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW (QUOTE RIGHT) (QUOTE TOP))) (PROGN (* \; "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \; "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ (QUOTE (("--Abort--" NIL "Abort the current FileBrowser operation"))) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT (QUOTE WEIGHT) (QUOTE BOLD)) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W (QUOTE PASSTOMAINCOMS)))) |do| (* \; "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W (QUOTE PASSTOMAINCOMS) (UNION (QUOTE (HARDCOPYIMAGEW)) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST (QUOTE PRINTFN) (FUNCTION FB.PRINTFN) (QUOTE COPYFN) (FUNCTION FB.COPYFN) (QUOTE USERDATA) BROWSER (QUOTE CLOSEFN) (FUNCTION FB.CLOSEFN) (QUOTE AFTERCLOSEFN) (FUNCTION FB.AFTERCLOSEFN) (QUOTE HEADINGWINDOW) HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW (QUOTE HARDCOPYFN) (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \; "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.STARTUP)) (QUOTE (\\\, BROWSER)) (QUOTE (\\\, COMMANDMENU)) (QUOTE (\\\, (FUNCTION FB.UPDATEBROWSERITEMS))))) (QUOTE NAME) (QUOTE |FB-Update|) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) (RETURN BROWSERWINDOW))) -) - -(FB.TABLEBROWSER -(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)))) -) - -(FB.SELECTEDFILES -(LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))) (QUOTE SELECTED))) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL))) -) - -(FB.FETCHFILENAME -(LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM (QUOTE TABLEITEM))))) -) - -(FB.PROMPTWPRINT -(LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) (QUOTE FILEBROWSER)))) THING) (* \; "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW))))))) -) - -(FB.PROMPTW.FORMAT -(CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS))) -) - -(FB.PROMPTFORINPUT -(LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW (QUOTE WIDTH))) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) " -" (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL (QUOTE TTY) (CHARCODE (CR)))))) (WINDOWPROP PWINDOW (QUOTE PROCESS) NIL) (* \; "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT)) -) - -(FB.YES-OR-NO-P -(LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;| "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) (QUOTE Y)) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) (QUOTE N)) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL)))) -) - -(FB.ALLOW.ABORT -(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) (QUOTE BOTTOM)) (* \; "And repaint it in case it was used last time") (REDISPLAYW (CAR W))))) -) - -(\\FB.HARDCOPY.TOFILE.EXTENSION -(LAMBDA NIL (* \; "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS (QUOTE IP)) (POSTSCRIPT (QUOTE PS)) (DEFAULT TYPE)))) -) -) - - - -(* \; "Setup") - -(DEFINEQ - -(FB.STARTUP -(LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC (QUOTE |Recompute|) (|fetch| (MENU ITEMS) |of| COMMANDMENU)) COMMANDMENU) (CL:FUNCALL FN BROWSER))) -) - -(FB.MAKERIGIDWINDOW -(LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW (QUOTE REGION))))) (WINDOWPROP WINDOW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (WINDOWPROP WINDOW (QUOTE MAXSIZE) (CONS SCREENWIDTH HEIGHT)) WINDOW)) -) -) -(DEFINEQ - -(FB.PRINTFN -(LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW (QUOTE DSP))) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \; "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \; "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \; "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \; "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT (QUOTE DATE)) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM)))) -) - -(FB.COPYFN -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) -) -) - - - -(* \; "commands and major subfunctions") - -(DEFINEQ - -(FB.MENU.WHENSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.COMMANDSELECTEDFN)) (QUOTE (\\\, ITEM)) (QUOTE (\\\, MENU)) (QUOTE (\\\, KEY)))) (QUOTE NAME) (PACK* (QUOTE FB-) (CAR ITEM)) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) -) - -(FB.COMMANDSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER)))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW)))))) -) - -(FB.SUBITEMP -(LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) (QUOTE SUBITEMS)) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I)))))) -) - -(FB.MAKE.BROWSER.BUSY -(LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T))) -) - -(FB.FINISH.COMMAND -(LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \; "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W (QUOTE MENU)))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted.")))) -) - -(FB.HANDLE.ABORT.BUTTON -(LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) (QUOTE FILEBROWSER))) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER)) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \; "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC)))) -) -) -(DEFINEQ - -(FB.DELETECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) - -(FB.DELVERCOMMAND -(LAMBDA (FBROWSER) (* \; "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM))))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.DECREASING.VERSION (* \; "Just right") FILES) (FB.NAMES.INCREASING.VERSION (* \; "Close, but no cigar") (FB.SORT.VERSIONS FILES (FUNCTION FB.DECREASING.VERSION))) (SORT FILES (FUNCTION FB.NAMES.DECREASING.VERSION))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER (QUOTE DELETED)) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED))))) -) - -(FB.IS.NOT.SUBDIRECTORY.ITEM -(LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) - -(FB.DELVER.FILES -(LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \; "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED))) -) - -(FB.DELETE.FILE -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T)))) -) -) -(DEFINEQ - -(FB.UNDELETECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) - -(FB.UNDELETEALLCOMMAND -(LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) -) - -(FB.UNDELETE.FILE -(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE)))))))) -) -) -(DEFINEQ - -(FB.COPYCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE)))) -) - -(FB.RENAMECOMMAND -(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Rename|) (CONS (FUNCTION RENAMEFILE)))) -) - -(FB.COPY/RENAME.COMMAND -(LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN))))))))) -) - -(FB.COPY/RENAME.ONE -(LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \; "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD (QUOTE |Rename|)) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) (QUOTE BOTH)) (T (QUOTE TOTAL))))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \; "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE (QUOTE TOTAL))))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME)))))) -) - -(FB.COPY/RENAME.MANY -(LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted")) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST)) (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE DEVICE))) (OR (LISTGET FIELDS (QUOTE NAME)) (LISTGET FIELDS (QUOTE EXTENSION)) (LISTGET FIELDS (QUOTE VERSION)))) (* \; "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST))) (SETQ DIR (OR (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE RELATIVEDIRECTORY)))) (SETQ DEVICE (LISTGET FIELDS (QUOTE DEVICE))) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM)))) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER (QUOTE Y)) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay")) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION)))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING (QUOTE HOST) HOST (QUOTE DEVICE) DEVICE (QUOTE DIRECTORY) (|if| (NOT RETAIN) |then| DIR |else| (* \; "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) CMD MOVEFN)))))) -) - -(FB.MERGE.DIRECTORIES -(LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL)))) -) - -(FB.GREATEST.PREFIX -(LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL))))))) -) - -(FB.MAYBE.INSERT.FILE -(LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \; "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;| "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER)))) (* |;;| "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;| "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \; "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM)))) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME (QUOTE VERSION) NIL (QUOTE TENEX)))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION (QUOTE CREATIONDATE) (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)))) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME (QUOTE ICREATIONDATE))) (= CRDATE2 CRDATE))) |then| (* \; "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \; "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING (QUOTE BODY) NEWNAME (QUOTE EXTENSION) "" (QUOTE VERSION) VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \; "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \; "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD (QUOTE |Rename|))) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD (QUOTE |Rename|)) (|fetch| TISELECTED |of| OLDITEM)) (* \; "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T)))) -) - -(FB.GET.NEW.FILE.SPEC -(LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING (QUOTE DIRECTORY) (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) (QUOTE NAME)))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING (QUOTE DIRECTORY) NEWNAME (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS (QUOTE EXTENSION)))) (EQ (NCHARS NAMEFIELD) 0))) (* \; "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these")) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) (QUOTE HOST)) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME))))))) -) - -(FB.CANONICAL.DIRECTORY -(LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER (QUOTE FILEBROWSER)))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \; "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL (QUOTE ASK))) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) (QUOTE Y)) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW (QUOTE PROCESS) NIL)))) -) -) -(DEFINEQ - -(FB.HARDCOPYCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST (QUOTE SERVER) PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS)))))) -) - -(FB.HARDCOPY.TOFILE -(LAMBDA (BROWSER FILES) (* \; "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING (QUOTE NAME) (QUOTE *) (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION))) (T (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION) (QUOTE BODY) (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS (QUOTE *) (CADR TAIL))) (|if| (NEQ (CAR TAIL) (QUOTE NAME)) |then| (RETURN (SETQ MSG "Only name portion can contain *"))) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files"))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \; "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS (QUOTE DIRECTORY) NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE (QUOTE EXTENSION)))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION) (CDR TYPE)))) |do| (* \; "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE (QUOTE CONVERSION))) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) (QUOTE TEXT))) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL (QUOTE TENEX))) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS (QUOTE NAME)) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE VERSION) NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE)))))) -) -) -(DEFINEQ - -(FB.EDITCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (SELECTQ (OR OPTION FB.DEFAULT.EDITOR) (READONLY (* \; "From SEE command") (COND ((NOT (GETD (QUOTE OPENTEXTSTREAM))) (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU)) (T (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE (QUOTE INPUT)))) (COND ((LISPSOURCEFILEP STR) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STR NSTR) NSTR))) ((NOT (RANDACCESSP STR)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW) NIL (LIST (LIST (QUOTE TYPE) (GETFILEINFO STR (QUOTE TYPE))))))) (COPYBYTES STR NSTR) NSTR)))) (OPENTEXTSTREAM STR WINDOW NIL NIL (QUOTE (READONLY T)))))))) (TEDIT (TEDIT (MKATOM FILE))) (LISP (FB.EDITLISPFILE FILE BROWSER)) (NIL (COND ((LISPSOURCEFILEP FILE) (FB.EDITLISPFILE FILE BROWSER)) (T (TEDIT (MKATOM FILE))))) (CL:FUNCALL OPTION (MKATOM FILE)))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) -) - -(FB.EDITLISPFILE -(LAMBDA (FILE BROWSER) (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) (QUOTE FILEDATES))) FILE)) (NOT (GET ROOT (QUOTE FILE))) (NOT (BOUNDP (FILECOMS ROOT)))) (COND ((MOUSECONFIRM (CONCAT "The file " FILE " is not loaded or is not current. (LOAD '" FILE " 'PROP)?") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL (BQUOTE (LOAD (QUOTE (\\\, FILE)) (QUOTE PROP))))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT (QUOTE (FILES :DONTWAIT)))))) -) - -(FB.BROWSECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ FILE (|fetch| TIDATA |of| FILE)) (SETQ NAME (|fetch| (FBFILEDATA FILENAME) |of| FILE)) (|if| (OR (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL (QUOTE TENEX))) (NAMETAIL (MEMB (QUOTE NAME) FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) (QUOTE VERSION)) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \; "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \; "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS (QUOTE DIRECTORY))) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS (QUOTE DIRECTORY) (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS (QUOTE HOST)) (QUOTE OSTYPE)) (QUOTE UNIX)) |then| (* \; "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, NAME)) (QUOTE (\\\, (MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)))) (\\\,@ (AND DEPTH (BQUOTE ((QUOTE (:DEPTH (\\\, DEPTH)))))))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME)))) -) -) -(DEFINEQ - -(FB.FASTSEECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE NAME)) (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE EXTENSION))))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW (QUOTE PAGEFULLFN) (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (WINDOWPROP W (QUOTE INUSE) NIL) (DEL.PROCESS (WINDOWPROP W (QUOTE PROCESS)))))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* \; "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW (QUOTE MORETYPE))))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \; "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \; "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL)))))) -) - -(FB.FASTSEE.ONEFILE -(LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((OR (UNPACKFILENAME FILE (QUOTE NAME)) (UNPACKFILENAME FILE (QUOTE EXTENSION))) (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T))))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT (WINDOWPROP WINDOW (QUOTE TITLE)) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW (QUOTE MORETYPE) (COND (MORE (QUOTE YETMOREBUTTONS)) (T (QUOTE LASTMOREBUTTONS)))) (COND (UNFORMATTED (COPYBYTES STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT (WINDOWPROP WINDOW (QUOTE TITLE)) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW (QUOTE DSP)) (QUOTE FINISHEDMOREBUTTONS)))))))) (T (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER)))) -) - -(FB.SEEFULLFN -(LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW (QUOTE MORETYPE)))))) (EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS (QUOTE (("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one") ("Abort" ABORT "Abort viewing of this and any further files")))) (FINISHEDMOREBUTTONS (QUOTE ((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files")))) (QUOTE ((" More " MORE "View another screenfull of the file") (" Abort " ABORT "Abort view; allow this window to be re-used")))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW (QUOTE MOREEVENT) (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW (QUOTE TITLE))))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS (QUOTE REGION))) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW (QUOTE REGION)))) (QUOTE TOP)) (T (QUOTE BOTTOM))) (QUOTE LEFT)) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW (QUOTE MOREOK) NIL)))) -) - -(FB.SEEBUTTONFN -(LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \; "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW (QUOTE MOREOK) T) (NOTIFY.EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (NEXT (* \; "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW (QUOTE PROCESS)) (QUOTE (CL:THROW :NEXT)))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS)))) (SHOULDNT)))) -) -) -(DEFINEQ - -(FB.LOADCOMMAND -(LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) (QUOTE NAME) (QUOTE LOAD) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) -) - -(FB.COMPILECOMMAND -(LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) (QUOTE NAME) (QUOTE COMPILE) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) -) - -(FB.OPERATE.ON.FILES -(LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN (QUOTE LOAD))) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| (BQUOTE ((\\\, FN) (QUOTE (\\\, (FB.FETCHFILENAME FILEENTRY))) (\\\,@ (AND LDFLG (BQUOTE ((QUOTE (\\\, LDFLG)))))))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS (QUOTE PROGN) FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM)))) -) -) -(DEFINEQ - -(FB.UPDATECOMMAND -(LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER (QUOTE |Recompute|)) (FB.UPDATEBROWSERITEMS BROWSER)))) -) - -(FB.MAYBE.EXPUNGE -(LAMBDA (BROWSER COMMAND) (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. -Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL)))) -) - -(FB.UPDATEBROWSERITEMS -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \; "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \; "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \; "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION (QUOTE SIZE) INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION (QUOTE LENGTH) INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \; "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN (QUOTE DIRECTORY))))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS (QUOTE SUBTREE.SIZE))) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS (QUOTE (SORT RESETLST)))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \; "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \; "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER (QUOTE |done|)) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER)))) -) - -(FB.DATE -(LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;| "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9)))) -) - -(FB.ADJUST.DATE.WIDTH -(LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) (QUOTE DATE)) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \; "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT))) -) - -(FB.SET.BROWSER.TITLE -(LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (QUOTE TITLE) (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser")))))) -) - -(FB.MAYBE.WIDEN.NAMES -(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \; "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \; "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T)))))) -) - -(FB.SET.DEFAULT.NAME.WIDTH -(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL))) -) - -(FB.CREATE.FILEBUCKET -(LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \; "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \; "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \; "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \; "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \; "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA)) -) - -(FB.CHECK.NAME.LENGTH -(LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \; "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN))))))))) -) - -(FB.ADD.FILEGROUP -(LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA)))) (* \; "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \; "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA))))) -) - -(FB.INSERT.DIRECTORY -(LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM)) -) - -(FB.MAKE.SUBDIRECTORY.ITEM -(LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T)))) -) - -(FB.ADD.FILE -(LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM))) -) - -(FB.INSERT.FILE -(LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already")) (T (* |;;| "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \; "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \; "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE (QUOTE ADD)))) -) - -(FB.ANALYZE.PATTERN -(LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \; "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \; "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \; "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))))) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \; "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN)) -) - -(FB.GETALLFILEINFO -(LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) (QUOTE (SIZE LENGTH))) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR (QUOTE SUBTREE.SIZE)))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE))) -) -) -(DEFINEQ - -(FB.SORT.VERSIONS -(LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \; "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \; "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS)) -) - -(FB.DECREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y)))) -) - -(FB.INCREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y)))) -) - -(FB.NAMES.DECREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL)) -) - -(FB.NAMES.INCREASING.VERSION -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL)) -) - -(FB.DECREASING.NUMERIC.ATTR -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) -) - -(FB.INCREASING.NUMERIC.ATTR -(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) -) - -(FB.ALPHABETIC.ATTR -(LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL)) -) -) -(DEFINEQ - -(FB.SORTCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \; "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \; "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \; "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA)))) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \; "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done"))) -) - -(FB.INSERT.SUBDIRECTORIES -(LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \; "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL)))) -) - -(FB.GET.SORT.MENU -(LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS (QUOTE ("Name" (QUOTE NAME) "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" (QUOTE NAME) "Sort files by name, decreasing version numbers") ("Increasing version" (QUOTE (NAME T)) "Sort files by name, increasing version numbers")))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) |collect| (BQUOTE ((\\\, (SETQ ATTR (CAR ATTR))) (QUOTE (\\\, ATTR)) "Sort by this attribute" (\\\, (SELECTQ ATTR ((SIZE LENGTH BYTESIZE) (BQUOTE (SUBITEMS ("Decreasing" (QUOTE (\\\, ATTR)) "Sort files in order of decreasing size") ("Increasing" (QUOTE ((\\\, ATTR) T)) "Sort files in order of increasing size")))) ((CREATIONDATE WRITEDATE READDATE) (BQUOTE (SUBITEMS ("Newer first" (QUOTE (\\\, ATTR)) "Sort files with newer dates appearing before older dates") ("Older first" (QUOTE ((\\\, ATTR) T)) "Sort files with older dates appearing before newer dates")))) NIL)))))))))) -) -) -(DEFINEQ - -(FB.EXPUNGECOMMAND -(LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER (QUOTE DELETED))) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER (QUOTE BOTH))) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;| "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " -No") (T (CONCAT (COND (FAILED " -Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T))) -) - -(FB.NEWPATTERNCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER))))) -) - -(FB.NEWINFOCOMMAND -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW (QUOTE REGION)))) 0) (* \; "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) (QUOTE FILEBROWSER))) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "Select from the lower menu which attributes are to be displayed, -then click Recompute")))) - -(FB.DEPTHCOMMAND -(LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH)))) -) - -(FB.SHAPECOMMAND -(LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW (QUOTE EXTENT))) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW (QUOTE WIDTH)))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW (QUOTE HEIGHT)) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW (QUOTE REGION))) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) (QUOTE REGION)))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \; "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT))))) -) - -(FB.REMOVE.FILE -(LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM (QUOTE REMOVE)))) -) - -(FB.COUNT.FILE.CHANGE -(LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))))))) -) - -(FB.SETNEWPATTERN -(LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| (DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN (QUOTE HOST)))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) (QUOTE ICONWINDOW))) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN)) -) - -(FB.GET.NEWPATTERN -(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN))))) -) - -(FB.OPTIONSCOMMAND -(LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire.")) -) -) - - - -(* \; "window functions") - -(DEFINEQ - -(FB.INFOMENU.SHADEINITIALSELECTIONS -(LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW (QUOTE MENU)))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW)))) -) - -(FB.INFO.ITEM.NAMED -(LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM))) -) -) -(DEFINEQ - -(FB.MAKECOUNTERWINDOW -(LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW (QUOTE TOP)) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER)) |with| COUNTERW) (WINDOWPROP COUNTERW (QUOTE REPAINTFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE RESHAPEFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE PAGEFULLFN) (FUNCTION NILL)) COUNTERW)) -) - -(FB.COUNTERW.REDISPLAYFN -(LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) (QUOTE FILEBROWSER)))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \; "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER)))) -) - -(FB.UPDATE.COUNTERS -(LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE (QUOTE DELETED)) (* \; "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE (QUOTE TOTAL)) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT (QUOTE REPLACE))))) -) - -(FB.DISPLAY.COUNTERS -(LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW (QUOTE WIDTH))) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)))) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \; "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT (QUOTE REPLACE)) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING))) -) - -(FB.COUNTER.STRING -(LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES)))) -) -) -(DEFINEQ - -(FB.MAKEHEADINGWINDOW -(LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW (QUOTE TOP)) (WINDOWPROP HEADINGW (QUOTE PASSTOMAINCOMS) T) (* \; "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW (QUOTE REPAINTFN) (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW (QUOTE RESHAPEFN) (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \; "This is a white on black window") (DSPOPERATION (QUOTE INVERT) HEADINGW) (DSPFILL NIL BLACKSHADE (QUOTE REPLACE) HEADINGW) HEADINGW)) -) - -(FB.HEADINGW.REDISPLAYFN -(LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)) WINDOW)) -) - -(FB.HEADINGW.RESHAPEFN -(LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW))) -) - -(FB.HEADINGW.DISPLAY -(LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW (QUOTE DSP))) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) (QUOTE BORDER))) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE (QUOTE REPLACE) STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \; "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \; "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))))) -) -) -(DEFINEQ - -(FB.ICONFN -(LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) FB.ICONFONT POSITION NIL NIL (QUOTE FILE)))) -) - -(FB.INFOMENU.WHENSELECTEDFN -(LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (BROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN))) -) - -(FB.CLOSEFN -(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) (QUOTE DON\'T)) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER (QUOTE DELETED)) 0) (* \; "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) (QUOTE DON\'T)))))) -) - -(FB.EXPUNGE?.MENU -(LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT)))) -) - -(FB.AFTERCLOSEFN -(LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER) NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL))) -) - -(FB.CLOSE&EXPUNGE -(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W (QUOTE MENU)))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC (QUOTE |Expunge|) (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG)))))) -) -) -(DEFINEQ - -(FB.HARDCOPY.DIRECTORY -(LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (TBROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \; "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \; "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \; "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER))) (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS) (LIST* (QUOTE DOCUMENT.NAME) TITLE (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS)))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER) (QUOTE TITLE))) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) (QUOTE DATE)) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \; "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \; "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \; "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM)) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \; "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \; "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \; "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM)))) -) - -(FB.HARDCOPY.PRINT.TITLE -(LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T)) -) - -(FB.HARDCOPY.MAXWIDTH -(LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;| "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \; "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH))) -) -) -(DECLARE\: EVAL@COMPILE DONTCOPY - -(FILESLOAD (SOURCE) - TBDECLS) - -(DECLARE\: EVAL@COMPILE - -(RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) - -(DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") - (FILEINFO POINTER) (* \; "Plist of attributes") - (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") - (DIRECTORYP FLAG) (* \; "True if it's a directory line") - (HASDIRPREFIX FLAG) (* \; - "True if it has a directory prefix beyond that in common to all the files") - (DIRECTORYFILEP FLAG) (* \; - "True if the \"file\" in this item is actually a subdirectory") - (NIL 5 FLAG) - (SIZE POINTER) (* \; "Size of file, for stats") - (FILEDEPTH BYTE) (* \; - "Number of levels of subdirectory beneath the main pattern--zero for files at that level") - (SORTVALUE POINTER) (* \; - "Cached value by which we are sorting the dir.") - (SUBDIREND WORD) (* \; - "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") - (STARTOFPNAME WORD) (* \; - "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") - (VERSION WORD) (* \; "Version, or zero if none") - (STARTOFNAME WORD) (* \; - "Index beyond all directory fields") - DUMMY) - (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME - ) - OF DATUM) - (FETCH (FBFILEDATA STARTOFPNAME - ) OF DATUM))) - (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA - FILENAME) - OF DATUM) - 1 - (FETCH (FBFILEDATA SUBDIREND - ) OF - DATUM)))))) - -(DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \; - "True if we don't want separate subdirectory lines -- subdirs then included in name") - (NSPATTERN? FLAG) (* \; "True if host is an ns host") - (SHOWUNDELETED? FLAG) (* \; - "True if counter window should show `Undeleted' rather than `Total' counts") - (PATTERNPARSED? FLAG) (* \; - "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") - (SORTBYDATE FLAG) (* \; - "True if SORTATTRIBUTE is one of the date attributes") - (FBREADY FLAG) (* \; "False while FB is enumerating.") - (ABORTING FLAG) (* \; - "True if enumeration is being aborted") - (FIXEDTITLE FLAG) (* \; "True if caller supplied title") - (TABLEBROWSER POINTER) (* \; - "Pointer to TABLEBROWSER object controlling the browser") - (FBDISPLAYEDDEPTH BYTE) (* \; - "Depth we are currently displaying (zero for infinite)") - (BROWSERWINDOW POINTER) (* \; "Main window") - (FBCOMPUTEDDEPTH BYTE) (* \; - "Depth at the time we enumerated directory (zero for infinite)") - (COUNTERWINDOW POINTER) (* \; - "Window that counts files, pages, deletions") - (HEADINGWINDOW POINTER) (* \; - "Window with headings for browser columns") - (INFOMENUW POINTER) (* \; - "Window containing choices for info to be displayed, or NIL if none yet") - (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") - (INFODISPLAYED POINTER) (* \; - "List of attribute specs to be displayed") - (PATTERN POINTER) (* \; - "Directory pattern being enumerated") - (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") - (SEEWINDOW POINTER) (* \; - "Primary window used by FAST SEE command") - (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") - (SORTBY POINTER) (* \; - "Sorting function or NIL for default sort") - (NAMESTART WORD) (* \; - "Index of first character in file name beyond the common prefix shared by all") - (DIRECTORYSTART WORD) (* \; - "Index of first character of directory in file names") - (INFOSTART WORD) (* \; - "X position in browser where first col of info is displayed") - (NAMEOVERHEAD WORD) (* \; - "This plus width of name gives is how much to allow before INFOSTART") - (OVERFLOWSPACING WORD) (* \; - "Increment between sizes considered for INFOSTART") - (DIGITWIDTH WORD) - (TOTALFILES WORD) (* \; - "Total number of files, deleted files, pages, deleted pages at the moment") - (DELETEDFILES WORD) - (TOTALPAGES POINTER) - (DELETEDPAGES POINTER) - (PAGECOUNT? POINTER) (* \; - "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") - (COUNTERPOSITIONS POINTER) (* \; - "List of pairs (left right) describing regions where the values of the counters are displayed") - (COUNTERPAGESTRING POINTER) (* \; - "String to print after file/page count") - (OVERFLOWWIDTHS POINTER) (* \; - "List of (xpos occurrences) describing files whose names exceed default INFOSTART") - (INFOMENUCHOICES POINTER) (* \; - "Selections user has made in Info window, not necessarily the info currently displayed") - (UPDATEPROC POINTER) (* \; - "Process doing an Update (Recompute)") - (DEFAULTDIR POINTER) (* \; - "Default directory for destination of Copy/Rename") - (SORTATTRIBUTE POINTER) (* \; - "Attribute being sorted on, or NIL if by name") - (SORTMENU POINTER) - (FBLOCK POINTER) (* \; - "Lock acquired by filebrowser operations") - (SORTINDEX WORD) (* \; - "Index (zero-based) in file info of the sort attribute") - (SIZEINDEX WORD) (* \; "Index of size attribute") - (FBDEPTH POINTER) (* \; - "Enumeration depth, or NIL for default") - (ABORTWINDOW POINTER) (* \; - "Dotted pair of (abortwindow . menuw) for this browser's abort window.") - DUMMY)) -) - -(/DECLAREDATATYPE 'FBFILEDATA - '(POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE POINTER WORD - WORD WORD WORD POINTER) - '((FBFILEDATA 0 POINTER) - (FBFILEDATA 2 POINTER) - (FBFILEDATA 4 POINTER) - (FBFILEDATA 4 (FLAGBITS . 0)) - (FBFILEDATA 4 (FLAGBITS . 16)) - (FBFILEDATA 4 (FLAGBITS . 32)) - (FBFILEDATA 4 (FLAGBITS . 48)) - (FBFILEDATA 4 (FLAGBITS . 64)) - (FBFILEDATA 4 (FLAGBITS . 80)) - (FBFILEDATA 4 (FLAGBITS . 96)) - (FBFILEDATA 4 (FLAGBITS . 112)) - (FBFILEDATA 6 POINTER) - (FBFILEDATA 6 (BITS . 7)) - (FBFILEDATA 8 POINTER) - (FBFILEDATA 10 (BITS . 15)) - (FBFILEDATA 11 (BITS . 15)) - (FBFILEDATA 12 (BITS . 15)) - (FBFILEDATA 13 (BITS . 15)) - (FBFILEDATA 14 POINTER)) - '16) - -(/DECLAREDATATYPE 'FILEBROWSER - '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE POINTER BYTE POINTER POINTER POINTER - POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD - WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) - '((FILEBROWSER 0 (FLAGBITS . 0)) - (FILEBROWSER 0 (FLAGBITS . 16)) - (FILEBROWSER 0 (FLAGBITS . 32)) - (FILEBROWSER 0 (FLAGBITS . 48)) - (FILEBROWSER 0 (FLAGBITS . 64)) - (FILEBROWSER 0 (FLAGBITS . 80)) - (FILEBROWSER 0 (FLAGBITS . 96)) - (FILEBROWSER 0 (FLAGBITS . 112)) - (FILEBROWSER 0 POINTER) - (FILEBROWSER 2 (BITS . 7)) - (FILEBROWSER 2 POINTER) - (FILEBROWSER 4 (BITS . 7)) - (FILEBROWSER 4 POINTER) - (FILEBROWSER 6 POINTER) - (FILEBROWSER 8 POINTER) - (FILEBROWSER 10 POINTER) - (FILEBROWSER 12 POINTER) - (FILEBROWSER 14 POINTER) - (FILEBROWSER 16 POINTER) - (FILEBROWSER 18 POINTER) - (FILEBROWSER 20 POINTER) - (FILEBROWSER 22 POINTER) - (FILEBROWSER 24 (BITS . 15)) - (FILEBROWSER 25 (BITS . 15)) - (FILEBROWSER 26 (BITS . 15)) - (FILEBROWSER 27 (BITS . 15)) - (FILEBROWSER 28 (BITS . 15)) - (FILEBROWSER 29 (BITS . 15)) - (FILEBROWSER 30 (BITS . 15)) - (FILEBROWSER 31 (BITS . 15)) - (FILEBROWSER 32 POINTER) - (FILEBROWSER 34 POINTER) - (FILEBROWSER 36 POINTER) - (FILEBROWSER 38 POINTER) - (FILEBROWSER 40 POINTER) - (FILEBROWSER 42 POINTER) - (FILEBROWSER 44 POINTER) - (FILEBROWSER 46 POINTER) - (FILEBROWSER 48 POINTER) - (FILEBROWSER 50 POINTER) - (FILEBROWSER 52 POINTER) - (FILEBROWSER 54 POINTER) - (FILEBROWSER 56 (BITS . 15)) - (FILEBROWSER 57 (BITS . 15)) - (FILEBROWSER 58 POINTER) - (FILEBROWSER 60 POINTER) - (FILEBROWSER 62 POINTER)) - '64) - -(DECLARE\: EVAL@COMPILE - -(RPAQQ FB.MORE.BORDER 8) - -(RPAQQ FB.NULL.VERSION 0) - - -(CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) -) - -(DECLARE\: EVAL@COMPILE - -(PUTPROPS NULL.VERSIONP MACRO ((V) - (EQ V 0))) - -(PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) - (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) - 0))) - -(PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) - (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) - |of| FD1) - (|fetch| (FBFILEDATA FILENAME) |of| - FD2) - :END1 - (|fetch| (FBFILEDATA SUBDIREND) |of| - FD1) - :END2 - (|fetch| (FBFILEDATA SUBDIREND) |of| - FD2)))) - -(PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) - (OR (NULL STR) - (EQ (NCHARS STR) - 0)))) -) - -(DECLARE\: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT - FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS - FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE - FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| - FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC - FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) -) - -(DECLARE\: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) - -(/DECLAREDATATYPE 'FILEBROWSER - '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE POINTER BYTE POINTER POINTER POINTER - POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD - WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) - '((FILEBROWSER 0 (FLAGBITS . 0)) - (FILEBROWSER 0 (FLAGBITS . 16)) - (FILEBROWSER 0 (FLAGBITS . 32)) - (FILEBROWSER 0 (FLAGBITS . 48)) - (FILEBROWSER 0 (FLAGBITS . 64)) - (FILEBROWSER 0 (FLAGBITS . 80)) - (FILEBROWSER 0 (FLAGBITS . 96)) - (FILEBROWSER 0 (FLAGBITS . 112)) - (FILEBROWSER 0 POINTER) - (FILEBROWSER 2 (BITS . 7)) - (FILEBROWSER 2 POINTER) - (FILEBROWSER 4 (BITS . 7)) - (FILEBROWSER 4 POINTER) - (FILEBROWSER 6 POINTER) - (FILEBROWSER 8 POINTER) - (FILEBROWSER 10 POINTER) - (FILEBROWSER 12 POINTER) - (FILEBROWSER 14 POINTER) - (FILEBROWSER 16 POINTER) - (FILEBROWSER 18 POINTER) - (FILEBROWSER 20 POINTER) - (FILEBROWSER 22 POINTER) - (FILEBROWSER 24 (BITS . 15)) - (FILEBROWSER 25 (BITS . 15)) - (FILEBROWSER 26 (BITS . 15)) - (FILEBROWSER 27 (BITS . 15)) - (FILEBROWSER 28 (BITS . 15)) - (FILEBROWSER 29 (BITS . 15)) - (FILEBROWSER 30 (BITS . 15)) - (FILEBROWSER 31 (BITS . 15)) - (FILEBROWSER 32 POINTER) - (FILEBROWSER 34 POINTER) - (FILEBROWSER 36 POINTER) - (FILEBROWSER 38 POINTER) - (FILEBROWSER 40 POINTER) - (FILEBROWSER 42 POINTER) - (FILEBROWSER 44 POINTER) - (FILEBROWSER 46 POINTER) - (FILEBROWSER 48 POINTER) - (FILEBROWSER 50 POINTER) - (FILEBROWSER 52 POINTER) - (FILEBROWSER 54 POINTER) - (FILEBROWSER 56 (BITS . 15)) - (FILEBROWSER 57 (BITS . 15)) - (FILEBROWSER 58 POINTER) - (FILEBROWSER 60 POINTER) - (FILEBROWSER 62 POINTER)) - '64) - -(/DECLAREDATATYPE 'FBFILEDATA - '(POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE POINTER WORD - WORD WORD WORD POINTER) - '((FBFILEDATA 0 POINTER) - (FBFILEDATA 2 POINTER) - (FBFILEDATA 4 POINTER) - (FBFILEDATA 4 (FLAGBITS . 0)) - (FBFILEDATA 4 (FLAGBITS . 16)) - (FBFILEDATA 4 (FLAGBITS . 32)) - (FBFILEDATA 4 (FLAGBITS . 48)) - (FBFILEDATA 4 (FLAGBITS . 64)) - (FBFILEDATA 4 (FLAGBITS . 80)) - (FBFILEDATA 4 (FLAGBITS . 96)) - (FBFILEDATA 4 (FLAGBITS . 112)) - (FBFILEDATA 6 POINTER) - (FBFILEDATA 6 (BITS . 7)) - (FBFILEDATA 8 POINTER) - (FBFILEDATA 10 (BITS . 15)) - (FBFILEDATA 11 (BITS . 15)) - (FBFILEDATA 12 (BITS . 15)) - (FBFILEDATA 13 (BITS . 15)) - (FBFILEDATA 14 POINTER)) - '16) -(ADDTOVAR SYSTEMRECLST - -(DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) - (NSPATTERN? FLAG) - (SHOWUNDELETED? FLAG) - (PATTERNPARSED? FLAG) - (SORTBYDATE FLAG) - (FBREADY FLAG) - (ABORTING FLAG) - (FIXEDTITLE FLAG) - (TABLEBROWSER POINTER) - (FBDISPLAYEDDEPTH BYTE) - (BROWSERWINDOW POINTER) - (FBCOMPUTEDDEPTH BYTE) - (COUNTERWINDOW POINTER) - (HEADINGWINDOW POINTER) - (INFOMENUW POINTER) - (PROMPTWINDOW POINTER) - (INFODISPLAYED POINTER) - (PATTERN POINTER) - (PREPAREDPATTERN POINTER) - (SEEWINDOW POINTER) - (BROWSERFONT POINTER) - (SORTBY POINTER) - (NAMESTART WORD) - (DIRECTORYSTART WORD) - (INFOSTART WORD) - (NAMEOVERHEAD WORD) - (OVERFLOWSPACING WORD) - (DIGITWIDTH WORD) - (TOTALFILES WORD) - (DELETEDFILES WORD) - (TOTALPAGES POINTER) - (DELETEDPAGES POINTER) - (PAGECOUNT? POINTER) - (COUNTERPOSITIONS POINTER) - (COUNTERPAGESTRING POINTER) - (OVERFLOWWIDTHS POINTER) - (INFOMENUCHOICES POINTER) - (UPDATEPROC POINTER) - (DEFAULTDIR POINTER) - (SORTATTRIBUTE POINTER) - (SORTMENU POINTER) - (FBLOCK POINTER) - (SORTINDEX WORD) - (SIZEINDEX WORD) - (FBDEPTH POINTER) - (ABORTWINDOW POINTER) - DUMMY)) - -(DATATYPE FBFILEDATA ((FILENAME POINTER) - (FILEINFO POINTER) - (VERSIONLESSNAME POINTER) - (DIRECTORYP FLAG) - (HASDIRPREFIX FLAG) - (DIRECTORYFILEP FLAG) - (NIL 5 FLAG) - (SIZE POINTER) - (FILEDEPTH BYTE) - (SORTVALUE POINTER) - (SUBDIREND WORD) - (STARTOFPNAME WORD) - (VERSION WORD) - (STARTOFNAME WORD) - DUMMY)) -) -(DECLARE\: DONTEVAL@LOAD DOCOPY - -(MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) - - -(ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) - (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) - -(ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) - "Opens a filebrowser window; prompts for pattern")) - - -(RPAQQ |BackgroundMenu| NIL) -) -(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA FB) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) -) -(PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 -1991 1993 1994)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (20900 32609 (FB 20910 . 21465) (FB.COPYBINARYCOMMAND 21467 . 21655) (FB.COPYTEXTCOMMAND - 21657 . 21841) (FILEBROWSER 21843 . 28085) (FB.TABLEBROWSER 28087 . 28249) (FB.SELECTEDFILES 28251 . -28705) (FB.FETCHFILENAME 28707 . 28942) (FB.PROMPTWPRINT 28944 . 29395) (FB.PROMPTW.FORMAT 29397 . -29918) (FB.PROMPTFORINPUT 29920 . 31269) (FB.YES-OR-NO-P 31271 . 31831) (FB.ALLOW.ABORT 31833 . 32408) - (\\FB.HARDCOPY.TOFILE.EXTENSION 32410 . 32607)) (32633 33295 (FB.STARTUP 32643 . 32938) ( -FB.MAKERIGIDWINDOW 32940 . 33293)) (33296 36315 (FB.PRINTFN 33306 . 36166) (FB.COPYFN 36168 . 36313)) -(36365 39782 (FB.MENU.WHENSELECTEDFN 36375 . 36669) (FB.COMMANDSELECTEDFN 36671 . 37532) (FB.SUBITEMP -37534 . 37846) (FB.MAKE.BROWSER.BUSY 37848 . 38256) (FB.FINISH.COMMAND 38258 . 39177) ( -FB.HANDLE.ABORT.BUTTON 39179 . 39780)) (39783 42491 (FB.DELETECOMMAND 39793 . 39993) (FB.DELVERCOMMAND - 39995 . 41374) (FB.IS.NOT.SUBDIRECTORY.ITEM 41376 . 41503) (FB.DELVER.FILES 41505 . 42081) ( -FB.DELETE.FILE 42083 . 42489)) (42492 43322 (FB.UNDELETECOMMAND 42502 . 42706) (FB.UNDELETEALLCOMMAND -42708 . 42906) (FB.UNDELETE.FILE 42908 . 43320)) (43323 55461 (FB.COPYCOMMAND 43333 . 43491) ( -FB.RENAMECOMMAND 43493 . 43657) (FB.COPY/RENAME.COMMAND 43659 . 44182) (FB.COPY/RENAME.ONE 44184 . -45282) (FB.COPY/RENAME.MANY 45284 . 48395) (FB.MERGE.DIRECTORIES 48397 . 48634) (FB.GREATEST.PREFIX -48636 . 49296) (FB.MAYBE.INSERT.FILE 49298 . 52987) (FB.GET.NEW.FILE.SPEC 52989 . 54800) ( -FB.CANONICAL.DIRECTORY 54802 . 55459)) (55462 59073 (FB.HARDCOPYCOMMAND 55472 . 56087) ( -FB.HARDCOPY.TOFILE 56089 . 59071)) (59074 63251 (FB.EDITCOMMAND 59084 . 60375) (FB.EDITLISPFILE 60377 - . 60971) (FB.BROWSECOMMAND 60973 . 63249)) (63252 68617 (FB.FASTSEECOMMAND 63262 . 64855) ( -FB.FASTSEE.ONEFILE 64857 . 66336) (FB.SEEFULLFN 66338 . 67960) (FB.SEEBUTTONFN 67962 . 68615)) (68618 -69748 (FB.LOADCOMMAND 68628 . 68935) (FB.COMPILECOMMAND 68937 . 69278) (FB.OPERATE.ON.FILES 69280 . -69746)) (69749 94509 (FB.UPDATECOMMAND 69759 . 69918) (FB.MAYBE.EXPUNGE 69920 . 70515) ( -FB.UPDATEBROWSERITEMS 70517 . 76963) (FB.DATE 76965 . 77361) (FB.ADJUST.DATE.WIDTH 77363 . 78706) ( -FB.SET.BROWSER.TITLE 78708 . 79304) (FB.MAYBE.WIDEN.NAMES 79306 . 80282) (FB.SET.DEFAULT.NAME.WIDTH -80284 . 80869) (FB.CREATE.FILEBUCKET 80871 . 84496) (FB.CHECK.NAME.LENGTH 84498 . 85995) ( -FB.ADD.FILEGROUP 85997 . 86977) (FB.INSERT.DIRECTORY 86979 . 87188) (FB.MAKE.SUBDIRECTORY.ITEM 87190 - . 88002) (FB.ADD.FILE 88004 . 88454) (FB.INSERT.FILE 88456 . 90353) (FB.ANALYZE.PATTERN 90355 . 93024 -) (FB.CANONICALIZE.PATTERN 93026 . 93772) (FB.GETALLFILEINFO 93774 . 94507)) (94510 98920 ( -FB.SORT.VERSIONS 94520 . 95613) (FB.DECREASING.VERSION 95615 . 96005) (FB.INCREASING.VERSION 96007 . -96394) (FB.NAMES.DECREASING.VERSION 96396 . 96946) (FB.NAMES.INCREASING.VERSION 96948 . 97493) ( -FB.DECREASING.NUMERIC.ATTR 97495 . 97989) (FB.INCREASING.NUMERIC.ATTR 97991 . 98479) ( -FB.ALPHABETIC.ATTR 98481 . 98918)) (98921 103500 (FB.SORTCOMMAND 98931 . 101943) ( -FB.INSERT.SUBDIRECTORIES 101945 . 102372) (FB.GET.SORT.MENU 102374 . 103498)) (103501 112137 ( -FB.EXPUNGECOMMAND 103511 . 104578) (FB.NEWPATTERNCOMMAND 104580 . 104847) (FB.NEWINFOCOMMAND 104849 . -106136) (FB.DEPTHCOMMAND 106138 . 106937) (FB.SHAPECOMMAND 106939 . 108876) (FB.REMOVE.FILE 108878 . -110058) (FB.COUNT.FILE.CHANGE 110060 . 110853) (FB.SETNEWPATTERN 110855 . 111601) (FB.GET.NEWPATTERN -111603 . 111960) (FB.OPTIONSCOMMAND 111962 . 112135)) (112172 112766 ( -FB.INFOMENU.SHADEINITIALSELECTIONS 112182 . 112534) (FB.INFO.ITEM.NAMED 112536 . 112764)) (112767 -117596 (FB.MAKECOUNTERWINDOW 112777 . 113456) (FB.COUNTERW.REDISPLAYFN 113458 . 113816) ( -FB.UPDATE.COUNTERS 113818 . 115097) (FB.DISPLAY.COUNTERS 115099 . 117396) (FB.COUNTER.STRING 117398 . -117594)) (117597 120196 (FB.MAKEHEADINGWINDOW 117607 . 118376) (FB.HEADINGW.REDISPLAYFN 118378 . -118556) (FB.HEADINGW.RESHAPEFN 118558 . 118842) (FB.HEADINGW.DISPLAY 118844 . 120194)) (120197 122901 -(FB.ICONFN 120207 . 120455) (FB.INFOMENU.WHENSELECTEDFN 120457 . 120980) (FB.CLOSEFN 120982 . 121612) -(FB.EXPUNGE?.MENU 121614 . 121869) (FB.AFTERCLOSEFN 121871 . 122157) (FB.CLOSE&EXPUNGE 122159 . 122899 -)) (122902 129086 (FB.HARDCOPY.DIRECTORY 122912 . 128062) (FB.HARDCOPY.PRINT.TITLE 128064 . 128313) ( -FB.HARDCOPY.MAXWIDTH 128315 . 129084))))) -STOP diff --git a/library/FOREIGN-FUNCTIONS.~1~ b/library/FOREIGN-FUNCTIONS.~1~ deleted file mode 100644 index cc38c5dd..00000000 --- a/library/FOREIGN-FUNCTIONS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "29-Jan-92 17:36:03" |{PELE:MV:ENVOS}LIBRARY>FOREIGN-FUNCTIONS.;2| 4980 |changes| |to:| (FUNCTIONS FOREIGN-FUNCTIONS:DEFFOREIGN FOREIGN-FUNCTIONS::DLD-LINK) (VARS FOREIGN-FUNCTIONSCOMS) |previous| |date:| "29-Jan-92 13:51:24" |{PELE:MV:ENVOS}LIBRARY>FOREIGN-FUNCTIONS.;1| ) ; Copyright (c) 1992 by Venue. All rights reserved. (PRETTYCOMPRINT FOREIGN-FUNCTIONSCOMS) (RPAQQ FOREIGN-FUNCTIONSCOMS ((P (CL:UNLESS (FIND-PACKAGE :FOREIGN-FUNCTIONS) (CL:MAKE-PACKAGE "FOREIGN-FUNCTIONS" :NICKNAMES '(:FF :FOREIGN) :USE '(:CL)))) (FUNCTIONS FOREIGN-FUNCTIONS:DEFFOREIGN FOREIGN-FUNCTIONS::DLD-LINK ))) (CL:UNLESS (FIND-PACKAGE :FOREIGN-FUNCTIONS) (CL:MAKE-PACKAGE "FOREIGN-FUNCTIONS" :NICKNAMES '(:FF :FOREIGN) :USE '(:CL))) (CL:DEFUN FOREIGN-FUNCTIONS:DEFFOREIGN (CL:FUNCTION FOREIGN-FUNCTIONS::RESULT-TYPE FOREIGN-FUNCTIONS::ARGLIST &KEY FOREIGN-FUNCTIONS::FUNCTION-NAME) (* |;;| "Define a foreign function") (COND ((CL:GETHASH CL:FUNCTION FOREIGN-FUNCTIONS::*FOREIGN-FUNCTION-ADDRESS*) (CL:WARN "Function ~s being redefined." CL:FUNCTION))) (CL:SETF (CL:GETHASH CL:FUNCTION FOREIGN-FUNCTIONS::*FOREIGN-FUNCTION-ADDRESS*) 0) (OR (FMEMB FOREIGN-FUNCTIONS::RESULT-TYPE '(:INT :VOID :LONG :SHORT :CHAR :BYTE :LISPPTR :CPOINTER :FLOAT)) (CL:ERROR "RESULT-TYPE arg ~s not a valid choice." FOREIGN-FUNCTIONS::RESULT-TYPE)) (CL:DOLIST (FOREIGN-FUNCTIONS::ARG FOREIGN-FUNCTIONS::ARGLIST) (OR (FMEMB FOREIGN-FUNCTIONS::ARG '(:INT :VOID :LONG :SHORT :CHAR :BYTE :LISPPTR :CPOINTER :FLOAT)) (CL:ERROR "ARGLIST arg ~s not a valid choice." FOREIGN-FUNCTIONS::ARG))) (LET ((FOREIGN-FUNCTIONS::ADDRESS-CELL (\\CREATECELL \\FIXP)) (FOREIGN-FUNCTIONS::ERROR-CELL (\\CREATECELL \\FIXP)) (FOREIGN-FUNCTIONS::CONVERSIONS-BLOCK (\\ALLOCBLOCK (CL:1+ (CL:LENGTH FOREIGN-FUNCTIONS::ARGLIST )) NIL))) (CL:EVAL `(CL:DEFUN ,CL:FUNCTION ,(FOR FOREIGN-FUNCTIONS::ARG FOREIGN-FUNCTIONS::ARGLIST AS FOREIGN-FUNCTIONS::I FROM 1 COLLECT (CL:INTERN (CONCAT "Arg-" FOREIGN-FUNCTIONS::I) (CL:SYMBOL-PACKAGE CL:FUNCTION))) (COND ((CL:ZEROP ,FOREIGN-FUNCTIONS::ADDRESS-CELL) (CL:ERROR "Foreign function never loaded: ~s" ',CL:FUNCTION)) ((= -1 ,FOREIGN-FUNCTIONS::ADDRESS-CELL) (CL:ERROR "Foreign function was unloaded: ~s" ',CL:FUNCTION)) ((= -2 ,FOREIGN-FUNCTIONS::ADDRESS-CELL) (CL:ERROR "Foreign function has unresolved external references: ~s" ',CL:FUNCTION)) (T (PROG1 (MISCN 12 ,FOREIGN-FUNCTIONS::ADDRESS-CELL ,FOREIGN-FUNCTIONS::CONVERSIONS-BLOCK ,FOREIGN-FUNCTIONS::ERROR-CELL ,@(FOR FOREIGN-FUNCTIONS::ARG IN FOREIGN-FUNCTIONS::ARGLIST AS FOREIGN-FUNCTIONS::I FROM 1 COLLECT (CL:INTERN (CONCAT "Arg-" USER::I) (CL:SYMBOL-PACKAGE CL:FUNCTION)))) (OR (CL:ZEROP ,FOREIGN-FUNCTIONS::ERROR-CELL) (CL:ERROR "Foreign function encountered error during call: ~s" ',CL:FUNCTION))))))) (CL:COMPILE CL:FUNCTION))) (CL:DEFUN FOREIGN-FUNCTIONS::DLD-LINK (PATHNAME) (CL:TYPECASE PATHNAME (STRING (FOREIGN-FUNCTIONS::SUBR FOREIGN-FUNCTIONS::DLD-LINK PATHNAME)) (T (CL:ERROR "PATHNAME SHOULD BE OF TYPE STRING")))) (PUTPROPS FOREIGN-FUNCTIONS COPYRIGHT ("Venue" 1992)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/GRAPHER.~1~ b/library/GRAPHER.~1~ deleted file mode 100644 index 937befc0..00000000 --- a/library/GRAPHER.~1~ +++ /dev/null @@ -1,3829 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Apr-94 14:04:03" {DSK}export>lispcore>library>GRAPHER.;3 214067 - - changes to%: (FNS ADD/AND/DISPLAY/LINK DELETE/AND/DISPLAY/LINK DISPLAY/NAME DISPLAYLINK/BT - DISPLAYLINK/LR DISPLAYLINK/RL DISPLAYLINK/TB ERASE/GRAPHNODE EDITADDNODE - FLIPNODE FROMLINKS GN/BOTTOM GN/LEFT GN/RIGHT GN/TOP GRAPHADDLINK - GRAPHDELETELINK GRAPHREGION LAYOUT/POSITION LINKPARAMETERS MEASUREGRAPHNODE - NODELST/AS/MENU PRINTDISPLAYNODE RESET/NODE/BORDER RESET/NODE/LABELSHADE - SCALE/GRAPH SCALE/TONODES SET/LABEL/SIZE SET/LAYOUT/POSITION TOLINKS - TRACKCURSOR TRANSGRAPH MOVEDESCENDENTS BRHL/LAYOUT/DAUGHTERS BRHL/MOVE/RIGHT - LATTICE/BREAK/CYCLES LAYOUTGRAPH MARK/GRAPH/NODE NEW/INSTANCE/OF/GRAPHNODE - ALIGNMENTNODE GRAPHOBJ.CHECKALIGN GRAPHOBJ.GETALIGN GRAPHOBJ.IMAGEBOXFN - GRAPHOBJ.PUTALIGN COPYGRAPH DUMPGRAPH READGRAPH) - - previous date%: "28-Sep-93 17:25:38" {DSK}export>lispcore>library>GRAPHER.;2) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT GRAPHERCOMS) - -(RPAQQ GRAPHERCOMS - [(COMS (* ; "Graph Editing") - (FNS ADD/AND/DISPLAY/LINK APPLYTOSELECTEDNODE CALL.MOVENODEFN CHANGE.NODEFONT.SIZE - DEFAULT.ADDNODEFN DELETE/AND/DISPLAY/LINK DISPLAY/NAME DISPLAYGRAPH DISPLAYLINK - DISPLAYLINK/BT DISPLAYLINK/LR DISPLAYLINK/RL DISPLAYLINK/TB DISPLAYNODE - ERASE/GRAPHNODE DISPLAYNODE DISPLAYNODELINKS DRAW/GRAPHNODE/BORDER DRAWAREABOX - EDITADDLINK EDITADDNODE EDITAPPLYTOLINK EDITCHANGEFONT EDITCHANGELABEL - EDITDELETELINK EDITDELETENODE EDITGRAPH EDITGRAPH1 EDITGRAPH2 EDITMOVENODE - EDITTOGGLEBORDER EDITTOGGLELABEL FILL/GRAPHNODE/LABEL FIX/SCALE FLIPNODE - FONTNAMELIST FROMLINKS GETNODEFROMID GN/BOTTOM GN/LEFT GN/RIGHT GN/TOP - GRAPHADDLINK GRAPHADDNODE GRAPHBUTTONEVENTFN GRAPHCHANGELABEL GRAPHDELETELINK - GRAPHDELETENODE GRAPHEDITCOMMANDFN GRAPHEDITEVENTFN GRAPHER/CENTERPRINTINAREA - GRAPHERPROP GRAPHNODE/BORDER/WIDTH GRAPHREGION HARDCOPYGRAPH - INTERSECT/REGIONP/LBWH INVERTED/GRAPHNODE/BORDER INVERTED/SHADE/FOR/GRAPHER - LAYOUT/POSITION LINKPARAMETERS MAX/RIGHT MAX/TOP MEASUREGRAPHNODE MEMBTONODES - MIN/BOTTOM MIN/LEFT MOVENODE NODECREATE NODELST/AS/MENU NODEREGION - PRINTDISPLAYNODE PROMPTINWINDOW READ/NODE REDISPLAYGRAPH REMOVETONODES - RESET/NODE/BORDER RESET/NODE/LABELSHADE SCALE/GRAPH SCALE/GRAPHNODE/BORDER - SCALE/TONODES SET/LABEL/SIZE SET/LAYOUT/POSITION SHOWGRAPH SIZE/GRAPH/WINDOW - TOGGLE/DIRECTEDFLG TOGGLE/SIDESFLG TOLINKS TRACKCURSOR TRACKNODE TRANSGRAPH) - - (* ;; "Support for EDITSUBGRAPH and EDITREGION") - - (FNS EDITMOVEREGION EDITMOVESUBTREE NOT.TRACKCURSOR RECURSIVE.COLLECTDESCENDENTS - MOVEDESCENDENTS COLLECT.CHILD.NODES CREATE.NEW.NODEPOSITION - GETBOXPOSITION.FROMINITIALREGION COLLECTDESCENDENTS)) - (COMS (* ; - "functions for finding larger and smaller fonts") - (FNS NEXTSIZEFONT DECREASING.FONT.LIST SCALE.FONT) - [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DECREASING.FONT.LIST (DECREASING.FONT.LIST] - (GLOBALVARS DECREASING.FONT.LIST)) - (* ; - "functions for LAYOUTGRAPH And LAYOUTLATTICE") - (FNS BRH/LAYOUT BRH/LAYOUT/DAUGHTERS BRH/OFFSET BRHC/INTERTREE/SPACE BRHC/LAYOUT - BRHC/LAYOUT/DAUGHTERS BRHC/LAYOUT/TERMINAL BRHC/OFFSET BRHL/LAYOUT BRHL/LAYOUT/DAUGHTERS - BRHL/MOVE/RIGHT BROWSE/LAYOUT/HORIZ BROWSE/LAYOUT/HORIZ/COMPACTLY BROWSE/LAYOUT/LATTICE - BRV/OFFSET EXTEND/TRANSITION/CHAIN FOREST/BREAK/CYCLES INIT/NODES/FOR/LAYOUT - INTERPRET/MARK/FORMAT LATTICE/BREAK/CYCLES LAYOUTFOREST LAYOUTGRAPH LAYOUTLATTICE - LAYOUTSEXPR LAYOUTSEXPR1 MARK/GRAPH/NODE NEW/INSTANCE/OF/GRAPHNODE - RAISE/TRANSITION/CHAIN REFLECT/GRAPH/DIAGONALLY REFLECT/GRAPH/HORIZONTALLY - REFLECT/GRAPH/VERTICALLY SWITCH/NODE/HEIGHT/WIDTH) - (CONSTANTS (LINKPARAMS 'Link% Parameters)) - [VARS (DEFAULT.GRAPH.NODEBORDER) - (DEFAULT.GRAPH.NODEFONT) - (DEFAULT.GRAPH.NODELABELSHADE) - (ScalableLinkParameters '(LINEWIDTH)) - (CACHE/NODE/LABEL/BITMAPS) - (NODEBORDERWIDTH 1) - (GRAPH/HARDCOPY/FORMAT '(MODE PORTRAIT PAGENUMBERS T TRANS NIL] - [INITVARS (DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7) - (TIMES SCREENHEIGHT 0.4))) - (EDITGRAPHMENUCOMMANDS '((Move% Node 'MOVENODE "Moves a single node in the graph." - (SUBITEMS (|Move Single Node| 'MOVENODE - "Moves a single node in the graph.") - (|Move Node and Subtree| (EDITMOVESUBTREE - GRAPHWINDOW) - - "Moves a subtree of nodes relative to the movement of their root." - ) - (Move% Region (EDITMOVEREGION GRAPHWINDOW) - - "Moves a group of nodes within a specified region to another region." - ))) - ("Add Node" 'ADDNODE) - ("Delete Node" 'DELETENODE) - ("Add Link" 'ADDLINK) - ("Delete Link" 'DELETELINK) - ("Change label" 'CHANGELABEL) - ("label smaller" 'SMALLER) - ("label larger" 'LARGER) - ("<-> Directed" 'DIRECTED) - ("<-> Sides" 'SIDES) - ("<-> Border" 'BORDER) - ("<-> Shade" 'SHADE) - STOP] - (LOCALVARS . T) - (RECORDS GRAPHNODE GRAPH) - (DECLARE%: DONTCOPY (MACROS HALF)) - (COMS (* ; "Grapher image objects") - (FNS GRAPHERCOPYBUTTONEVENTFN GRAPHOBJ.FINDGRAPH) - (FNS ALIGNMENTNODE GRAPHOBJ.CHECKALIGN) - (FNS GRAPHEROBJ GRAPHOBJ.BUTTONEVENTINFN GRAPHOBJ.COPYBUTTONEVENTFN GRAPHOBJ.COPYFN - GRAPHOBJ.DISPLAYFN GRAPHOBJ.GETALIGN GRAPHOBJ.GETFN GRAPHOBJ.IMAGEBOXFN - GRAPHOBJ.PUTALIGN GRAPHOBJ.PUTFN) - (FNS COPYGRAPH DUMPGRAPH READGRAPH) - (VARS (GRAPHERIMAGEFNS)) - (ALISTS (IMAGEOBJGETFNS GRAPHOBJ.GETFN]) - - - -(* ; "Graph Editing") - -(DEFINEQ - -(ADD/AND/DISPLAY/LINK - [LAMBDA (FROMND TOND WIN G) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* adds and displays a link.) - (COND - ((MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) - (TOLINKS FROMND)) - (printout PROMPTWINDOW "Link already exists. " T) - NIL) - (T (GRAPHADDLINK FROMND TOND G WIN) - (DISPLAYLINK FROMND TOND (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WIN G) - T]) - -(APPLYTOSELECTEDNODE - [LAMBDA (WINDOW) (* rmk%: "20-Nov-85 16:33") - - (* applys a function whenever the node is selected. - Is used as BUTTONEVENTFN and gets called whenever cursor moves or button is - down.) - - (GRAPHBUTTONEVENTFN WINDOW (WINDOWPROP WINDOW 'GRAPH) - (WINDOWPROP WINDOW 'BROWSER/LEFTFN) - (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN) - (WINDOWPROP WINDOW 'REGION]) - -(CALL.MOVENODEFN - [LAMBDA (NODE NEWPOS GRAPH WINDOW OLDPOS) (* BBB "13-Sep-85 15:37") - (* calls a graphs movenodefn.) - (PROG ((MOVEFN (fetch (GRAPH GRAPH.MOVENODEFN) of GRAPH))) - (AND MOVEFN (APPLY* MOVEFN NODE NEWPOS GRAPH WINDOW OLDPOS]) - -(CHANGE.NODEFONT.SIZE - [LAMBDA (HOW NODE GRAPH WINDOW) (* ; "Edited 22-Jul-87 16:32 by sye") - (* makes the label font of a node - larger.) - (PROG [(NEWFONT (NEXTSIZEFONT HOW (fetch (GRAPHNODE NODEFONT) of NODE] - (COND - (NEWFONT (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WINDOW GRAPH) - (PROG ((CHNGFN (fetch (GRAPH GRAPH.FONTCHANGEFN) of GRAPH))) - (AND CHNGFN (APPLY* CHNGFN HOW NODE GRAPH WINDOW))) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (replace (GRAPHNODE NODEFONT) of NODE with NEWFONT) - (MEASUREGRAPHNODE NODE T) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WINDOW GRAPH]) - -(DEFAULT.ADDNODEFN - [LAMBDA (GRAPH WINDOW BOXED) (* ; "Edited 9-Jan-89 15:57 by sye") - (* ; - "reads a node label name from the user and puts a node at the current cursor position.") - (PROG (NODELABEL NODENAME) - (OR (SETQ NODELABEL (PROMPTINWINDOW "Node label? ")) - (RETURN)) - LP (COND - ((FASSOC (SETQ NODENAME (PACK* NODELABEL (GENSYM))) - (fetch (GRAPH GRAPHNODES) of GRAPH)) - (GO LP))) - (RETURN (NODECREATE NODENAME NODELABEL (CURSORPOSITION NIL WINDOW) - NIL NIL (OR DEFAULT.GRAPH.NODEFONT DEFAULTFONT) - BOXED]) - -(DELETE/AND/DISPLAY/LINK - [LAMBDA (FROMND TOND WIN G) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* delete a link and updates the - display.) - - (* * rht 4/4/85%: Added temporary var LINKPARAMS to hold link parameters since - they'll get tossed by GRAPHDELETELINK.) - - (COND - ([NOT (OR (MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) - (TOLINKS FROMND)) - (AND (MEMBTONODES (fetch (GRAPHNODE NODEID) of FROMND) - (TOLINKS TOND)) - (NOT (fetch (GRAPH DIRECTEDFLG) of G)) - (PROG ((TMP FROMND)) (* editting graph, don't distinguish - between links.) - (SETQ FROMND TOND) - (SETQ TOND TMP) - (RETURN T] - (printout PROMPTWINDOW "Link does not exist. " T) - NIL) - (T (PROG ((LPARAMS (LINKPARAMETERS FROMND TOND))) - (GRAPHDELETELINK FROMND TOND G WIN) - (DISPLAYLINK FROMND TOND (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WIN G NIL LPARAMS)) - T]) - -(DISPLAY/NAME - [LAMBDA (ND) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (fetch (GRAPHNODE NODELABEL) of ND]) - -(DISPLAYGRAPH - [LAMBDA (GRAPH STREAM CLIP/REG TRANS) (* ; "Edited 27-Jul-90 09:09 by tafel") - - (* ;; "Displays GRAPH with coordinates system translated to TRANS on STREAM. POS=NIL is interpreted as 0,0. Draws links first then labels so that lattices don't have lines through the labels.") - - (PROG (SCALE (LINEWIDTH 1) - NNODES NODEHASHTABLE) - [OR (type? POSITION TRANS) - (SETQ TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0] - (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) - (COND - ((DISPLAYSTREAMP STREAM) - - (* ;; "This is because PRIN3 on displaystreams can sometimes cause CR's to be output. GRAPHER/CENTERPRINTINAREA doesn't have the rightmargin kludge that the CENTERPRINTINAREA in MENU has.") - - (DSPRIGHTMARGIN 65000 STREAM)) - (T (SETQ SCALE (DSPSCALE NIL STREAM)) - (SETQ GRAPH (SCALE/GRAPH GRAPH STREAM SCALE)) - [SETQ TRANS (create POSITION - XCOORD _ (FIXR (FTIMES SCALE (fetch (POSITION XCOORD) - of TRANS))) - YCOORD _ (FIXR (FTIMES SCALE (fetch (POSITION YCOORD) - of TRANS] - (SETQ LINEWIDTH SCALE))) - - (* ;; "nhb, 23-Feb-89: modified to create hashtable for nodeid to node lookup for cases where hash tables provide better performance than A-Lists.") - - [COND - ((IGREATERP (SETQ NNODES (LENGTH (fetch (GRAPH GRAPHNODES) of GRAPH))) - 25) - (SETQ NODEHASHTABLE (HASHARRAY NNODES)) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (PUTHASH (fetch (GRAPHNODE NODEID) of N) - N NODEHASHTABLE] - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH NODEHASHTABLE)) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (PRINTDISPLAYNODE N TRANS STREAM CLIP/REG]) - -(DISPLAYLINK - [LAMBDA (FRND TOND TRANS STREAM G LINEWIDTH PARAMS) (* rht%: "13-Mar-85 13:58") - (* draws in a link from FRND TO - TOND, translated by TRANS) - (COND - ((fetch (GRAPH SIDESFLG) of G) - (COND - ((OR (fetch (GRAPH DIRECTEDFLG) of G) - (IGREATERP (GN/LEFT TOND) - (GN/RIGHT FRND))) (* in the horizontal case of - LATTICE, always draw from right to - left.) - (DISPLAYLINK/RL TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/LEFT FRND) - (GN/RIGHT TOND)) - (DISPLAYLINK/LR TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/BOTTOM FRND) - (GN/TOP TOND)) - (DISPLAYLINK/BT TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/BOTTOM TOND) - (GN/TOP FRND)) - (DISPLAYLINK/TB TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - (T (* if on top of each other, don't - draw.) - NIL))) - (T (COND - ((OR (fetch (GRAPH DIRECTEDFLG) of G) - (IGREATERP (GN/BOTTOM FRND) - (GN/TOP TOND))) - - (* if LATTICE, always draw from FROMNODE BOTTOM to TONODE TOP. - Otherwise find the one that looks best.) - - (DISPLAYLINK/BT TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/BOTTOM TOND) - (GN/TOP FRND)) - (DISPLAYLINK/TB TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/LEFT TOND) - (GN/RIGHT FRND)) - (DISPLAYLINK/RL TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/LEFT FRND) - (GN/RIGHT TOND)) - (DISPLAYLINK/LR TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - (T (* if on top of each other, don't - draw.) - NIL]) - -(DISPLAYLINK/BT - [LAMBDA (TRANS GNB GNT WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the bottom edge of GNB to the top edge of GNT translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB))) - (IPLUS (fetch YCOORD of TRANS) - (SUB1 (GN/BOTTOM GNB))) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT))) - (IPLUS (fetch YCOORD of TRANS) - (ADD1 (GN/TOP GNT))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) - -(DISPLAYLINK/LR - [LAMBDA (TRANS GNL GNR WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the left edge of GNL to the right edge of GNR, translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (SUB1 (GN/LEFT GNL))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL))) - (IPLUS (fetch XCOORD of TRANS) - (ADD1 (GN/RIGHT GNR))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) - -(DISPLAYLINK/RL - [LAMBDA (TRANS GNR GNL WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the right edge of GNR, to the left edge of GNL translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (ADD1 (GN/RIGHT GNR))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR))) - (IPLUS (fetch XCOORD of TRANS) - (SUB1 (GN/LEFT GNL))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) - -(DISPLAYLINK/TB - [LAMBDA (TRANS GNT GNB WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the top edge of GNT to the bottom edge of GNR, translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT))) - (IPLUS (fetch YCOORD of TRANS) - (ADD1 (GN/TOP GNT))) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB))) - (IPLUS (fetch YCOORD of TRANS) - (SUB1 (GN/BOTTOM GNB))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) - -(DISPLAYNODE - [LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08") - - (* displays a node and its links. IF TOSONLY IS NON-NIL, DRAWS ONLY THE TO - LINKS.) - - (DISPLAYNODELINKS NODE TRANS STREAM G TOSONLY) - (PRINTDISPLAYNODE NODE TRANS STREAM (DSPCLIPPINGREGION NIL STREAM]) - -(ERASE/GRAPHNODE - [LAMBDA (NODE STREAM TRANS) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* erases a node at its position - translated by TRANS) - (OR [NOT (OR (WINDOWP STREAM) - (IMAGESTREAMTYPEP STREAM 'DISPLAY] - (ZEROP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (BITBLT NIL NIL NIL STREAM (COND - (TRANS (IPLUS (fetch (POSITION XCOORD) of TRANS) - (GN/LEFT NODE))) - (T (GN/LEFT NODE))) - (COND - (TRANS (IPLUS (fetch (POSITION YCOORD) of TRANS) - (GN/BOTTOM NODE))) - (T (GN/BOTTOM NODE))) - (fetch (GRAPHNODE NODEWIDTH) of NODE) - (fetch (GRAPHNODE NODEHEIGHT) of NODE) - 'TEXTURE - 'REPLACE WHITESHADE]) - -(DISPLAYNODE - [LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08") - - (* displays a node and its links. IF TOSONLY IS NON-NIL, DRAWS ONLY THE TO - LINKS.) - - (DISPLAYNODELINKS NODE TRANS STREAM G TOSONLY) - (PRINTDISPLAYNODE NODE TRANS STREAM (DSPCLIPPINGREGION NIL STREAM]) - -(DISPLAYNODELINKS - [LAMBDA (NODE TRANS STREAM G TOSONLY LINEWIDTH NODEHASHTABLE) - (* ; "Edited 24-Feb-89 11:56 by Briggs") - - (* ;; "displays a node links. If TOSONLY is non-NIL, draws only the TO links.") - - (* ;; - "nhb, 23-Feb-89: modified to accept a hash table of nodes by nodeid to assist GETNODEFROMID.") - - (PROG ((NODELST (fetch (GRAPH GRAPHNODES) of G))) - (for TONODEID TONODE in (TOLINKS NODE) - do (DISPLAYLINK NODE (SETQ TONODE (GETNODEFROMID TONODEID NODELST - NODEHASHTABLE)) - TRANS STREAM G LINEWIDTH (LINKPARAMETERS NODE TONODE))) - (OR TOSONLY (for FROMNDID FROMND in (FROMLINKS NODE) - do (DISPLAYLINK (SETQ FROMND (GETNODEFROMID FROMNDID NODELST - NODEHASHTABLE)) - NODE TRANS STREAM G LINEWIDTH (LINKPARAMETERS FROMND NODE]) - -(DRAW/GRAPHNODE/BORDER - [LAMBDA (BORDER LEFT BOTTOM WIDTH HEIGHT STREAM) (* lmm " 9-Jun-85 22:38") - - (* interprets the node border. If the border is a shade, then bitblt twice in - invert mode. This will look ugly if a link runs underneath the node, but at - least the label will be legible.) - - (COND - ((EQ BORDER NIL)) - ((EQ BORDER T) - (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT 1 NIL STREAM)) - ((FIXP BORDER) - (OR (ILEQ BORDER 0) - (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT BORDER NIL STREAM))) - ((LISTP BORDER) (* Extract the PROG after Intermezzo - is released) - (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT (CAR BORDER) - NIL STREAM (CADR BORDER))) - (T (ERROR "Illegal border:" BORDER]) - -(DRAWAREABOX - [LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) - (* lmm " 9-Jun-85 22:36") - (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* lmm " 9-Jun-85 22:04") - (* draws lines inside the region.) - (* draw left edge) - (BLTSHADE TEXTURE W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT OP) - (* draw top) - (BLTSHADE TEXTURE W (PLUS BOXLEFT BORDER) - (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) - BORDER) - (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) - BORDER OP) (* draw bottom) - (BLTSHADE TEXTURE W (PLUS BOXLEFT BORDER) - BOXBOTTOM - (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) - BORDER OP) (* draw right edge) - (BLTSHADE TEXTURE W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) - BORDER) - BOXBOTTOM BORDER BOXHEIGHT OP]) - -(EDITADDLINK - [LAMBDA (W) (* kvl "20-APR-82 13:53") - (* reads and adds a link to the - graph) - (EDITAPPLYTOLINK (FUNCTION ADD/AND/DISPLAY/LINK) - 'added - (WINDOWPROP W 'GRAPH) - W]) - -(EDITADDNODE - [LAMBDA (W NewPosition MSGW NODELABELFN) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* ; - "adds a node to the graph in the window W and displays it.") - - (* ;; "pmi 4/8/88: Added NewPosition argument so that the new position for a node may be specified programatically.") - - (* ;; "sye Jan/9/89: added MSGW & NODELABELFN args ") - - (DECLARE (GLOBALVARS PROMPTWINDOW)) - (PROG [NODE ORIGPOS NEWPOS NODELABEL (GRAPH (WINDOWPROP W 'GRAPH)) - (Stream (WINDOWPROP W 'DSP] - (OR (SETQ NODE (GRAPHADDNODE GRAPH W)) - (RETURN)) - (MEASUREGRAPHNODE NODE) - (if (POSITIONP NewPosition) - then (SETQ ORIGPOS (create POSITION using (fetch (GRAPHNODE - NODEPOSITION) - of NODE))) - (MOVENODE NODE ORIGPOS NewPosition GRAPH Stream) - (FLIPNODE NODE Stream) - (EXTENDEXTENT (WFROMDS Stream) - (NODEREGION NODE)) - (CALL.MOVENODEFN NODE NewPosition GRAPH (WFROMDS Stream) - ORIGPOS) - else (printout (OR MSGW PROMPTWINDOW) - "Position node " - (OR (AND NODELABELFN (APPLY* NODELABELFN NODE)) - (fetch (GRAPHNODE NODELABEL) - NODE))) - (PRINTDISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - W - (DSPCLIPPINGREGION NIL W)) - (TRACKCURSOR NODE Stream GRAPH)) - (RETURN NODE]) - -(EDITAPPLYTOLINK - [LAMBDA (FN MSG GRAPH DS MSGW NODELABELFN) (* ; "Edited 9-Jan-89 09:10 by sye") - (SETQ MSGW (OR MSGW PROMPTWINDOW)) - (CLEARW MSGW) - (CLRPROMPT) - (COND - [(fetch (GRAPH GRAPHNODES) of GRAPH) - (PROG (FROM TO (ABORTMSG "No selection was made ... operation aborted.")) - (printout MSGW "Specify the link by selecting the FROM node, then the TO node." T - "FROM?" T) (* - "if no FROM node was selected, abort the operation") - (OR (SETQ FROM (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout PROMPTWINDOW ABORTMSG T))) - (FLIPNODE FROM DS) - (printout MSGW "TO?" T) - (COND - [(ERSETQ (SETQ TO (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS] - (T (FLIPNODE FROM DS) - (ERROR!))) - (FLIPNODE FROM DS) (* - "if no TO node was selected, abort the operation") - (OR TO (RETURN (printout PROMPTWINDOW ABORTMSG T))) - (COND - ((APPLY* FN FROM TO DS GRAPH) (* return non-nil if changed - anything.) - (printout PROMPTWINDOW "Link from " (OR (AND NODELABELFN (APPLY* NODELABELFN FROM)) - (DISPLAY/NAME FROM)) - " to " - (OR (AND NODELABELFN (APPLY* NODELABELFN TO)) - (DISPLAY/NAME TO)) - %, MSG T) - (RETURN T] - (T (printout PROMPTWINDOW - "There are no nodes. You can create nodes with the Add Node command." T]) - -(EDITCHANGEFONT - [LAMBDA (HOW W) (* ; "Edited 7-Jan-89 13:14 by sye") - (* prompts the user for a node and - deletes it) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT " No nodes in graph yet. ") - (RETURN))) - (CLRPROMPT) - (printout PROMPTWINDOW "Select node to be made " (COND - ((EQ HOW 'SMALLER) - "smaller.") - (T "larger."))) - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout PROMPTWINDOW T "No selection was made ... operation aborted." T))) - (CHANGE.NODEFONT.SIZE HOW NODE GRAPH W) - (RETURN NODE]) - -(EDITCHANGELABEL - [LAMBDA (W MSGW) (* ; "Edited 7-Jan-89 13:31 by sye") - (* prompts the user for a node and - deletes it) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (GETSTREAM W)) - (TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0))) - NODE NEWLABEL) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT "No nodes in graph yet. ") - (RETURN))) - (CLRPROMPT) - (SETQ MSGW (OR MSGW PROMPTWINDOW)) - (CLEARW MSGW) - (printout MSGW "Select node to have label changed.") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout PROMPTWINDOW T "No selection was made ... operation aborted." T))) - (if (NULL (SETQ NEWLABEL (GRAPHCHANGELABEL GRAPH W NODE))) - then (RETURN)) - (DISPLAYNODE NODE TRANS W GRAPH) - (ERASE/GRAPHNODE NODE DS TRANS) - (replace (GRAPHNODE NODELABEL) of NODE with NEWLABEL) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (MEASUREGRAPHNODE NODE T) - (DISPLAYNODE NODE TRANS W GRAPH) - (RETURN NODE]) - -(EDITDELETELINK - [LAMBDA (W) (* kvl "20-APR-82 13:54") - (* reads and adds a link to the - graph) - (EDITAPPLYTOLINK (FUNCTION DELETE/AND/DISPLAY/LINK) - 'deleted - (WINDOWPROP W 'GRAPH) - W]) - -(EDITDELETENODE - [LAMBDA (W) (* ; "Edited 9-Jan-89 09:14 by sye") - (* prompts the user for a node and - deletes it) - (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) - (CLRPROMPT) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE NODELABEL) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT " No nodes to delete. ") - (RETURN))) - (PROMPTPRINT "Select node to be deleted. ") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout T T "No selection was made ... operation aborted." T))) - (TERPRI T) - (FLIPNODE NODE DS) - (COND - ((EQ [ASKUSER NIL NIL (LIST "delete node " (SETQ NODELABEL (DISPLAY/NAME - NODE] - 'Y) - (FLIPNODE NODE DS) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - DS GRAPH) - (for TOND in (APPEND (TOLINKS NODE)) - do (GRAPHDELETELINK NODE (GETNODEFROMID TOND (fetch - (GRAPH GRAPHNODES) - of GRAPH)) - GRAPH W)) - (for FROMND in (APPEND (FROMLINKS NODE)) - do (GRAPHDELETELINK (GETNODEFROMID FROMND (fetch (GRAPH - GRAPHNODES) - of GRAPH)) - NODE GRAPH W)) - (GRAPHDELETENODE NODE GRAPH W) - (printout T "Node " NODELABEL " deleted." T) - (RETURN NODE)) - (T (FLIPNODE NODE DS) - (printout T "nothing deleted." T) - (RETURN NIL]) - -(EDITGRAPH - [LAMBDA (G W) - (SHOWGRAPH G W NIL NIL T T]) - -(EDITGRAPH1 - [LAMBDA (GRAPH WINDOW) (* ; "Edited 19-Aug-88 08:30 by sye") - - (* ;; "top level function for editing a graph. If there is no graph, create one empty. IF there is no window, create on the right size for the graph. After getting the arguments right, put the right button functions on, display it and enter the main loop.") - - (OR GRAPH (SETQ GRAPH (create GRAPH))) - (SETQ WINDOW (SIZE/GRAPH/WINDOW GRAPH WINDOW)) - (WINDOWPROP WINDOW 'GRAPH GRAPH) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (DSPOPERATION 'INVERT WINDOW) - (REDISPLAYGRAPH WINDOW) - (EDITGRAPH2 WINDOW) - GRAPH]) - -(EDITGRAPH2 - [LAMBDA (W) (* rrb " 7-NOV-83 14:51") - - (* Can also be called from top level if the given window W has a graph on its - GRAPH windowprop and the graph has been displayed by SHOWGRAPH or its - equivalent. It waits for mouse hits, does the comand, then waits for mouse - clear. Each edit command function takes only the window so that they can be - hung separately on button event functions. - However, the window must have INVERT as its display operation mode.) - - (PROG (VAL) - (CLRPROMPT) - (printout PROMPTWINDOW "Use the left button to move nodes." T - "Use the middle button to get a menu of edit commands." T - "During an edit command, the middle button can be used to abort.") - LP (until (MOUSESTATE (OR LEFT MIDDLE)) do) - (COND - [(LASTMOUSESTATE MIDDLE) - (SETQ VAL (ERSETQ (GRAPHEDITCOMMANDFN W))) - (COND - ((NULL VAL) (* aborted) - (printout PROMPTWINDOW T T "command aborted." T)) - ((EQ (CAR VAL) - 'STOP) - (RETURN (CLRPROMPT] - ((fetch (GRAPH GRAPHNODES) of (WINDOWPROP W 'GRAPH)) - (* track the nearest node.) - (TRACKNODE W)) - (T (printout PROMPTWINDOW T "There are no nodes to move yet." T - "Press the middle button and select the 'Add a node' command."))) - (until (MOUSESTATE UP) do) - (GO LP]) - -(EDITMOVENODE - [LAMBDA (WINDOW) (* ; "Edited 7-Jan-89 13:22 by sye") - (* hilite nodes until the cursor - goes down then move it) - (PROG ((DS (WINDOWPROP WINDOW 'DSP)) - (REG (WINDOWPROP WINDOW 'REGION)) - (GRAPH (WINDOWPROP WINDOW 'GRAPH)) - OLDPOS NOW NEAR NODELST) - (COND - (GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) - (T (RETURN))) - (CLRPROMPT) - (printout PROMPTWINDOW "Move the cursor to the node " "you want to move " - "and press any button.") - [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (GETMOUSESTATE) - (COND - ((LASTMOUSESTATE (NOT UP)) (* button up, process it.) - (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) - ) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP))) - (printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position" - "and release the button.") - (TRACKCURSOR NOW DS GRAPH) - (printout PROMPTWINDOW T "Done."]) - -(EDITTOGGLEBORDER - [LAMBDA (W) (* ; "Edited 7-Jan-89 13:38 by sye") - (* ; - "prompts the user for a node and inverts its border") - (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) - (CLRPROMPT) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT "No nodes to invert. ") - (RETURN))) - (PROMPTPRINT "Select node to have border inverted. ") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout T T "No selection was made ... operation aborted." T))) - (TERPRI T) - (RESET/NODE/BORDER NODE 'INVERT W GRAPH) - (AND (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) - (APPLY* (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) - NODE GRAPH W)) - (RETURN NODE]) - -(EDITTOGGLELABEL - [LAMBDA (W) (* ; "Edited 7-Jan-89 13:17 by sye") - (* prompts the user for a node and - inverts its lable) - (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) - (CLRPROMPT) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT " No nodes to invert.") - (RETURN))) - (PROMPTPRINT "Select node to have label inverted. ") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout T T "No selection was made ... operation aborted." T))) - (TERPRI T) - (RESET/NODE/LABELSHADE NODE 'INVERT W) - (AND (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) - (APPLY* (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) - NODE GRAPH W)) - (RETURN NODE]) - -(FILL/GRAPHNODE/LABEL - [LAMBDA (SHADE LEFT BOTTOM WIDTH HEIGHT NBW STREAM) (* kvl "10-Sep-84 14:41") - (* NBW is the border, which must be - subtracted from the node's region) - (PROG ((NS SHADE)) - (OR (WINDOWP STREAM) - (DISPLAYSTREAMP STREAM) - (RETURN)) - (COND - ((EQ SHADE T) - (SETQ NS BLACKSHADE)) - ((NULL SHADE) - (SETQ NS WHITESHADE))) - (BITBLT NIL NIL NIL STREAM (IPLUS LEFT NBW) - (IPLUS BOTTOM NBW) - (IDIFFERENCE WIDTH (IPLUS NBW NBW)) - (IDIFFERENCE HEIGHT (IPLUS NBW NBW)) - 'TEXTURE - 'INVERT NS]) - -(FIX/SCALE - [LAMBDA (PARAMVALUE SCALE) (* dgb%: "28-Jan-85 10:01") - - (* * fixes PARAMVALUE by SCALE If PARAMVALUE is a list, then fixes the elements - of the list) - - (COND - ((LISTP PARAMVALUE) - (for V in PARAMVALUE collect (FIX/SCALE V SCALE))) - (T (* Note that some parameters may go - to zero) - (FIXR (FTIMES SCALE PARAMVALUE]) - -(FLIPNODE - [LAMBDA (NODE DS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* flips the region around a node.) - (BITBLT NIL NIL NIL DS (IDIFFERENCE (GN/LEFT NODE) - 1) - (IDIFFERENCE (GN/BOTTOM NODE) - 1) - (IPLUS (fetch (GRAPHNODE NODEWIDTH) of NODE) - 2) - (IPLUS (fetch (GRAPHNODE NODEHEIGHT) of NODE) - 2) - 'TEXTURE - 'INVERT BLACKSHADE]) - -(FONTNAMELIST - [LAMBDA (FONTDESC) (* rrb " 2-NOV-83 21:00") - (LIST (FONTPROP FONTDESC 'FAMILY) - (FONTPROP FONTDESC 'SIZE) - (FONTPROP FONTDESC 'FACE]) - -(FROMLINKS - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (fetch (GRAPHNODE FROMNODES) of NODE]) - -(GETNODEFROMID - [LAMBDA (ID NODELST NODEHASHTABLE) (* ; "Edited 24-Feb-89 11:55 by Briggs") - - (* ;; "Allow Link parameters to be passed as a property list of the node description.") - - (* ;; "nhb, 23-Feb-89: modified -- If the (optional) NODEHASHTABLE is passed then we will use this rather than assoc'ing in the node list to find the node. Also switched order of listp check and bare FASSOC") - - (COND - (NODEHASHTABLE (OR (AND (LISTP ID) - (EQ 'Link% Parameters (CAR ID)) - (GETHASH (CADR ID) - NODEHASHTABLE)) - (GETHASH ID NODEHASHTABLE) - (ERROR "No graphnode for nodeid:" ID))) - (T (OR (AND (LISTP ID) - (EQ 'Link% Parameters (CAR ID)) - (FASSOC (CADR ID) - NODELST)) - (FASSOC ID NODELST) - (ERROR "No graphnode for nodeid:" ID]) - -(GN/BOTTOM - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (IDIFFERENCE (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (HALF (fetch (GRAPHNODE NODEHEIGHT) of NODE]) - -(GN/LEFT - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (IDIFFERENCE (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (HALF (fetch (GRAPHNODE NODEWIDTH) of NODE]) - -(GN/RIGHT - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* Assumes that the big-half of width is to the left of the center, for even - width) - - (IPLUS (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (SUB1 (HALF (ADD1 (fetch (GRAPHNODE NODEWIDTH) of NODE]) - -(GN/TOP - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* Assumes that big-half of height is under the center, for even height. - Result is -1 for height=0, which is correct.) - - (IPLUS (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (SUB1 (HALF (ADD1 (fetch (GRAPHNODE NODEHEIGHT) of NODE]) - -(GRAPHADDLINK - [LAMBDA (FROM TO GRAPH WINDOW) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* links two nodes) - (PROG ((ADDFN (fetch (GRAPH GRAPH.ADDLINKFN) of GRAPH))) - (AND ADDFN (APPLY* ADDFN FROM TO GRAPH WINDOW))) - (push (fetch (GRAPHNODE FROMNODES) of TO) - (fetch (GRAPHNODE NODEID) of FROM)) - (push (fetch (GRAPHNODE TONODES) of FROM) - (fetch (GRAPHNODE NODEID) of TO]) - -(GRAPHADDNODE - [LAMBDA (GRAPH W) (* rrb " 2-NOV-83 20:29") - (* adds a node to the graph GRAPH) - (PROG (ADDFN NODE) - (OR [SETQ NODE (COND - ((SETQ ADDFN (fetch (GRAPH GRAPH.ADDNODEFN) of GRAPH)) - (APPLY* ADDFN GRAPH W)) - (T (DEFAULT.ADDNODEFN GRAPH W T] - (RETURN)) - (replace (GRAPH GRAPHNODES) of GRAPH with (NCONC1 (fetch (GRAPH GRAPHNODES) - of GRAPH) - NODE)) - (RETURN NODE]) - -(GRAPHBUTTONEVENTFN - [LAMBDA (WINDOW GRAPH LEFTFNOFNODE MIDDLEFNOFNODE REG) (* rmk%: "20-Nov-85 16:33") - - (* applys a function whenever the node is selected. - Is used as BUTTONEVENTFN and gets called whenever cursor moves or button is - down.) - - (TOTOPW WINDOW) - (PROG ((NODELST (fetch (GRAPH GRAPHNODES) of GRAPH)) - (DS (GETSTREAM WINDOW)) - BUTTON OLDPOS REG NOW NEAR) (* note which button is down.) - (COND - ((LASTMOUSESTATE LEFT) - (OR LEFTFNOFNODE (RETURN)) - (SETQ BUTTON 'LEFT)) - ((LASTMOUSESTATE MIDDLE) - (OR MIDDLEFNOFNODE (RETURN)) - (SETQ BUTTON 'MIDDLE)) - (T (* no button down, not interested.) - (RETURN))) (* get the region of this window.) - [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (* wait for a button up or move out - of region) - (GETMOUSESTATE) - (COND - ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* button up, process it.) - (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) - (RETURN (APPLY* (SELECTQ BUTTON - (LEFT LEFTFNOFNODE) - (MIDDLE MIDDLEFNOFNODE) - (SHOULDNT)) - NOW WINDOW))) - ((NOT (INSIDE? (WINDOWPROP WINDOW 'REGION) - LASTMOUSEX LASTMOUSEY)) (* outside of region, return) - (AND NOW (FLIPNODE NOW DS)) - (RETURN)) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP]) - -(GRAPHCHANGELABEL - [LAMBDA (GRAPH W NODE) (* rmk%: "19-Sep-85 10:50") - (* Returns a new label for NODE) - (LET (CHANGEFN) - (COND - ((SETQ CHANGEFN (fetch (GRAPH GRAPH.CHANGELABELFN) of GRAPH)) - (APPLY* CHANGEFN GRAPH W NODE)) - (T (PROMPTINWINDOW "Node label? "]) - -(GRAPHDELETELINK - [LAMBDA (FROM TO GRAPH WINDOW) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* deletes a link from a graph) - - (* * rht 4/4/85%: Changed to call REMOVETONODES to remove either nodeID or - paramlist thingie for nodeID.) - - (PROG ((DELFN (fetch (GRAPH GRAPH.DELETELINKFN) of GRAPH))) - (AND DELFN (APPLY* DELFN FROM TO GRAPH WINDOW))) - (replace (GRAPHNODE TONODES) of FROM with (REMOVETONODES (fetch (GRAPHNODE - NODEID) - of TO) - (fetch (GRAPHNODE TONODES) - of FROM))) - (replace (GRAPHNODE FROMNODES) of TO with (REMOVE (fetch (GRAPHNODE NODEID) - of FROM) - (fetch (GRAPHNODE FROMNODES) - of TO]) - -(GRAPHDELETENODE - [LAMBDA (NODE GRAPH WINDOW) (* kvl " 5-Sep-84 19:03") - (PROG ((DELFN (fetch (GRAPH GRAPH.DELETENODEFN) of GRAPH))) - (AND DELFN (APPLY* DELFN NODE GRAPH WINDOW)) - (replace (GRAPH GRAPHNODES) of GRAPH with (DREMOVE NODE (fetch (GRAPH - GRAPHNODES) - of GRAPH]) - -(GRAPHEDITCOMMANDFN - [LAMBDA (GRAPHWINDOW) (* rmk%: "19-Sep-85 11:12") - (DECLARE (SPECVARS GRAPHWINDOW)) (* So that window is available to - functions called from menu items) - (SELECTQ [MENU (COND - ((type? MENU EDITGRAPHMENU) - EDITGRAPHMENU) - (T (SETQ EDITGRAPHMENU (create MENU - ITEMS _ EDITGRAPHMENUCOMMANDS - CENTERFLG _ T - CHANGEOFFSETFLG _ T] - (STOP 'STOP) - (MOVENODE (EDITMOVENODE GRAPHWINDOW)) - (ADDNODE (EDITADDNODE GRAPHWINDOW)) - (DELETENODE (EDITDELETENODE GRAPHWINDOW)) - (ADDLINK (EDITADDLINK GRAPHWINDOW)) - (SMALLER (EDITCHANGEFONT 'SMALLER GRAPHWINDOW)) - (LARGER (EDITCHANGEFONT 'LARGER GRAPHWINDOW)) - (DELETELINK (EDITDELETELINK GRAPHWINDOW)) - (CHANGELABEL (EDITCHANGELABEL GRAPHWINDOW)) - (DIRECTED (TOGGLE/DIRECTEDFLG GRAPHWINDOW)) - (SIDES (TOGGLE/SIDESFLG GRAPHWINDOW)) - (BORDER (EDITTOGGLEBORDER GRAPHWINDOW)) - (SHADE (EDITTOGGLELABEL GRAPHWINDOW)) - NIL]) - -(GRAPHEDITEVENTFN - [LAMBDA (GRWINDOW) (* rmk%: "16-Feb-85 10:15") - (* implements a graph editor on the - right button transition of a window.) - (COND - ((NOT (INSIDE? (DSPCLIPPINGREGION NIL GRWINDOW) - (LASTMOUSEX GRWINDOW) - (LASTMOUSEY GRWINDOW))) - (DOWINDOWCOM GRWINDOW)) - ((SHIFTDOWNP 'CTRL) - (TRACKNODE GRWINDOW)) - ((EQ (GRAPHEDITCOMMANDFN GRWINDOW) - 'STOP) (* do menu) - (CLOSEW GRWINDOW]) - -(GRAPHER/CENTERPRINTINAREA - [LAMBDA (EXP X Y WIDTH HEIGHT STREAM) (* kvl "15-Aug-84 11:01") - - (* ;; "prints an expression in a box. The system CENTERPRINTINAREA on MENU worried about overflowing the right margin, which we ignore here.") - - (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) - (PROG (XPOS (STRWIDTH (STRINGWIDTH EXP STREAM))) - (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) - (PRIN3 EXP STREAM]) - -(GRAPHERPROP - [LAMBDA (GRAPH PROP NEWVALUE) (* ; "Edited 19-Aug-88 14:09 by sye") - (LET (PROPLIST) - (SETPROPLIST PROPLIST (fetch (GRAPH GRAPH.PROPS) of GRAPH)) - (if NEWVALUE - then (PROG1 (PUTPROP PROPLIST PROP NEWVALUE) - (replace (GRAPH GRAPH.PROPS) of GRAPH with (GETPROPLIST - PROPLIST))) - else (GETPROP PROPLIST PROP]) - -(GRAPHNODE/BORDER/WIDTH - [LAMBDA (BORDER) (* kvl " 5-Sep-84 16:19") - (* returns a non-negative interger) - (COND - ((NULL BORDER) - 0) - ((EQ BORDER T) - 1) - ((FIXP BORDER) - (ABS BORDER)) - ((AND (LISTP BORDER) - (FIXP (CAR BORDER)) - (IGEQ (CAR BORDER) - 0)) - (CAR BORDER)) - (T (ERROR "Illegal border:" BORDER]) - -(GRAPHREGION - [LAMBDA (GRAPH) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* Returns the minimum region - containing the graph.) - (PROG (LEFTOFFSET BOTTOMOFFSET (NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) - (RETURN (COND - [NODELST (* Determine the dimensions of the - node labels) - (for N in NODELST do (MEASUREGRAPHNODE N)) - (CREATEREGION (SETQ LEFTOFFSET (MIN/LEFT NODELST)) - (SETQ BOTTOMOFFSET (MIN/BOTTOM NODELST)) - (ADD1 (IDIFFERENCE (MAX/RIGHT NODELST) - LEFTOFFSET)) - (ADD1 (IDIFFERENCE (MAX/TOP NODELST) - BOTTOMOFFSET] - (T (CREATEREGION 0 0 0 0]) - -(HARDCOPYGRAPH - [LAMBDA (GRAPH/WINDOW FILE IMAGETYPE TRANS) (* ; "Edited 23-Apr-92 16:51 by jds") - (LET* - ((LANDSCAPE-FLAG (EQ (LISTGET GRAPH/HARDCOPY/FORMAT 'MODE) - 'LANDSCAPE)) - [PSTREAM (OR (AND FILE (OPENP FILE 'OUTPUT) - (GETSTREAM FILE)) - (OPENIMAGESTREAM FILE IMAGETYPE (APPEND '(CLIP.INCLUSIVE T) - (AND LANDSCAPE-FLAG '(LANDSCAPE T] - (PSCALE (DSPSCALE NIL PSTREAM)) - (ORIGINAL-CLIPREGION (DSPCLIPPINGREGION NIL PSTREAM)) - (GRAPH (COND - ((WINDOWP GRAPH/WINDOW) - (WINDOWPROP GRAPH/WINDOW 'GRAPH)) - (T GRAPH/WINDOW))) - (GRAPH-REGION (GRAPHREGION GRAPH)) - (GRAPH-LEFT (fetch (REGION LEFT) of GRAPH-REGION)) - (GRAPH-BOTTOM (fetch (REGION BOTTOM) of GRAPH-REGION)) - (GRAPH-WIDTH (fetch (REGION WIDTH) of GRAPH-REGION)) - (GRAPH-HEIGHT (fetch (REGION HEIGHT) of GRAPH-REGION)) - (SCREENPOINTS-PER-INCH 72) - (PAGENUMBERS-FLAG (LISTGET GRAPH/HARDCOPY/FORMAT 'PAGENUMBERS)) - [RIGHT-MARGIN (FIXR (TIMES 0 SCREENPOINTS-PER-INCH (OR (LISTGET GRAPH/HARDCOPY/FORMAT - 'RIGHTMARGIN) - 0.5] - [UPPER-MARGIN (FIXR (TIMES 0 SCREENPOINTS-PER-INCH (OR (LISTGET GRAPH/HARDCOPY/FORMAT - 'UPPERMARGIN) - 0.4] - (PAGE-WIDTH (- (FIXR (QUOTIENT (fetch (REGION WIDTH) of ORIGINAL-CLIPREGION) - PSCALE)) - RIGHT-MARGIN)) - (PAGE-HEIGHT (- (FIXR (QUOTIENT (fetch (REGION HEIGHT) of ORIGINAL-CLIPREGION) - PSCALE)) - UPPER-MARGIN)) - (NUMBER-OF-X-PAGES (CL:CEILING GRAPH-WIDTH PAGE-WIDTH)) - (NUMBER-OF-Y-PAGES (CL:CEILING GRAPH-HEIGHT PAGE-HEIGHT)) - [X-POSITION (FIXR (TIMES PSCALE (PLUS PAGE-WIDTH (TIMES 0.2 RIGHT-MARGIN] - [Y-POSITION (FIXR (TIMES PSCALE (PLUS PAGE-HEIGHT (TIMES 0.5 UPPER-MARGIN] - (BOTTOM-CENTERING-OFFSET NIL) - [LEFT-CENTERING-OFFSET (LET (TRAN) - (COND - ((type? POSITION TRANS) - (SETQ BOTTOM-CENTERING-OFFSET (fetch YCOORD of TRANS)) - (fetch XCOORD of TRANS)) - ([type? POSITION (SETQ TRAN (LISTGET GRAPH/HARDCOPY/FORMAT - 'TRANS] - (SETQ BOTTOM-CENTERING-OFFSET (fetch YCOORD of TRAN)) - (fetch XCOORD of TRAN)) - (T (SETQ BOTTOM-CENTERING-OFFSET - (QUOTIENT (PLUS UPPER-MARGIN (DIFFERENCE PAGE-HEIGHT - (REMAINDER GRAPH-HEIGHT - PAGE-HEIGHT))) - 2)) - (QUOTIENT (PLUS RIGHT-MARGIN (DIFFERENCE PAGE-WIDTH - (REMAINDER GRAPH-WIDTH - PAGE-WIDTH))) - 2] - [CLIPREGION (CREATEREGION 0 0 (FIXR (TIMES PSCALE PAGE-WIDTH)) - (FIXR (TIMES PSCALE PAGE-HEIGHT] - (SCALED-GRAPH (SCALE/GRAPH GRAPH PSTREAM))) - - (* ;; "") - - (* ;; " set up margins and clip/region for the print stream") - - (* ;; "") - - (DSPLEFTMARGIN 0 PSTREAM) - (DSPBOTTOMMARGIN 0 PSTREAM) - (DSPTOPMARGIN (fetch (REGION HEIGHT) of ORIGINAL-CLIPREGION) - PSTREAM) - (DSPRIGHTMARGIN (TIMES 2 (fetch (REGION WIDTH) of ORIGINAL-CLIPREGION)) - PSTREAM) - (DSPCLIPPINGREGION CLIPREGION PSTREAM) - - (* ;; "") - - (* ;; " print graph") - - (* ;; "") - - [for Y-PAGE-NUMBER from 1 to NUMBER-OF-Y-PAGES - do (for X-PAGE-NUMBER from 1 to NUMBER-OF-X-PAGES - do (LET [(PTRANS (create POSITION - XCOORD _ - [FIXR (FTIMES PSCALE (PLUS LEFT-CENTERING-OFFSET - (MINUS GRAPH-LEFT) - (MINUS (TIMES (SUB1 - X-PAGE-NUMBER - ) - PAGE-WIDTH] - YCOORD _ - (FIXR (FTIMES PSCALE (PLUS BOTTOM-CENTERING-OFFSET - (MINUS GRAPH-BOTTOM) - (MINUS (TIMES (SUB1 - Y-PAGE-NUMBER - ) - PAGE-HEIGHT] - - (* ;; "") - - (* ;; "write a page-full of graph to the print stream") - - (* ;; "") - - (for N in (fetch (GRAPH GRAPHNODES) of SCALED-GRAPH) - do (DISPLAYNODELINKS N PTRANS PSTREAM SCALED-GRAPH T PSCALE) - ) - (for N in (fetch (GRAPH GRAPHNODES) of SCALED-GRAPH) - do (PRINTDISPLAYNODE N PTRANS PSTREAM CLIPREGION)) - - (* ;; "") - - (* ;; " print the page number & start a new page") - - (* ;; "") - - (CL:UNLESS (AND (= X-PAGE-NUMBER NUMBER-OF-X-PAGES) - (= Y-PAGE-NUMBER NUMBER-OF-Y-PAGES)) - (COND - (PAGENUMBERS-FLAG (DSPCLIPPINGREGION ORIGINAL-CLIPREGION PSTREAM - ) - (MOVETO X-POSITION Y-POSITION PSTREAM) - (printout PSTREAM Y-PAGE-NUMBER "-" X-PAGE-NUMBER) - (DSPCLIPPINGREGION CLIPREGION PSTREAM))) - (DSPNEWPAGE PSTREAM))] - (CLOSEF PSTREAM]) - -(INTERSECT/REGIONP/LBWH - [LAMBDA (L B W H REG HOW NODE) (* ; "Edited 11-Jun-90 16:15 by mitani") - (* ; - "like intersect regions, but without requiring the consing") - (* - |how = partial :check if the nodelabel was partially intersect with REG|) - (* - |otherwise :check if the whole nodelabel was contained in REG|) - (SELECTQ HOW - (PARTIAL (NOT (OR (IGREATERP (fetch (REGION BOTTOM) of REG) - (IPLUS B H)) - (ILESSP (fetch (REGION PRIGHT) of REG) - L) - (IGREATERP (fetch (REGION LEFT) of REG) - (IPLUS L W)) - (ILESSP (fetch (REGION PTOP) of REG) - B)))) - (EQUAL (INTERSECTREGIONS REG (LIST L B W H)) - (LIST L B W H]) - -(INVERTED/GRAPHNODE/BORDER - [LAMBDA (BORDER) (* kvl " 5-Sep-84 18:49") - (* returns the right thing to invert - a graphnode's border) - (COND - ((EQ BORDER T) - NIL) - ((NULL BORDER) - T) - ((FIXP BORDER) - (IMINUS BORDER)) - ((AND (LISTP BORDER) - (FIXP (CAR BORDER))) - (LIST (CAR BORDER) - (INVERTED/SHADE/FOR/GRAPHER (CADR BORDER]) - -(INVERTED/SHADE/FOR/GRAPHER - [LAMBDA (SHADE) (* rmk%: "20-Sep-85 09:31") - (* funny name because hopefully will - become system function) - (COND - ((EQ SHADE T) - NIL) - ((NULL SHADE) - T) - ((FIXP SHADE) - (LOGNOT SHADE)) - ((BITMAPP SHADE) - (PROG ((NB (BITMAPCOPY SHADE))) - (BLTSHADE BLACKSHADE NB NIL NIL NIL NIL 'INVERT) - (RETURN NB))) - (T (ERROR "Illegal shade:" SHADE]) - -(LAYOUT/POSITION - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (fetch (GRAPHNODE NODEPOSITION) of NODE]) - -(LINKPARAMETERS - [LAMBDA (FROMND TOND) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (PROG (TOPARAMS) - (RETURN (AND (SETQ TOPARAMS (MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) - (TOLINKS FROMND))) - (LISTP TOPARAMS) - (EQ 'Link% Parameters (CAR TOPARAMS)) - (CDDR TOPARAMS]) - -(MAX/RIGHT - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:33") - (for NODE in NODES largest (GN/RIGHT NODE) finally (RETURN $$EXTREME]) - -(MAX/TOP - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") - (for NODE in NODES largest (GN/TOP NODE) finally (RETURN $$EXTREME]) - -(MEASUREGRAPHNODE - [LAMBDA (NODE RESETFLG) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* Measure the nodelabel image) - (SET/LABEL/SIZE NODE RESETFLG) - (SET/LAYOUT/POSITION NODE (OR (fetch (GRAPHNODE NODEPOSITION) of NODE) - (ERROR "This graphnode has not been given a position:" NODE]) - -(MEMBTONODES - [LAMBDA (TOND TONODES) (* dgb%: "24-Jan-85 08:05") - (for Z in TONODES do (COND - ([OR (EQ TOND Z) - (AND (LISTP Z) - (EQ (CAR Z) - 'Link% Parameters) - (EQ TOND (CADR Z] - (RETURN Z]) - -(MIN/BOTTOM - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") - (* returns the bottommost point of - the graph.) - (for NODE in NODES smallest (GN/BOTTOM NODE) finally (RETURN $$EXTREME]) - -(MIN/LEFT - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") - (* returns the leftmost point of the - graph.) - (for NODE in NODES smallest (GN/LEFT NODE) finally (RETURN $$EXTREME]) - -(MOVENODE - [LAMBDA (NODE OLDPOS POS GRAPH STREAM) (* rmk%: "10-Apr-84 12:31") - (* moves a node from its current - position to POS) - (COND - ((EQUAL OLDPOS POS) (* don't move if position hasn't - changed) - NIL) - (T (* node is flipped, flip it back.) - (FLIPNODE NODE STREAM) (* erase current position) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - STREAM GRAPH) (* put it in new one.) - (SET/LAYOUT/POSITION NODE POS) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - STREAM GRAPH) - (FLIPNODE NODE STREAM]) - -(NODECREATE - [LAMBDA (ID LABEL POS TONODEIDS FROMNODEIDS FONT BORDER LABELSHADE) - (* Randy.Gobbel "13-May-87 12:04") - (* creates a node for a grapher.) - (create GRAPHNODE - NODEID _ ID - NODEPOSITION _ POS - NODELABEL _ LABEL - NODEFONT _ (COND - (FONT) - ((IMAGEOBJP LABEL) - NIL) - (DEFAULT.GRAPH.NODEFONT) - (T (FONTNAMELIST DEFAULTFONT))) - TONODES _ TONODEIDS - FROMNODES _ FROMNODEIDS - NODEBORDER _ BORDER - NODELABELSHADE _ LABELSHADE]) - -(NODELST/AS/MENU - [LAMBDA (NODELST POS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* finds the node that is closest to - POS) - (for N in NODELST bind (X _ (fetch XCOORD of POS)) - (Y _ (fetch YCOORD of POS)) - T1 T2 - thereis (AND (ILESSP [IDIFFERENCE (SETQ T1 (fetch YCOORD of (fetch - (GRAPHNODE - NODEPOSITION) - of N))) - (SETQ T2 (HALF (fetch (GRAPHNODE NODEHEIGHT) of N] - Y) - (ILESSP Y (IPLUS T1 T2)) - (ILESSP [IDIFFERENCE (SETQ T1 (fetch XCOORD of (fetch - (GRAPHNODE - NODEPOSITION) - of N))) - (SETQ T2 (HALF (fetch (GRAPHNODE NODEWIDTH) of N] - X) - (ILESSP X (IPLUS T1 T2]) - -(NODEREGION - [LAMBDA (NODE) (* kvl "10-Aug-84 17:25") - (* returns the region taken up by - NODE) - (CREATEREGION (GN/LEFT NODE) - (GN/BOTTOM NODE) - (fetch (GRAPHNODE NODEWIDTH) of NODE) - (fetch (GRAPHNODE NODEHEIGHT) of NODE]) - -(PRINTDISPLAYNODE - [LAMBDA (NODE TRANS STREAM CLIP/REG) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* ; "Edited 12-Aug-88 12:58 by sye") - - (* ;; "prints a node at its position translated by TRANS. Takes the operation from the stream so that when editor has set the operation to invert, this may erase as well as draw; but when the operation is paint, then nodes obliterate any link lines that they are drawn over.") - - (OR (ZEROP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (PROG* [(LABEL (fetch (GRAPHNODE NODELABEL) of NODE)) - (LEFT (IPLUS (fetch (POSITION XCOORD) of TRANS) - (GN/LEFT NODE))) - (BOTTOM (IPLUS (fetch (POSITION YCOORD) of TRANS) - (GN/BOTTOM NODE))) - (WIDTH (fetch (GRAPHNODE NODEWIDTH) of NODE)) - (HEIGHT (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (FONT (fetch (GRAPHNODE NODEFONT) of NODE)) - (NBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE] - [AND (WINDOWP STREAM) - (SETQ STREAM (WINDOWPROP STREAM 'DSP] - (COND - ([AND CLIP/REG (NOT (INTERSECT/REGIONP/LBWH LEFT BOTTOM WIDTH HEIGHT CLIP/REG - 'PARTIAL] - (RETURN NODE)) - ((BITMAPP (fetch (GRAPHNODE NODELABELBITMAP) of NODE)) - (BITBLT (fetch (GRAPHNODE NODELABELBITMAP) of NODE) - 0 0 STREAM LEFT BOTTOM WIDTH HEIGHT 'INPUT)) - [(BITMAPP LABEL) - (COND - ((NEQ 0 NBW) - (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) - LEFT BOTTOM WIDTH HEIGHT STREAM) - (BITBLT LABEL 0 0 STREAM (IPLUS LEFT NBW) - (IPLUS BOTTOM NBW) - (BITMAPWIDTH LABEL) - (BITMAPHEIGHT LABEL) - 'INPUT)) - (T (BITBLT LABEL 0 0 STREAM LEFT BOTTOM WIDTH HEIGHT 'INPUT] - ((IMAGEOBJP LABEL) - (OR (ZEROP NBW) - (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) - LEFT BOTTOM WIDTH HEIGHT STREAM)) - - (* RMK--In order to place image objects properly, must take into account their - XKERN and YDESC) - - (LET ((IMAGEBOX (APPLY* (IMAGEOBJPROP LABEL 'IMAGEBOXFN) - LABEL STREAM 0 WIDTH))) - (* Formerly just LEFT and BOTTOM) - (MOVETO (IPLUS NBW LEFT (fetch XKERN of IMAGEBOX)) - (IPLUS NBW BOTTOM (fetch YDESC of IMAGEBOX)) - STREAM)) - - (* * End of modifications. RMK) - - (APPLY* (IMAGEOBJPROP LABEL 'DISPLAYFN) - LABEL STREAM)) - ((EQ FONT 'SHADE) (* so small just use texture) - (LET [(2SCALE (ITIMES 2 (DSPSCALE NIL STREAM] - (BLTSHADE BLACKSHADE STREAM LEFT BOTTOM 2SCALE 2SCALE))) - ((NULL FONT)) - (T (OR (FONTP FONT) - (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM))) - (AND (NEQ NBW 0) - (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) - LEFT BOTTOM WIDTH HEIGHT STREAM)) - (DSPFONT FONT STREAM) - (GRAPHER/CENTERPRINTINAREA LABEL LEFT BOTTOM WIDTH HEIGHT STREAM) - (AND (fetch (GRAPHNODE NODELABELSHADE) of NODE) - (FILL/GRAPHNODE/LABEL (fetch (GRAPHNODE NODELABELSHADE) - of NODE) - LEFT BOTTOM WIDTH HEIGHT NBW STREAM)) - (COND - ((AND CACHE/NODE/LABEL/BITMAPS (DISPLAYSTREAMP STREAM) - CLIP/REG - (INTERSECT/REGIONP/LBWH LEFT BOTTOM WIDTH HEIGHT CLIP/REG - 'WHOLE)) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with (BITMAPCREATE - WIDTH HEIGHT) - ) - (BITBLT STREAM LEFT BOTTOM (fetch (GRAPHNODE NODELABELBITMAP) - of NODE) - 0 0 WIDTH HEIGHT 'INPUT]) - -(PROMPTINWINDOW - [LAMBDA (PROMPTSTR POSITION WHICHCORNER BORDERSIZE) (* jds "18-Mar-86 17:49") - (* opens a small window for - prompting at a position and - PROMPTFORWORD's a word.) - - (* POSITION is the location in screen coordinate of the window. - Default is the cursor position.) - - (* WHICHCORNER can be a list of up to two of the atoms LEFT RIGHT TOP BOTTOM - which specify which corner position is intended to be. - Default is lower left.) - (* BORDERSIZE is the border size of - the prompt window. - Default is 6.0) - (PROG ((PROMPTWBORDER (OR (NUMBERP BORDERSIZE) - 6)) - (X (COND - (POSITION (fetch (POSITION XCOORD) of POSITION)) - (T LASTMOUSEX))) - (Y (COND - (POSITION (fetch (POSITION YCOORD) of POSITION)) - (T LASTMOUSEY))) - HGHT WDTH READSTR PREVTTY) - (SETQ HGHT (HEIGHTIFWINDOW (ITIMES (FONTPROP (DEFAULTFONT 'DISPLAY) - 'HEIGHT) - 2) - T PROMPTWBORDER)) - (SETQ WDTH (WIDTHIFWINDOW (IMAX (STRINGWIDTH PROMPTSTR WindowTitleDisplayStream) - 60) - PROMPTWBORDER)) - (SETQ PREVTTY (CREATEW (CREATEREGION (COND - ((MEMB 'RIGHT WHICHCORNER) - (DIFFERENCE X WDTH)) - (T X)) - (COND - ((MEMB 'TOP WHICHCORNER) - (DIFFERENCE Y HGHT)) - (T Y)) - WDTH HGHT) - PROMPTSTR PROMPTWBORDER)) - (DSPLEFTMARGIN (IMAX 0 (fetch (CURSOR CUHOTSPOTX) of (CARET))) - PREVTTY) - (MOVETOUPPERLEFT PREVTTY) - [SETQ READSTR (ERSETQ (PROMPTFORWORD NIL NIL NIL PREVTTY NIL NIL (LIST (CHARCODE EOL] - (CLOSEW PREVTTY) - (RETURN (COND - (READSTR (CAR READSTR)) - (T (* pass back the error.) - (ERROR!]) - -(READ/NODE - [LAMBDA (NODES DS) (* ; "Edited 23-Jul-87 18:20 by sye") - - (* * rht 8/20/85%: Modified "until" statement so it waits till user clicks - inside of window.) - - [bind (CR _ (DSPCLIPPINGREGION NIL DS)) until (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) - (INSIDEP CR (CURSORPOSITION NIL DS] - (PROG (NEAR NOW OLDPOS) - [SETQ NEAR (NODELST/AS/MENU NODES (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (* turn off old flip - (if one) and turn on new flip.) - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (COND - ((MOUSESTATE UP) - (AND NOW (FLIPNODE NOW DS)) - (RETURN NOW)) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODES (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP]) - -(REDISPLAYGRAPH - [LAMBDA (WINDOW REGION) (* kvl "10-Aug-84 19:52") - - (* displays the graph that is in a window. - REGION if given is the clipping region. - Later this could be used to make things run faster.) - - (DSPFILL NIL NIL 'REPLACE WINDOW) - (DISPLAYGRAPH (WINDOWPROP WINDOW 'GRAPH) - WINDOW - (OR REGION (DSPCLIPPINGREGION NIL WINDOW]) - -(REMOVETONODES - [LAMBDA (TOND TONODES) (* rht%: " 4-Apr-85 19:32") - - (* * Removes either TOND or a paramlist thingie for TOND.) - - (for Z in TONODES unless [OR (EQ Z TOND) - (AND (LISTP Z) - (EQ (CAR Z) - 'Link% Parameters) - (EQ TOND (CADR Z] collect Z]) - -(RESET/NODE/BORDER - [LAMBDA (NODE BORDER STREAM GRAPH TRANS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* ;; "gives the node a new border, and displays it if there is a stream. Might not be a stream if being called just to finagle a graph datastructure.") - - (PROG [(ONBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE] - [OR TRANS (SETQ TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0] - (COND - (STREAM (ERASE/GRAPHNODE NODE STREAM TRANS) - [OR GRAPH (AND (WINDOWP STREAM) - (SETQ GRAPH (WINDOWPROP STREAM 'GRAPH] - (DISPLAYNODELINKS NODE TRANS STREAM GRAPH))) - (replace (GRAPHNODE NODEBORDER) of NODE with (COND - ((EQ BORDER 'INVERT) - (INVERTED/GRAPHNODE/BORDER - (fetch (GRAPHNODE - NODEBORDER) - of NODE))) - (T BORDER))) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (OR (IEQP ONBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE))) - (SET/LABEL/SIZE NODE T)) - (AND STREAM (DISPLAYNODE NODE TRANS STREAM GRAPH)) - (RETURN NODE]) - -(RESET/NODE/LABELSHADE - [LAMBDA (NODE SHADE STREAM TRANS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* gives the node a new SHADE and - displays it if there is a stream) - (AND STREAM (ERASE/GRAPHNODE NODE STREAM TRANS)) - (replace (GRAPHNODE NODELABELSHADE) of NODE with (COND - ((EQ SHADE 'INVERT) - (INVERTED/SHADE/FOR/GRAPHER - (fetch (GRAPHNODE - NODELABELSHADE - ) - of NODE))) - (T SHADE))) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (AND STREAM (PRINTDISPLAYNODE NODE (OR TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0))) - STREAM - (DSPCLIPPINGREGION NIL STREAM))) - NODE]) - -(SCALE/GRAPH - [LAMBDA (GRAPH STREAM) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - - (* ;; "Scale the graph GRAPH so it'll look right when rendered on the image stream STREAM. This involves both scaling all the coordinates, and fixing node positions (because we keep track of teh CENTER of each node, even though we really want the lower, left corner to be in the right place).") - - (LET ((SCALE (DSPSCALE NIL STREAM)) - [LAYOUT-IS-VERTICAL (EQMEMB 'VERTICAL (LISTGET (fetch (GRAPH GRAPH.PROPS) of GRAPH) - 'FORMAT] - HEIGHT WIDTH) - (create GRAPH - using - GRAPH GRAPHNODES _ - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - collect - - (* ;; "Move each node to its new position.") - - (* ;; "Start by finding the node's lower, left corner, then scaling that.") - - (SETQ WIDTH (fetch (GRAPHNODE NODEWIDTH) of N)) - (SETQ HEIGHT (fetch (GRAPHNODE NODEHEIGHT) of N)) - (SETQ N (create GRAPHNODE - using - N NODEPOSITION _ - [COND - [LAYOUT-IS-VERTICAL - - (* ;; "Layout is vertical, so make the center correct.") - - (create POSITION - XCOORD _ [FIXR (FTIMES SCALE (fetch XCOORD - of (fetch - (GRAPHNODE - NODEPOSITION - ) - of N] - YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD - of (fetch - (GRAPHNODE - NODEPOSITION - ) - of N] - (T - (* ;; "Horizontal layout, so make the left bottom correct.") - - (create POSITION - XCOORD _ [FIXR (FTIMES SCALE - (IDIFFERENCE - (fetch XCOORD - of (fetch (GRAPHNODE - - NODEPOSITION - ) - of N)) - (LRSH WIDTH 1] - YCOORD _ (FIXR (FTIMES SCALE - (IDIFFERENCE - (fetch YCOORD - of (fetch (GRAPHNODE - - NODEPOSITION - ) - of N)) - (LRSH HEIGHT 1] - NODEWIDTH _ NIL NODEHEIGHT _ NIL NODEFONT _ - (FONTCREATE (fetch (GRAPHNODE NODEFONT) - N) - NIL NIL NIL STREAM) - TONODES _ (SCALE/TONODES N SCALE) - NODEBORDER _ (SCALE/GRAPHNODE/BORDER (fetch (GRAPHNODE - NODEBORDER - ) - of N) - SCALE))) - - (* ;; "Now figure out the new width & height of the node:") - - (SET/LABEL/SIZE N NIL STREAM) - - (* ;; "Now find the new center point, so the node prints in the right place:") - - [COND - ((NOT LAYOUT-IS-VERTICAL) - - (* ;; "Only do this if the layout is horizontal.") - - (add (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) - of N)) - (LRSH (fetch (GRAPHNODE NODEHEIGHT) of N) - 1)) - (add (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) - of N)) - (LRSH (fetch (GRAPHNODE NODEWIDTH) of N) - 1] - N]) - -(SCALE/GRAPHNODE/BORDER - [LAMBDA (BORDER SCALE) (* kvl " 5-Sep-84 18:06") - (* returns a new setting for the - border appropriate for the given - SCALE) - (COND - ((NULL BORDER) - 0) - ((EQ BORDER T) - (FIXR (FTIMES SCALE NODEBORDERWIDTH))) - ((FIXP BORDER) - (FIXR (FTIMES SCALE BORDER))) - ((AND (LISTP BORDER) - (FIXP (CAR BORDER))) - (CONS (FIXR (FTIMES SCALE (CAR BORDER))) - (CDR BORDER]) - -(SCALE/TONODES - [LAMBDA (NODE SCALE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (for NODEID in (fetch (GRAPHNODE TONODES) of NODE) - collect (* copy the property list so that - the scaling doesn't change the - original.) - (COND - [(AND (LISTP NODEID) - (EQ 'Link% Parameters (CAR NODEID)) - (SETQ NODEID (APPEND NODEID)) - (for prop val in ScalableLinkParameters - do (AND (SETQ val (LISTGET NODEID prop)) - (LISTPUT NODEID prop (FIX/SCALE val SCALE] - (T NODEID]) - -(SET/LABEL/SIZE - [LAMBDA (NODE RESET/FLG STREAM) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* the SHADE and null font stuff is - for ZOOMGRAPH) - (OR (AND (NOT RESET/FLG) - (FIXP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (FIXP (fetch (GRAPHNODE NODEWIDTH) of NODE))) - (PROG ((SCALE (DSPSCALE NIL STREAM)) - (FONT (fetch (GRAPHNODE NODEFONT) of NODE)) - (LAB (fetch (GRAPHNODE NODELABEL) of NODE)) - (NBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE))) - WIDTH HEIGHT) - [COND - [(BITMAPP LAB) (* (* ; - "set up appropriate width & height by checking the scale of stream")) - (SETQ WIDTH (OR [AND (NEQ SCALE 1) - (FIXR (FTIMES SCALE (BITMAPWIDTH LAB] - (BITMAPWIDTH LAB))) - (SETQ HEIGHT (OR [AND (NEQ SCALE 1) - (FIXR (FTIMES SCALE (BITMAPHEIGHT LAB] - (BITMAPHEIGHT LAB] - ((IMAGEOBJP LAB) - (SETQ WIDTH (APPLY* (IMAGEOBJPROP LAB 'IMAGEBOXFN) - LAB STREAM)) - (SETQ HEIGHT (fetch (IMAGEBOX YSIZE) of WIDTH)) - (SETQ WIDTH (fetch (IMAGEBOX XSIZE) of WIDTH))) - ((EQ FONT 'SHADE) (* node image is very small) - (SETQ WIDTH (SETQ HEIGHT 2))) - [(NULL FONT) (* FONT of NIL means that the node - is smaller than displays) - (SETQ NBW (SETQ WIDTH (SETQ HEIGHT 0] - (T (OR (FONTP FONT) - (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM))) - [SETQ WIDTH (IPLUS (STRINGWIDTH (fetch (GRAPHNODE NODELABEL) of NODE) - FONT) - (FONTPROP FONT 'DESCENT] - (SETQ HEIGHT (IPLUS (FONTPROP FONT 'HEIGHT) - (FONTPROP FONT 'DESCENT] - (OR (AND (NOT RESET/FLG) - (FIXP (fetch (GRAPHNODE NODEWIDTH) of NODE))) - (replace (GRAPHNODE NODEWIDTH) of NODE with (IPLUS WIDTH NBW NBW))) - (OR (AND (NOT RESET/FLG) - (FIXP (fetch (GRAPHNODE NODEHEIGHT) of NODE))) - (replace (GRAPHNODE NODEHEIGHT) of NODE with (IPLUS HEIGHT NBW NBW))) - (RETURN NODE]) - -(SET/LAYOUT/POSITION - [LAMBDA (NODE POS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* sets a nodes position) - (replace XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE) - with (fetch XCOORD of POS)) - (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE) - with (fetch YCOORD of POS)) - NODE]) - -(SHOWGRAPH - [LAMBDA (GRAPH WINDOW LEFTBUTTONFN MIDDLEBUTTONFN TOPJUSTIFYFLG ALLOWEDITFLG COPYBUTTONEVENTFN - CENTERFLG) (* ; "Edited 28-Sep-93 17:20 by jds") - - (* ;; "puts a graph in the given window, creating one if a window is not given.") - - (SETQ WINDOW (SIZE/GRAPH/WINDOW (COND - ((NULL GRAPH) - (SETQ GRAPH (create GRAPH))) - (T GRAPH)) - (COND - (WINDOW) - (ALLOWEDITFLG (* ; - "put on a title so there will be a place to get window commands.") - "Graph Editor Window")) - TOPJUSTIFYFLG CENTERFLG)) - (WINDOWPROP WINDOW 'GRAPH GRAPH) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION HARDCOPYGRAPH)) - (COND - (ALLOWEDITFLG (* ; - "change the mode to invert so lines can be erased by being redrawn.") - (DSPOPERATION 'INVERT WINDOW) - (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION GRAPHEDITEVENTFN))) - (T (WINDOWPROP WINDOW 'RIGHTBUTTONFN NIL))) - (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (OR COPYBUTTONEVENTFN (FUNCTION GRAPHERCOPYBUTTONEVENTFN))) - (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION APPLYTOSELECTEDNODE)) - (WINDOWPROP WINDOW 'BROWSER/LEFTFN LEFTBUTTONFN) - (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN MIDDLEBUTTONFN) - (REDISPLAYGRAPH WINDOW) - WINDOW]) - -(SIZE/GRAPH/WINDOW - [LAMBDA (GRAPH WINDOW/TITLE TOPJUSTIFYFLG CENTERFLG) (* ; "Edited 28-Sep-93 17:21 by jds") - - (* ;; "returns a window sized to fit the given graph. WINDOW/TITLE can be either a window to be printed in or a title of a window to be created. If TOPJUSTIFYFLG is true, scrolls so top of graph is at top of window, else puts bottom of graph at bottom of window.") - - (PROG ((GRAPHREG (GRAPHREGION GRAPH)) - TITLE WINDOW) - (COND - ((WINDOWP WINDOW/TITLE) - (SETQ WINDOW WINDOW/TITLE)) - (T (SETQ TITLE WINDOW/TITLE))) - - (* ;; "if there is not already a window, ask the user for one to fit.") - - (COND - ((NULL WINDOW) - (SETQ WINDOW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (IMIN (IMAX (fetch (REGION - WIDTH) - of GRAPHREG) - 100) - (FIXR (CAR - DEFAULT.GRAPH.WINDOWSIZE - )) - SCREENWIDTH)) - (HEIGHTIFWINDOW (IMIN (IMAX (fetch (REGION HEIGHT) - of GRAPHREG) - 60) - (FIXR (CADR DEFAULT.GRAPH.WINDOWSIZE - )) - SCREENHEIGHT) - TITLE)) - TITLE))) - (T (CLEARW WINDOW))) - (WINDOWPROP WINDOW 'EXTENT GRAPHREG) - (WXOFFSET [COND - [CENTERFLG (IDIFFERENCE (WXOFFSET NIL WINDOW) - (IDIFFERENCE (IPLUS (fetch (REGION LEFT) of GRAPHREG - ) - (LRSH (fetch (REGION WIDTH) - of GRAPHREG) - 1)) - (LRSH (WINDOWPROP WINDOW 'WIDTH) - 1] - (T (* ; "Put it at the left edge.") - (IDIFFERENCE (WXOFFSET NIL WINDOW) - (fetch (REGION LEFT) of GRAPHREG] - WINDOW) - (WYOFFSET [IDIFFERENCE (WYOFFSET NIL WINDOW) - (COND - [TOPJUSTIFYFLG (IDIFFERENCE (fetch (REGION PTOP) of GRAPHREG) - (WINDOWPROP WINDOW 'HEIGHT] - (T (fetch (REGION BOTTOM) of GRAPHREG] - WINDOW) - (RETURN WINDOW]) - -(TOGGLE/DIRECTEDFLG - [LAMBDA (WIN) (* kvl "20-APR-82 13:38") - (* flips the value of the flag that - indicates whether the graph is a - lattice.) - [replace (GRAPH DIRECTEDFLG) of (WINDOWPROP WIN 'GRAPH) - with (NOT (fetch (GRAPH DIRECTEDFLG) of (WINDOWPROP WIN 'GRAPH] - (DSPFILL NIL (DSPTEXTURE NIL WIN) - 'REPLACE WIN) - (REDISPLAYGRAPH WIN]) - -(TOGGLE/SIDESFLG - [LAMBDA (WIN) (* kvl "20-APR-82 13:15") - - (* flips the value of the flag that indicates whether the graph is to be layed - out vertically or horizontally.) - - [replace (GRAPH SIDESFLG) of (WINDOWPROP WIN 'GRAPH) - with (NOT (fetch (GRAPH SIDESFLG) of (WINDOWPROP WIN 'GRAPH] - (DSPFILL NIL (DSPTEXTURE NIL WIN) - 'REPLACE WIN) - (REDISPLAYGRAPH WIN]) - -(TOLINKS - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (fetch (GRAPHNODE TONODES) of NODE]) - -(TRACKCURSOR - [LAMBDA (ND DS GRAPH) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* causes ND to follow cursor.) - (PROG (OLDPOS ORIGPOS DOWNFLG) (* maybe there aren't any nodes) - (OR ND (RETURN)) - (SETQ ORIGPOS (create POSITION using (fetch (GRAPHNODE NODEPOSITION) - of ND))) - (SETQ OLDPOS (CURSORPOSITION (fetch (GRAPHNODE NODEPOSITION) of ND) - DS)) - (FLIPNODE ND DS) - (until (COND - (DOWNFLG (MOUSESTATE UP)) - ((SETQ DOWNFLG (MOUSESTATE (NOT UP))) - NIL)) do (MOVENODE ND (fetch (GRAPHNODE NODEPOSITION) - of ND) - (CURSORPOSITION NIL DS OLDPOS) - GRAPH DS)) - (FLIPNODE ND DS) - (COND - ([NOT (EQUAL ORIGPOS (SETQ OLDPOS (fetch (GRAPHNODE NODEPOSITION) of ND] - (EXTENDEXTENT (WFROMDS DS) - (NODEREGION ND)) - (CALL.MOVENODEFN ND OLDPOS GRAPH (WFROMDS DS) - ORIGPOS]) - -(TRACKNODE - [LAMBDA (W) (* ; "Edited 17-Jul-87 15:26 by sye") - - (* grabs the nearest nodes and hauls it around with the cursor, leaving it - where it is when the button goes up.) - - (TRACKCURSOR (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES) of (WINDOWPROP - W - 'GRAPH)) - (CURSORPOSITION NIL W)) - (WINDOWPROP W 'DSP) - (WINDOWPROP W 'GRAPH]) - -(TRANSGRAPH - [LAMBDA (GRAPH X Y) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (create GRAPH reusing GRAPH GRAPHNODES _ - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - collect (create GRAPHNODE - reusing N NODEPOSITION _ - (create POSITION - XCOORD _ (PLUS X - (fetch XCOORD - of - (fetch (GRAPHNODE - NODEPOSITION - ) - of N))) - YCOORD _ (PLUS Y - (fetch YCOORD - of - (fetch (GRAPHNODE - NODEPOSITION - ) - of N]) -) - - - -(* ;; "Support for EDITSUBGRAPH and EDITREGION") - -(DEFINEQ - -(EDITMOVEREGION - [LAMBDA (Window) (* Newman "27-Jan-87 11:08") - - (* * This function moves all the nodes within a selected region to another - region of similar shape and size.) - - (if (NOT (WINDOWP Window)) - then (ERROR Window " not a window.") - else (PROMPTPRINT " Select the region containing the nodes you wish to move.") - (PROG* ((DisplayStream (WINDOWPROP Window 'DSP)) - (Region (GETWREGION Window)) - (Graph (WINDOWPROP Window 'GRAPH)) - (NodeList (for Node in (fetch (GRAPH GRAPHNODES) of Graph) - when (OR (INTERSECTREGIONS Region (NODEREGION Node)) - (SUBREGIONP Region (NODEREGION Node))) collect - Node))) - (if (NULL Graph) - then (ERROR Window " not a graph window.") - elseif (NULL NodeList) - then (PROMPTPRINT "No nodes in the region selected.")) - (for Node in NodeList do (FLIPNODE Node DisplayStream)) - (bind OldPos (NewRegionPosition _ (GETBOXPOSITION.FROMINITIALREGION Window - Region DisplayStream)) for - SelectedNode - in NodeList eachtime (SETQ OldPos (fetch (GRAPHNODE NODEPOSITION) - of SelectedNode)) - do (MOVENODE SelectedNode OldPos (CREATE.NEW.NODEPOSITION - SelectedNode - (DIFFERENCE (fetch (POSITION - XCOORD) - of - NewRegionPosition - ) - (fetch (REGION LEFT) - of Region)) - (DIFFERENCE (fetch (POSITION - YCOORD) - of - NewRegionPosition - ) - (fetch (REGION BOTTOM) - of Region))) - Graph DisplayStream) - (EXTENDEXTENT (WFROMDS DisplayStream) - (NODEREGION SelectedNode)) - (* extent the graph extent because - the node may be outside the old - extent.) - (FLIPNODE SelectedNode DisplayStream]) - -(EDITMOVESUBTREE - [LAMBDA (WINDOW) (* Newman "27-Jan-87 11:10") - - (* * Code derived from EDITMOVENODE by Richard Burton. - Changes to prompt strings, and changes the to TRACKCURSOR to a call to - NOT.TRACKCURSOR) - (* hilite nodes until the cursor - goes down then move it) - (PROG ((DS (WINDOWPROP WINDOW 'DSP)) - (REG (WINDOWPROP WINDOW 'REGION)) - (GRAPH (WINDOWPROP WINDOW 'GRAPH)) - OLDPOS NOW NEAR NODELST) - (COND - (GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) - (T (RETURN))) - (printout PROMPTWINDOW T "Move the cursor to the node " "that is the common root of " - "the subtree you want to move " "and press any button.") - [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (GETMOUSESTATE) - (COND - ((LASTMOUSESTATE (NOT UP)) (* button up, process it.) - (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) - ) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP))) - (printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position" - "and release the button.") - (NOT.TRACKCURSOR NOW DS GRAPH) - (printout PROMPTWINDOW T "Done."]) - -(NOT.TRACKCURSOR - [LAMBDA (Node DisplayStream Graph) (* ; "Edited 3-Aug-88 14:50 by pmi") - - (* ;; "Gets an old, and a new region from the user, and uses these to calculate all the new positions for all the children of Node.") - - (* ;; - "rht 4/28/87: Changed from APPLY of UNIONREGIONS to for loop doing successive UNIONREGIONS calls.") - - (* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.") - - (if (NULL Node) - then (PROMPTPRINT "No node selected.") - else (PROG* ((Children (COLLECTDESCENDENTS Node Graph)) - (OldRegion (for EachNode in (CONS Node Children) - bind (TotalRegion _ (NODEREGION Node)) - do (FLIPNODE EachNode DisplayStream) - (SETQ TotalRegion (UNIONREGIONS TotalRegion (NODEREGION - EachNode))) - finally (RETURN TotalRegion))) - (NewRegionPosition (GETBOXPOSITION.FROMINITIALREGION (WFROMDS - DisplayStream) - OldRegion DisplayStream)) - (deltaX (DIFFERENCE (fetch (POSITION XCOORD) of NewRegionPosition) - (fetch (REGION LEFT) of OldRegion))) - (deltaY (DIFFERENCE (fetch (POSITION YCOORD) of NewRegionPosition) - (fetch (REGION BOTTOM) of OldRegion))) - (OldPos (fetch (GRAPHNODE NODEPOSITION) of Node)) - (NewPos (CREATE.NEW.NODEPOSITION Node deltaX deltaY))) - [if (NOT (EQUAL OldPos NewPos)) - then (MOVENODE Node OldPos NewPos Graph DisplayStream) - (EXTENDEXTENT (WFROMDS DisplayStream) - (NODEREGION Node)) - (CALL.MOVENODEFN Node OldPos Graph (WFROMDS DisplayStream) - NewPos) - (if Children - then (PROG [(MovedNodes (LIST (fetch (GRAPHNODE NODEID) - of Node] - (MOVEDESCENDENTS Graph Node DisplayStream - deltaX deltaY] - (for EachNode in (CONS Node Children) do (FLIPNODE EachNode - DisplayStream]) - -(RECURSIVE.COLLECTDESCENDENTS - [LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 16:06 by pmi") - - (* ;; "Collect all descendents of Node in Graph.") - - (* ;; - "pmi 8/2/88: Changed to break infinite recursion on circular graphs. Now marks nodes as visited.") - - (* ;; "pmi 8/5/88: FIxes bug introduced by previous fix.") - - (LET (NodeId) - - (* ;; "Node's NODEID may be a list if it is a virtual node. ") - - (if (LISTP (SETQ NodeId (fetch (GRAPHNODE NODEID) of Node))) - then (SETQ NodeId (CAR NodeId))) - (NC.GraphNodeIDPutProp NodeId 'Visited T) - (for ChildNode in (COLLECT.CHILD.NODES Node Graph) bind ChildNodeID - when [PROGN (SETQ ChildNodeID (fetch (GRAPHNODE NODEID) of ChildNode)) - - (* ;; "This node has not been visited, and it is not a virtual node.") - - (NOT (NC.GraphNodeIDGetProp (if (LISTP ChildNodeID) - then (CAR ChildNodeID) - else ChildNodeID) - 'Visited] join (CONS ChildNode ( - RECURSIVE.COLLECTDESCENDENTS - ChildNode Graph]) - -(MOVEDESCENDENTS - [LAMBDA (Graph Node DisplayStream deltaX deltaY) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* ;; "Moves Node and all Children of Node by deltaX and deltaY.") - - (* ;; "first, finds all descendents of Node. For each of these, create a new position based on the old and the deltas. Then, if the child has not been moved yet, we add it to the list of moved nodes, move the node, and call the MOVENODEFN,") - - (* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.") - - (bind (MovedNodes _ (LIST Node)) - NewPos for Child in (COLLECTDESCENDENTS Node Graph) - eachtime (SETQ NewPos (CREATE.NEW.NODEPOSITION Child deltaX deltaY)) - unless (MEMBER (fetch (GRAPHNODE NODEID) of Child) - MovedNodes) do (SETQ MovedNodes (CONS (fetch (GRAPHNODE NODEID) - of Child) - MovedNodes)) - (MOVENODE Child (fetch (GRAPHNODE NODEPOSITION) - of Child) - NewPos Graph DisplayStream) - (EXTENDEXTENT (WFROMDS DisplayStream) - (NODEREGION Child)) - - (* ;; "we must call EXTENDEXTENT to extend the graph extent in case we have moved a node outside the previous extent.") - - (CALL.MOVENODEFN Child NewPos Graph (WFROMDS - DisplayStream - ) - (fetch (GRAPHNODE NODEPOSITION) of Child]) - -(COLLECT.CHILD.NODES - [LAMBDA (Node Graph) (* Newman "27-Jan-87 11:16") - - (* * collect all immediate children (only one generation) of Node in Graph.) - - (bind (GraphNodes _ (fetch (GRAPH GRAPHNODES) of Graph)) for NodeID - in (fetch (GRAPHNODE TONODES) of Node) collect - (* ??? (ASSOC (if (AND - (LISTP NodeID) (EQUAL - (CAR NodeID) (QUOTE Link% Parameters))) - then (* Special case where the - second item in the list is the - NodeID) (CADR NodeID) else NodeID) - GraphNodes)) - (GETNODEFROMID NodeID GraphNodes]) - -(CREATE.NEW.NODEPOSITION - [LAMBDA (Node deltaX deltaY) (* Newman "27-Jan-87 11:06") - - (* * Creates a new position for Node by adding deltaX and deltaY to the - appropriate coordinates.) - - (PROG ((OldPos (fetch (GRAPHNODE NODEPOSITION) of Node))) - (RETURN (create POSITION - XCOORD _ (PLUS deltaX (fetch (POSITION XCOORD) of OldPos)) - YCOORD _ (PLUS deltaY (fetch (POSITION YCOORD) of OldPos]) - -(GETBOXPOSITION.FROMINITIALREGION - [LAMBDA (Window Region DisplayStream) (* Newman "26-Jan-87 11:38") - - (* * This function obtains a new region from the user, and it prompts the user - using the region passed in as Region. DisplayStream is the displaystream of - Window, and Region is considered to be a region within Window. - This function was written to be called from EDITMOVEREGION.) - - (* All of the garbage below to calculate the third and fourth arguments to - GETBOXPOSITION exists to put the ghost box prompting the user in exactly the - same place as the region passed in.) - - (GETBOXPOSITION (fetch (REGION WIDTH) of Region) - (fetch (REGION HEIGHT) of Region) - (DIFFERENCE (PLUS (fetch (REGION LEFT) of Region) - (fetch (REGION LEFT) of (WINDOWPROP Window 'REGION)) - (WINDOWPROP Window 'BORDER)) - (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL DisplayStream))) - (DIFFERENCE (PLUS (fetch (REGION BOTTOM) of Region) - (fetch (REGION BOTTOM) of (WINDOWPROP Window 'REGION)) - (WINDOWPROP Window 'BORDER)) - (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL DisplayStream))) - Window "Select new region for nodes."]) - -(COLLECTDESCENDENTS - [LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 15:40 by pmi") - - (* ;; "pmi 8/3/88: Created to wrap RESETLST around call to RECURSIVE.COLLECTDESCENDENTS. Prevents infinite looping on circular graph structures by marking where we have been.") - - (* ;; "Clean up the Visited markers placed on the nodes traversed.") - - (* ;; "pmi 8/5/88: Now also cleans up Visited marker on Node.") - - (LET (NodeID Descendents) - (RESETLST - [RESETSAVE NIL - '(PROGN (for VisitedNode in (CONS Node Descendents) bind - VisitedNodeID - do (NC.GraphNodeIDPutProp - (if (LISTP (SETQ VisitedNodeID (fetch (GRAPHNODE - NODEID) - of VisitedNode))) - then (CAR VisitedNodeID) - else VisitedNodeID) - 'Visited NIL] - (SETQ Descendents (RECURSIVE.COLLECTDESCENDENTS Node Graph)))]) -) - - - -(* ; "functions for finding larger and smaller fonts") - -(DEFINEQ - -(NEXTSIZEFONT - [LAMBDA (WHICHDIR NOWFONT) (* rmk%: "15-Sep-84 00:14") - - (* returns the next sized font either SMALLER or LARGER that on of size FONT. - (NEXTSIZEFONT (QUOTE LARGER) DEFAULTFONT)) - - (PROG [(NOWSIZE (FONTPROP NOWFONT 'HEIGHT] - (RETURN (COND - [(EQ WHICHDIR 'LARGER) - (COND - ((IGEQ NOWSIZE (FONTPROP (CAR DECREASING.FONT.LIST) - 'HEIGHT)) (* nothing larger) - NIL) - (T (for FONTTAIL on DECREASING.FONT.LIST - when [AND (CDR FONTTAIL) - (IGEQ NOWSIZE (FONTPROP (CADR FONTTAIL) - 'HEIGHT] - do (RETURN (FONTNAMELIST (CAR FONTTAIL] - (T (for FONT in DECREASING.FONT.LIST - when (LESSP (FONTPROP FONT 'HEIGHT) - NOWSIZE) do (RETURN (FONTNAMELIST FONT]) - -(DECREASING.FONT.LIST - [LAMBDA NIL (* rrb "16-Dec-83 12:28") - - (* returns a list of the font descriptors for the fonts sketch windows are - willing to print in.) - - (for SIZE in '(18 14 12 10 8 5) collect (FONTCREATE 'HELVETICA SIZE]) - -(SCALE.FONT - [LAMBDA (WID STR) (* rrb " 7-NOV-83 11:35") - - (* returns the font that text should be printed in to have the text STR fit - into a region WID points wide) - - (COND - ((GREATERP WID (TIMES (STRINGWIDTH STR (CAR DECREASING.FONT.LIST)) - 1.5)) (* scale it too large for even the - largest font.) - NIL) - (T (for FONT in DECREASING.FONT.LIST when (NOT (GREATERP (STRINGWIDTH STR FONT) - WID)) - do (RETURN FONT) finally (RETURN 'SHADE]) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(RPAQ DECREASING.FONT.LIST (DECREASING.FONT.LIST)) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DECREASING.FONT.LIST) -) - - - -(* ; "functions for LAYOUTGRAPH And LAYOUTLATTICE") - -(DEFINEQ - -(BRH/LAYOUT - [LAMBDA (N X Y MOMLST GN) (* kvl "26-DEC-83 16:44") - - (* X and Y are the lower left corner of the box that will surround the tree - headed by the browsenode N. MOMLST is the mother node inside a cons cell. - GN is the graphnode for the nodeid N. It is crucial that the NODEPOSITION be - set before recursion because this marks that the node has been - (is being) laid out already. BRH/OFFSET is used to raise the daughters in those - rare cases where the label is bigger than the daughters.) - - (DECLARE (USEDFREE MOTHERD PERSONALD NODELST)) - (PROG ((DS (fetch (GRAPHNODE TONODES) of GN)) - (W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (YHEIGHT (IPLUS PERSONALD (fetch (GRAPHNODE NODEHEIGHT) of GN))) - DHEIGHT) - (replace (GRAPHNODE FROMNODES) of GN with MOMLST) - [replace (GRAPHNODE NODEPOSITION) of GN with (create POSITION - XCOORD _ - (IPLUS X (HALF W] - (COND - ((NULL DS)) - [[IGREATERP YHEIGHT (SETQ DHEIGHT (BRH/LAYOUT/DAUGHTERS DS (IPLUS X W MOTHERD) - Y - (LIST N] - (BRH/OFFSET DS (HALF (IDIFFERENCE YHEIGHT DHEIGHT] - (T (SETQ YHEIGHT DHEIGHT))) - (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) - with (IPLUS Y (HALF YHEIGHT))) - (RETURN YHEIGHT]) - -(BRH/LAYOUT/DAUGHTERS - [LAMBDA (DS X Y MOMLST) (* rmk%: " 5-Feb-84 15:01") - - (* DS are the daughters of (CAR MOMLST)%. - X is where the left edge of their labels will be, and Y is the bottom of the - mother's box. Returns the height of the mother's box. - Tests to see if a node has been layout out already If so, it replaces the - daughter with one that has no descendents, and splices into the mother's - daughter list, side-effecting the graphnode structure.) - - (DECLARE (USEDFREE NODELST)) - (for D (FLOOR _ Y) in DS do [SETQ FLOOR (IPLUS FLOOR (BRH/LAYOUT D X FLOOR MOMLST - (GETNODEFROMID D - NODELST] - finally (RETURN (IDIFFERENCE FLOOR Y]) - -(BRH/OFFSET - [LAMBDA (NODEIDS YINC) - (DECLARE (USEDFREE NODELST)) (* kvl "11-Dec-84 14:35") - (for N in NODEIDS do (SETQ N (GETNODEFROMID N NODELST)) - (add (fetch YCOORD of (fetch (GRAPHNODE - NODEPOSITION) - of N)) - YINC) - (BRH/OFFSET (fetch (GRAPHNODE TONODES) of N) - YINC]) - -(BRHC/INTERTREE/SPACE - [LAMBDA (TTC BTC) (* kvl "21-DEC-83 10:23") - - (* Given the top transition chain of the old daughter and the bottom transition - chain of the new daughter, where BTC is sitting on the bottom of the box, - calculate how much the bottom must be raised so that it just clears the TTC. - OP is the top left corner of some label. - NP is the bottom left corner.) - - (PROG ((RAISE -1000) - NP DIST OP) - (SETQ OP (pop TTC)) - (SETQ NP (pop BTC)) - L (SETQ DIST (IDIFFERENCE (fetch YCOORD of OP) - (fetch YCOORD of NP))) - (AND (IGREATERP DIST RAISE) - (SETQ RAISE DIST)) - [COND - ((NULL BTC) - (RETURN RAISE)) - ((NULL TTC) - (RETURN RAISE)) - ((IEQP (fetch XCOORD of (CAR BTC)) - (fetch XCOORD of (CAR TTC))) - (SETQ NP (pop BTC)) - (SETQ OP (pop TTC))) - ((ILESSP (fetch XCOORD of (CAR BTC)) - (fetch XCOORD of (CAR TTC))) - (SETQ NP (pop BTC))) - (T (SETQ OP (pop TTC] - (GO L]) - -(BRHC/LAYOUT - [LAMBDA (N X MOMLST GN) (* rmk%: " 5-Feb-84 14:47") - - (* See comment on BRH/LAYOUT. Instead of keeping only the graphnode in layed - out node's position field, keep the offset as well. - The offset is how much this nodes box must be raised relative to the inclosing - box. Uses two free variables to return transition chains. - RETURNTTC is the top left corners of all the labels. - RETURNBTC is the bottom left corners.) - - (DECLARE (USEDFREE PERSONALD RETURNTTC RETURNBTC)) - (PROG ((DS (fetch (GRAPHNODE TONODES) of GN)) - (W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (H (fetch (GRAPHNODE NODEHEIGHT) of GN)) - YCENTER X/SW H/2) - (SETQ H/2 (HALF H)) - (SETQ X/SW (IPLUS X W)) - (replace (GRAPHNODE FROMNODES) of GN with MOMLST) - (replace (GRAPHNODE NODEPOSITION) of GN with (LIST 0)) - [SETQ YCENTER (COND - (DS (BRHC/LAYOUT/DAUGHTERS DS X/SW (LIST N))) - (T (BRHC/LAYOUT/TERMINAL GN X/SW] - (RPLACD (fetch (GRAPHNODE NODEPOSITION) of GN) - (create POSITION - XCOORD _ (IPLUS X (HALF W)) - YCOORD _ YCENTER)) - [push RETURNTTC (create POSITION - XCOORD _ X - YCOORD _ (IPLUS PERSONALD (IPLUS (IDIFFERENCE YCENTER H/2) - H] - (push RETURNBTC (create POSITION - XCOORD _ X - YCOORD _ (IDIFFERENCE YCENTER H/2))) - (RETURN YCENTER]) - -(BRHC/LAYOUT/DAUGHTERS - [LAMBDA (DS X/SW MOMLST) - (DECLARE (USEDFREE MOTHERD FAMILYD NODELST RETURNTTC RETURNBTC)) - (* rmk%: " 5-Feb-84 14:52") - - (* see comment on BRH/LAYOUT/DAUGHTERS. - First daughter is always laid out on the bottom of the box. - Subsequent daughters have the amount that they are to be raised calculated by - comparing the top edge of the old daughter - (in TTC) with the bottom edge of the new daughter - (in RETURNBTC)%. TTC is update by adding the new daughter's transition chain to - the front, because the new daughter's front is guaranteed to be higher than the - old daughter's front. Conversely, BTC is updated by adding the new daughter's - transition chain to the back, because the old daughter's front is guaranteed to - be lower.) - - (for D in DS bind GN BTC TTC 1ST/DCENTER LST/DCENTER (OFFSET _ 0) - (X _ (IPLUS X/SW MOTHERD)) - do (SETQ GN (GETNODEFROMID D NODELST)) - (SETQ LST/DCENTER (BRHC/LAYOUT D X MOMLST GN)) - [COND - ((NULL TTC) (* first daughter) - (SETQ 1ST/DCENTER LST/DCENTER) - (SETQ TTC RETURNTTC) - (SETQ BTC RETURNBTC)) - (T (SETQ OFFSET (BRHC/INTERTREE/SPACE TTC RETURNBTC)) - (RPLACA (fetch (GRAPHNODE NODEPOSITION) of GN) - OFFSET) - (SETQ TTC (EXTEND/TRANSITION/CHAIN (RAISE/TRANSITION/CHAIN RETURNTTC - OFFSET) - TTC)) - (SETQ BTC (EXTEND/TRANSITION/CHAIN BTC (RAISE/TRANSITION/CHAIN RETURNBTC - OFFSET] - finally - - (* add a mythical top left corner at the height of the highest daughter because - diagnonal links are getting clobbered. Move lowest daughter's bottom left - corner to the left for the same reason.) - - (SETQ RETURNTTC (CONS (create POSITION - XCOORD _ X/SW - YCOORD _ (fetch YCOORD of (CAR TTC))) - TTC)) - (replace XCOORD of (CAR BTC) with X/SW) - (add (fetch YCOORD of (CAR TTC)) - FAMILYD) - (SETQ RETURNBTC BTC) - - (* center of mother is halfway between first and last daughter's label centers - using fact that offset of first daughter is zero and last daughter's offset is - OFFSET) - - (RETURN (HALF (IPLUS 1ST/DCENTER OFFSET LST/DCENTER]) - -(BRHC/LAYOUT/TERMINAL - [LAMBDA (GN X/SW) (* rmk%: " 3-Feb-84 09:55") - - (* initiallizes the transition chains to the right edge of the node label, and - returns the label's center.) - - (DECLARE (USEDFREE RETURNTTC RETURN/TBC)) - (SETQ RETURNTTC (LIST (create POSITION - XCOORD _ X/SW - YCOORD _ 0))) - [SETQ RETURNBTC (LIST (create POSITION - XCOORD _ X/SW - YCOORD _ (fetch (GRAPHNODE NODEHEIGHT) of GN] - (HALF (fetch (GRAPHNODE NODEHEIGHT) of GN]) - -(BRHC/OFFSET - [LAMBDA (N ABSY) (* dgb%: "22-Jan-85 07:17") - (* Adds in all the offsets. - See comment on - BRHC/LAYOUT/DAUGHTERS.) - (DECLARE (USEDFREE NODELST)) - (PROG ((GN (GETNODEFROMID N NODELST))) - [SETQ ABSY (IPLUS ABSY (pop (fetch (GRAPHNODE NODEPOSITION) of GN] - [replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) - with (IPLUS ABSY (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) - of GN] - (for D in (fetch (GRAPHNODE TONODES) of GN) do (BRHC/OFFSET D ABSY]) - -(BRHL/LAYOUT - [LAMBDA (N X Y MOMLST GN) (* kvl "26-DEC-83 16:36") - - (* X and Y are the lower left corner of the box that will surround the tree - headed by the browsenode N. MOMLST is the mother node inside a cons cell. - GN is the graphnode for the nodeid N. It is crucial that the NODEPOSITION be - set before recursion because this marks that the node has been laid out - already. If in addition, the YCOORD is NIL, then the node is still in the - process of being laid out. BRHL/LAYOUT/DAUGHTERS uses this fact to break loops - by inserting boxed nodes.) - - (DECLARE (USEDFREE MOTHERD PERSONALD NODELST)) - (COND - ((fetch (GRAPHNODE NODEPOSITION) of GN) - - (* This case only occurs if this node has been put in the roots list, and has - already been visited by recursion. Value won't be used) - - 0) - (T (PROG [(DS (fetch (GRAPHNODE TONODES) of GN)) - (W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (YHEIGHT (IPLUS PERSONALD (fetch (GRAPHNODE NODEHEIGHT) of GN] - (replace (GRAPHNODE FROMNODES) of GN with MOMLST) - (* This is first time for layout, so - set FROMNODES) - [replace (GRAPHNODE NODEPOSITION) of GN with (create - POSITION - XCOORD _ - (IPLUS X (HALF W] - (AND DS (SETQ YHEIGHT (IMAX (BRHL/LAYOUT/DAUGHTERS DS (IPLUS X W MOTHERD) - Y - (LIST N)) - YHEIGHT))) - (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) - with (IPLUS Y (HALF YHEIGHT))) - (RETURN YHEIGHT]) - -(BRHL/LAYOUT/DAUGHTERS - [LAMBDA (DS X Y MOMLST) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* DS are the daughters of (CAR MOMLST)%. - X is where their the left edge of their labels will be, and Y is the bottom of - the mother's box. Returns the height of the mother's box. - Tests to see if a node has been laid out out already If so, it sees if the node - is far enought to the right; if not it moves the node and its daughters.) - - (DECLARE (USEDFREE NODELST YHEIGHT)) - (for DTAIL on DS bind D GN NP DELTA (FLOOR _ Y) finally (RETURN (IDIFFERENCE - FLOOR Y)) - do (SETQ GN (GETNODEFROMID (SETQ D (CAR DTAIL)) - NODELST)) - (COND - ((SETQ NP (fetch (GRAPHNODE NODEPOSITION) of GN)) - [COND - [(NULL (fetch YCOORD of NP)) - (SETQ GN (NEW/INSTANCE/OF/GRAPHNODE GN)) - (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of GN)) - (SETQ FLOOR (IPLUS FLOOR (BRHL/LAYOUT (fetch (GRAPHNODE NODEID) - of GN) - X FLOOR MOMLST GN] - (T (BRHL/MOVE/RIGHT GN X NIL) - (push (fetch (GRAPHNODE FROMNODES) of GN) - (CAR MOMLST] (* Add this mother to the fromLinks) - ) - (T (SETQ FLOOR (IPLUS FLOOR (BRHL/LAYOUT D X FLOOR MOMLST GN]) - -(BRHL/MOVE/RIGHT - [LAMBDA (GN X STACK) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* Move this node and its children - right) - (DECLARE (USEDFREE NODELST)) - (PROG ((W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (NP (fetch (GRAPHNODE NODEPOSITION) of GN))) - (AND (FMEMB GN STACK) - (ERROR "Loop caught in BRHL/MOVE/RIGHT at" (fetch (GRAPHNODE NODELABEL) - of GN))) - (COND - ((ILESSP X (IDIFFERENCE (fetch XCOORD of NP) - (HALF W))) - (RETURN))) - (for D in (TOLINKS GN) bind (NEWX _ (IPLUS X W MOTHERD)) - (NSTACK _ (CONS GN STACK)) - do (BRHL/MOVE/RIGHT (GETNODEFROMID D NODELST) - NEWX NSTACK)) - (replace XCOORD of NP with (IPLUS X (HALF W]) - -(BROWSE/LAYOUT/HORIZ - [LAMBDA (ROOTIDS) (* ; "Edited 19-Aug-88 08:32 by sye") - - (* each subtree is given a box centered vertically on its label. - Sister boxes abut but do not intrude as they do in the compacting version.) - - (DECLARE (USEDFREE NODELST)) - [for N in ROOTIDS bind (Y _ 0) do (SETQ Y (IPLUS Y (BRH/LAYOUT N 0 Y NIL - (GETNODEFROMID - N NODELST] - (create GRAPH - GRAPHNODES _ NODELST - SIDESFLG _ T - DIRECTEDFLG _ NIL]) - -(BROWSE/LAYOUT/HORIZ/COMPACTLY - [LAMBDA (ROOTS) - (DECLARE (USEDFREE NODELST MOTHERD)) (* ; "Edited 19-Aug-88 08:33 by sye") - - (* See comments on BRH/LAYOUT and BRH/LAYOUT/DAUGHTERS first. - This differs in that it keeps (on the stack) a representation of the shape of - the tree that fills the node's box. The representation is a list of POSITIONs. - If one starts drawing a line from left to right starting at the CAR, each point - is a step in the line, and the point begins the new plateau - (or valley)%. The last point is where the line would turn around and head back - to the left.) - (* builds dummy top node for ROOTS - if necessary, and adjusts the - horizontal distance accordingly.) - [PROG (RETURNTTC RETURNBTC) - (DECLARE (SPECVARS RETURNTTC RETURNBTC)) - (COND - ((NLISTP ROOTS) - (BRHC/LAYOUT ROOTS 0 NIL (GETNODEFROMID ROOTS NODELST)) - (BRHC/OFFSET ROOTS 0)) - ((NULL (CDR ROOTS)) - (BRHC/LAYOUT (CAR ROOTS) - 0 NIL (GETNODEFROMID (CAR ROOTS) - NODELST)) - (BRHC/OFFSET (CAR ROOTS) - 0)) - (T (PROG ((GN (create GRAPHNODE - NODELABEL _ (PACK) - NODEID _ (CONS) - TONODES _ ROOTS - NODEWIDTH _ 0 - NODEHEIGHT _ 0)) - TOPNODE) - (push NODELST GN) - (SETQ TOPNODE (fetch (GRAPHNODE NODEID) of GN)) - (BRHC/LAYOUT TOPNODE (IMINUS MOTHERD) - NIL GN) - (BRHC/OFFSET TOPNODE 0) - [for N GN in ROOTS do (replace (GRAPHNODE FROMNODES) - of (SETQ GN (FASSOC N NODELST)) - with (DREMOVE TOPNODE - (fetch (GRAPHNODE - FROMNODES) - of GN] - (SETQ NODELST (DREMOVE GN NODELST] - (create GRAPH - GRAPHNODES _ NODELST - SIDESFLG _ T - DIRECTEDFLG _ NIL]) - -(BROWSE/LAYOUT/LATTICE - [LAMBDA (NS) (* ; "Edited 19-Aug-88 08:33 by sye") - - (* almost the same as BROWSE/LAYOUT/HORIZ, except that it doesn't box nodes - unless there are cycles. Instead, a single node is placed at the rightmost of - the positions that would be laid out by for all of its - (boxed) occurrences by BROWSE/LAYOUT/HORIZ.) - - (DECLARE (USEDFREE NODELST)) - [for N in NS bind (Y _ 0) do (SETQ Y (IPLUS Y (BRHL/LAYOUT N 0 Y NIL - (GETNODEFROMID N NODELST - ] - (create GRAPH - GRAPHNODES _ NODELST - SIDESFLG _ T - DIRECTEDFLG _ NIL]) - -(BRV/OFFSET - [LAMBDA (N ABSX) (* dgb%: "22-Jan-85 07:25") - - (* Adds in offset which are kept in car of NODEPOSITION. - TERMY is Y of lowest node. Adding it in raises tree so lowest node is at zero.) - - (DECLARE (USEDFREE NODELST TERMY)) - (PROG (P (GN (GETNODEFROMID N NODELST))) - [SETQ ABSX (IPLUS ABSX (pop (fetch (GRAPHNODE NODEPOSITION) of GN] - (replace XCOORD of (SETQ P (fetch (GRAPHNODE NODEPOSITION) of GN)) - with (IPLUS ABSX (fetch XCOORD of P))) - (replace YCOORD of P with (IDIFFERENCE (fetch YCOORD of P) - TERMY)) - (for D in (fetch (GRAPHNODE TONODES) of GN) do (BRV/OFFSET D ABSX]) - -(EXTEND/TRANSITION/CHAIN - [LAMBDA (LTC RTC) (* kvl "21-DEC-83 11:00") - - (* Extends the left transition chain by appending the part of the right - transition chain that is to the right of the end of the left transition chain. - End point of left transition chain is changed to intersect right transition - chain) - - (PROG ((LTAIL LTC) - (RTAIL RTC) - LX RX) - L [COND - ((NULL (CDR RTAIL)) - (replace YCOORD of (CAR (FLAST LTAIL)) with (fetch YCOORD - of (CAR RTAIL))) - (RETURN LTC)) - ((NULL (CDR LTAIL)) - (RPLACD LTAIL (CDR RTAIL)) - (replace YCOORD of (CAR LTAIL) with (fetch YCOORD of (CAR RTAIL))) - (RETURN LTC)) - ([IEQP (SETQ LX (fetch XCOORD of (CADR LTAIL))) - (SETQ RX (fetch XCOORD of (CADR RTAIL] - (SETQ LTAIL (CDR LTAIL)) - (SETQ RTAIL (CDR RTAIL))) - ((ILESSP LX RX) - (SETQ LTAIL (CDR LTAIL))) - (T (SETQ RTAIL (CDR RTAIL] - (GO L]) - -(FOREST/BREAK/CYCLES - [LAMBDA (NODE) (* kvl "14-Aug-84 09:19") - (* Breaks any cycles by inserting - new nodes and boxing) - (DECLARE (USEDFREE NODELST)) - (replace (GRAPHNODE NODEPOSITION) of NODE with T) - (for DTAIL DN on (fetch (GRAPHNODE TONODES) of NODE) - do (SETQ DN (GETNODEFROMID (CAR DTAIL) - NODELST)) - (COND - ((fetch (GRAPHNODE NODEPOSITION) of DN) - (* We've seen this before) - (SETQ DN (NEW/INSTANCE/OF/GRAPHNODE DN)) - (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of DN))) - (T (FOREST/BREAK/CYCLES DN]) - -(INIT/NODES/FOR/LAYOUT - [LAMBDA (NS FORMAT ROOTIDS FONT) (* Randy.Gobbel " 8-May-87 16:22") - (for GN in NS do [replace (GRAPHNODE NODEPOSITION) of GN - with (NOT (NOT (FMEMB (fetch (GRAPHNODE NODEID) - of GN) - ROOTIDS] - (* T Used to indicate prior - visitation. Roots are already - visited) - (OR (IMAGEOBJP (fetch (GRAPHNODE NODELABEL) of GN)) - (fetch (GRAPHNODE NODEFONT) of GN) - (replace (GRAPHNODE NODEFONT) of GN with FONT))) - [for R in ROOTIDS do (COND - ((EQMEMB 'LATTICE FORMAT) - (LATTICE/BREAK/CYCLES (GETNODEFROMID R NODELST) - NIL)) - (T (FOREST/BREAK/CYCLES (GETNODEFROMID R NODELST] - (for GN in NODELST do (replace (GRAPHNODE NODEPOSITION) of GN with NIL) - (SET/LABEL/SIZE GN]) - -(INTERPRET/MARK/FORMAT - [LAMBDA (FORMAT) (* rmk%: "20-Sep-85 08:59") - (* sets specvars for - NEW/INSTANCE/OF/GRAPHNODE and - MARK/GRAPH/NODE) - (DECLARE (USEDFREE BOX.BOTH.FLG BOX.LEAVES.FLG BORDER.FOR.MARKING LABELSHADE.FOR.MARKING)) - (PROG (PL) - (AND (EQMEMB 'COPIES/ONLY FORMAT) - (SETQ BOX.BOTH.FLG NIL)) - (AND (EQMEMB 'NOT/LEAVES FORMAT) - (SETQ BOX.LEAVES.FLG NIL)) - (COND - ((NLISTP FORMAT) - (RETURN)) - ((EQ (CAR FORMAT) - 'MARK) - (SETQ PL (CDR FORMAT))) - ((SETQ PL (FASSOC 'MARK FORMAT)) - (SETQ PL (CDR PL))) - (T (RETURN))) - [COND - [(FMEMB 'BORDER PL) - (SETQ BORDER.FOR.MARKING (LISTGET PL 'BORDER] - (T (SETQ BORDER.FOR.MARKING 'DON'T] - (COND - [(FMEMB 'LABELSHADE PL) - (SETQ LABELSHADE.FOR.MARKING (LISTGET PL 'LABELSHADE] - (T (SETQ LABELSHADE.FOR.MARKING 'DON'T]) - -(LATTICE/BREAK/CYCLES - [LAMBDA (NODE STACK) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (replace (GRAPHNODE NODEPOSITION) of NODE with T) - (for DTAIL on (fetch (GRAPHNODE TONODES) of NODE) bind D GN - do (SETQ GN (GETNODEFROMID (SETQ D (CAR DTAIL)) - NODELST)) - (COND - ((FMEMB D STACK) - (SETQ GN (NEW/INSTANCE/OF/GRAPHNODE GN)) - (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of GN))) - ((NULL (fetch (GRAPHNODE NODEPOSITION) of GN)) - (LATTICE/BREAK/CYCLES GN (CONS D STACK]) - -(LAYOUTFOREST - [LAMBDA (NODELST ROOTIDS FORMAT BOXING FONT MOTHERD PERSONALD FAMILYD) - (* ; "Edited 16-Apr-90 19:05 by gadener") - (* This is an older version of - LayoutGraph, kept around temporarily - but de-documented) - (LAYOUTGRAPH NODELST ROOTIDS (CL:IF (LISTP FORMAT) - (APPEND FORMAT BOXING) - (CONS FORMAT BOXING)) - FONT MOTHERD PERSONALD]) - -(LAYOUTGRAPH - [LAMBDA (NODELST ROOTIDS FORMAT FONT MOTHERD PERSONALD FAMILYD) - (* ; "Edited 29-Apr-94 14:01 by sybalsky") - - (* ;; "takes a list of GRAPHNODE records and a list node ids for the top level nodes, where the graphnodes have only the NODEID, NODELABEL and TONODES fields filled in. It fills in the other fields appropriately according the format switch and the boxing switch so that the graph becomes a forest. If there are loops in the graph, they are snapped and the NODELST is extended with Push This function returns a GRAPH record with the display slots filled in appropriately.") - - (DECLARE (SPECVARS NODELST MOTHERD PERSONALD FAMILYD)) - (PROG ((BOX.BOTH.FLG T) - (BOX.LEAVES.FLG T) - (BORDER.FOR.MARKING T) - (LABELSHADE.FOR.MARKING 'DON'T) - G) - (DECLARE (SPECVARS BOX.BOTH.FLG BOX.LEAVES.FLG BORDER.FOR.MARKING - LABELSHADE.FOR.MARKING)) - (OR (LISTP ROOTIDS) - (ERROR "LAYOUTGRAPH needs a LIST of root node ids")) - (for R in ROOTIDS unless (FASSOC R NODELST) do (ERROR R - "is in ROOTIDS but no GRAPHNODE for it in NODELST." - )) - (OR FONT (SETQ FONT (OR DEFAULT.GRAPH.NODEFONT DEFAULTFONT))) - (OR MOTHERD (SETQ MOTHERD (STRINGWIDTH "AAAAAA" FONT))) - [OR PERSONALD (SETQ PERSONALD (COND - ((EQMEMB 'VERTICAL FORMAT) - (STRINGWIDTH "AA" FONT)) - (T 0] - [OR FAMILYD (SETQ FAMILYD (HALF (FONTPROP FONT 'ASCENT] - (INTERPRET/MARK/FORMAT FORMAT) - (INIT/NODES/FOR/LAYOUT NODELST FORMAT ROOTIDS FONT) - (AND (EQMEMB 'VERTICAL FORMAT) - (SWITCH/NODE/HEIGHT/WIDTH NODELST)) - [SETQ G (COND - ((EQMEMB 'LATTICE FORMAT) - (BROWSE/LAYOUT/LATTICE ROOTIDS)) - ((EQMEMB 'FAST FORMAT) - (BROWSE/LAYOUT/HORIZ ROOTIDS)) - (T (BROWSE/LAYOUT/HORIZ/COMPACTLY ROOTIDS] - (replace (GRAPH GRAPH.PROPS) of G with (LIST 'FORMAT FORMAT)) - [for N in NODELST do (OR (type? POSITION (fetch (GRAPHNODE NODEPOSITION - ) of N)) - (ERROR - "Disconnected graph. Root(s) didn't connect to:" - (fetch (GRAPHNODE NODELABEL) of N] - [COND - ((EQMEMB 'VERTICAL FORMAT) - (SWITCH/NODE/HEIGHT/WIDTH NODELST) - (REFLECT/GRAPH/DIAGONALLY G) - (OR (EQMEMB 'REVERSE FORMAT) - (REFLECT/GRAPH/VERTICALLY G)) - (AND (EQMEMB 'REVERSE/DAUGHTERS FORMAT) - (REFLECT/GRAPH/HORIZONTALLY G))) - (T (AND (EQMEMB 'REVERSE FORMAT) - (REFLECT/GRAPH/HORIZONTALLY G)) - (AND (EQMEMB 'REVERSE/DAUGHTERS FORMAT) - (REFLECT/GRAPH/VERTICALLY G] - (RETURN G]) - -(LAYOUTLATTICE - [LAMBDA (NODELST ROOTIDS FORMAT FONT MOTHERD PERSONALD FAMILYD) - (* rmk%: " 6-Dec-85 12:19") - - (* takes a list of GRAPHNODE records and a list node ids for the top level - nodes, where the graphnodes have only the NODEID, NODELABEL and TONODES fields - filled in. It fills in the other fields appropriately according the format - switch If there are loops in the graph, they are detected in BRHL/MOVE/RIGHT - and an error occurs. This function returns a GRAPH record with the display - slots filled in appropriately.) - - (DECLARE (SPECVARS NODELST MOTHERD PERSONALD FAMILYD)) - (for R in ROOTIDS unless (FASSOC R NODELST) do (ERROR R - "is in ROOTIDS but no GRAPHNODE for it in NODELST." - )) - (SETQ FONT (OR FONT DEFAULTFONT)) - (INIT/NODES/FOR/LAYOUT NODELST FORMAT ROOTIDS FONT) - [OR FAMILYD (SETQ FAMILYD (HALF (FONTPROP FONT 'ASCENT] - (OR MOTHERD (SETQ MOTHERD (STRINGWIDTH "AAAAAA" FONT))) - [OR PERSONALD (SETQ PERSONALD (COND - ((EQ FORMAT 'VERTICAL) - (STRINGWIDTH "AA" FONT)) - (T 0] - (BROWSE/LAYOUT/LATTICE ROOTIDS]) - -(LAYOUTSEXPR - [LAMBDA (TREE FORMAT BOXING FONT MOTHERD PERSONALD FAMILYD) - (* ; "Edited 1-Sep-92 17:26 by jds") - - (* ;; "assumes CAR of tree is node label, CDR is daughter trees.") - - (COND - [TREE (PROG (RESULT) - (DECLARE (SPECVARS RESULT)) - (LAYOUTSEXPR1 TREE) - - (* ;; "Boxing arg will only be taken into account if they are valid Format arguments") - (* ; "otherwise, it is ignored") - (AND (OR (NLISTP BOXING) - (EQ (CAR BOXING) - 'MARK)) - (SETQ BOXING (CONS BOXING))) - (RETURN (LAYOUTGRAPH RESULT (LIST TREE) - (APPEND (MKLIST FORMAT) - BOXING) - FONT MOTHERD PERSONALD FAMILYD] - (T (ERROR "Cannot layout NIL as S-EXPRESSION"]) - -(LAYOUTSEXPR1 - [LAMBDA (TREE) (* dgb%: "22-Jan-85 07:07") - (DECLARE (SPECVARS RESULT)) - (COND - [(for R in RESULT thereis (EQ TREE (fetch (GRAPHNODE NODEID) of R] - ((NLISTP TREE) - (push RESULT (create GRAPHNODE - NODEID _ TREE - NODELABEL _ TREE))) - (T [push RESULT (create GRAPHNODE - NODEID _ TREE - NODELABEL _ (CAR TREE) - TONODES _ (APPEND (CDR TREE] - (for D in (CDR TREE) do (LAYOUTSEXPR1 D]) - -(MARK/GRAPH/NODE - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* changes appearance of graph node - to indicate that a link has been - snapped.) - (DECLARE (USEDFREE BORDER.FOR.MARKING LABELSHADE.FOR.MARKING)) - (OR (EQ BORDER.FOR.MARKING 'DON'T) - (replace (GRAPHNODE NODEBORDER) of NODE with BORDER.FOR.MARKING)) - (OR (EQ LABELSHADE.FOR.MARKING 'DON'T) - (replace (GRAPHNODE NODELABELSHADE) of NODE with LABELSHADE.FOR.MARKING]) - -(NEW/INSTANCE/OF/GRAPHNODE - [LAMBDA (GN) - (DECLARE (USEDFREE NODELST BOX.LEAVES.FLG BOX.BOTH.FLG)) - (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* returns a second instance of the - node, boxing it appropriately. - No daughters.) - (PROG [(NEW (create GRAPHNODE - NODEID _ (LIST (fetch (GRAPHNODE NODEID) of GN)) - NODELABEL _ (fetch (GRAPHNODE NODELABEL) of GN) - NODEFONT _ (fetch (GRAPHNODE NODEFONT) of GN) - NODEWIDTH _ (fetch (GRAPHNODE NODEWIDTH) of GN) - NODEHEIGHT _ (fetch (GRAPHNODE NODEHEIGHT) of GN) - NODEBORDER _ (COPY (fetch (GRAPHNODE NODEBORDER) of GN)) - NODELABELSHADE _ (fetch (GRAPHNODE NODELABELSHADE) of GN] - (push NODELST NEW) - [COND - ((OR BOX.LEAVES.FLG (fetch (GRAPHNODE TONODES) of GN)) - (MARK/GRAPH/NODE NEW) - (COND - (BOX.BOTH.FLG (MARK/GRAPH/NODE GN] - (RETURN NEW]) - -(RAISE/TRANSITION/CHAIN - [LAMBDA (TC RAISE) (* kvl "21-DEC-83 10:25") - - (* raises a daughters transition chain by adding in the offset of the - daughter's box relative to the mother's box.) - - (for P in TC do (add (fetch YCOORD of P) - RAISE) finally (RETURN TC]) - -(REFLECT/GRAPH/DIAGONALLY - [LAMBDA (GRAPH) (* kvl "26-DEC-83 10:58") - (replace (GRAPH SIDESFLG) of GRAPH with (NOT (fetch (GRAPH SIDESFLG) of - GRAPH))) - [for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) - (replace XCOORD of N with (PROG1 (fetch YCOORD of N) - (replace YCOORD of N - with (fetch XCOORD of N)))] - GRAPH]) - -(REFLECT/GRAPH/HORIZONTALLY - [LAMBDA (GRAPH) (* kvl "10-Aug-84 17:23") - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - bind [W _ (IPLUS (MAX/RIGHT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (MIN/LEFT (fetch (GRAPH GRAPHNODES) of GRAPH] - do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) - (replace XCOORD of N with (IDIFFERENCE W (fetch XCOORD of N]) - -(REFLECT/GRAPH/VERTICALLY - [LAMBDA (GRAPH) (* kvl "10-Aug-84 16:48") - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - bind [H _ (IPLUS (MAX/TOP (fetch (GRAPH GRAPHNODES) of GRAPH)) - (MIN/BOTTOM (fetch (GRAPH GRAPHNODES) of GRAPH] - do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) - (replace YCOORD of N with (IDIFFERENCE H (fetch YCOORD of N]) - -(SWITCH/NODE/HEIGHT/WIDTH - [LAMBDA (NL) (* rmk%: " 2-Feb-84 22:19") - (for N in NL do (swap (fetch (GRAPHNODE NODEWIDTH) of N) - (fetch (GRAPHNODE NODEHEIGHT) of N]) -) -(DECLARE%: EVAL@COMPILE - -(RPAQQ LINKPARAMS Link% Parameters) - - -(CONSTANTS (LINKPARAMS 'Link% Parameters)) -) - -(RPAQQ DEFAULT.GRAPH.NODEBORDER NIL) - -(RPAQQ DEFAULT.GRAPH.NODEFONT NIL) - -(RPAQQ DEFAULT.GRAPH.NODELABELSHADE NIL) - -(RPAQQ ScalableLinkParameters (LINEWIDTH)) - -(RPAQQ CACHE/NODE/LABEL/BITMAPS NIL) - -(RPAQQ NODEBORDERWIDTH 1) - -(RPAQQ GRAPH/HARDCOPY/FORMAT (MODE PORTRAIT PAGENUMBERS T TRANS NIL)) - -(RPAQ? DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7) - (TIMES SCREENHEIGHT 0.4))) - -(RPAQ? EDITGRAPHMENUCOMMANDS '((Move% Node 'MOVENODE "Moves a single node in the graph." - (SUBITEMS (|Move Single Node| 'MOVENODE - "Moves a single node in the graph.") - (|Move Node and Subtree| (EDITMOVESUBTREE - GRAPHWINDOW) - - "Moves a subtree of nodes relative to the movement of their root." - ) - (Move% Region (EDITMOVEREGION GRAPHWINDOW) - - "Moves a group of nodes within a specified region to another region." - ))) - ("Add Node" 'ADDNODE) - ("Delete Node" 'DELETENODE) - ("Add Link" 'ADDLINK) - ("Delete Link" 'DELETELINK) - ("Change label" 'CHANGELABEL) - ("label smaller" 'SMALLER) - ("label larger" 'LARGER) - ("<-> Directed" 'DIRECTED) - ("<-> Sides" 'SIDES) - ("<-> Border" 'BORDER) - ("<-> Shade" 'SHADE) - STOP)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -(DECLARE%: EVAL@COMPILE - -(RECORD GRAPHNODE (NODEID NODEPOSITION NODELABELBITMAP NIL NODELABELSHADE NODEWIDTH NODEHEIGHT - TONODES FROMNODES NODEFONT NODELABEL NODEBORDER) - NODEBORDER _ DEFAULT.GRAPH.NODEBORDER NODELABELSHADE _ - DEFAULT.GRAPH.NODELABELSHADE NODEFONT _ DEFAULT.GRAPH.NODEFONT) - -(RECORD GRAPH (GRAPHNODES SIDESFLG DIRECTEDFLG GRAPH.MOVENODEFN GRAPH.ADDNODEFN - GRAPH.DELETENODEFN GRAPH.ADDLINKFN GRAPH.DELETELINKFN GRAPH.FONTCHANGEFN - GRAPH.INVERTBORDERFN GRAPH.INVERTLABELFN GRAPH.CHANGELABELFN . GRAPH.PROPS)) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS HALF MACRO ((X) - (LRSH X 1))) -) -) - - - -(* ; "Grapher image objects") - -(DEFINEQ - -(GRAPHERCOPYBUTTONEVENTFN - [LAMBDA (WINDOW) (* ; "Edited 1-Aug-87 14:54 by sye") - - (* ;; "Called on down transition in WINDOW. If GRAPHOBJ.FINDGRAPH locates a graph in window, it is copy inserted. Another callers of GRAPHOBJ.FINDGRAPH might also specify alignments to GRAPHEROBJ.") - - (PROG* [(GRAPH (OR (GRAPHOBJ.FINDGRAPH WINDOW) - (RETURN))) - (REG (GRAPHREGION GRAPH)) - (LEFT (MINUS (fetch (REGION LEFT) of REG))) - (BOTTOM (MINUS (fetch (REGION BOTTOM) of REG))) - (LEFTBUTTONFN (WINDOWPROP WINDOW 'BROWSER/LEFTFN)) - (MIDDLEBUTTONFN (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN] - (if (NOT (AND (ZEROP LEFT) - (ZEROP BOTTOM))) - then (SETQ GRAPH (TRANSGRAPH GRAPH LEFT BOTTOM))) - (COPYINSERT (GRAPHEROBJ GRAPH NIL NIL LEFTBUTTONFN MIDDLEBUTTONFN]) - -(GRAPHOBJ.FINDGRAPH - [LAMBDA (WINDOW) (* rmk%: "22-Dec-84 11:29") - - (* Get control on down transition, track until key goes up or mouse leaves the - window) - - (bind (DS _ (GETSTREAM WINDOW)) - (REG _ (WINDOWPROP WINDOW 'REGION)) first (DSPFILL NIL BLACKSHADE 'INVERT DS) - do (GETMOUSESTATE) - (COND - ((NOT (INSIDE? REG LASTMOUSEX LASTMOUSEY)) - (DSPFILL NIL BLACKSHADE 'INVERT DS) - (RETURN)) - ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE RIGHT))) - (DSPFILL NIL BLACKSHADE 'INVERT DS) - (RETURN (COPYGRAPH (WINDOWPROP WINDOW 'GRAPH]) -) -(DEFINEQ - -(ALIGNMENTNODE - [LAMBDA (NODESPEC GRAPH) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* Returns the alignment node - specified by NODESPEC) - - (* Early implementation had *TOP, but documentation says *TOP*. - Remove earlier ones (*TOP) at some point) - - (SELECTQ NODESPEC - ((*TOP* *TOP) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) largest (GN/TOP - N))) - ((*BOTTOM* *BOTTOM) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) smallest (GN/BOTTOM - N))) - ((*RIGHT* *RIGHT) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) largest (GN/RIGHT - N))) - ((*LEFT* *LEFT) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) smallest (GN/LEFT - N))) - (GETNODEFROMID NODESPEC (fetch (GRAPH GRAPHNODES) of GRAPH]) - -(GRAPHOBJ.CHECKALIGN - [LAMBDA (GRAPH ALIGNSPEC) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (* Makes sure that the ALIGNMENTSPEC - is valid, putting it into standard - form if necessary) - (OR (AND (NULL ALIGNSPEC) - (SETQ ALIGNSPEC 0)) - (NUMBERP ALIGNSPEC) - [AND (LISTP ALIGNSPEC) - (SELECTQ (CAR ALIGNSPEC) - ((*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT) - T) - (GETNODEFROMID (CAR ALIGNSPEC) - (fetch (GRAPH GRAPHNODES) of GRAPH))) - (LISTP (CDR ALIGNSPEC)) - (OR (NUMBERP (CADR ALIGNSPEC)) - (EQ (CADR ALIGNSPEC) - 'BASELINE) - (AND (NULL (CADR ALIGNSPEC)) - (SETQ ALIGNSPEC (LIST (CAR ALIGNSPEC) - 0] - (ERROR "ILLEGAL GRAPH ALIGNMENT SPECIFICATION" ALIGNSPEC)) - ALIGNSPEC]) -) -(DEFINEQ - -(GRAPHEROBJ - [LAMBDA (GRAPH HALIGN VALIGN LEFTBUTTONFN MIDDLEBUTTONFN COPYBUTTONEVENTFN) - (* rmk%: " 6-Dec-85 11:35") - (* Constructs a Grapher image - object.) - - (* HALIGN and VALIGN specify the horizontal or vertical alignment. - Each can be a floating point number between 0 and 1, specifying that the - alignment point is located at that portion of the width/height of the - graphregion, or a list of the form (nodespec align)%, where nodespec is a node - ID or one of the atoms LEFT, RIGHT, BOTTOM, TOP, and align is either a floating - point number bewtween 0 and 1, or the atom BASELINE) - - (LET [(REG (GRAPHREGION GRAPH)) - (OBJ (IMAGEOBJCREATE (LIST GRAPH (GRAPHOBJ.CHECKALIGN GRAPH HALIGN) - (GRAPHOBJ.CHECKALIGN GRAPH VALIGN)) - (COND - ((IMAGEFNSP GRAPHERIMAGEFNS)) - (T (SETQ GRAPHERIMAGEFNS (IMAGEFNSCREATE (FUNCTION GRAPHOBJ.DISPLAYFN) - (FUNCTION GRAPHOBJ.IMAGEBOXFN) - (FUNCTION GRAPHOBJ.PUTFN) - (FUNCTION GRAPHOBJ.GETFN) - (FUNCTION GRAPHOBJ.COPYFN) - (FUNCTION GRAPHOBJ.BUTTONEVENTINFN) - (FUNCTION GRAPHOBJ.COPYBUTTONEVENTFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - NIL - 'GRAPHER] - [IMAGEOBJPROP OBJ 'OBJECTORIGIN (CREATEPOSITION (MINUS (fetch (REGION LEFT) of - REG)) - (MINUS (fetch (REGION BOTTOM) of REG] - (AND LEFTBUTTONFN (IMAGEOBJPROP OBJ 'LEFTBUTTONFN LEFTBUTTONFN)) - (AND MIDDLEBUTTONFN (IMAGEOBJPROP OBJ 'MIDDLEBUTTONFN MIDDLEBUTTONFN)) - (AND COPYBUTTONEVENTFN (IMAGEOBJPROP OBJ 'COPYBUTTONEVENTFN COPYBUTTONEVENTFN)) - OBJ]) - -(GRAPHOBJ.BUTTONEVENTINFN - [LAMBDA (GROBJ WINDOW) (* ; "Edited 1-Aug-87 16:16 by sye") - (* the user has pressed a button - inside the grapher object IMAGEOBJ.) - (LET [(LEFT (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN)) - (MIDDLE (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN] - (if (OR LEFT MIDDLE) - then (GRAPHBUTTONEVENTFN WINDOW (CAR (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - LEFT MIDDLE) - elseif [MENU (create MENU - ITEMS _ '((Edit% graph T " Opens a window to edit this graph"] - then (PROG [W (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM] - (SETQ W (SIZE/GRAPH/WINDOW (CAR DATUM) - NIL T)) - (IMAGEOBJPROP GROBJ 'OBJECTDATUM (LIST (EDITGRAPH1 - (COPYGRAPH (CAR DATUM)) - W) - (CADR DATUM) - (CADDR DATUM))) - (CLOSEW W)) - 'CHANGED]) - -(GRAPHOBJ.COPYBUTTONEVENTFN - [LAMBDA (GROBJ WINDOW) (* rmk%: " 6-Dec-85 11:42") - - (* the user has pressed a button inside the grapher object IMAGEOBJ while a - copy key was down) - - (LET [(CBEFN (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN] - (if CBEFN - then (APPLY* CBEFN GROBJ WINDOW) - else (COPYINSERT (GRAPHOBJ.COPYFN GROBJ]) - -(GRAPHOBJ.COPYFN - [LAMBDA (GROBJ) (* rmk%: " 6-Dec-85 12:07") - (* makes a copy of a grapher image - object.) - (LET* [(DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - (NEW (GRAPHEROBJ (COPYGRAPH (CAR DATUM)) - (CADR DATUM) - (CADDR DATUM] - [IMAGEOBJPROP NEW 'OBJECTORIGIN (create POSITION using (IMAGEOBJPROP GROBJ - 'OBJECTORIGIN] - (IMAGEOBJPROP NEW 'LEFTBUTTONFN (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN)) - (IMAGEOBJPROP NEW 'MIDDLEBUTTONFN (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN)) - (IMAGEOBJPROP NEW 'COPYBUTTONEVENTFN (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN)) - NEW]) - -(GRAPHOBJ.DISPLAYFN - [LAMBDA (GROBJ STREAM) (* rmk%: " 2-Apr-85 10:56") - (* display function for a grapher - image object) - - (* Scale the streams position back to display coordinates, since DISPLAYGRAPH - translates the translation. Might be simplest to define DISPLAYGRAPH without a - translation, as locating the graph coordinate system at the current X,Y - position) - - (PROG [REG (BOX (IMAGEOBJPROP GROBJ 'BOUNDBOX)) - (SCALE (DSPSCALE NIL STREAM)) - (GRAPH (CAR (IMAGEOBJPROP GROBJ 'OBJECTDATUM] - (OR BOX (SETQ BOX (APPLY* (IMAGEOBJPROP GROBJ 'IMAGEBOXFN) - GROBJ STREAM))) - [SETQ REG (GRAPHREGION (COND - ((EQP SCALE 1) - GRAPH) - (T (SCALE/GRAPH GRAPH STREAM SCALE] - - (* Kludgy%: we have to scale the graph to get the real region, but then - DISPLAYGRAPH will do it again, cause it assumes screen points.) - (* Other kludge is that the - translation is also in screen points) - (DISPLAYGRAPH GRAPH STREAM NIL (CREATEPOSITION (QUOTIENT (DIFFERENCE - (DIFFERENCE (DSPXPOSITION - NIL STREAM) - (fetch XKERN - of BOX)) - (fetch (REGION LEFT) - of REG)) - SCALE) - (QUOTIENT (DIFFERENCE (DIFFERENCE (DSPYPOSITION - NIL STREAM) - (fetch YDESC - of BOX)) - (fetch (REGION BOTTOM) - of REG)) - SCALE]) - -(GRAPHOBJ.GETALIGN - [LAMBDA (STREAM GRAPH) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (PROG ((ALIGN (READ STREAM FILERDTBL))) - [if [AND (LISTP ALIGN) - (NOT (MEMB (CAR ALIGN) - '(*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT] - then (SETQ ALIGN (CONS [fetch (GRAPHNODE NODEID) - of (CAR (NTH (CAR ALIGN) - (fetch (GRAPH GRAPHNODES) - of GRAPH] - (CDR ALIGN] - (RETURN ALIGN]) - -(GRAPHOBJ.GETFN - [LAMBDA (STREAM) (* ; "Edited 7-Dec-88 18:38 by sye") - (* ; - "reads a grapher image object from a file.") - (OR (EQ (SKIPSEPRCODES STREAM FILERDTBL) - (CHARCODE %()) - (ERROR "ILLEGAL GRAPHOBJECT FORMAT")) - (READCCODE STREAM) (* Read the paren) - (PROG ((GRAPH (READGRAPH STREAM)) - IMAGEOBJ) - (SETQ IMAGEOBJ (GRAPHEROBJ GRAPH (GRAPHOBJ.GETALIGN STREAM GRAPH) - (GRAPHOBJ.GETALIGN STREAM GRAPH))) - - (* ;; "read leftbuttonfn & middlebuttonfn & copybuttoneventfn") - - [COND - ((NEQ (SKIPSEPRCODES STREAM FILERDTBL) - (CHARCODE %))) (* ; ") means extra props don't exist") - (IMAGEOBJPROP IMAGEOBJ 'LEFTBUTTONFN (HREAD STREAM)) - (IMAGEOBJPROP IMAGEOBJ 'MIDDLEBUTTONFN (HREAD STREAM)) - (IMAGEOBJPROP IMAGEOBJ 'COPYBUTTONEVENTFN (HREAD STREAM)) - - (* ;; "read imageobject origin") - - (IMAGEOBJPROP IMAGEOBJ 'OBJECTORIGIN (CREATEPOSITION (READ STREAM) - (READ STREAM] - (RATOM STREAM FILERDTBL) (* ; "Skip the closing paren") - (RETURN IMAGEOBJ]) - -(GRAPHOBJ.IMAGEBOXFN - [LAMBDA (GROBJ STREAM) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* size function for a tedit bitmap - object.) - (PROG (REGION GRAPH HALIGN VALIGN ALNODE (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - (SCALE (DSPSCALE NIL STREAM)) - BMW BMH) - (SETQ GRAPH (CAR DATUM)) - (SETQ HALIGN (CADR DATUM)) - (SETQ VALIGN (CADDR DATUM)) - (OR (EQ 1 SCALE) - (SETQ GRAPH (SCALE/GRAPH GRAPH STREAM SCALE))) - (SETQ REGION (GRAPHREGION GRAPH)) - (RETURN (create IMAGEBOX - XSIZE _ (fetch (REGION WIDTH) of REGION) - YSIZE _ (fetch (REGION HEIGHT) of REGION) - YDESC _ [COND - ((NUMBERP VALIGN) - (TIMES VALIGN (fetch (REGION HEIGHT) of REGION))) - (T (* Must be a list, cause of checks - in GRAPHEROBJ) - (SETQ ALNODE (ALIGNMENTNODE (CAR VALIGN) - GRAPH)) - (PLUS (GN/BOTTOM ALNODE) - (COND - ((EQ (CADR VALIGN) - 'BASELINE) - (IQUOTIENT (IPLUS (IDIFFERENCE - (fetch (GRAPHNODE NODEHEIGHT) - of ALNODE) - (FONTPROP (fetch (GRAPHNODE - NODEFONT) - of ALNODE) - 'ASCENT)) - (FONTPROP (fetch (GRAPHNODE - NODEFONT) - of ALNODE) - 'DESCENT)) - 2)) - (T (TIMES (CADR VALIGN) - (fetch (GRAPHNODE NODEHEIGHT) - of ALNODE] - XKERN _ (COND - ((NUMBERP HALIGN) - (TIMES HALIGN (fetch (REGION WIDTH) of REGION))) - (T (* Must be a list, cause of checks - in GRAPHEROBJ) - (SETQ ALNODE (ALIGNMENTNODE (CAR HALIGN) - GRAPH)) - (PLUS (GN/LEFT ALNODE) - (TIMES (COND - ((EQ (CADR HALIGN) - 'BASELINE) - 0) - (T (CADR HALIGN))) - (fetch (GRAPHNODE NODEWIDTH) of ALNODE]) - -(GRAPHOBJ.PUTALIGN - [LAMBDA (STREAM GRAPH ALIGN) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (PRIN2 [COND - ([OR (NLISTP ALIGN) - (MEMB (CAR ALIGN) - '(*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT] - ALIGN) - (T (* Convert node ID to node index) - (CONS (for I from 1 as N in (fetch (GRAPH GRAPHNODES) - of GRAPH) - when (EQ (CAR ALIGN) - (fetch (GRAPHNODE NODEID) of N)) - do (RETURN I)) - (CDR ALIGN] - STREAM FILERDTBL]) - -(GRAPHOBJ.PUTFN - [LAMBDA (GROBJ STREAM) (* rmk%: "31-Dec-84 12:25") - (* Put a description of a grapher - object into the file.) - (PROG [ALIGN GRAPH (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - (OBJORIGIN (IMAGEOBJPROP GROBJ 'OBJECTORIGIN] - (PRIN1 "(" STREAM) - - (* ;; " dump graph") - - (SETQ GRAPH (CAR DATUM)) - (DUMPGRAPH GRAPH STREAM) - (TERPRI STREAM) - - (* ;; " dump halign and valign") - - (GRAPHOBJ.PUTALIGN STREAM GRAPH (CADR DATUM)) - (SPACES 1 STREAM) - (GRAPHOBJ.PUTALIGN STREAM GRAPH (CADDR DATUM)) - (TERPRI STREAM) - - (* ;; " dump leftbuttonfn & middlebuttonfn & copybuttoneventfn ") - - (HPRINT (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN) - STREAM) - (HPRINT (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN) - STREAM) - (HPRINT (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN) - STREAM) - - (* ;; "dump objectorigin") - - (PRIN1 (fetch XCOORD of OBJORIGIN) - STREAM) - (SPACES 1 STREAM) - (PRIN1 (fetch YCOORD of OBJORIGIN) - STREAM) - (printout STREAM ")" T]) -) -(DEFINEQ - -(COPYGRAPH - [LAMBDA (GRAPH) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (create GRAPH using GRAPH GRAPHNODES _ - (for N L in (fetch (GRAPH GRAPHNODES) of GRAPH) - collect (create GRAPHNODE - using N NODEPOSITION _ (create POSITION - using - (fetch (GRAPHNODE - NODEPOSITION) - of N)) - NODELABEL _ - (CL:TYPECASE (SETQ L (fetch (GRAPHNODE - NODELABEL) - of N)) - (BITMAP (BITMAPCOPY L)) - (IMAGEOBJ (APPLY* (IMAGEOBJPROP L - 'COPYFN) - L)) - (T L))]) - -(DUMPGRAPH - [LAMBDA (GRAPH STREAM) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (* Put a description of a graph into - a file.) - (RESETLST - (RESETSAVE (SETREADTABLE FILERDTBL)) - (PROG (BORDERS FONTS IDS SHADES (%#BORDERS 0) - (%#FONTS 0) - (%#SHADES 0) - (%#IDS 0)) - (printout STREAM "(" T "FIELDS (") - (if (fetch (GRAPH SIDESFLG) of GRAPH) - then (printout STREAM 2 "SIDESFLG " .P2 (fetch (GRAPH SIDESFLG) - of GRAPH))) - (if (fetch (GRAPH DIRECTEDFLG) of GRAPH) - then (printout STREAM 2 "DIRECTEDFLG " .P2 (fetch (GRAPH DIRECTEDFLG) - of GRAPH))) - (if (fetch (GRAPH GRAPH.MOVENODEFN) of GRAPH) - then (printout STREAM 2 "MOVENODEFN " .P2 (fetch (GRAPH GRAPH.MOVENODEFN) - of GRAPH))) - (if (fetch (GRAPH GRAPH.ADDNODEFN) of GRAPH) - then (printout STREAM 2 "ADDNODEFN " .P2 (fetch (GRAPH GRAPH.ADDNODEFN) - of GRAPH))) - (if (fetch (GRAPH GRAPH.DELETENODEFN) of GRAPH) - then (printout STREAM 2 "DELETENODEFN " .P2 (fetch (GRAPH - GRAPH.DELETENODEFN - ) of GRAPH))) - (if (fetch (GRAPH GRAPH.ADDLINKFN) of GRAPH) - then (printout STREAM 2 "ADDLINKFN " .P2 (fetch (GRAPH GRAPH.ADDLINKFN) - of GRAPH))) - (if (fetch (GRAPH GRAPH.DELETELINKFN) of GRAPH) - then (printout STREAM 2 "DELETELINKFN " .P2 (fetch (GRAPH - GRAPH.DELETELINKFN - ) of GRAPH))) - (if (fetch (GRAPH GRAPH.FONTCHANGEFN) of GRAPH) - then (printout STREAM 2 "FONTCHANGEFN " .P2 (fetch (GRAPH - GRAPH.FONTCHANGEFN - ) of GRAPH))) - (if (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) - then (printout STREAM 2 "INVERTBORDERFN " .P2 (fetch (GRAPH - GRAPH.INVERTBORDERFN - ) of GRAPH) - )) - (if (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) - then (printout STREAM 2 "INVERTLABELFN " .P2 (fetch (GRAPH - GRAPH.INVERTLABELFN - ) of GRAPH)) - ) - (if (fetch (GRAPH GRAPH.CHANGELABELFN) of GRAPH) - then (printout STREAM 2 "CHANGELABELFN " .P2 (fetch (GRAPH - GRAPH.CHANGELABELFN - ) of GRAPH)) - ) - (if (fetch (GRAPH GRAPH.PROPS) of GRAPH) - then (printout STREAM 2 "PROPS ") - (HPRINT (fetch (GRAPH GRAPH.PROPS) of GRAPH) - STREAM)) - (PRIN1 ")" STREAM) - [for N TEMP in (fetch (GRAPH GRAPHNODES) of GRAPH) - do [OR (ASSOC (fetch (GRAPHNODE NODEID) of N) - IDS) - (push IDS (CONS (fetch (GRAPHNODE NODEID) of N) - (add %#IDS 1] - [AND (SETQ TEMP (fetch (GRAPHNODE NODELABELSHADE) of N)) - (OR (ASSOC TEMP SHADES) - (push SHADES (CONS TEMP (add %#SHADES 1] - [OR (ASSOC (fetch (GRAPHNODE NODEFONT) of N) - FONTS) - (push FONTS (CONS (fetch (GRAPHNODE NODEFONT) of N) - (add %#FONTS 1] - (SELECTQ (SETQ TEMP (fetch (GRAPHNODE NODEBORDER) of N)) - ((T NIL)) - (OR (ASSOC TEMP BORDERS) - (push BORDERS (CONS TEMP (add %#BORDERS 1] - (printout STREAM T "IDS " %#IDS %,) - (for X in (SETQ IDS (DREVERSE IDS)) do (PRIN2 (CAR X) - STREAM) - (SPACES 1 STREAM)) - (printout STREAM T "FONTS " %#FONTS %,) - (for X in (SETQ FONTS (DREVERSE FONTS)) - do (SETQ X (CAR X)) - (PRIN2 (if (LISTP X) - elseif (type? FONTDESCRIPTOR X) - then (FONTUNPARSE X) - elseif (FONTP X) - then (* Mark it as a class) - (CONS 'CLASS (FONTCLASSUNPARSE X))) - STREAM) - (SPACES 1 STREAM)) - [COND - (BORDERS (printout STREAM T "BORDERS " %#BORDERS %,) - (for X (POS _ (POSITION STREAM)) in (SETQ BORDERS (DREVERSE BORDERS)) - do (TAB POS 1 STREAM) - (HPRINT (CAR X) - STREAM] - [COND - (SHADES (printout STREAM T "SHADES " %#SHADES %,) - (for X (POS _ (POSITION STREAM)) in (SETQ SHADES (DREVERSE SHADES)) - do (TAB POS 1 STREAM) - (HPRINT (CAR X) - STREAM] - (printout STREAM T "NODES (") - (for N POS in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (printout STREAM 2 "(" .P2 (CDR (ASSOC (fetch (GRAPHNODE NODEID) - of N) - IDS)) - %,) - (SETQ POS (POSITION STREAM)) - (HPRINT (fetch (GRAPHNODE NODELABEL) of N) - STREAM) - (printout STREAM %, .TAB POS .P2 (fetch (GRAPHNODE NODEPOSITION) - of N) - %, .P2 (CDR (ASSOC (fetch (GRAPHNODE NODEFONT) of N) - FONTS)) - %, .P2 (SELECTQ (fetch (GRAPHNODE NODEBORDER) of N) - ((NIL T) - (fetch (GRAPHNODE NODEBORDER) of N)) - (CDR (ASSOC (fetch (GRAPHNODE NODEBORDER) of N) - BORDERS))) - %, .P2 (AND (fetch (GRAPHNODE NODELABELSHADE) of N) - (CDR (ASSOC (fetch (GRAPHNODE NODELABELSHADE) - of N) - SHADES))) - %,) - (if (fetch (GRAPHNODE TONODES) of N) - then (PRIN1 "(" STREAM) - (for X in (fetch (GRAPHNODE TONODES) of N) - do (printout STREAM .P2 - [COND - [(EQ (CAR (LISTP X)) - 'Link% Parameters) - (CONS (CAR X) - (CONS (CDR (ASSOC (CADR X) - IDS)) - (CDDR X] - (T (CDR (ASSOC X IDS] - %,)) - (PRIN1 ") " STREAM) - else (PRIN1 "NIL " STREAM)) - (if (fetch (GRAPHNODE FROMNODES) of N) - then (PRIN1 "(" STREAM) - (for X in (fetch (GRAPHNODE FROMNODES) of N) - do (printout STREAM .P2 (CDR (ASSOC X IDS)) - %,)) - (PRIN1 ")" STREAM) - else (PRIN1 NIL STREAM)) - (printout STREAM ")" T)) - (PRIN1 "))" STREAM)))]) - -(READGRAPH - [LAMBDA (STREAM) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (* reads a graph from a file.) - (OR (EQ (SKIPSEPRS STREAM FILERDTBL) - '%() - (ERROR "ILLEGAL GRAPH FORMAT")) - (READC STREAM) (* Read the paren) - (bind NUM TEMP FONTS BORDERS SHADES IDS (GRAPH _ (create GRAPH)) - do - (SELECTQ (SETQ TEMP (RATOM STREAM FILERDTBL)) - (FIELDS [for F on (READ STREAM FILERDTBL) by (CDDR F) - do (SELECTQ (CAR F) - (SIDESFLG (replace (GRAPH SIDESFLG) of GRAPH - with (CADR F))) - (DIRECTEDFLG (replace (GRAPH DIRECTEDFLG) of GRAPH - with (CADR F))) - (MOVENODEFN (replace (GRAPH GRAPH.MOVENODEFN) of GRAPH - with (CADR F))) - (ADDNODEFN (replace (GRAPH GRAPH.ADDNODEFN) of GRAPH - with (CADR F))) - (DELETENODEFN (replace (GRAPH GRAPH.DELETENODEFN) of GRAPH - with (CADR F))) - (ADDLINKFN (replace (GRAPH GRAPH.ADDLINKFN) of GRAPH - with (CADR F))) - (DELETELINKFN (replace (GRAPH GRAPH.DELETELINKFN) of GRAPH - with (CADR F))) - (FONTCHANGEFN (replace (GRAPH GRAPH.FONTCHANGEFN) of GRAPH - with (CADR F))) - (INVERTBORDERFN - (replace (GRAPH GRAPH.INVERTBORDERFN) of GRAPH - with (CADR F))) - (INVERTLABELFN (replace (GRAPH GRAPH.INVERTLABELFN) of - GRAPH - with (CADR F))) - (CHANGELABELFN (replace (GRAPH GRAPH.CHANGELABELFN) of - GRAPH - with (CADR F))) - (PROPS (replace (GRAPH GRAPH.PROPS) of GRAPH - with (CADR F))) - (ERROR "UNRECOGNIZED GRAPH FIELD" (CAR F]) - (IDS (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ IDS (ARRAY NUM)) - (for I to NUM do (SETA IDS I (READ STREAM FILERDTBL)))) - (BORDERS (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ BORDERS (ARRAY NUM)) - (for I to NUM do (SETA BORDERS I (HREAD STREAM)))) - (FONTS (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ FONTS (ARRAY NUM)) - [for I to NUM do (SETA FONTS I (COND - ((EQ (SETQ TEMP (READ STREAM - FILERDTBL)) - 'C) - (* A font class) - (SETQ TEMP (READ STREAM FILERDTBL)) - (FONTCLASS (CAR TEMP) - (CDR TEMP))) - ((EQ (CAR (LISTP TEMP)) - 'CLASS) - (FONTCLASS (CADR TEMP) - (CDDR TEMP))) - (T TEMP]) - (NODES (RATOM STREAM) (* Skip paren) - [replace (GRAPH GRAPHNODES) of GRAPH - with - (while (EQ (SKIPSEPRS STREAM FILERDTBL) - '%() - collect (READC STREAM) - (PROG1 (create GRAPHNODE - NODEID _ (ELT IDS (RATOM STREAM FILERDTBL)) - NODELABEL _ (HREAD STREAM) - NODEPOSITION _ (READ STREAM FILERDTBL) - NODEFONT _ (ELT FONTS (RATOM STREAM FILERDTBL)) - NODEBORDER _ (SELECTQ (SETQ TEMP (RATOM STREAM FILERDTBL) - ) - ((NIL T) - TEMP) - (ELT BORDERS TEMP)) - NODELABELSHADE _ (AND (SETQ TEMP (RATOM STREAM FILERDTBL) - ) - (ELT SHADES TEMP)) - TONODES _ - [for X in (READ STREAM FILERDTBL) - collect (COND - [(EQ (CAR (LISTP X)) - 'Link% Parameters) - (CONS (CAR X) - (CONS (ELT IDS (CADR X)) - (CDDR X] - (T (ELT IDS X] - FROMNODES _ (for X in (READ STREAM FILERDTBL) - collect (ELT IDS X))) - (* Skip the closing paren) - (RATOM STREAM FILERDTBL))] (* Skip the closing paren) - (RATOM STREAM FILERDTBL)) - (SHADES (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ SHADES (ARRAY NUM)) - (for I to NUM do (SETA SHADES I (HREAD STREAM)))) - (%) (* The closing paren) - (RETURN GRAPH)) - (ERROR "INVALID GRAPHER IMAGE OBJECT" STREAM]) -) - -(RPAQQ GRAPHERIMAGEFNS NIL) - -(ADDTOVAR IMAGEOBJGETFNS (GRAPHOBJ.GETFN)) -(PUTPROPS GRAPHER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 -1992 1993 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (7867 111916 (ADD/AND/DISPLAY/LINK 7877 . 8579) (APPLYTOSELECTEDNODE 8581 . 9069) ( -CALL.MOVENODEFN 9071 . 9420) (CHANGE.NODEFONT.SIZE 9422 . 10734) (DEFAULT.ADDNODEFN 10736 . 11534) ( -DELETE/AND/DISPLAY/LINK 11536 . 13103) (DISPLAY/NAME 13105 . 13276) (DISPLAYGRAPH 13278 . 15649) ( -DISPLAYLINK 15651 . 18204) (DISPLAYLINK/BT 18206 . 19228) (DISPLAYLINK/LR 19230 . 20253) ( -DISPLAYLINK/RL 20255 . 21278) (DISPLAYLINK/TB 21280 . 22303) (DISPLAYNODE 22305 . 22653) ( -ERASE/GRAPHNODE 22655 . 23762) (DISPLAYNODE 23764 . 24112) (DISPLAYNODELINKS 24114 . 25258) ( -DRAW/GRAPHNODE/BORDER 25260 . 26179) (DRAWAREABOX 26181 . 27382) (EDITADDLINK 27384 . 27782) ( -EDITADDNODE 27784 . 29873) (EDITAPPLYTOLINK 29875 . 31954) (EDITCHANGEFONT 31956 . 33128) ( -EDITCHANGELABEL 33130 . 34671) (EDITDELETELINK 34673 . 35079) (EDITDELETENODE 35081 . 37782) ( -EDITGRAPH 37784 . 37851) (EDITGRAPH1 37853 . 38611) (EDITGRAPH2 38613 . 40344) (EDITMOVENODE 40346 . -41923) (EDITTOGGLEBORDER 41925 . 43221) (EDITTOGGLELABEL 43223 . 44520) (FILL/GRAPHNODE/LABEL 44522 . -45350) (FIX/SCALE 45352 . 45908) (FLIPNODE 45910 . 46514) (FONTNAMELIST 46516 . 46735) (FROMLINKS -46737 . 46907) (GETNODEFROMID 46909 . 47928) (GN/BOTTOM 47930 . 48206) (GN/LEFT 48208 . 48481) ( -GN/RIGHT 48483 . 48874) (GN/TOP 48876 . 49300) (GRAPHADDLINK 49302 . 49861) (GRAPHADDNODE 49863 . -50652) (GRAPHBUTTONEVENTFN 50654 . 52834) (GRAPHCHANGELABEL 52836 . 53279) (GRAPHDELETELINK 53281 . -54589) (GRAPHDELETENODE 54591 . 55123) (GRAPHEDITCOMMANDFN 55125 . 56509) (GRAPHEDITEVENTFN 56511 . -57222) (GRAPHER/CENTERPRINTINAREA 57224 . 57988) (GRAPHERPROP 57990 . 58534) (GRAPHNODE/BORDER/WIDTH -58536 . 59057) (GRAPHREGION 59059 . 60228) (HARDCOPYGRAPH 60230 . 67612) (INTERSECT/REGIONP/LBWH 67614 - . 68890) (INVERTED/GRAPHNODE/BORDER 68892 . 69476) (INVERTED/SHADE/FOR/GRAPHER 69478 . 70110) ( -LAYOUT/POSITION 70112 . 70291) (LINKPARAMETERS 70293 . 70745) (MAX/RIGHT 70747 . 70949) (MAX/TOP 70951 - . 71149) (MEASUREGRAPHNODE 71151 . 71600) (MEMBTONODES 71602 . 72127) (MIN/BOTTOM 72129 . 72510) ( -MIN/LEFT 72512 . 72887) (MOVENODE 72889 . 74132) (NODECREATE 74134 . 74914) (NODELST/AS/MENU 74916 . -76516) (NODEREGION 76518 . 76978) (PRINTDISPLAYNODE 76980 . 82038) (PROMPTINWINDOW 82040 . 84849) ( -READ/NODE 84851 . 85965) (REDISPLAYGRAPH 85967 . 86409) (REMOVETONODES 86411 . 86932) ( -RESET/NODE/BORDER 86934 . 88721) (RESET/NODE/LABELSHADE 88723 . 90238) (SCALE/GRAPH 90240 . 96526) ( -SCALE/GRAPHNODE/BORDER 96528 . 97223) (SCALE/TONODES 97225 . 98106) (SET/LABEL/SIZE 98108 . 101054) ( -SET/LAYOUT/POSITION 101056 . 101541) (SHOWGRAPH 101543 . 103342) (SIZE/GRAPH/WINDOW 103344 . 106828) ( -TOGGLE/DIRECTEDFLG 106830 . 107460) (TOGGLE/SIDESFLG 107462 . 107950) (TOLINKS 107952 . 108118) ( -TRACKCURSOR 108120 . 109527) (TRACKNODE 109529 . 110165) (TRANSGRAPH 110167 . 111914)) (111974 128591 -(EDITMOVEREGION 111984 . 115787) (EDITMOVESUBTREE 115789 . 117566) (NOT.TRACKCURSOR 117568 . 120546) ( -RECURSIVE.COLLECTDESCENDENTS 120548 . 122036) (MOVEDESCENDENTS 122038 . 124100) (COLLECT.CHILD.NODES -124102 . 125218) (CREATE.NEW.NODEPOSITION 125220 . 125760) (GETBOXPOSITION.FROMINITIALREGION 125762 . -127234) (COLLECTDESCENDENTS 127236 . 128589)) (128655 130944 (NEXTSIZEFONT 128665 . 129855) ( -DECREASING.FONT.LIST 129857 . 130183) (SCALE.FONT 130185 . 130942)) (131168 170320 (BRH/LAYOUT 131178 - . 132922) (BRH/LAYOUT/DAUGHTERS 132924 . 133870) (BRH/OFFSET 133872 . 134550) (BRHC/INTERTREE/SPACE -134552 . 135870) (BRHC/LAYOUT 135872 . 137728) (BRHC/LAYOUT/DAUGHTERS 137730 . 140684) ( -BRHC/LAYOUT/TERMINAL 140686 . 141367) (BRHC/OFFSET 141369 . 142265) (BRHL/LAYOUT 142267 . 144491) ( -BRHL/LAYOUT/DAUGHTERS 144493 . 146251) (BRHL/MOVE/RIGHT 146253 . 147396) (BROWSE/LAYOUT/HORIZ 147398 - . 148122) (BROWSE/LAYOUT/HORIZ/COMPACTLY 148124 . 150930) (BROWSE/LAYOUT/LATTICE 150932 . 151788) ( -BRV/OFFSET 151790 . 152653) (EXTEND/TRANSITION/CHAIN 152655 . 153926) (FOREST/BREAK/CYCLES 153928 . -154858) (INIT/NODES/FOR/LAYOUT 154860 . 156355) (INTERPRET/MARK/FORMAT 156357 . 157624) ( -LATTICE/BREAK/CYCLES 157626 . 158330) (LAYOUTFOREST 158332 . 159033) (LAYOUTGRAPH 159035 . 162502) ( -LAYOUTLATTICE 162504 . 163957) (LAYOUTSEXPR 163959 . 165030) (LAYOUTSEXPR1 165032 . 165734) ( -MARK/GRAPH/NODE 165736 . 166466) (NEW/INSTANCE/OF/GRAPHNODE 166468 . 167837) (RAISE/TRANSITION/CHAIN -167839 . 168240) (REFLECT/GRAPH/DIAGONALLY 168242 . 168971) (REFLECT/GRAPH/HORIZONTALLY 168973 . -169499) (REFLECT/GRAPH/VERTICALLY 169501 . 170025) (SWITCH/NODE/HEIGHT/WIDTH 170027 . 170318)) (173442 - 175170 (GRAPHERCOPYBUTTONEVENTFN 173452 . 174431) (GRAPHOBJ.FINDGRAPH 174433 . 175168)) (175171 -177791 (ALIGNMENTNODE 175181 . 176603) (GRAPHOBJ.CHECKALIGN 176605 . 177789)) (177792 194690 ( -GRAPHEROBJ 177802 . 180596) (GRAPHOBJ.BUTTONEVENTINFN 180598 . 182025) (GRAPHOBJ.COPYBUTTONEVENTFN -182027 . 182464) (GRAPHOBJ.COPYFN 182466 . 183390) (GRAPHOBJ.DISPLAYFN 183392 . 186207) ( -GRAPHOBJ.GETALIGN 186209 . 186948) (GRAPHOBJ.GETFN 186950 . 188455) (GRAPHOBJ.IMAGEBOXFN 188457 . -192473) (GRAPHOBJ.PUTALIGN 192475 . 193305) (GRAPHOBJ.PUTFN 193307 . 194688)) (194691 213843 ( -COPYGRAPH 194701 . 196249) (DUMPGRAPH 196251 . 206507) (READGRAPH 206509 . 213841))))) -STOP diff --git a/library/GRAPHER.~3~ b/library/GRAPHER.~3~ deleted file mode 100644 index 3c5c30a4..00000000 --- a/library/GRAPHER.~3~ +++ /dev/null @@ -1,3199 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Apr-2018 09:14:28" {DSK}kaplan>Local>medley3.5>lispcore>library>GRAPHER.;3 213776 changes to%: (VARS GRAPHERCOMS) (FNS GRAPHERIMAGEFNS) previous date%: "10-Apr-2018 11:02:23" {DSK}kaplan>Local>medley3.5>lispcore>library>GRAPHER.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT GRAPHERCOMS) (RPAQQ GRAPHERCOMS [(COMS (* ; "Graph Editing") (FNS ADD/AND/DISPLAY/LINK APPLYTOSELECTEDNODE CALL.MOVENODEFN CHANGE.NODEFONT.SIZE DEFAULT.ADDNODEFN DELETE/AND/DISPLAY/LINK DISPLAY/NAME DISPLAYGRAPH DISPLAYLINK DISPLAYLINK/BT DISPLAYLINK/LR DISPLAYLINK/RL DISPLAYLINK/TB DISPLAYNODE ERASE/GRAPHNODE DISPLAYNODE DISPLAYNODELINKS DRAW/GRAPHNODE/BORDER DRAWAREABOX EDITADDLINK EDITADDNODE EDITAPPLYTOLINK EDITCHANGEFONT EDITCHANGELABEL EDITDELETELINK EDITDELETENODE EDITGRAPH EDITGRAPH1 EDITGRAPH2 EDITMOVENODE EDITTOGGLEBORDER EDITTOGGLELABEL FILL/GRAPHNODE/LABEL FIX/SCALE FLIPNODE FONTNAMELIST FROMLINKS GETNODEFROMID GN/BOTTOM GN/LEFT GN/RIGHT GN/TOP GRAPHADDLINK GRAPHADDNODE GRAPHBUTTONEVENTFN GRAPHCHANGELABEL GRAPHDELETELINK GRAPHDELETENODE GRAPHEDITCOMMANDFN GRAPHEDITEVENTFN GRAPHER/CENTERPRINTINAREA GRAPHERPROP GRAPHNODE/BORDER/WIDTH GRAPHREGION HARDCOPYGRAPH INTERSECT/REGIONP/LBWH INVERTED/GRAPHNODE/BORDER INVERTED/SHADE/FOR/GRAPHER LAYOUT/POSITION LINKPARAMETERS MAX/RIGHT MAX/TOP MEASUREGRAPHNODE MEMBTONODES MIN/BOTTOM MIN/LEFT MOVENODE NODECREATE NODELST/AS/MENU NODEREGION PRINTDISPLAYNODE PROMPTINWINDOW READ/NODE REDISPLAYGRAPH REMOVETONODES RESET/NODE/BORDER RESET/NODE/LABELSHADE SCALE/GRAPH SCALE/GRAPHNODE/BORDER SCALE/TONODES SET/LABEL/SIZE SET/LAYOUT/POSITION SHOWGRAPH SIZE/GRAPH/WINDOW TOGGLE/DIRECTEDFLG TOGGLE/SIDESFLG TOLINKS TRACKCURSOR TRACKNODE TRANSGRAPH) (* ;; "Support for EDITSUBGRAPH and EDITREGION") (FNS EDITMOVEREGION EDITMOVESUBTREE NOT.TRACKCURSOR RECURSIVE.COLLECTDESCENDENTS MOVEDESCENDENTS COLLECT.CHILD.NODES CREATE.NEW.NODEPOSITION GETBOXPOSITION.FROMINITIALREGION COLLECTDESCENDENTS)) (COMS (* ;  "functions for finding larger and smaller fonts") (FNS NEXTSIZEFONT DECREASING.FONT.LIST SCALE.FONT) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DECREASING.FONT.LIST (DECREASING.FONT.LIST] (GLOBALVARS DECREASING.FONT.LIST)) (* ;  "functions for LAYOUTGRAPH And LAYOUTLATTICE") (FNS BRH/LAYOUT BRH/LAYOUT/DAUGHTERS BRH/OFFSET BRHC/INTERTREE/SPACE BRHC/LAYOUT BRHC/LAYOUT/DAUGHTERS BRHC/LAYOUT/TERMINAL BRHC/OFFSET BRHL/LAYOUT BRHL/LAYOUT/DAUGHTERS BRHL/MOVE/RIGHT BROWSE/LAYOUT/HORIZ BROWSE/LAYOUT/HORIZ/COMPACTLY BROWSE/LAYOUT/LATTICE BRV/OFFSET EXTEND/TRANSITION/CHAIN FOREST/BREAK/CYCLES INIT/NODES/FOR/LAYOUT INTERPRET/MARK/FORMAT LATTICE/BREAK/CYCLES LAYOUTFOREST LAYOUTGRAPH LAYOUTLATTICE LAYOUTSEXPR LAYOUTSEXPR1 MARK/GRAPH/NODE NEW/INSTANCE/OF/GRAPHNODE RAISE/TRANSITION/CHAIN REFLECT/GRAPH/DIAGONALLY REFLECT/GRAPH/HORIZONTALLY REFLECT/GRAPH/VERTICALLY SWITCH/NODE/HEIGHT/WIDTH) (CONSTANTS (LINKPARAMS 'Link% Parameters)) [VARS (DEFAULT.GRAPH.NODEBORDER) (DEFAULT.GRAPH.NODEFONT) (DEFAULT.GRAPH.NODELABELSHADE) (ScalableLinkParameters '(LINEWIDTH)) (CACHE/NODE/LABEL/BITMAPS) (NODEBORDERWIDTH 1) (GRAPH/HARDCOPY/FORMAT '(MODE PORTRAIT PAGENUMBERS T TRANS NIL] [INITVARS (DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7) (TIMES SCREENHEIGHT 0.4))) (EDITGRAPHMENUCOMMANDS '((Move% Node 'MOVENODE "Moves a single node in the graph." (SUBITEMS (|Move Single Node| 'MOVENODE "Moves a single node in the graph.") (|Move Node and Subtree| (EDITMOVESUBTREE GRAPHWINDOW) "Moves a subtree of nodes relative to the movement of their root." ) (Move% Region (EDITMOVEREGION GRAPHWINDOW) "Moves a group of nodes within a specified region to another region." ))) ("Add Node" 'ADDNODE) ("Delete Node" 'DELETENODE) ("Add Link" 'ADDLINK) ("Delete Link" 'DELETELINK) ("Change label" 'CHANGELABEL) ("label smaller" 'SMALLER) ("label larger" 'LARGER) ("<-> Directed" 'DIRECTED) ("<-> Sides" 'SIDES) ("<-> Border" 'BORDER) ("<-> Shade" 'SHADE) STOP] (LOCALVARS . T) (RECORDS GRAPHNODE GRAPH) (DECLARE%: DONTCOPY (MACROS HALF)) (COMS (* ; "Grapher image objects") (FNS GRAPHERIMAGEFNS) (FNS GRAPHERCOPYBUTTONEVENTFN GRAPHOBJ.FINDGRAPH) (FNS ALIGNMENTNODE GRAPHOBJ.CHECKALIGN) (FNS GRAPHEROBJ GRAPHOBJ.BUTTONEVENTINFN GRAPHOBJ.COPYBUTTONEVENTFN GRAPHOBJ.COPYFN GRAPHOBJ.DISPLAYFN GRAPHOBJ.GETALIGN GRAPHOBJ.GETFN GRAPHOBJ.IMAGEBOXFN GRAPHOBJ.PUTALIGN GRAPHOBJ.PUTFN) (FNS COPYGRAPH DUMPGRAPH READGRAPH) (INITVARS (GRAPHERIMAGEFNS)) (ALISTS (IMAGEOBJGETFNS GRAPHOBJ.GETFN]) (* ; "Graph Editing") (DEFINEQ (ADD/AND/DISPLAY/LINK - [LAMBDA (FROMND TOND WIN G) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* adds and displays a link.) - (COND - ((MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) - (TOLINKS FROMND)) - (printout PROMPTWINDOW "Link already exists. " T) - NIL) - (T (GRAPHADDLINK FROMND TOND G WIN) - (DISPLAYLINK FROMND TOND (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WIN G) - T]) (APPLYTOSELECTEDNODE - [LAMBDA (WINDOW) (* rmk%: "20-Nov-85 16:33") - - (* applys a function whenever the node is selected. - Is used as BUTTONEVENTFN and gets called whenever cursor moves or button is - down.) - - (GRAPHBUTTONEVENTFN WINDOW (WINDOWPROP WINDOW 'GRAPH) - (WINDOWPROP WINDOW 'BROWSER/LEFTFN) - (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN) - (WINDOWPROP WINDOW 'REGION]) (CALL.MOVENODEFN - [LAMBDA (NODE NEWPOS GRAPH WINDOW OLDPOS) (* BBB "13-Sep-85 15:37") - (* calls a graphs movenodefn.) - (PROG ((MOVEFN (fetch (GRAPH GRAPH.MOVENODEFN) of GRAPH))) - (AND MOVEFN (APPLY* MOVEFN NODE NEWPOS GRAPH WINDOW OLDPOS]) (CHANGE.NODEFONT.SIZE - [LAMBDA (HOW NODE GRAPH WINDOW) (* ; "Edited 22-Jul-87 16:32 by sye") - (* makes the label font of a node - larger.) - (PROG [(NEWFONT (NEXTSIZEFONT HOW (fetch (GRAPHNODE NODEFONT) of NODE] - (COND - (NEWFONT (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WINDOW GRAPH) - (PROG ((CHNGFN (fetch (GRAPH GRAPH.FONTCHANGEFN) of GRAPH))) - (AND CHNGFN (APPLY* CHNGFN HOW NODE GRAPH WINDOW))) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (replace (GRAPHNODE NODEFONT) of NODE with NEWFONT) - (MEASUREGRAPHNODE NODE T) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WINDOW GRAPH]) (DEFAULT.ADDNODEFN - [LAMBDA (GRAPH WINDOW BOXED) (* ; "Edited 9-Jan-89 15:57 by sye") - (* ; - "reads a node label name from the user and puts a node at the current cursor position.") - (PROG (NODELABEL NODENAME) - (OR (SETQ NODELABEL (PROMPTINWINDOW "Node label? ")) - (RETURN)) - LP (COND - ((FASSOC (SETQ NODENAME (PACK* NODELABEL (GENSYM))) - (fetch (GRAPH GRAPHNODES) of GRAPH)) - (GO LP))) - (RETURN (NODECREATE NODENAME NODELABEL (CURSORPOSITION NIL WINDOW) - NIL NIL (OR DEFAULT.GRAPH.NODEFONT DEFAULTFONT) - BOXED]) (DELETE/AND/DISPLAY/LINK - [LAMBDA (FROMND TOND WIN G) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* delete a link and updates the - display.) - - (* * rht 4/4/85%: Added temporary var LINKPARAMS to hold link parameters since - they'll get tossed by GRAPHDELETELINK.) - - (COND - ([NOT (OR (MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) - (TOLINKS FROMND)) - (AND (MEMBTONODES (fetch (GRAPHNODE NODEID) of FROMND) - (TOLINKS TOND)) - (NOT (fetch (GRAPH DIRECTEDFLG) of G)) - (PROG ((TMP FROMND)) (* editting graph, don't distinguish - between links.) - (SETQ FROMND TOND) - (SETQ TOND TMP) - (RETURN T] - (printout PROMPTWINDOW "Link does not exist. " T) - NIL) - (T (PROG ((LPARAMS (LINKPARAMETERS FROMND TOND))) - (GRAPHDELETELINK FROMND TOND G WIN) - (DISPLAYLINK FROMND TOND (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - WIN G NIL LPARAMS)) - T]) (DISPLAY/NAME - [LAMBDA (ND) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (fetch (GRAPHNODE NODELABEL) of ND]) (DISPLAYGRAPH - [LAMBDA (GRAPH STREAM CLIP/REG TRANS) (* ; "Edited 27-Jul-90 09:09 by tafel") - - (* ;; "Displays GRAPH with coordinates system translated to TRANS on STREAM. POS=NIL is interpreted as 0,0. Draws links first then labels so that lattices don't have lines through the labels.") - - (PROG (SCALE (LINEWIDTH 1) - NNODES NODEHASHTABLE) - [OR (type? POSITION TRANS) - (SETQ TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0] - (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) - (COND - ((DISPLAYSTREAMP STREAM) - - (* ;; "This is because PRIN3 on displaystreams can sometimes cause CR's to be output. GRAPHER/CENTERPRINTINAREA doesn't have the rightmargin kludge that the CENTERPRINTINAREA in MENU has.") - - (DSPRIGHTMARGIN 65000 STREAM)) - (T (SETQ SCALE (DSPSCALE NIL STREAM)) - (SETQ GRAPH (SCALE/GRAPH GRAPH STREAM SCALE)) - [SETQ TRANS (create POSITION - XCOORD _ (FIXR (FTIMES SCALE (fetch (POSITION XCOORD) - of TRANS))) - YCOORD _ (FIXR (FTIMES SCALE (fetch (POSITION YCOORD) - of TRANS] - (SETQ LINEWIDTH SCALE))) - - (* ;; "nhb, 23-Feb-89: modified to create hashtable for nodeid to node lookup for cases where hash tables provide better performance than A-Lists.") - - [COND - ((IGREATERP (SETQ NNODES (LENGTH (fetch (GRAPH GRAPHNODES) of GRAPH))) - 25) - (SETQ NODEHASHTABLE (HASHARRAY NNODES)) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (PUTHASH (fetch (GRAPHNODE NODEID) of N) - N NODEHASHTABLE] - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH NODEHASHTABLE)) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (PRINTDISPLAYNODE N TRANS STREAM CLIP/REG]) (DISPLAYLINK - [LAMBDA (FRND TOND TRANS STREAM G LINEWIDTH PARAMS) (* rht%: "13-Mar-85 13:58") - (* draws in a link from FRND TO - TOND, translated by TRANS) - (COND - ((fetch (GRAPH SIDESFLG) of G) - (COND - ((OR (fetch (GRAPH DIRECTEDFLG) of G) - (IGREATERP (GN/LEFT TOND) - (GN/RIGHT FRND))) (* in the horizontal case of - LATTICE, always draw from right to - left.) - (DISPLAYLINK/RL TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/LEFT FRND) - (GN/RIGHT TOND)) - (DISPLAYLINK/LR TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/BOTTOM FRND) - (GN/TOP TOND)) - (DISPLAYLINK/BT TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/BOTTOM TOND) - (GN/TOP FRND)) - (DISPLAYLINK/TB TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - (T (* if on top of each other, don't - draw.) - NIL))) - (T (COND - ((OR (fetch (GRAPH DIRECTEDFLG) of G) - (IGREATERP (GN/BOTTOM FRND) - (GN/TOP TOND))) - - (* if LATTICE, always draw from FROMNODE BOTTOM to TONODE TOP. - Otherwise find the one that looks best.) - - (DISPLAYLINK/BT TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/BOTTOM TOND) - (GN/TOP FRND)) - (DISPLAYLINK/TB TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/LEFT TOND) - (GN/RIGHT FRND)) - (DISPLAYLINK/RL TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - ((IGREATERP (GN/LEFT FRND) - (GN/RIGHT TOND)) - (DISPLAYLINK/LR TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) - (T (* if on top of each other, don't - draw.) - NIL]) (DISPLAYLINK/BT - [LAMBDA (TRANS GNB GNT WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the bottom edge of GNB to the top edge of GNT translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB))) - (IPLUS (fetch YCOORD of TRANS) - (SUB1 (GN/BOTTOM GNB))) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT))) - (IPLUS (fetch YCOORD of TRANS) - (ADD1 (GN/TOP GNT))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) (DISPLAYLINK/LR - [LAMBDA (TRANS GNL GNR WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the left edge of GNL to the right edge of GNR, translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (SUB1 (GN/LEFT GNL))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL))) - (IPLUS (fetch XCOORD of TRANS) - (ADD1 (GN/RIGHT GNR))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) (DISPLAYLINK/RL - [LAMBDA (TRANS GNR GNL WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the right edge of GNR, to the left edge of GNL translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (ADD1 (GN/RIGHT GNR))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR))) - (IPLUS (fetch XCOORD of TRANS) - (SUB1 (GN/LEFT GNL))) - (IPLUS (fetch YCOORD of TRANS) - (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) (DISPLAYLINK/TB - [LAMBDA (TRANS GNT GNB WIDTH OPERATION STREAM PARAMS) - (* ; "Edited 29-Apr-94 13:59 by sybalsky") - - (* draws a line from the top edge of GNT to the bottom edge of GNR, translated - by TRANS) - - (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) - 'DRAWLINE) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT))) - (IPLUS (fetch YCOORD of TRANS) - (ADD1 (GN/TOP GNT))) - (IPLUS (fetch XCOORD of TRANS) - (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB))) - (IPLUS (fetch YCOORD of TRANS) - (SUB1 (GN/BOTTOM GNB))) - (OR (LISTGET PARAMS 'LINEWIDTH) - WIDTH 1) - OPERATION STREAM (LISTGET PARAMS 'COLOR) - (LISTGET PARAMS 'DASHING) - PARAMS]) (DISPLAYNODE - [LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08") - - (* displays a node and its links. IF TOSONLY IS NON-NIL, DRAWS ONLY THE TO - LINKS.) - - (DISPLAYNODELINKS NODE TRANS STREAM G TOSONLY) - (PRINTDISPLAYNODE NODE TRANS STREAM (DSPCLIPPINGREGION NIL STREAM]) (ERASE/GRAPHNODE - [LAMBDA (NODE STREAM TRANS) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* erases a node at its position - translated by TRANS) - (OR [NOT (OR (WINDOWP STREAM) - (IMAGESTREAMTYPEP STREAM 'DISPLAY] - (ZEROP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (BITBLT NIL NIL NIL STREAM (COND - (TRANS (IPLUS (fetch (POSITION XCOORD) of TRANS) - (GN/LEFT NODE))) - (T (GN/LEFT NODE))) - (COND - (TRANS (IPLUS (fetch (POSITION YCOORD) of TRANS) - (GN/BOTTOM NODE))) - (T (GN/BOTTOM NODE))) - (fetch (GRAPHNODE NODEWIDTH) of NODE) - (fetch (GRAPHNODE NODEHEIGHT) of NODE) - 'TEXTURE - 'REPLACE WHITESHADE]) (DISPLAYNODE - [LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08") - - (* displays a node and its links. IF TOSONLY IS NON-NIL, DRAWS ONLY THE TO - LINKS.) - - (DISPLAYNODELINKS NODE TRANS STREAM G TOSONLY) - (PRINTDISPLAYNODE NODE TRANS STREAM (DSPCLIPPINGREGION NIL STREAM]) (DISPLAYNODELINKS - [LAMBDA (NODE TRANS STREAM G TOSONLY LINEWIDTH NODEHASHTABLE) - (* ; "Edited 24-Feb-89 11:56 by Briggs") - - (* ;; "displays a node links. If TOSONLY is non-NIL, draws only the TO links.") - - (* ;; - "nhb, 23-Feb-89: modified to accept a hash table of nodes by nodeid to assist GETNODEFROMID.") - - (PROG ((NODELST (fetch (GRAPH GRAPHNODES) of G))) - (for TONODEID TONODE in (TOLINKS NODE) - do (DISPLAYLINK NODE (SETQ TONODE (GETNODEFROMID TONODEID NODELST - NODEHASHTABLE)) - TRANS STREAM G LINEWIDTH (LINKPARAMETERS NODE TONODE))) - (OR TOSONLY (for FROMNDID FROMND in (FROMLINKS NODE) - do (DISPLAYLINK (SETQ FROMND (GETNODEFROMID FROMNDID NODELST - NODEHASHTABLE)) - NODE TRANS STREAM G LINEWIDTH (LINKPARAMETERS FROMND NODE]) (DRAW/GRAPHNODE/BORDER - [LAMBDA (BORDER LEFT BOTTOM WIDTH HEIGHT STREAM) (* lmm " 9-Jun-85 22:38") - - (* interprets the node border. If the border is a shade, then bitblt twice in - invert mode. This will look ugly if a link runs underneath the node, but at - least the label will be legible.) - - (COND - ((EQ BORDER NIL)) - ((EQ BORDER T) - (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT 1 NIL STREAM)) - ((FIXP BORDER) - (OR (ILEQ BORDER 0) - (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT BORDER NIL STREAM))) - ((LISTP BORDER) (* Extract the PROG after Intermezzo - is released) - (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT (CAR BORDER) - NIL STREAM (CADR BORDER))) - (T (ERROR "Illegal border:" BORDER]) (DRAWAREABOX - [LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) - (* lmm " 9-Jun-85 22:36") - (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* lmm " 9-Jun-85 22:04") - (* draws lines inside the region.) - (* draw left edge) - (BLTSHADE TEXTURE W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT OP) - (* draw top) - (BLTSHADE TEXTURE W (PLUS BOXLEFT BORDER) - (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) - BORDER) - (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) - BORDER OP) (* draw bottom) - (BLTSHADE TEXTURE W (PLUS BOXLEFT BORDER) - BOXBOTTOM - (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) - BORDER OP) (* draw right edge) - (BLTSHADE TEXTURE W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) - BORDER) - BOXBOTTOM BORDER BOXHEIGHT OP]) (EDITADDLINK - [LAMBDA (W) (* kvl "20-APR-82 13:53") - (* reads and adds a link to the - graph) - (EDITAPPLYTOLINK (FUNCTION ADD/AND/DISPLAY/LINK) - 'added - (WINDOWPROP W 'GRAPH) - W]) (EDITADDNODE - [LAMBDA (W NewPosition MSGW NODELABELFN) (* ; "Edited 29-Apr-94 13:59 by sybalsky") - (* ; - "adds a node to the graph in the window W and displays it.") - - (* ;; "pmi 4/8/88: Added NewPosition argument so that the new position for a node may be specified programatically.") - - (* ;; "sye Jan/9/89: added MSGW & NODELABELFN args ") - - (DECLARE (GLOBALVARS PROMPTWINDOW)) - (PROG [NODE ORIGPOS NEWPOS NODELABEL (GRAPH (WINDOWPROP W 'GRAPH)) - (Stream (WINDOWPROP W 'DSP] - (OR (SETQ NODE (GRAPHADDNODE GRAPH W)) - (RETURN)) - (MEASUREGRAPHNODE NODE) - (if (POSITIONP NewPosition) - then (SETQ ORIGPOS (create POSITION using (fetch (GRAPHNODE - NODEPOSITION) - of NODE))) - (MOVENODE NODE ORIGPOS NewPosition GRAPH Stream) - (FLIPNODE NODE Stream) - (EXTENDEXTENT (WFROMDS Stream) - (NODEREGION NODE)) - (CALL.MOVENODEFN NODE NewPosition GRAPH (WFROMDS Stream) - ORIGPOS) - else (printout (OR MSGW PROMPTWINDOW) - "Position node " - (OR (AND NODELABELFN (APPLY* NODELABELFN NODE)) - (fetch (GRAPHNODE NODELABEL) - NODE))) - (PRINTDISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - W - (DSPCLIPPINGREGION NIL W)) - (TRACKCURSOR NODE Stream GRAPH)) - (RETURN NODE]) (EDITAPPLYTOLINK - [LAMBDA (FN MSG GRAPH DS MSGW NODELABELFN) (* ; "Edited 9-Jan-89 09:10 by sye") - (SETQ MSGW (OR MSGW PROMPTWINDOW)) - (CLEARW MSGW) - (CLRPROMPT) - (COND - [(fetch (GRAPH GRAPHNODES) of GRAPH) - (PROG (FROM TO (ABORTMSG "No selection was made ... operation aborted.")) - (printout MSGW "Specify the link by selecting the FROM node, then the TO node." T - "FROM?" T) (* - "if no FROM node was selected, abort the operation") - (OR (SETQ FROM (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout PROMPTWINDOW ABORTMSG T))) - (FLIPNODE FROM DS) - (printout MSGW "TO?" T) - (COND - [(ERSETQ (SETQ TO (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS] - (T (FLIPNODE FROM DS) - (ERROR!))) - (FLIPNODE FROM DS) (* - "if no TO node was selected, abort the operation") - (OR TO (RETURN (printout PROMPTWINDOW ABORTMSG T))) - (COND - ((APPLY* FN FROM TO DS GRAPH) (* return non-nil if changed - anything.) - (printout PROMPTWINDOW "Link from " (OR (AND NODELABELFN (APPLY* NODELABELFN FROM)) - (DISPLAY/NAME FROM)) - " to " - (OR (AND NODELABELFN (APPLY* NODELABELFN TO)) - (DISPLAY/NAME TO)) - %, MSG T) - (RETURN T] - (T (printout PROMPTWINDOW - "There are no nodes. You can create nodes with the Add Node command." T]) (EDITCHANGEFONT - [LAMBDA (HOW W) (* ; "Edited 7-Jan-89 13:14 by sye") - (* prompts the user for a node and - deletes it) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT " No nodes in graph yet. ") - (RETURN))) - (CLRPROMPT) - (printout PROMPTWINDOW "Select node to be made " (COND - ((EQ HOW 'SMALLER) - "smaller.") - (T "larger."))) - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout PROMPTWINDOW T "No selection was made ... operation aborted." T))) - (CHANGE.NODEFONT.SIZE HOW NODE GRAPH W) - (RETURN NODE]) (EDITCHANGELABEL - [LAMBDA (W MSGW) (* ; "Edited 7-Jan-89 13:31 by sye") - (* prompts the user for a node and - deletes it) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (GETSTREAM W)) - (TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0))) - NODE NEWLABEL) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT "No nodes in graph yet. ") - (RETURN))) - (CLRPROMPT) - (SETQ MSGW (OR MSGW PROMPTWINDOW)) - (CLEARW MSGW) - (printout MSGW "Select node to have label changed.") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout PROMPTWINDOW T "No selection was made ... operation aborted." T))) - (if (NULL (SETQ NEWLABEL (GRAPHCHANGELABEL GRAPH W NODE))) - then (RETURN)) - (DISPLAYNODE NODE TRANS W GRAPH) - (ERASE/GRAPHNODE NODE DS TRANS) - (replace (GRAPHNODE NODELABEL) of NODE with NEWLABEL) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (MEASUREGRAPHNODE NODE T) - (DISPLAYNODE NODE TRANS W GRAPH) - (RETURN NODE]) (EDITDELETELINK - [LAMBDA (W) (* kvl "20-APR-82 13:54") - (* reads and adds a link to the - graph) - (EDITAPPLYTOLINK (FUNCTION DELETE/AND/DISPLAY/LINK) - 'deleted - (WINDOWPROP W 'GRAPH) - W]) (EDITDELETENODE - [LAMBDA (W) (* ; "Edited 9-Jan-89 09:14 by sye") - (* prompts the user for a node and - deletes it) - (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) - (CLRPROMPT) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE NODELABEL) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT " No nodes to delete. ") - (RETURN))) - (PROMPTPRINT "Select node to be deleted. ") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout T T "No selection was made ... operation aborted." T))) - (TERPRI T) - (FLIPNODE NODE DS) - (COND - ((EQ [ASKUSER NIL NIL (LIST "delete node " (SETQ NODELABEL (DISPLAY/NAME - NODE] - 'Y) - (FLIPNODE NODE DS) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - DS GRAPH) - (for TOND in (APPEND (TOLINKS NODE)) - do (GRAPHDELETELINK NODE (GETNODEFROMID TOND (fetch - (GRAPH GRAPHNODES) - of GRAPH)) - GRAPH W)) - (for FROMND in (APPEND (FROMLINKS NODE)) - do (GRAPHDELETELINK (GETNODEFROMID FROMND (fetch (GRAPH - GRAPHNODES) - of GRAPH)) - NODE GRAPH W)) - (GRAPHDELETENODE NODE GRAPH W) - (printout T "Node " NODELABEL " deleted." T) - (RETURN NODE)) - (T (FLIPNODE NODE DS) - (printout T "nothing deleted." T) - (RETURN NIL]) (EDITGRAPH - [LAMBDA (G W) - (SHOWGRAPH G W NIL NIL T T]) (EDITGRAPH1 - [LAMBDA (GRAPH WINDOW) (* ; "Edited 19-Aug-88 08:30 by sye") - - (* ;; "top level function for editing a graph. If there is no graph, create one empty. IF there is no window, create on the right size for the graph. After getting the arguments right, put the right button functions on, display it and enter the main loop.") - - (OR GRAPH (SETQ GRAPH (create GRAPH))) - (SETQ WINDOW (SIZE/GRAPH/WINDOW GRAPH WINDOW)) - (WINDOWPROP WINDOW 'GRAPH GRAPH) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (DSPOPERATION 'INVERT WINDOW) - (REDISPLAYGRAPH WINDOW) - (EDITGRAPH2 WINDOW) - GRAPH]) (EDITGRAPH2 - [LAMBDA (W) (* rrb " 7-NOV-83 14:51") - - (* Can also be called from top level if the given window W has a graph on its - GRAPH windowprop and the graph has been displayed by SHOWGRAPH or its - equivalent. It waits for mouse hits, does the comand, then waits for mouse - clear. Each edit command function takes only the window so that they can be - hung separately on button event functions. - However, the window must have INVERT as its display operation mode.) - - (PROG (VAL) - (CLRPROMPT) - (printout PROMPTWINDOW "Use the left button to move nodes." T - "Use the middle button to get a menu of edit commands." T - "During an edit command, the middle button can be used to abort.") - LP (until (MOUSESTATE (OR LEFT MIDDLE)) do) - (COND - [(LASTMOUSESTATE MIDDLE) - (SETQ VAL (ERSETQ (GRAPHEDITCOMMANDFN W))) - (COND - ((NULL VAL) (* aborted) - (printout PROMPTWINDOW T T "command aborted." T)) - ((EQ (CAR VAL) - 'STOP) - (RETURN (CLRPROMPT] - ((fetch (GRAPH GRAPHNODES) of (WINDOWPROP W 'GRAPH)) - (* track the nearest node.) - (TRACKNODE W)) - (T (printout PROMPTWINDOW T "There are no nodes to move yet." T - "Press the middle button and select the 'Add a node' command."))) - (until (MOUSESTATE UP) do) - (GO LP]) (EDITMOVENODE - [LAMBDA (WINDOW) (* ; "Edited 7-Jan-89 13:22 by sye") - (* hilite nodes until the cursor - goes down then move it) - (PROG ((DS (WINDOWPROP WINDOW 'DSP)) - (REG (WINDOWPROP WINDOW 'REGION)) - (GRAPH (WINDOWPROP WINDOW 'GRAPH)) - OLDPOS NOW NEAR NODELST) - (COND - (GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) - (T (RETURN))) - (CLRPROMPT) - (printout PROMPTWINDOW "Move the cursor to the node " "you want to move " - "and press any button.") - [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (GETMOUSESTATE) - (COND - ((LASTMOUSESTATE (NOT UP)) (* button up, process it.) - (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) - ) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP))) - (printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position" - "and release the button.") - (TRACKCURSOR NOW DS GRAPH) - (printout PROMPTWINDOW T "Done."]) (EDITTOGGLEBORDER - [LAMBDA (W) (* ; "Edited 7-Jan-89 13:38 by sye") - (* ; - "prompts the user for a node and inverts its border") - (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) - (CLRPROMPT) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT "No nodes to invert. ") - (RETURN))) - (PROMPTPRINT "Select node to have border inverted. ") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout T T "No selection was made ... operation aborted." T))) - (TERPRI T) - (RESET/NODE/BORDER NODE 'INVERT W GRAPH) - (AND (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) - (APPLY* (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) - NODE GRAPH W)) - (RETURN NODE]) (EDITTOGGLELABEL - [LAMBDA (W) (* ; "Edited 7-Jan-89 13:17 by sye") - (* prompts the user for a node and - inverts its lable) - (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) - (CLRPROMPT) - (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) - (DS (WINDOWPROP W 'DSP)) - NODE) - (COND - ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (PROMPTPRINT " No nodes to invert.") - (RETURN))) - (PROMPTPRINT "Select node to have label inverted. ") - (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) - DS)) - (RETURN (printout T T "No selection was made ... operation aborted." T))) - (TERPRI T) - (RESET/NODE/LABELSHADE NODE 'INVERT W) - (AND (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) - (APPLY* (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) - NODE GRAPH W)) - (RETURN NODE]) (FILL/GRAPHNODE/LABEL - [LAMBDA (SHADE LEFT BOTTOM WIDTH HEIGHT NBW STREAM) (* kvl "10-Sep-84 14:41") - (* NBW is the border, which must be - subtracted from the node's region) - (PROG ((NS SHADE)) - (OR (WINDOWP STREAM) - (DISPLAYSTREAMP STREAM) - (RETURN)) - (COND - ((EQ SHADE T) - (SETQ NS BLACKSHADE)) - ((NULL SHADE) - (SETQ NS WHITESHADE))) - (BITBLT NIL NIL NIL STREAM (IPLUS LEFT NBW) - (IPLUS BOTTOM NBW) - (IDIFFERENCE WIDTH (IPLUS NBW NBW)) - (IDIFFERENCE HEIGHT (IPLUS NBW NBW)) - 'TEXTURE - 'INVERT NS]) (FIX/SCALE - [LAMBDA (PARAMVALUE SCALE) (* dgb%: "28-Jan-85 10:01") - - (* * fixes PARAMVALUE by SCALE If PARAMVALUE is a list, then fixes the elements - of the list) - - (COND - ((LISTP PARAMVALUE) - (for V in PARAMVALUE collect (FIX/SCALE V SCALE))) - (T (* Note that some parameters may go - to zero) - (FIXR (FTIMES SCALE PARAMVALUE]) (FLIPNODE - [LAMBDA (NODE DS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* flips the region around a node.) - (BITBLT NIL NIL NIL DS (IDIFFERENCE (GN/LEFT NODE) - 1) - (IDIFFERENCE (GN/BOTTOM NODE) - 1) - (IPLUS (fetch (GRAPHNODE NODEWIDTH) of NODE) - 2) - (IPLUS (fetch (GRAPHNODE NODEHEIGHT) of NODE) - 2) - 'TEXTURE - 'INVERT BLACKSHADE]) (FONTNAMELIST - [LAMBDA (FONTDESC) (* rrb " 2-NOV-83 21:00") - (LIST (FONTPROP FONTDESC 'FAMILY) - (FONTPROP FONTDESC 'SIZE) - (FONTPROP FONTDESC 'FACE]) (FROMLINKS - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (fetch (GRAPHNODE FROMNODES) of NODE]) (GETNODEFROMID - [LAMBDA (ID NODELST NODEHASHTABLE) (* ; "Edited 24-Feb-89 11:55 by Briggs") - - (* ;; "Allow Link parameters to be passed as a property list of the node description.") - - (* ;; "nhb, 23-Feb-89: modified -- If the (optional) NODEHASHTABLE is passed then we will use this rather than assoc'ing in the node list to find the node. Also switched order of listp check and bare FASSOC") - - (COND - (NODEHASHTABLE (OR (AND (LISTP ID) - (EQ 'Link% Parameters (CAR ID)) - (GETHASH (CADR ID) - NODEHASHTABLE)) - (GETHASH ID NODEHASHTABLE) - (ERROR "No graphnode for nodeid:" ID))) - (T (OR (AND (LISTP ID) - (EQ 'Link% Parameters (CAR ID)) - (FASSOC (CADR ID) - NODELST)) - (FASSOC ID NODELST) - (ERROR "No graphnode for nodeid:" ID]) (GN/BOTTOM - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (IDIFFERENCE (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (HALF (fetch (GRAPHNODE NODEHEIGHT) of NODE]) (GN/LEFT - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (IDIFFERENCE (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (HALF (fetch (GRAPHNODE NODEWIDTH) of NODE]) (GN/RIGHT - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* Assumes that the big-half of width is to the left of the center, for even - width) - - (IPLUS (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (SUB1 (HALF (ADD1 (fetch (GRAPHNODE NODEWIDTH) of NODE]) (GN/TOP - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* Assumes that big-half of height is under the center, for even height. - Result is -1 for height=0, which is correct.) - - (IPLUS (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) - (SUB1 (HALF (ADD1 (fetch (GRAPHNODE NODEHEIGHT) of NODE]) (GRAPHADDLINK - [LAMBDA (FROM TO GRAPH WINDOW) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* links two nodes) - (PROG ((ADDFN (fetch (GRAPH GRAPH.ADDLINKFN) of GRAPH))) - (AND ADDFN (APPLY* ADDFN FROM TO GRAPH WINDOW))) - (push (fetch (GRAPHNODE FROMNODES) of TO) - (fetch (GRAPHNODE NODEID) of FROM)) - (push (fetch (GRAPHNODE TONODES) of FROM) - (fetch (GRAPHNODE NODEID) of TO]) (GRAPHADDNODE - [LAMBDA (GRAPH W) (* rrb " 2-NOV-83 20:29") - (* adds a node to the graph GRAPH) - (PROG (ADDFN NODE) - (OR [SETQ NODE (COND - ((SETQ ADDFN (fetch (GRAPH GRAPH.ADDNODEFN) of GRAPH)) - (APPLY* ADDFN GRAPH W)) - (T (DEFAULT.ADDNODEFN GRAPH W T] - (RETURN)) - (replace (GRAPH GRAPHNODES) of GRAPH with (NCONC1 (fetch (GRAPH GRAPHNODES) - of GRAPH) - NODE)) - (RETURN NODE]) (GRAPHBUTTONEVENTFN - [LAMBDA (WINDOW GRAPH LEFTFNOFNODE MIDDLEFNOFNODE REG) (* rmk%: "20-Nov-85 16:33") - - (* applys a function whenever the node is selected. - Is used as BUTTONEVENTFN and gets called whenever cursor moves or button is - down.) - - (TOTOPW WINDOW) - (PROG ((NODELST (fetch (GRAPH GRAPHNODES) of GRAPH)) - (DS (GETSTREAM WINDOW)) - BUTTON OLDPOS REG NOW NEAR) (* note which button is down.) - (COND - ((LASTMOUSESTATE LEFT) - (OR LEFTFNOFNODE (RETURN)) - (SETQ BUTTON 'LEFT)) - ((LASTMOUSESTATE MIDDLE) - (OR MIDDLEFNOFNODE (RETURN)) - (SETQ BUTTON 'MIDDLE)) - (T (* no button down, not interested.) - (RETURN))) (* get the region of this window.) - [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (* wait for a button up or move out - of region) - (GETMOUSESTATE) - (COND - ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* button up, process it.) - (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) - (RETURN (APPLY* (SELECTQ BUTTON - (LEFT LEFTFNOFNODE) - (MIDDLE MIDDLEFNOFNODE) - (SHOULDNT)) - NOW WINDOW))) - ((NOT (INSIDE? (WINDOWPROP WINDOW 'REGION) - LASTMOUSEX LASTMOUSEY)) (* outside of region, return) - (AND NOW (FLIPNODE NOW DS)) - (RETURN)) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP]) (GRAPHCHANGELABEL - [LAMBDA (GRAPH W NODE) (* rmk%: "19-Sep-85 10:50") - (* Returns a new label for NODE) - (LET (CHANGEFN) - (COND - ((SETQ CHANGEFN (fetch (GRAPH GRAPH.CHANGELABELFN) of GRAPH)) - (APPLY* CHANGEFN GRAPH W NODE)) - (T (PROMPTINWINDOW "Node label? "]) (GRAPHDELETELINK - [LAMBDA (FROM TO GRAPH WINDOW) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* deletes a link from a graph) - - (* * rht 4/4/85%: Changed to call REMOVETONODES to remove either nodeID or - paramlist thingie for nodeID.) - - (PROG ((DELFN (fetch (GRAPH GRAPH.DELETELINKFN) of GRAPH))) - (AND DELFN (APPLY* DELFN FROM TO GRAPH WINDOW))) - (replace (GRAPHNODE TONODES) of FROM with (REMOVETONODES (fetch (GRAPHNODE - NODEID) - of TO) - (fetch (GRAPHNODE TONODES) - of FROM))) - (replace (GRAPHNODE FROMNODES) of TO with (REMOVE (fetch (GRAPHNODE NODEID) - of FROM) - (fetch (GRAPHNODE FROMNODES) - of TO]) (GRAPHDELETENODE - [LAMBDA (NODE GRAPH WINDOW) (* kvl " 5-Sep-84 19:03") - (PROG ((DELFN (fetch (GRAPH GRAPH.DELETENODEFN) of GRAPH))) - (AND DELFN (APPLY* DELFN NODE GRAPH WINDOW)) - (replace (GRAPH GRAPHNODES) of GRAPH with (DREMOVE NODE (fetch (GRAPH - GRAPHNODES) - of GRAPH]) (GRAPHEDITCOMMANDFN - [LAMBDA (GRAPHWINDOW) (* rmk%: "19-Sep-85 11:12") - (DECLARE (SPECVARS GRAPHWINDOW)) (* So that window is available to - functions called from menu items) - (SELECTQ [MENU (COND - ((type? MENU EDITGRAPHMENU) - EDITGRAPHMENU) - (T (SETQ EDITGRAPHMENU (create MENU - ITEMS _ EDITGRAPHMENUCOMMANDS - CENTERFLG _ T - CHANGEOFFSETFLG _ T] - (STOP 'STOP) - (MOVENODE (EDITMOVENODE GRAPHWINDOW)) - (ADDNODE (EDITADDNODE GRAPHWINDOW)) - (DELETENODE (EDITDELETENODE GRAPHWINDOW)) - (ADDLINK (EDITADDLINK GRAPHWINDOW)) - (SMALLER (EDITCHANGEFONT 'SMALLER GRAPHWINDOW)) - (LARGER (EDITCHANGEFONT 'LARGER GRAPHWINDOW)) - (DELETELINK (EDITDELETELINK GRAPHWINDOW)) - (CHANGELABEL (EDITCHANGELABEL GRAPHWINDOW)) - (DIRECTED (TOGGLE/DIRECTEDFLG GRAPHWINDOW)) - (SIDES (TOGGLE/SIDESFLG GRAPHWINDOW)) - (BORDER (EDITTOGGLEBORDER GRAPHWINDOW)) - (SHADE (EDITTOGGLELABEL GRAPHWINDOW)) - NIL]) (GRAPHEDITEVENTFN - [LAMBDA (GRWINDOW) (* rmk%: "16-Feb-85 10:15") - (* implements a graph editor on the - right button transition of a window.) - (COND - ((NOT (INSIDE? (DSPCLIPPINGREGION NIL GRWINDOW) - (LASTMOUSEX GRWINDOW) - (LASTMOUSEY GRWINDOW))) - (DOWINDOWCOM GRWINDOW)) - ((SHIFTDOWNP 'CTRL) - (TRACKNODE GRWINDOW)) - ((EQ (GRAPHEDITCOMMANDFN GRWINDOW) - 'STOP) (* do menu) - (CLOSEW GRWINDOW]) (GRAPHER/CENTERPRINTINAREA - [LAMBDA (EXP X Y WIDTH HEIGHT STREAM) (* kvl "15-Aug-84 11:01") - - (* ;; "prints an expression in a box. The system CENTERPRINTINAREA on MENU worried about overflowing the right margin, which we ignore here.") - - (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) - (PROG (XPOS (STRWIDTH (STRINGWIDTH EXP STREAM))) - (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) - (PRIN3 EXP STREAM]) (GRAPHERPROP - [LAMBDA (GRAPH PROP NEWVALUE) (* ; "Edited 19-Aug-88 14:09 by sye") - (LET (PROPLIST) - (SETPROPLIST PROPLIST (fetch (GRAPH GRAPH.PROPS) of GRAPH)) - (if NEWVALUE - then (PROG1 (PUTPROP PROPLIST PROP NEWVALUE) - (replace (GRAPH GRAPH.PROPS) of GRAPH with (GETPROPLIST - PROPLIST))) - else (GETPROP PROPLIST PROP]) (GRAPHNODE/BORDER/WIDTH - [LAMBDA (BORDER) (* kvl " 5-Sep-84 16:19") - (* returns a non-negative interger) - (COND - ((NULL BORDER) - 0) - ((EQ BORDER T) - 1) - ((FIXP BORDER) - (ABS BORDER)) - ((AND (LISTP BORDER) - (FIXP (CAR BORDER)) - (IGEQ (CAR BORDER) - 0)) - (CAR BORDER)) - (T (ERROR "Illegal border:" BORDER]) (GRAPHREGION - [LAMBDA (GRAPH) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* Returns the minimum region - containing the graph.) - (PROG (LEFTOFFSET BOTTOMOFFSET (NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) - (RETURN (COND - [NODELST (* Determine the dimensions of the - node labels) - (for N in NODELST do (MEASUREGRAPHNODE N)) - (CREATEREGION (SETQ LEFTOFFSET (MIN/LEFT NODELST)) - (SETQ BOTTOMOFFSET (MIN/BOTTOM NODELST)) - (ADD1 (IDIFFERENCE (MAX/RIGHT NODELST) - LEFTOFFSET)) - (ADD1 (IDIFFERENCE (MAX/TOP NODELST) - BOTTOMOFFSET] - (T (CREATEREGION 0 0 0 0]) (HARDCOPYGRAPH - [LAMBDA (GRAPH/WINDOW FILE IMAGETYPE TRANS) (* ; "Edited 23-Apr-92 16:51 by jds") - (LET* - ((LANDSCAPE-FLAG (EQ (LISTGET GRAPH/HARDCOPY/FORMAT 'MODE) - 'LANDSCAPE)) - [PSTREAM (OR (AND FILE (OPENP FILE 'OUTPUT) - (GETSTREAM FILE)) - (OPENIMAGESTREAM FILE IMAGETYPE (APPEND '(CLIP.INCLUSIVE T) - (AND LANDSCAPE-FLAG '(LANDSCAPE T] - (PSCALE (DSPSCALE NIL PSTREAM)) - (ORIGINAL-CLIPREGION (DSPCLIPPINGREGION NIL PSTREAM)) - (GRAPH (COND - ((WINDOWP GRAPH/WINDOW) - (WINDOWPROP GRAPH/WINDOW 'GRAPH)) - (T GRAPH/WINDOW))) - (GRAPH-REGION (GRAPHREGION GRAPH)) - (GRAPH-LEFT (fetch (REGION LEFT) of GRAPH-REGION)) - (GRAPH-BOTTOM (fetch (REGION BOTTOM) of GRAPH-REGION)) - (GRAPH-WIDTH (fetch (REGION WIDTH) of GRAPH-REGION)) - (GRAPH-HEIGHT (fetch (REGION HEIGHT) of GRAPH-REGION)) - (SCREENPOINTS-PER-INCH 72) - (PAGENUMBERS-FLAG (LISTGET GRAPH/HARDCOPY/FORMAT 'PAGENUMBERS)) - [RIGHT-MARGIN (FIXR (TIMES 0 SCREENPOINTS-PER-INCH (OR (LISTGET GRAPH/HARDCOPY/FORMAT - 'RIGHTMARGIN) - 0.5] - [UPPER-MARGIN (FIXR (TIMES 0 SCREENPOINTS-PER-INCH (OR (LISTGET GRAPH/HARDCOPY/FORMAT - 'UPPERMARGIN) - 0.4] - (PAGE-WIDTH (- (FIXR (QUOTIENT (fetch (REGION WIDTH) of ORIGINAL-CLIPREGION) - PSCALE)) - RIGHT-MARGIN)) - (PAGE-HEIGHT (- (FIXR (QUOTIENT (fetch (REGION HEIGHT) of ORIGINAL-CLIPREGION) - PSCALE)) - UPPER-MARGIN)) - (NUMBER-OF-X-PAGES (CL:CEILING GRAPH-WIDTH PAGE-WIDTH)) - (NUMBER-OF-Y-PAGES (CL:CEILING GRAPH-HEIGHT PAGE-HEIGHT)) - [X-POSITION (FIXR (TIMES PSCALE (PLUS PAGE-WIDTH (TIMES 0.2 RIGHT-MARGIN] - [Y-POSITION (FIXR (TIMES PSCALE (PLUS PAGE-HEIGHT (TIMES 0.5 UPPER-MARGIN] - (BOTTOM-CENTERING-OFFSET NIL) - [LEFT-CENTERING-OFFSET (LET (TRAN) - (COND - ((type? POSITION TRANS) - (SETQ BOTTOM-CENTERING-OFFSET (fetch YCOORD of TRANS)) - (fetch XCOORD of TRANS)) - ([type? POSITION (SETQ TRAN (LISTGET GRAPH/HARDCOPY/FORMAT - 'TRANS] - (SETQ BOTTOM-CENTERING-OFFSET (fetch YCOORD of TRAN)) - (fetch XCOORD of TRAN)) - (T (SETQ BOTTOM-CENTERING-OFFSET - (QUOTIENT (PLUS UPPER-MARGIN (DIFFERENCE PAGE-HEIGHT - (REMAINDER GRAPH-HEIGHT - PAGE-HEIGHT))) - 2)) - (QUOTIENT (PLUS RIGHT-MARGIN (DIFFERENCE PAGE-WIDTH - (REMAINDER GRAPH-WIDTH - PAGE-WIDTH))) - 2] - [CLIPREGION (CREATEREGION 0 0 (FIXR (TIMES PSCALE PAGE-WIDTH)) - (FIXR (TIMES PSCALE PAGE-HEIGHT] - (SCALED-GRAPH (SCALE/GRAPH GRAPH PSTREAM))) - - (* ;; "") - - (* ;; " set up margins and clip/region for the print stream") - - (* ;; "") - - (DSPLEFTMARGIN 0 PSTREAM) - (DSPBOTTOMMARGIN 0 PSTREAM) - (DSPTOPMARGIN (fetch (REGION HEIGHT) of ORIGINAL-CLIPREGION) - PSTREAM) - (DSPRIGHTMARGIN (TIMES 2 (fetch (REGION WIDTH) of ORIGINAL-CLIPREGION)) - PSTREAM) - (DSPCLIPPINGREGION CLIPREGION PSTREAM) - - (* ;; "") - - (* ;; " print graph") - - (* ;; "") - - [for Y-PAGE-NUMBER from 1 to NUMBER-OF-Y-PAGES - do (for X-PAGE-NUMBER from 1 to NUMBER-OF-X-PAGES - do (LET [(PTRANS (create POSITION - XCOORD _ - [FIXR (FTIMES PSCALE (PLUS LEFT-CENTERING-OFFSET - (MINUS GRAPH-LEFT) - (MINUS (TIMES (SUB1 - X-PAGE-NUMBER - ) - PAGE-WIDTH] - YCOORD _ - (FIXR (FTIMES PSCALE (PLUS BOTTOM-CENTERING-OFFSET - (MINUS GRAPH-BOTTOM) - (MINUS (TIMES (SUB1 - Y-PAGE-NUMBER - ) - PAGE-HEIGHT] - - (* ;; "") - - (* ;; "write a page-full of graph to the print stream") - - (* ;; "") - - (for N in (fetch (GRAPH GRAPHNODES) of SCALED-GRAPH) - do (DISPLAYNODELINKS N PTRANS PSTREAM SCALED-GRAPH T PSCALE) - ) - (for N in (fetch (GRAPH GRAPHNODES) of SCALED-GRAPH) - do (PRINTDISPLAYNODE N PTRANS PSTREAM CLIPREGION)) - - (* ;; "") - - (* ;; " print the page number & start a new page") - - (* ;; "") - - (CL:UNLESS (AND (= X-PAGE-NUMBER NUMBER-OF-X-PAGES) - (= Y-PAGE-NUMBER NUMBER-OF-Y-PAGES)) - (COND - (PAGENUMBERS-FLAG (DSPCLIPPINGREGION ORIGINAL-CLIPREGION PSTREAM - ) - (MOVETO X-POSITION Y-POSITION PSTREAM) - (printout PSTREAM Y-PAGE-NUMBER "-" X-PAGE-NUMBER) - (DSPCLIPPINGREGION CLIPREGION PSTREAM))) - (DSPNEWPAGE PSTREAM))] - (CLOSEF PSTREAM]) (INTERSECT/REGIONP/LBWH - [LAMBDA (L B W H REG HOW NODE) (* ; "Edited 11-Jun-90 16:15 by mitani") - (* ; - "like intersect regions, but without requiring the consing") - (* - |how = partial :check if the nodelabel was partially intersect with REG|) - (* - |otherwise :check if the whole nodelabel was contained in REG|) - (SELECTQ HOW - (PARTIAL (NOT (OR (IGREATERP (fetch (REGION BOTTOM) of REG) - (IPLUS B H)) - (ILESSP (fetch (REGION PRIGHT) of REG) - L) - (IGREATERP (fetch (REGION LEFT) of REG) - (IPLUS L W)) - (ILESSP (fetch (REGION PTOP) of REG) - B)))) - (EQUAL (INTERSECTREGIONS REG (LIST L B W H)) - (LIST L B W H]) (INVERTED/GRAPHNODE/BORDER - [LAMBDA (BORDER) (* kvl " 5-Sep-84 18:49") - (* returns the right thing to invert - a graphnode's border) - (COND - ((EQ BORDER T) - NIL) - ((NULL BORDER) - T) - ((FIXP BORDER) - (IMINUS BORDER)) - ((AND (LISTP BORDER) - (FIXP (CAR BORDER))) - (LIST (CAR BORDER) - (INVERTED/SHADE/FOR/GRAPHER (CADR BORDER]) (INVERTED/SHADE/FOR/GRAPHER - [LAMBDA (SHADE) (* rmk%: "20-Sep-85 09:31") - (* funny name because hopefully will - become system function) - (COND - ((EQ SHADE T) - NIL) - ((NULL SHADE) - T) - ((FIXP SHADE) - (LOGNOT SHADE)) - ((BITMAPP SHADE) - (PROG ((NB (BITMAPCOPY SHADE))) - (BLTSHADE BLACKSHADE NB NIL NIL NIL NIL 'INVERT) - (RETURN NB))) - (T (ERROR "Illegal shade:" SHADE]) (LAYOUT/POSITION - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (fetch (GRAPHNODE NODEPOSITION) of NODE]) (LINKPARAMETERS - [LAMBDA (FROMND TOND) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (PROG (TOPARAMS) - (RETURN (AND (SETQ TOPARAMS (MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) - (TOLINKS FROMND))) - (LISTP TOPARAMS) - (EQ 'Link% Parameters (CAR TOPARAMS)) - (CDDR TOPARAMS]) (MAX/RIGHT - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:33") - (for NODE in NODES largest (GN/RIGHT NODE) finally (RETURN $$EXTREME]) (MAX/TOP - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") - (for NODE in NODES largest (GN/TOP NODE) finally (RETURN $$EXTREME]) (MEASUREGRAPHNODE - [LAMBDA (NODE RESETFLG) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* Measure the nodelabel image) - (SET/LABEL/SIZE NODE RESETFLG) - (SET/LAYOUT/POSITION NODE (OR (fetch (GRAPHNODE NODEPOSITION) of NODE) - (ERROR "This graphnode has not been given a position:" NODE]) (MEMBTONODES - [LAMBDA (TOND TONODES) (* dgb%: "24-Jan-85 08:05") - (for Z in TONODES do (COND - ([OR (EQ TOND Z) - (AND (LISTP Z) - (EQ (CAR Z) - 'Link% Parameters) - (EQ TOND (CADR Z] - (RETURN Z]) (MIN/BOTTOM - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") - (* returns the bottommost point of - the graph.) - (for NODE in NODES smallest (GN/BOTTOM NODE) finally (RETURN $$EXTREME]) (MIN/LEFT - [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") - (* returns the leftmost point of the - graph.) - (for NODE in NODES smallest (GN/LEFT NODE) finally (RETURN $$EXTREME]) (MOVENODE - [LAMBDA (NODE OLDPOS POS GRAPH STREAM) (* rmk%: "10-Apr-84 12:31") - (* moves a node from its current - position to POS) - (COND - ((EQUAL OLDPOS POS) (* don't move if position hasn't - changed) - NIL) - (T (* node is flipped, flip it back.) - (FLIPNODE NODE STREAM) (* erase current position) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - STREAM GRAPH) (* put it in new one.) - (SET/LAYOUT/POSITION NODE POS) - (DISPLAYNODE NODE (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0)) - STREAM GRAPH) - (FLIPNODE NODE STREAM]) (NODECREATE - [LAMBDA (ID LABEL POS TONODEIDS FROMNODEIDS FONT BORDER LABELSHADE) - (* Randy.Gobbel "13-May-87 12:04") - (* creates a node for a grapher.) - (create GRAPHNODE - NODEID _ ID - NODEPOSITION _ POS - NODELABEL _ LABEL - NODEFONT _ (COND - (FONT) - ((IMAGEOBJP LABEL) - NIL) - (DEFAULT.GRAPH.NODEFONT) - (T (FONTNAMELIST DEFAULTFONT))) - TONODES _ TONODEIDS - FROMNODES _ FROMNODEIDS - NODEBORDER _ BORDER - NODELABELSHADE _ LABELSHADE]) (NODELST/AS/MENU - [LAMBDA (NODELST POS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* finds the node that is closest to - POS) - (for N in NODELST bind (X _ (fetch XCOORD of POS)) - (Y _ (fetch YCOORD of POS)) - T1 T2 - thereis (AND (ILESSP [IDIFFERENCE (SETQ T1 (fetch YCOORD of (fetch - (GRAPHNODE - NODEPOSITION) - of N))) - (SETQ T2 (HALF (fetch (GRAPHNODE NODEHEIGHT) of N] - Y) - (ILESSP Y (IPLUS T1 T2)) - (ILESSP [IDIFFERENCE (SETQ T1 (fetch XCOORD of (fetch - (GRAPHNODE - NODEPOSITION) - of N))) - (SETQ T2 (HALF (fetch (GRAPHNODE NODEWIDTH) of N] - X) - (ILESSP X (IPLUS T1 T2]) (NODEREGION - [LAMBDA (NODE) (* kvl "10-Aug-84 17:25") - (* returns the region taken up by - NODE) - (CREATEREGION (GN/LEFT NODE) - (GN/BOTTOM NODE) - (fetch (GRAPHNODE NODEWIDTH) of NODE) - (fetch (GRAPHNODE NODEHEIGHT) of NODE]) (PRINTDISPLAYNODE - [LAMBDA (NODE TRANS STREAM CLIP/REG) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* ; "Edited 12-Aug-88 12:58 by sye") - - (* ;; "prints a node at its position translated by TRANS. Takes the operation from the stream so that when editor has set the operation to invert, this may erase as well as draw; but when the operation is paint, then nodes obliterate any link lines that they are drawn over.") - - (OR (ZEROP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (PROG* [(LABEL (fetch (GRAPHNODE NODELABEL) of NODE)) - (LEFT (IPLUS (fetch (POSITION XCOORD) of TRANS) - (GN/LEFT NODE))) - (BOTTOM (IPLUS (fetch (POSITION YCOORD) of TRANS) - (GN/BOTTOM NODE))) - (WIDTH (fetch (GRAPHNODE NODEWIDTH) of NODE)) - (HEIGHT (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (FONT (fetch (GRAPHNODE NODEFONT) of NODE)) - (NBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE] - [AND (WINDOWP STREAM) - (SETQ STREAM (WINDOWPROP STREAM 'DSP] - (COND - ([AND CLIP/REG (NOT (INTERSECT/REGIONP/LBWH LEFT BOTTOM WIDTH HEIGHT CLIP/REG - 'PARTIAL] - (RETURN NODE)) - ((BITMAPP (fetch (GRAPHNODE NODELABELBITMAP) of NODE)) - (BITBLT (fetch (GRAPHNODE NODELABELBITMAP) of NODE) - 0 0 STREAM LEFT BOTTOM WIDTH HEIGHT 'INPUT)) - [(BITMAPP LABEL) - (COND - ((NEQ 0 NBW) - (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) - LEFT BOTTOM WIDTH HEIGHT STREAM) - (BITBLT LABEL 0 0 STREAM (IPLUS LEFT NBW) - (IPLUS BOTTOM NBW) - (BITMAPWIDTH LABEL) - (BITMAPHEIGHT LABEL) - 'INPUT)) - (T (BITBLT LABEL 0 0 STREAM LEFT BOTTOM WIDTH HEIGHT 'INPUT] - ((IMAGEOBJP LABEL) - (OR (ZEROP NBW) - (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) - LEFT BOTTOM WIDTH HEIGHT STREAM)) - - (* RMK--In order to place image objects properly, must take into account their - XKERN and YDESC) - - (LET ((IMAGEBOX (APPLY* (IMAGEOBJPROP LABEL 'IMAGEBOXFN) - LABEL STREAM 0 WIDTH))) - (* Formerly just LEFT and BOTTOM) - (MOVETO (IPLUS NBW LEFT (fetch XKERN of IMAGEBOX)) - (IPLUS NBW BOTTOM (fetch YDESC of IMAGEBOX)) - STREAM)) - - (* * End of modifications. RMK) - - (APPLY* (IMAGEOBJPROP LABEL 'DISPLAYFN) - LABEL STREAM)) - ((EQ FONT 'SHADE) (* so small just use texture) - (LET [(2SCALE (ITIMES 2 (DSPSCALE NIL STREAM] - (BLTSHADE BLACKSHADE STREAM LEFT BOTTOM 2SCALE 2SCALE))) - ((NULL FONT)) - (T (OR (FONTP FONT) - (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM))) - (AND (NEQ NBW 0) - (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) - LEFT BOTTOM WIDTH HEIGHT STREAM)) - (DSPFONT FONT STREAM) - (GRAPHER/CENTERPRINTINAREA LABEL LEFT BOTTOM WIDTH HEIGHT STREAM) - (AND (fetch (GRAPHNODE NODELABELSHADE) of NODE) - (FILL/GRAPHNODE/LABEL (fetch (GRAPHNODE NODELABELSHADE) - of NODE) - LEFT BOTTOM WIDTH HEIGHT NBW STREAM)) - (COND - ((AND CACHE/NODE/LABEL/BITMAPS (DISPLAYSTREAMP STREAM) - CLIP/REG - (INTERSECT/REGIONP/LBWH LEFT BOTTOM WIDTH HEIGHT CLIP/REG - 'WHOLE)) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with (BITMAPCREATE - WIDTH HEIGHT) - ) - (BITBLT STREAM LEFT BOTTOM (fetch (GRAPHNODE NODELABELBITMAP) - of NODE) - 0 0 WIDTH HEIGHT 'INPUT]) (PROMPTINWINDOW - [LAMBDA (PROMPTSTR POSITION WHICHCORNER BORDERSIZE) (* jds "18-Mar-86 17:49") - (* opens a small window for - prompting at a position and - PROMPTFORWORD's a word.) - - (* POSITION is the location in screen coordinate of the window. - Default is the cursor position.) - - (* WHICHCORNER can be a list of up to two of the atoms LEFT RIGHT TOP BOTTOM - which specify which corner position is intended to be. - Default is lower left.) - (* BORDERSIZE is the border size of - the prompt window. - Default is 6.0) - (PROG ((PROMPTWBORDER (OR (NUMBERP BORDERSIZE) - 6)) - (X (COND - (POSITION (fetch (POSITION XCOORD) of POSITION)) - (T LASTMOUSEX))) - (Y (COND - (POSITION (fetch (POSITION YCOORD) of POSITION)) - (T LASTMOUSEY))) - HGHT WDTH READSTR PREVTTY) - (SETQ HGHT (HEIGHTIFWINDOW (ITIMES (FONTPROP (DEFAULTFONT 'DISPLAY) - 'HEIGHT) - 2) - T PROMPTWBORDER)) - (SETQ WDTH (WIDTHIFWINDOW (IMAX (STRINGWIDTH PROMPTSTR WindowTitleDisplayStream) - 60) - PROMPTWBORDER)) - (SETQ PREVTTY (CREATEW (CREATEREGION (COND - ((MEMB 'RIGHT WHICHCORNER) - (DIFFERENCE X WDTH)) - (T X)) - (COND - ((MEMB 'TOP WHICHCORNER) - (DIFFERENCE Y HGHT)) - (T Y)) - WDTH HGHT) - PROMPTSTR PROMPTWBORDER)) - (DSPLEFTMARGIN (IMAX 0 (fetch (CURSOR CUHOTSPOTX) of (CARET))) - PREVTTY) - (MOVETOUPPERLEFT PREVTTY) - [SETQ READSTR (ERSETQ (PROMPTFORWORD NIL NIL NIL PREVTTY NIL NIL (LIST (CHARCODE EOL] - (CLOSEW PREVTTY) - (RETURN (COND - (READSTR (CAR READSTR)) - (T (* pass back the error.) - (ERROR!]) (READ/NODE - [LAMBDA (NODES DS) (* ; "Edited 23-Jul-87 18:20 by sye") - - (* * rht 8/20/85%: Modified "until" statement so it waits till user clicks - inside of window.) - - [bind (CR _ (DSPCLIPPINGREGION NIL DS)) until (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) - (INSIDEP CR (CURSORPOSITION NIL DS] - (PROG (NEAR NOW OLDPOS) - [SETQ NEAR (NODELST/AS/MENU NODES (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (* turn off old flip - (if one) and turn on new flip.) - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (COND - ((MOUSESTATE UP) - (AND NOW (FLIPNODE NOW DS)) - (RETURN NOW)) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODES (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP]) (REDISPLAYGRAPH - [LAMBDA (WINDOW REGION) (* kvl "10-Aug-84 19:52") - - (* displays the graph that is in a window. - REGION if given is the clipping region. - Later this could be used to make things run faster.) - - (DSPFILL NIL NIL 'REPLACE WINDOW) - (DISPLAYGRAPH (WINDOWPROP WINDOW 'GRAPH) - WINDOW - (OR REGION (DSPCLIPPINGREGION NIL WINDOW]) (REMOVETONODES - [LAMBDA (TOND TONODES) (* rht%: " 4-Apr-85 19:32") - - (* * Removes either TOND or a paramlist thingie for TOND.) - - (for Z in TONODES unless [OR (EQ Z TOND) - (AND (LISTP Z) - (EQ (CAR Z) - 'Link% Parameters) - (EQ TOND (CADR Z] collect Z]) (RESET/NODE/BORDER - [LAMBDA (NODE BORDER STREAM GRAPH TRANS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* ;; "gives the node a new border, and displays it if there is a stream. Might not be a stream if being called just to finagle a graph datastructure.") - - (PROG [(ONBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE] - [OR TRANS (SETQ TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0] - (COND - (STREAM (ERASE/GRAPHNODE NODE STREAM TRANS) - [OR GRAPH (AND (WINDOWP STREAM) - (SETQ GRAPH (WINDOWPROP STREAM 'GRAPH] - (DISPLAYNODELINKS NODE TRANS STREAM GRAPH))) - (replace (GRAPHNODE NODEBORDER) of NODE with (COND - ((EQ BORDER 'INVERT) - (INVERTED/GRAPHNODE/BORDER - (fetch (GRAPHNODE - NODEBORDER) - of NODE))) - (T BORDER))) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (OR (IEQP ONBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE))) - (SET/LABEL/SIZE NODE T)) - (AND STREAM (DISPLAYNODE NODE TRANS STREAM GRAPH)) - (RETURN NODE]) (RESET/NODE/LABELSHADE - [LAMBDA (NODE SHADE STREAM TRANS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* gives the node a new SHADE and - displays it if there is a stream) - (AND STREAM (ERASE/GRAPHNODE NODE STREAM TRANS)) - (replace (GRAPHNODE NODELABELSHADE) of NODE with (COND - ((EQ SHADE 'INVERT) - (INVERTED/SHADE/FOR/GRAPHER - (fetch (GRAPHNODE - NODELABELSHADE - ) - of NODE))) - (T SHADE))) - (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) - (AND STREAM (PRINTDISPLAYNODE NODE (OR TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0))) - STREAM - (DSPCLIPPINGREGION NIL STREAM))) - NODE]) (SCALE/GRAPH - [LAMBDA (GRAPH STREAM) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - - (* ;; "Scale the graph GRAPH so it'll look right when rendered on the image stream STREAM. This involves both scaling all the coordinates, and fixing node positions (because we keep track of teh CENTER of each node, even though we really want the lower, left corner to be in the right place).") - - (LET ((SCALE (DSPSCALE NIL STREAM)) - [LAYOUT-IS-VERTICAL (EQMEMB 'VERTICAL (LISTGET (fetch (GRAPH GRAPH.PROPS) of GRAPH) - 'FORMAT] - HEIGHT WIDTH) - (create GRAPH - using - GRAPH GRAPHNODES _ - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - collect - - (* ;; "Move each node to its new position.") - - (* ;; "Start by finding the node's lower, left corner, then scaling that.") - - (SETQ WIDTH (fetch (GRAPHNODE NODEWIDTH) of N)) - (SETQ HEIGHT (fetch (GRAPHNODE NODEHEIGHT) of N)) - (SETQ N (create GRAPHNODE - using - N NODEPOSITION _ - [COND - [LAYOUT-IS-VERTICAL - - (* ;; "Layout is vertical, so make the center correct.") - - (create POSITION - XCOORD _ [FIXR (FTIMES SCALE (fetch XCOORD - of (fetch - (GRAPHNODE - NODEPOSITION - ) - of N] - YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD - of (fetch - (GRAPHNODE - NODEPOSITION - ) - of N] - (T - (* ;; "Horizontal layout, so make the left bottom correct.") - - (create POSITION - XCOORD _ [FIXR (FTIMES SCALE - (IDIFFERENCE - (fetch XCOORD - of (fetch (GRAPHNODE - - NODEPOSITION - ) - of N)) - (LRSH WIDTH 1] - YCOORD _ (FIXR (FTIMES SCALE - (IDIFFERENCE - (fetch YCOORD - of (fetch (GRAPHNODE - - NODEPOSITION - ) - of N)) - (LRSH HEIGHT 1] - NODEWIDTH _ NIL NODEHEIGHT _ NIL NODEFONT _ - (FONTCREATE (fetch (GRAPHNODE NODEFONT) - N) - NIL NIL NIL STREAM) - TONODES _ (SCALE/TONODES N SCALE) - NODEBORDER _ (SCALE/GRAPHNODE/BORDER (fetch (GRAPHNODE - NODEBORDER - ) - of N) - SCALE))) - - (* ;; "Now figure out the new width & height of the node:") - - (SET/LABEL/SIZE N NIL STREAM) - - (* ;; "Now find the new center point, so the node prints in the right place:") - - [COND - ((NOT LAYOUT-IS-VERTICAL) - - (* ;; "Only do this if the layout is horizontal.") - - (add (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) - of N)) - (LRSH (fetch (GRAPHNODE NODEHEIGHT) of N) - 1)) - (add (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) - of N)) - (LRSH (fetch (GRAPHNODE NODEWIDTH) of N) - 1] - N]) (SCALE/GRAPHNODE/BORDER - [LAMBDA (BORDER SCALE) (* kvl " 5-Sep-84 18:06") - (* returns a new setting for the - border appropriate for the given - SCALE) - (COND - ((NULL BORDER) - 0) - ((EQ BORDER T) - (FIXR (FTIMES SCALE NODEBORDERWIDTH))) - ((FIXP BORDER) - (FIXR (FTIMES SCALE BORDER))) - ((AND (LISTP BORDER) - (FIXP (CAR BORDER))) - (CONS (FIXR (FTIMES SCALE (CAR BORDER))) - (CDR BORDER]) (SCALE/TONODES - [LAMBDA (NODE SCALE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (for NODEID in (fetch (GRAPHNODE TONODES) of NODE) - collect (* copy the property list so that - the scaling doesn't change the - original.) - (COND - [(AND (LISTP NODEID) - (EQ 'Link% Parameters (CAR NODEID)) - (SETQ NODEID (APPEND NODEID)) - (for prop val in ScalableLinkParameters - do (AND (SETQ val (LISTGET NODEID prop)) - (LISTPUT NODEID prop (FIX/SCALE val SCALE] - (T NODEID]) (SET/LABEL/SIZE - [LAMBDA (NODE RESET/FLG STREAM) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* the SHADE and null font stuff is - for ZOOMGRAPH) - (OR (AND (NOT RESET/FLG) - (FIXP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) - (FIXP (fetch (GRAPHNODE NODEWIDTH) of NODE))) - (PROG ((SCALE (DSPSCALE NIL STREAM)) - (FONT (fetch (GRAPHNODE NODEFONT) of NODE)) - (LAB (fetch (GRAPHNODE NODELABEL) of NODE)) - (NBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE))) - WIDTH HEIGHT) - [COND - [(BITMAPP LAB) (* (* ; - "set up appropriate width & height by checking the scale of stream")) - (SETQ WIDTH (OR [AND (NEQ SCALE 1) - (FIXR (FTIMES SCALE (BITMAPWIDTH LAB] - (BITMAPWIDTH LAB))) - (SETQ HEIGHT (OR [AND (NEQ SCALE 1) - (FIXR (FTIMES SCALE (BITMAPHEIGHT LAB] - (BITMAPHEIGHT LAB] - ((IMAGEOBJP LAB) - (SETQ WIDTH (APPLY* (IMAGEOBJPROP LAB 'IMAGEBOXFN) - LAB STREAM)) - (SETQ HEIGHT (fetch (IMAGEBOX YSIZE) of WIDTH)) - (SETQ WIDTH (fetch (IMAGEBOX XSIZE) of WIDTH))) - ((EQ FONT 'SHADE) (* node image is very small) - (SETQ WIDTH (SETQ HEIGHT 2))) - [(NULL FONT) (* FONT of NIL means that the node - is smaller than displays) - (SETQ NBW (SETQ WIDTH (SETQ HEIGHT 0] - (T (OR (FONTP FONT) - (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM))) - [SETQ WIDTH (IPLUS (STRINGWIDTH (fetch (GRAPHNODE NODELABEL) of NODE) - FONT) - (FONTPROP FONT 'DESCENT] - (SETQ HEIGHT (IPLUS (FONTPROP FONT 'HEIGHT) - (FONTPROP FONT 'DESCENT] - (OR (AND (NOT RESET/FLG) - (FIXP (fetch (GRAPHNODE NODEWIDTH) of NODE))) - (replace (GRAPHNODE NODEWIDTH) of NODE with (IPLUS WIDTH NBW NBW))) - (OR (AND (NOT RESET/FLG) - (FIXP (fetch (GRAPHNODE NODEHEIGHT) of NODE))) - (replace (GRAPHNODE NODEHEIGHT) of NODE with (IPLUS HEIGHT NBW NBW))) - (RETURN NODE]) (SET/LAYOUT/POSITION - [LAMBDA (NODE POS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* sets a nodes position) - (replace XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE) - with (fetch XCOORD of POS)) - (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE) - with (fetch YCOORD of POS)) - NODE]) (SHOWGRAPH - [LAMBDA (GRAPH WINDOW LEFTBUTTONFN MIDDLEBUTTONFN TOPJUSTIFYFLG ALLOWEDITFLG COPYBUTTONEVENTFN - CENTERFLG) (* ; "Edited 28-Sep-93 17:20 by jds") - - (* ;; "puts a graph in the given window, creating one if a window is not given.") - - (SETQ WINDOW (SIZE/GRAPH/WINDOW (COND - ((NULL GRAPH) - (SETQ GRAPH (create GRAPH))) - (T GRAPH)) - (COND - (WINDOW) - (ALLOWEDITFLG (* ; - "put on a title so there will be a place to get window commands.") - "Graph Editor Window")) - TOPJUSTIFYFLG CENTERFLG)) - (WINDOWPROP WINDOW 'GRAPH GRAPH) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION HARDCOPYGRAPH)) - (COND - (ALLOWEDITFLG (* ; - "change the mode to invert so lines can be erased by being redrawn.") - (DSPOPERATION 'INVERT WINDOW) - (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION GRAPHEDITEVENTFN))) - (T (WINDOWPROP WINDOW 'RIGHTBUTTONFN NIL))) - (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (OR COPYBUTTONEVENTFN (FUNCTION GRAPHERCOPYBUTTONEVENTFN))) - (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION APPLYTOSELECTEDNODE)) - (WINDOWPROP WINDOW 'BROWSER/LEFTFN LEFTBUTTONFN) - (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN MIDDLEBUTTONFN) - (REDISPLAYGRAPH WINDOW) - WINDOW]) (SIZE/GRAPH/WINDOW - [LAMBDA (GRAPH WINDOW/TITLE TOPJUSTIFYFLG CENTERFLG) (* ; "Edited 28-Sep-93 17:21 by jds") - - (* ;; "returns a window sized to fit the given graph. WINDOW/TITLE can be either a window to be printed in or a title of a window to be created. If TOPJUSTIFYFLG is true, scrolls so top of graph is at top of window, else puts bottom of graph at bottom of window.") - - (PROG ((GRAPHREG (GRAPHREGION GRAPH)) - TITLE WINDOW) - (COND - ((WINDOWP WINDOW/TITLE) - (SETQ WINDOW WINDOW/TITLE)) - (T (SETQ TITLE WINDOW/TITLE))) - - (* ;; "if there is not already a window, ask the user for one to fit.") - - (COND - ((NULL WINDOW) - (SETQ WINDOW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (IMIN (IMAX (fetch (REGION - WIDTH) - of GRAPHREG) - 100) - (FIXR (CAR - DEFAULT.GRAPH.WINDOWSIZE - )) - SCREENWIDTH)) - (HEIGHTIFWINDOW (IMIN (IMAX (fetch (REGION HEIGHT) - of GRAPHREG) - 60) - (FIXR (CADR DEFAULT.GRAPH.WINDOWSIZE - )) - SCREENHEIGHT) - TITLE)) - TITLE))) - (T (CLEARW WINDOW))) - (WINDOWPROP WINDOW 'EXTENT GRAPHREG) - (WXOFFSET [COND - [CENTERFLG (IDIFFERENCE (WXOFFSET NIL WINDOW) - (IDIFFERENCE (IPLUS (fetch (REGION LEFT) of GRAPHREG - ) - (LRSH (fetch (REGION WIDTH) - of GRAPHREG) - 1)) - (LRSH (WINDOWPROP WINDOW 'WIDTH) - 1] - (T (* ; "Put it at the left edge.") - (IDIFFERENCE (WXOFFSET NIL WINDOW) - (fetch (REGION LEFT) of GRAPHREG] - WINDOW) - (WYOFFSET [IDIFFERENCE (WYOFFSET NIL WINDOW) - (COND - [TOPJUSTIFYFLG (IDIFFERENCE (fetch (REGION PTOP) of GRAPHREG) - (WINDOWPROP WINDOW 'HEIGHT] - (T (fetch (REGION BOTTOM) of GRAPHREG] - WINDOW) - (RETURN WINDOW]) (TOGGLE/DIRECTEDFLG - [LAMBDA (WIN) (* kvl "20-APR-82 13:38") - (* flips the value of the flag that - indicates whether the graph is a - lattice.) - [replace (GRAPH DIRECTEDFLG) of (WINDOWPROP WIN 'GRAPH) - with (NOT (fetch (GRAPH DIRECTEDFLG) of (WINDOWPROP WIN 'GRAPH] - (DSPFILL NIL (DSPTEXTURE NIL WIN) - 'REPLACE WIN) - (REDISPLAYGRAPH WIN]) (TOGGLE/SIDESFLG - [LAMBDA (WIN) (* kvl "20-APR-82 13:15") - - (* flips the value of the flag that indicates whether the graph is to be layed - out vertically or horizontally.) - - [replace (GRAPH SIDESFLG) of (WINDOWPROP WIN 'GRAPH) - with (NOT (fetch (GRAPH SIDESFLG) of (WINDOWPROP WIN 'GRAPH] - (DSPFILL NIL (DSPTEXTURE NIL WIN) - 'REPLACE WIN) - (REDISPLAYGRAPH WIN]) (TOLINKS - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (fetch (GRAPHNODE TONODES) of NODE]) (TRACKCURSOR - [LAMBDA (ND DS GRAPH) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* causes ND to follow cursor.) - (PROG (OLDPOS ORIGPOS DOWNFLG) (* maybe there aren't any nodes) - (OR ND (RETURN)) - (SETQ ORIGPOS (create POSITION using (fetch (GRAPHNODE NODEPOSITION) - of ND))) - (SETQ OLDPOS (CURSORPOSITION (fetch (GRAPHNODE NODEPOSITION) of ND) - DS)) - (FLIPNODE ND DS) - (until (COND - (DOWNFLG (MOUSESTATE UP)) - ((SETQ DOWNFLG (MOUSESTATE (NOT UP))) - NIL)) do (MOVENODE ND (fetch (GRAPHNODE NODEPOSITION) - of ND) - (CURSORPOSITION NIL DS OLDPOS) - GRAPH DS)) - (FLIPNODE ND DS) - (COND - ([NOT (EQUAL ORIGPOS (SETQ OLDPOS (fetch (GRAPHNODE NODEPOSITION) of ND] - (EXTENDEXTENT (WFROMDS DS) - (NODEREGION ND)) - (CALL.MOVENODEFN ND OLDPOS GRAPH (WFROMDS DS) - ORIGPOS]) (TRACKNODE - [LAMBDA (W) (* ; "Edited 17-Jul-87 15:26 by sye") - - (* grabs the nearest nodes and hauls it around with the cursor, leaving it - where it is when the button goes up.) - - (TRACKCURSOR (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES) of (WINDOWPROP - W - 'GRAPH)) - (CURSORPOSITION NIL W)) - (WINDOWPROP W 'DSP) - (WINDOWPROP W 'GRAPH]) (TRANSGRAPH - [LAMBDA (GRAPH X Y) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (create GRAPH reusing GRAPH GRAPHNODES _ - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - collect (create GRAPHNODE - reusing N NODEPOSITION _ - (create POSITION - XCOORD _ (PLUS X - (fetch XCOORD - of - (fetch (GRAPHNODE - NODEPOSITION - ) - of N))) - YCOORD _ (PLUS Y - (fetch YCOORD - of - (fetch (GRAPHNODE - NODEPOSITION - ) - of N]) ) (* ;; "Support for EDITSUBGRAPH and EDITREGION") (DEFINEQ (EDITMOVEREGION - [LAMBDA (Window) (* Newman "27-Jan-87 11:08") - - (* * This function moves all the nodes within a selected region to another - region of similar shape and size.) - - (if (NOT (WINDOWP Window)) - then (ERROR Window " not a window.") - else (PROMPTPRINT " Select the region containing the nodes you wish to move.") - (PROG* ((DisplayStream (WINDOWPROP Window 'DSP)) - (Region (GETWREGION Window)) - (Graph (WINDOWPROP Window 'GRAPH)) - (NodeList (for Node in (fetch (GRAPH GRAPHNODES) of Graph) - when (OR (INTERSECTREGIONS Region (NODEREGION Node)) - (SUBREGIONP Region (NODEREGION Node))) collect - Node))) - (if (NULL Graph) - then (ERROR Window " not a graph window.") - elseif (NULL NodeList) - then (PROMPTPRINT "No nodes in the region selected.")) - (for Node in NodeList do (FLIPNODE Node DisplayStream)) - (bind OldPos (NewRegionPosition _ (GETBOXPOSITION.FROMINITIALREGION Window - Region DisplayStream)) for - SelectedNode - in NodeList eachtime (SETQ OldPos (fetch (GRAPHNODE NODEPOSITION) - of SelectedNode)) - do (MOVENODE SelectedNode OldPos (CREATE.NEW.NODEPOSITION - SelectedNode - (DIFFERENCE (fetch (POSITION - XCOORD) - of - NewRegionPosition - ) - (fetch (REGION LEFT) - of Region)) - (DIFFERENCE (fetch (POSITION - YCOORD) - of - NewRegionPosition - ) - (fetch (REGION BOTTOM) - of Region))) - Graph DisplayStream) - (EXTENDEXTENT (WFROMDS DisplayStream) - (NODEREGION SelectedNode)) - (* extent the graph extent because - the node may be outside the old - extent.) - (FLIPNODE SelectedNode DisplayStream]) (EDITMOVESUBTREE - [LAMBDA (WINDOW) (* Newman "27-Jan-87 11:10") - - (* * Code derived from EDITMOVENODE by Richard Burton. - Changes to prompt strings, and changes the to TRACKCURSOR to a call to - NOT.TRACKCURSOR) - (* hilite nodes until the cursor - goes down then move it) - (PROG ((DS (WINDOWPROP WINDOW 'DSP)) - (REG (WINDOWPROP WINDOW 'REGION)) - (GRAPH (WINDOWPROP WINDOW 'GRAPH)) - OLDPOS NOW NEAR NODELST) - (COND - (GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) - (T (RETURN))) - (printout PROMPTWINDOW T "Move the cursor to the node " "that is the common root of " - "the subtree you want to move " "and press any button.") - [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] - FLIP - (AND NOW (FLIPNODE NOW DS)) - (AND NEAR (FLIPNODE NEAR DS)) - (SETQ NOW NEAR) - LP (GETMOUSESTATE) - (COND - ((LASTMOUSESTATE (NOT UP)) (* button up, process it.) - (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) - ) - ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] - (GO LP)) - (T (GO FLIP))) - (printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position" - "and release the button.") - (NOT.TRACKCURSOR NOW DS GRAPH) - (printout PROMPTWINDOW T "Done."]) (NOT.TRACKCURSOR - [LAMBDA (Node DisplayStream Graph) (* ; "Edited 3-Aug-88 14:50 by pmi") - - (* ;; "Gets an old, and a new region from the user, and uses these to calculate all the new positions for all the children of Node.") - - (* ;; - "rht 4/28/87: Changed from APPLY of UNIONREGIONS to for loop doing successive UNIONREGIONS calls.") - - (* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.") - - (if (NULL Node) - then (PROMPTPRINT "No node selected.") - else (PROG* ((Children (COLLECTDESCENDENTS Node Graph)) - (OldRegion (for EachNode in (CONS Node Children) - bind (TotalRegion _ (NODEREGION Node)) - do (FLIPNODE EachNode DisplayStream) - (SETQ TotalRegion (UNIONREGIONS TotalRegion (NODEREGION - EachNode))) - finally (RETURN TotalRegion))) - (NewRegionPosition (GETBOXPOSITION.FROMINITIALREGION (WFROMDS - DisplayStream) - OldRegion DisplayStream)) - (deltaX (DIFFERENCE (fetch (POSITION XCOORD) of NewRegionPosition) - (fetch (REGION LEFT) of OldRegion))) - (deltaY (DIFFERENCE (fetch (POSITION YCOORD) of NewRegionPosition) - (fetch (REGION BOTTOM) of OldRegion))) - (OldPos (fetch (GRAPHNODE NODEPOSITION) of Node)) - (NewPos (CREATE.NEW.NODEPOSITION Node deltaX deltaY))) - [if (NOT (EQUAL OldPos NewPos)) - then (MOVENODE Node OldPos NewPos Graph DisplayStream) - (EXTENDEXTENT (WFROMDS DisplayStream) - (NODEREGION Node)) - (CALL.MOVENODEFN Node OldPos Graph (WFROMDS DisplayStream) - NewPos) - (if Children - then (PROG [(MovedNodes (LIST (fetch (GRAPHNODE NODEID) - of Node] - (MOVEDESCENDENTS Graph Node DisplayStream - deltaX deltaY] - (for EachNode in (CONS Node Children) do (FLIPNODE EachNode - DisplayStream]) (RECURSIVE.COLLECTDESCENDENTS - [LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 16:06 by pmi") - - (* ;; "Collect all descendents of Node in Graph.") - - (* ;; - "pmi 8/2/88: Changed to break infinite recursion on circular graphs. Now marks nodes as visited.") - - (* ;; "pmi 8/5/88: FIxes bug introduced by previous fix.") - - (LET (NodeId) - - (* ;; "Node's NODEID may be a list if it is a virtual node. ") - - (if (LISTP (SETQ NodeId (fetch (GRAPHNODE NODEID) of Node))) - then (SETQ NodeId (CAR NodeId))) - (NC.GraphNodeIDPutProp NodeId 'Visited T) - (for ChildNode in (COLLECT.CHILD.NODES Node Graph) bind ChildNodeID - when [PROGN (SETQ ChildNodeID (fetch (GRAPHNODE NODEID) of ChildNode)) - - (* ;; "This node has not been visited, and it is not a virtual node.") - - (NOT (NC.GraphNodeIDGetProp (if (LISTP ChildNodeID) - then (CAR ChildNodeID) - else ChildNodeID) - 'Visited] join (CONS ChildNode ( - RECURSIVE.COLLECTDESCENDENTS - ChildNode Graph]) (MOVEDESCENDENTS - [LAMBDA (Graph Node DisplayStream deltaX deltaY) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* ;; "Moves Node and all Children of Node by deltaX and deltaY.") - - (* ;; "first, finds all descendents of Node. For each of these, create a new position based on the old and the deltas. Then, if the child has not been moved yet, we add it to the list of moved nodes, move the node, and call the MOVENODEFN,") - - (* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.") - - (bind (MovedNodes _ (LIST Node)) - NewPos for Child in (COLLECTDESCENDENTS Node Graph) - eachtime (SETQ NewPos (CREATE.NEW.NODEPOSITION Child deltaX deltaY)) - unless (MEMBER (fetch (GRAPHNODE NODEID) of Child) - MovedNodes) do (SETQ MovedNodes (CONS (fetch (GRAPHNODE NODEID) - of Child) - MovedNodes)) - (MOVENODE Child (fetch (GRAPHNODE NODEPOSITION) - of Child) - NewPos Graph DisplayStream) - (EXTENDEXTENT (WFROMDS DisplayStream) - (NODEREGION Child)) - - (* ;; "we must call EXTENDEXTENT to extend the graph extent in case we have moved a node outside the previous extent.") - - (CALL.MOVENODEFN Child NewPos Graph (WFROMDS - DisplayStream - ) - (fetch (GRAPHNODE NODEPOSITION) of Child]) (COLLECT.CHILD.NODES - [LAMBDA (Node Graph) (* Newman "27-Jan-87 11:16") - - (* * collect all immediate children (only one generation) of Node in Graph.) - - (bind (GraphNodes _ (fetch (GRAPH GRAPHNODES) of Graph)) for NodeID - in (fetch (GRAPHNODE TONODES) of Node) collect - (* ??? (ASSOC (if (AND - (LISTP NodeID) (EQUAL - (CAR NodeID) (QUOTE Link% Parameters))) - then (* Special case where the - second item in the list is the - NodeID) (CADR NodeID) else NodeID) - GraphNodes)) - (GETNODEFROMID NodeID GraphNodes]) (CREATE.NEW.NODEPOSITION - [LAMBDA (Node deltaX deltaY) (* Newman "27-Jan-87 11:06") - - (* * Creates a new position for Node by adding deltaX and deltaY to the - appropriate coordinates.) - - (PROG ((OldPos (fetch (GRAPHNODE NODEPOSITION) of Node))) - (RETURN (create POSITION - XCOORD _ (PLUS deltaX (fetch (POSITION XCOORD) of OldPos)) - YCOORD _ (PLUS deltaY (fetch (POSITION YCOORD) of OldPos]) (GETBOXPOSITION.FROMINITIALREGION - [LAMBDA (Window Region DisplayStream) (* Newman "26-Jan-87 11:38") - - (* * This function obtains a new region from the user, and it prompts the user - using the region passed in as Region. DisplayStream is the displaystream of - Window, and Region is considered to be a region within Window. - This function was written to be called from EDITMOVEREGION.) - - (* All of the garbage below to calculate the third and fourth arguments to - GETBOXPOSITION exists to put the ghost box prompting the user in exactly the - same place as the region passed in.) - - (GETBOXPOSITION (fetch (REGION WIDTH) of Region) - (fetch (REGION HEIGHT) of Region) - (DIFFERENCE (PLUS (fetch (REGION LEFT) of Region) - (fetch (REGION LEFT) of (WINDOWPROP Window 'REGION)) - (WINDOWPROP Window 'BORDER)) - (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL DisplayStream))) - (DIFFERENCE (PLUS (fetch (REGION BOTTOM) of Region) - (fetch (REGION BOTTOM) of (WINDOWPROP Window 'REGION)) - (WINDOWPROP Window 'BORDER)) - (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL DisplayStream))) - Window "Select new region for nodes."]) (COLLECTDESCENDENTS - [LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 15:40 by pmi") - - (* ;; "pmi 8/3/88: Created to wrap RESETLST around call to RECURSIVE.COLLECTDESCENDENTS. Prevents infinite looping on circular graph structures by marking where we have been.") - - (* ;; "Clean up the Visited markers placed on the nodes traversed.") - - (* ;; "pmi 8/5/88: Now also cleans up Visited marker on Node.") - - (LET (NodeID Descendents) - (RESETLST - [RESETSAVE NIL - '(PROGN (for VisitedNode in (CONS Node Descendents) bind - VisitedNodeID - do (NC.GraphNodeIDPutProp - (if (LISTP (SETQ VisitedNodeID (fetch (GRAPHNODE - NODEID) - of VisitedNode))) - then (CAR VisitedNodeID) - else VisitedNodeID) - 'Visited NIL] - (SETQ Descendents (RECURSIVE.COLLECTDESCENDENTS Node Graph)))]) ) (* ; "functions for finding larger and smaller fonts") (DEFINEQ (NEXTSIZEFONT - [LAMBDA (WHICHDIR NOWFONT) (* rmk%: "15-Sep-84 00:14") - - (* returns the next sized font either SMALLER or LARGER that on of size FONT. - (NEXTSIZEFONT (QUOTE LARGER) DEFAULTFONT)) - - (PROG [(NOWSIZE (FONTPROP NOWFONT 'HEIGHT] - (RETURN (COND - [(EQ WHICHDIR 'LARGER) - (COND - ((IGEQ NOWSIZE (FONTPROP (CAR DECREASING.FONT.LIST) - 'HEIGHT)) (* nothing larger) - NIL) - (T (for FONTTAIL on DECREASING.FONT.LIST - when [AND (CDR FONTTAIL) - (IGEQ NOWSIZE (FONTPROP (CADR FONTTAIL) - 'HEIGHT] - do (RETURN (FONTNAMELIST (CAR FONTTAIL] - (T (for FONT in DECREASING.FONT.LIST - when (LESSP (FONTPROP FONT 'HEIGHT) - NOWSIZE) do (RETURN (FONTNAMELIST FONT]) (DECREASING.FONT.LIST - [LAMBDA NIL (* rrb "16-Dec-83 12:28") - - (* returns a list of the font descriptors for the fonts sketch windows are - willing to print in.) - - (for SIZE in '(18 14 12 10 8 5) collect (FONTCREATE 'HELVETICA SIZE]) (SCALE.FONT - [LAMBDA (WID STR) (* rrb " 7-NOV-83 11:35") - - (* returns the font that text should be printed in to have the text STR fit - into a region WID points wide) - - (COND - ((GREATERP WID (TIMES (STRINGWIDTH STR (CAR DECREASING.FONT.LIST)) - 1.5)) (* scale it too large for even the - largest font.) - NIL) - (T (for FONT in DECREASING.FONT.LIST when (NOT (GREATERP (STRINGWIDTH STR FONT) - WID)) - do (RETURN FONT) finally (RETURN 'SHADE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ DECREASING.FONT.LIST (DECREASING.FONT.LIST)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DECREASING.FONT.LIST) ) (* ; "functions for LAYOUTGRAPH And LAYOUTLATTICE") (DEFINEQ (BRH/LAYOUT - [LAMBDA (N X Y MOMLST GN) (* kvl "26-DEC-83 16:44") - - (* X and Y are the lower left corner of the box that will surround the tree - headed by the browsenode N. MOMLST is the mother node inside a cons cell. - GN is the graphnode for the nodeid N. It is crucial that the NODEPOSITION be - set before recursion because this marks that the node has been - (is being) laid out already. BRH/OFFSET is used to raise the daughters in those - rare cases where the label is bigger than the daughters.) - - (DECLARE (USEDFREE MOTHERD PERSONALD NODELST)) - (PROG ((DS (fetch (GRAPHNODE TONODES) of GN)) - (W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (YHEIGHT (IPLUS PERSONALD (fetch (GRAPHNODE NODEHEIGHT) of GN))) - DHEIGHT) - (replace (GRAPHNODE FROMNODES) of GN with MOMLST) - [replace (GRAPHNODE NODEPOSITION) of GN with (create POSITION - XCOORD _ - (IPLUS X (HALF W] - (COND - ((NULL DS)) - [[IGREATERP YHEIGHT (SETQ DHEIGHT (BRH/LAYOUT/DAUGHTERS DS (IPLUS X W MOTHERD) - Y - (LIST N] - (BRH/OFFSET DS (HALF (IDIFFERENCE YHEIGHT DHEIGHT] - (T (SETQ YHEIGHT DHEIGHT))) - (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) - with (IPLUS Y (HALF YHEIGHT))) - (RETURN YHEIGHT]) (BRH/LAYOUT/DAUGHTERS - [LAMBDA (DS X Y MOMLST) (* rmk%: " 5-Feb-84 15:01") - - (* DS are the daughters of (CAR MOMLST)%. - X is where the left edge of their labels will be, and Y is the bottom of the - mother's box. Returns the height of the mother's box. - Tests to see if a node has been layout out already If so, it replaces the - daughter with one that has no descendents, and splices into the mother's - daughter list, side-effecting the graphnode structure.) - - (DECLARE (USEDFREE NODELST)) - (for D (FLOOR _ Y) in DS do [SETQ FLOOR (IPLUS FLOOR (BRH/LAYOUT D X FLOOR MOMLST - (GETNODEFROMID D - NODELST] - finally (RETURN (IDIFFERENCE FLOOR Y]) (BRH/OFFSET - [LAMBDA (NODEIDS YINC) - (DECLARE (USEDFREE NODELST)) (* kvl "11-Dec-84 14:35") - (for N in NODEIDS do (SETQ N (GETNODEFROMID N NODELST)) - (add (fetch YCOORD of (fetch (GRAPHNODE - NODEPOSITION) - of N)) - YINC) - (BRH/OFFSET (fetch (GRAPHNODE TONODES) of N) - YINC]) (BRHC/INTERTREE/SPACE - [LAMBDA (TTC BTC) (* kvl "21-DEC-83 10:23") - - (* Given the top transition chain of the old daughter and the bottom transition - chain of the new daughter, where BTC is sitting on the bottom of the box, - calculate how much the bottom must be raised so that it just clears the TTC. - OP is the top left corner of some label. - NP is the bottom left corner.) - - (PROG ((RAISE -1000) - NP DIST OP) - (SETQ OP (pop TTC)) - (SETQ NP (pop BTC)) - L (SETQ DIST (IDIFFERENCE (fetch YCOORD of OP) - (fetch YCOORD of NP))) - (AND (IGREATERP DIST RAISE) - (SETQ RAISE DIST)) - [COND - ((NULL BTC) - (RETURN RAISE)) - ((NULL TTC) - (RETURN RAISE)) - ((IEQP (fetch XCOORD of (CAR BTC)) - (fetch XCOORD of (CAR TTC))) - (SETQ NP (pop BTC)) - (SETQ OP (pop TTC))) - ((ILESSP (fetch XCOORD of (CAR BTC)) - (fetch XCOORD of (CAR TTC))) - (SETQ NP (pop BTC))) - (T (SETQ OP (pop TTC] - (GO L]) (BRHC/LAYOUT - [LAMBDA (N X MOMLST GN) (* rmk%: " 5-Feb-84 14:47") - - (* See comment on BRH/LAYOUT. Instead of keeping only the graphnode in layed - out node's position field, keep the offset as well. - The offset is how much this nodes box must be raised relative to the inclosing - box. Uses two free variables to return transition chains. - RETURNTTC is the top left corners of all the labels. - RETURNBTC is the bottom left corners.) - - (DECLARE (USEDFREE PERSONALD RETURNTTC RETURNBTC)) - (PROG ((DS (fetch (GRAPHNODE TONODES) of GN)) - (W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (H (fetch (GRAPHNODE NODEHEIGHT) of GN)) - YCENTER X/SW H/2) - (SETQ H/2 (HALF H)) - (SETQ X/SW (IPLUS X W)) - (replace (GRAPHNODE FROMNODES) of GN with MOMLST) - (replace (GRAPHNODE NODEPOSITION) of GN with (LIST 0)) - [SETQ YCENTER (COND - (DS (BRHC/LAYOUT/DAUGHTERS DS X/SW (LIST N))) - (T (BRHC/LAYOUT/TERMINAL GN X/SW] - (RPLACD (fetch (GRAPHNODE NODEPOSITION) of GN) - (create POSITION - XCOORD _ (IPLUS X (HALF W)) - YCOORD _ YCENTER)) - [push RETURNTTC (create POSITION - XCOORD _ X - YCOORD _ (IPLUS PERSONALD (IPLUS (IDIFFERENCE YCENTER H/2) - H] - (push RETURNBTC (create POSITION - XCOORD _ X - YCOORD _ (IDIFFERENCE YCENTER H/2))) - (RETURN YCENTER]) (BRHC/LAYOUT/DAUGHTERS - [LAMBDA (DS X/SW MOMLST) - (DECLARE (USEDFREE MOTHERD FAMILYD NODELST RETURNTTC RETURNBTC)) - (* rmk%: " 5-Feb-84 14:52") - - (* see comment on BRH/LAYOUT/DAUGHTERS. - First daughter is always laid out on the bottom of the box. - Subsequent daughters have the amount that they are to be raised calculated by - comparing the top edge of the old daughter - (in TTC) with the bottom edge of the new daughter - (in RETURNBTC)%. TTC is update by adding the new daughter's transition chain to - the front, because the new daughter's front is guaranteed to be higher than the - old daughter's front. Conversely, BTC is updated by adding the new daughter's - transition chain to the back, because the old daughter's front is guaranteed to - be lower.) - - (for D in DS bind GN BTC TTC 1ST/DCENTER LST/DCENTER (OFFSET _ 0) - (X _ (IPLUS X/SW MOTHERD)) - do (SETQ GN (GETNODEFROMID D NODELST)) - (SETQ LST/DCENTER (BRHC/LAYOUT D X MOMLST GN)) - [COND - ((NULL TTC) (* first daughter) - (SETQ 1ST/DCENTER LST/DCENTER) - (SETQ TTC RETURNTTC) - (SETQ BTC RETURNBTC)) - (T (SETQ OFFSET (BRHC/INTERTREE/SPACE TTC RETURNBTC)) - (RPLACA (fetch (GRAPHNODE NODEPOSITION) of GN) - OFFSET) - (SETQ TTC (EXTEND/TRANSITION/CHAIN (RAISE/TRANSITION/CHAIN RETURNTTC - OFFSET) - TTC)) - (SETQ BTC (EXTEND/TRANSITION/CHAIN BTC (RAISE/TRANSITION/CHAIN RETURNBTC - OFFSET] - finally - - (* add a mythical top left corner at the height of the highest daughter because - diagnonal links are getting clobbered. Move lowest daughter's bottom left - corner to the left for the same reason.) - - (SETQ RETURNTTC (CONS (create POSITION - XCOORD _ X/SW - YCOORD _ (fetch YCOORD of (CAR TTC))) - TTC)) - (replace XCOORD of (CAR BTC) with X/SW) - (add (fetch YCOORD of (CAR TTC)) - FAMILYD) - (SETQ RETURNBTC BTC) - - (* center of mother is halfway between first and last daughter's label centers - using fact that offset of first daughter is zero and last daughter's offset is - OFFSET) - - (RETURN (HALF (IPLUS 1ST/DCENTER OFFSET LST/DCENTER]) (BRHC/LAYOUT/TERMINAL - [LAMBDA (GN X/SW) (* rmk%: " 3-Feb-84 09:55") - - (* initiallizes the transition chains to the right edge of the node label, and - returns the label's center.) - - (DECLARE (USEDFREE RETURNTTC RETURN/TBC)) - (SETQ RETURNTTC (LIST (create POSITION - XCOORD _ X/SW - YCOORD _ 0))) - [SETQ RETURNBTC (LIST (create POSITION - XCOORD _ X/SW - YCOORD _ (fetch (GRAPHNODE NODEHEIGHT) of GN] - (HALF (fetch (GRAPHNODE NODEHEIGHT) of GN]) (BRHC/OFFSET - [LAMBDA (N ABSY) (* dgb%: "22-Jan-85 07:17") - (* Adds in all the offsets. - See comment on - BRHC/LAYOUT/DAUGHTERS.) - (DECLARE (USEDFREE NODELST)) - (PROG ((GN (GETNODEFROMID N NODELST))) - [SETQ ABSY (IPLUS ABSY (pop (fetch (GRAPHNODE NODEPOSITION) of GN] - [replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) - with (IPLUS ABSY (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) - of GN] - (for D in (fetch (GRAPHNODE TONODES) of GN) do (BRHC/OFFSET D ABSY]) (BRHL/LAYOUT - [LAMBDA (N X Y MOMLST GN) (* kvl "26-DEC-83 16:36") - - (* X and Y are the lower left corner of the box that will surround the tree - headed by the browsenode N. MOMLST is the mother node inside a cons cell. - GN is the graphnode for the nodeid N. It is crucial that the NODEPOSITION be - set before recursion because this marks that the node has been laid out - already. If in addition, the YCOORD is NIL, then the node is still in the - process of being laid out. BRHL/LAYOUT/DAUGHTERS uses this fact to break loops - by inserting boxed nodes.) - - (DECLARE (USEDFREE MOTHERD PERSONALD NODELST)) - (COND - ((fetch (GRAPHNODE NODEPOSITION) of GN) - - (* This case only occurs if this node has been put in the roots list, and has - already been visited by recursion. Value won't be used) - - 0) - (T (PROG [(DS (fetch (GRAPHNODE TONODES) of GN)) - (W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (YHEIGHT (IPLUS PERSONALD (fetch (GRAPHNODE NODEHEIGHT) of GN] - (replace (GRAPHNODE FROMNODES) of GN with MOMLST) - (* This is first time for layout, so - set FROMNODES) - [replace (GRAPHNODE NODEPOSITION) of GN with (create - POSITION - XCOORD _ - (IPLUS X (HALF W] - (AND DS (SETQ YHEIGHT (IMAX (BRHL/LAYOUT/DAUGHTERS DS (IPLUS X W MOTHERD) - Y - (LIST N)) - YHEIGHT))) - (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) - with (IPLUS Y (HALF YHEIGHT))) - (RETURN YHEIGHT]) (BRHL/LAYOUT/DAUGHTERS - [LAMBDA (DS X Y MOMLST) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - - (* DS are the daughters of (CAR MOMLST)%. - X is where their the left edge of their labels will be, and Y is the bottom of - the mother's box. Returns the height of the mother's box. - Tests to see if a node has been laid out out already If so, it sees if the node - is far enought to the right; if not it moves the node and its daughters.) - - (DECLARE (USEDFREE NODELST YHEIGHT)) - (for DTAIL on DS bind D GN NP DELTA (FLOOR _ Y) finally (RETURN (IDIFFERENCE - FLOOR Y)) - do (SETQ GN (GETNODEFROMID (SETQ D (CAR DTAIL)) - NODELST)) - (COND - ((SETQ NP (fetch (GRAPHNODE NODEPOSITION) of GN)) - [COND - [(NULL (fetch YCOORD of NP)) - (SETQ GN (NEW/INSTANCE/OF/GRAPHNODE GN)) - (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of GN)) - (SETQ FLOOR (IPLUS FLOOR (BRHL/LAYOUT (fetch (GRAPHNODE NODEID) - of GN) - X FLOOR MOMLST GN] - (T (BRHL/MOVE/RIGHT GN X NIL) - (push (fetch (GRAPHNODE FROMNODES) of GN) - (CAR MOMLST] (* Add this mother to the fromLinks) - ) - (T (SETQ FLOOR (IPLUS FLOOR (BRHL/LAYOUT D X FLOOR MOMLST GN]) (BRHL/MOVE/RIGHT - [LAMBDA (GN X STACK) (* ; "Edited 29-Apr-94 14:00 by sybalsky") - (* Move this node and its children - right) - (DECLARE (USEDFREE NODELST)) - (PROG ((W (fetch (GRAPHNODE NODEWIDTH) of GN)) - (NP (fetch (GRAPHNODE NODEPOSITION) of GN))) - (AND (FMEMB GN STACK) - (ERROR "Loop caught in BRHL/MOVE/RIGHT at" (fetch (GRAPHNODE NODELABEL) - of GN))) - (COND - ((ILESSP X (IDIFFERENCE (fetch XCOORD of NP) - (HALF W))) - (RETURN))) - (for D in (TOLINKS GN) bind (NEWX _ (IPLUS X W MOTHERD)) - (NSTACK _ (CONS GN STACK)) - do (BRHL/MOVE/RIGHT (GETNODEFROMID D NODELST) - NEWX NSTACK)) - (replace XCOORD of NP with (IPLUS X (HALF W]) (BROWSE/LAYOUT/HORIZ - [LAMBDA (ROOTIDS) (* ; "Edited 19-Aug-88 08:32 by sye") - - (* each subtree is given a box centered vertically on its label. - Sister boxes abut but do not intrude as they do in the compacting version.) - - (DECLARE (USEDFREE NODELST)) - [for N in ROOTIDS bind (Y _ 0) do (SETQ Y (IPLUS Y (BRH/LAYOUT N 0 Y NIL - (GETNODEFROMID - N NODELST] - (create GRAPH - GRAPHNODES _ NODELST - SIDESFLG _ T - DIRECTEDFLG _ NIL]) (BROWSE/LAYOUT/HORIZ/COMPACTLY - [LAMBDA (ROOTS) - (DECLARE (USEDFREE NODELST MOTHERD)) (* ; "Edited 19-Aug-88 08:33 by sye") - - (* See comments on BRH/LAYOUT and BRH/LAYOUT/DAUGHTERS first. - This differs in that it keeps (on the stack) a representation of the shape of - the tree that fills the node's box. The representation is a list of POSITIONs. - If one starts drawing a line from left to right starting at the CAR, each point - is a step in the line, and the point begins the new plateau - (or valley)%. The last point is where the line would turn around and head back - to the left.) - (* builds dummy top node for ROOTS - if necessary, and adjusts the - horizontal distance accordingly.) - [PROG (RETURNTTC RETURNBTC) - (DECLARE (SPECVARS RETURNTTC RETURNBTC)) - (COND - ((NLISTP ROOTS) - (BRHC/LAYOUT ROOTS 0 NIL (GETNODEFROMID ROOTS NODELST)) - (BRHC/OFFSET ROOTS 0)) - ((NULL (CDR ROOTS)) - (BRHC/LAYOUT (CAR ROOTS) - 0 NIL (GETNODEFROMID (CAR ROOTS) - NODELST)) - (BRHC/OFFSET (CAR ROOTS) - 0)) - (T (PROG ((GN (create GRAPHNODE - NODELABEL _ (PACK) - NODEID _ (CONS) - TONODES _ ROOTS - NODEWIDTH _ 0 - NODEHEIGHT _ 0)) - TOPNODE) - (push NODELST GN) - (SETQ TOPNODE (fetch (GRAPHNODE NODEID) of GN)) - (BRHC/LAYOUT TOPNODE (IMINUS MOTHERD) - NIL GN) - (BRHC/OFFSET TOPNODE 0) - [for N GN in ROOTS do (replace (GRAPHNODE FROMNODES) - of (SETQ GN (FASSOC N NODELST)) - with (DREMOVE TOPNODE - (fetch (GRAPHNODE - FROMNODES) - of GN] - (SETQ NODELST (DREMOVE GN NODELST] - (create GRAPH - GRAPHNODES _ NODELST - SIDESFLG _ T - DIRECTEDFLG _ NIL]) (BROWSE/LAYOUT/LATTICE - [LAMBDA (NS) (* ; "Edited 19-Aug-88 08:33 by sye") - - (* almost the same as BROWSE/LAYOUT/HORIZ, except that it doesn't box nodes - unless there are cycles. Instead, a single node is placed at the rightmost of - the positions that would be laid out by for all of its - (boxed) occurrences by BROWSE/LAYOUT/HORIZ.) - - (DECLARE (USEDFREE NODELST)) - [for N in NS bind (Y _ 0) do (SETQ Y (IPLUS Y (BRHL/LAYOUT N 0 Y NIL - (GETNODEFROMID N NODELST - ] - (create GRAPH - GRAPHNODES _ NODELST - SIDESFLG _ T - DIRECTEDFLG _ NIL]) (BRV/OFFSET - [LAMBDA (N ABSX) (* dgb%: "22-Jan-85 07:25") - - (* Adds in offset which are kept in car of NODEPOSITION. - TERMY is Y of lowest node. Adding it in raises tree so lowest node is at zero.) - - (DECLARE (USEDFREE NODELST TERMY)) - (PROG (P (GN (GETNODEFROMID N NODELST))) - [SETQ ABSX (IPLUS ABSX (pop (fetch (GRAPHNODE NODEPOSITION) of GN] - (replace XCOORD of (SETQ P (fetch (GRAPHNODE NODEPOSITION) of GN)) - with (IPLUS ABSX (fetch XCOORD of P))) - (replace YCOORD of P with (IDIFFERENCE (fetch YCOORD of P) - TERMY)) - (for D in (fetch (GRAPHNODE TONODES) of GN) do (BRV/OFFSET D ABSX]) (EXTEND/TRANSITION/CHAIN - [LAMBDA (LTC RTC) (* kvl "21-DEC-83 11:00") - - (* Extends the left transition chain by appending the part of the right - transition chain that is to the right of the end of the left transition chain. - End point of left transition chain is changed to intersect right transition - chain) - - (PROG ((LTAIL LTC) - (RTAIL RTC) - LX RX) - L [COND - ((NULL (CDR RTAIL)) - (replace YCOORD of (CAR (FLAST LTAIL)) with (fetch YCOORD - of (CAR RTAIL))) - (RETURN LTC)) - ((NULL (CDR LTAIL)) - (RPLACD LTAIL (CDR RTAIL)) - (replace YCOORD of (CAR LTAIL) with (fetch YCOORD of (CAR RTAIL))) - (RETURN LTC)) - ([IEQP (SETQ LX (fetch XCOORD of (CADR LTAIL))) - (SETQ RX (fetch XCOORD of (CADR RTAIL] - (SETQ LTAIL (CDR LTAIL)) - (SETQ RTAIL (CDR RTAIL))) - ((ILESSP LX RX) - (SETQ LTAIL (CDR LTAIL))) - (T (SETQ RTAIL (CDR RTAIL] - (GO L]) (FOREST/BREAK/CYCLES - [LAMBDA (NODE) (* kvl "14-Aug-84 09:19") - (* Breaks any cycles by inserting - new nodes and boxing) - (DECLARE (USEDFREE NODELST)) - (replace (GRAPHNODE NODEPOSITION) of NODE with T) - (for DTAIL DN on (fetch (GRAPHNODE TONODES) of NODE) - do (SETQ DN (GETNODEFROMID (CAR DTAIL) - NODELST)) - (COND - ((fetch (GRAPHNODE NODEPOSITION) of DN) - (* We've seen this before) - (SETQ DN (NEW/INSTANCE/OF/GRAPHNODE DN)) - (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of DN))) - (T (FOREST/BREAK/CYCLES DN]) (INIT/NODES/FOR/LAYOUT - [LAMBDA (NS FORMAT ROOTIDS FONT) (* Randy.Gobbel " 8-May-87 16:22") - (for GN in NS do [replace (GRAPHNODE NODEPOSITION) of GN - with (NOT (NOT (FMEMB (fetch (GRAPHNODE NODEID) - of GN) - ROOTIDS] - (* T Used to indicate prior - visitation. Roots are already - visited) - (OR (IMAGEOBJP (fetch (GRAPHNODE NODELABEL) of GN)) - (fetch (GRAPHNODE NODEFONT) of GN) - (replace (GRAPHNODE NODEFONT) of GN with FONT))) - [for R in ROOTIDS do (COND - ((EQMEMB 'LATTICE FORMAT) - (LATTICE/BREAK/CYCLES (GETNODEFROMID R NODELST) - NIL)) - (T (FOREST/BREAK/CYCLES (GETNODEFROMID R NODELST] - (for GN in NODELST do (replace (GRAPHNODE NODEPOSITION) of GN with NIL) - (SET/LABEL/SIZE GN]) (INTERPRET/MARK/FORMAT - [LAMBDA (FORMAT) (* rmk%: "20-Sep-85 08:59") - (* sets specvars for - NEW/INSTANCE/OF/GRAPHNODE and - MARK/GRAPH/NODE) - (DECLARE (USEDFREE BOX.BOTH.FLG BOX.LEAVES.FLG BORDER.FOR.MARKING LABELSHADE.FOR.MARKING)) - (PROG (PL) - (AND (EQMEMB 'COPIES/ONLY FORMAT) - (SETQ BOX.BOTH.FLG NIL)) - (AND (EQMEMB 'NOT/LEAVES FORMAT) - (SETQ BOX.LEAVES.FLG NIL)) - (COND - ((NLISTP FORMAT) - (RETURN)) - ((EQ (CAR FORMAT) - 'MARK) - (SETQ PL (CDR FORMAT))) - ((SETQ PL (FASSOC 'MARK FORMAT)) - (SETQ PL (CDR PL))) - (T (RETURN))) - [COND - [(FMEMB 'BORDER PL) - (SETQ BORDER.FOR.MARKING (LISTGET PL 'BORDER] - (T (SETQ BORDER.FOR.MARKING 'DON'T] - (COND - [(FMEMB 'LABELSHADE PL) - (SETQ LABELSHADE.FOR.MARKING (LISTGET PL 'LABELSHADE] - (T (SETQ LABELSHADE.FOR.MARKING 'DON'T]) (LATTICE/BREAK/CYCLES - [LAMBDA (NODE STACK) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (replace (GRAPHNODE NODEPOSITION) of NODE with T) - (for DTAIL on (fetch (GRAPHNODE TONODES) of NODE) bind D GN - do (SETQ GN (GETNODEFROMID (SETQ D (CAR DTAIL)) - NODELST)) - (COND - ((FMEMB D STACK) - (SETQ GN (NEW/INSTANCE/OF/GRAPHNODE GN)) - (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of GN))) - ((NULL (fetch (GRAPHNODE NODEPOSITION) of GN)) - (LATTICE/BREAK/CYCLES GN (CONS D STACK]) (LAYOUTFOREST - [LAMBDA (NODELST ROOTIDS FORMAT BOXING FONT MOTHERD PERSONALD FAMILYD) - (* ; "Edited 16-Apr-90 19:05 by gadener") - (* This is an older version of - LayoutGraph, kept around temporarily - but de-documented) - (LAYOUTGRAPH NODELST ROOTIDS (CL:IF (LISTP FORMAT) - (APPEND FORMAT BOXING) - (CONS FORMAT BOXING)) - FONT MOTHERD PERSONALD]) (LAYOUTGRAPH - [LAMBDA (NODELST ROOTIDS FORMAT FONT MOTHERD PERSONALD FAMILYD) - (* ; "Edited 29-Apr-94 14:01 by sybalsky") - - (* ;; "takes a list of GRAPHNODE records and a list node ids for the top level nodes, where the graphnodes have only the NODEID, NODELABEL and TONODES fields filled in. It fills in the other fields appropriately according the format switch and the boxing switch so that the graph becomes a forest. If there are loops in the graph, they are snapped and the NODELST is extended with Push This function returns a GRAPH record with the display slots filled in appropriately.") - - (DECLARE (SPECVARS NODELST MOTHERD PERSONALD FAMILYD)) - (PROG ((BOX.BOTH.FLG T) - (BOX.LEAVES.FLG T) - (BORDER.FOR.MARKING T) - (LABELSHADE.FOR.MARKING 'DON'T) - G) - (DECLARE (SPECVARS BOX.BOTH.FLG BOX.LEAVES.FLG BORDER.FOR.MARKING - LABELSHADE.FOR.MARKING)) - (OR (LISTP ROOTIDS) - (ERROR "LAYOUTGRAPH needs a LIST of root node ids")) - (for R in ROOTIDS unless (FASSOC R NODELST) do (ERROR R - "is in ROOTIDS but no GRAPHNODE for it in NODELST." - )) - (OR FONT (SETQ FONT (OR DEFAULT.GRAPH.NODEFONT DEFAULTFONT))) - (OR MOTHERD (SETQ MOTHERD (STRINGWIDTH "AAAAAA" FONT))) - [OR PERSONALD (SETQ PERSONALD (COND - ((EQMEMB 'VERTICAL FORMAT) - (STRINGWIDTH "AA" FONT)) - (T 0] - [OR FAMILYD (SETQ FAMILYD (HALF (FONTPROP FONT 'ASCENT] - (INTERPRET/MARK/FORMAT FORMAT) - (INIT/NODES/FOR/LAYOUT NODELST FORMAT ROOTIDS FONT) - (AND (EQMEMB 'VERTICAL FORMAT) - (SWITCH/NODE/HEIGHT/WIDTH NODELST)) - [SETQ G (COND - ((EQMEMB 'LATTICE FORMAT) - (BROWSE/LAYOUT/LATTICE ROOTIDS)) - ((EQMEMB 'FAST FORMAT) - (BROWSE/LAYOUT/HORIZ ROOTIDS)) - (T (BROWSE/LAYOUT/HORIZ/COMPACTLY ROOTIDS] - (replace (GRAPH GRAPH.PROPS) of G with (LIST 'FORMAT FORMAT)) - [for N in NODELST do (OR (type? POSITION (fetch (GRAPHNODE NODEPOSITION - ) of N)) - (ERROR - "Disconnected graph. Root(s) didn't connect to:" - (fetch (GRAPHNODE NODELABEL) of N] - [COND - ((EQMEMB 'VERTICAL FORMAT) - (SWITCH/NODE/HEIGHT/WIDTH NODELST) - (REFLECT/GRAPH/DIAGONALLY G) - (OR (EQMEMB 'REVERSE FORMAT) - (REFLECT/GRAPH/VERTICALLY G)) - (AND (EQMEMB 'REVERSE/DAUGHTERS FORMAT) - (REFLECT/GRAPH/HORIZONTALLY G))) - (T (AND (EQMEMB 'REVERSE FORMAT) - (REFLECT/GRAPH/HORIZONTALLY G)) - (AND (EQMEMB 'REVERSE/DAUGHTERS FORMAT) - (REFLECT/GRAPH/VERTICALLY G] - (RETURN G]) (LAYOUTLATTICE - [LAMBDA (NODELST ROOTIDS FORMAT FONT MOTHERD PERSONALD FAMILYD) - (* rmk%: " 6-Dec-85 12:19") - - (* takes a list of GRAPHNODE records and a list node ids for the top level - nodes, where the graphnodes have only the NODEID, NODELABEL and TONODES fields - filled in. It fills in the other fields appropriately according the format - switch If there are loops in the graph, they are detected in BRHL/MOVE/RIGHT - and an error occurs. This function returns a GRAPH record with the display - slots filled in appropriately.) - - (DECLARE (SPECVARS NODELST MOTHERD PERSONALD FAMILYD)) - (for R in ROOTIDS unless (FASSOC R NODELST) do (ERROR R - "is in ROOTIDS but no GRAPHNODE for it in NODELST." - )) - (SETQ FONT (OR FONT DEFAULTFONT)) - (INIT/NODES/FOR/LAYOUT NODELST FORMAT ROOTIDS FONT) - [OR FAMILYD (SETQ FAMILYD (HALF (FONTPROP FONT 'ASCENT] - (OR MOTHERD (SETQ MOTHERD (STRINGWIDTH "AAAAAA" FONT))) - [OR PERSONALD (SETQ PERSONALD (COND - ((EQ FORMAT 'VERTICAL) - (STRINGWIDTH "AA" FONT)) - (T 0] - (BROWSE/LAYOUT/LATTICE ROOTIDS]) (LAYOUTSEXPR - [LAMBDA (TREE FORMAT BOXING FONT MOTHERD PERSONALD FAMILYD) - (* ; "Edited 1-Sep-92 17:26 by jds") - - (* ;; "assumes CAR of tree is node label, CDR is daughter trees.") - - (COND - [TREE (PROG (RESULT) - (DECLARE (SPECVARS RESULT)) - (LAYOUTSEXPR1 TREE) - - (* ;; "Boxing arg will only be taken into account if they are valid Format arguments") - (* ; "otherwise, it is ignored") - (AND (OR (NLISTP BOXING) - (EQ (CAR BOXING) - 'MARK)) - (SETQ BOXING (CONS BOXING))) - (RETURN (LAYOUTGRAPH RESULT (LIST TREE) - (APPEND (MKLIST FORMAT) - BOXING) - FONT MOTHERD PERSONALD FAMILYD] - (T (ERROR "Cannot layout NIL as S-EXPRESSION"]) (LAYOUTSEXPR1 - [LAMBDA (TREE) (* dgb%: "22-Jan-85 07:07") - (DECLARE (SPECVARS RESULT)) - (COND - [(for R in RESULT thereis (EQ TREE (fetch (GRAPHNODE NODEID) of R] - ((NLISTP TREE) - (push RESULT (create GRAPHNODE - NODEID _ TREE - NODELABEL _ TREE))) - (T [push RESULT (create GRAPHNODE - NODEID _ TREE - NODELABEL _ (CAR TREE) - TONODES _ (APPEND (CDR TREE] - (for D in (CDR TREE) do (LAYOUTSEXPR1 D]) (MARK/GRAPH/NODE - [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* changes appearance of graph node - to indicate that a link has been - snapped.) - (DECLARE (USEDFREE BORDER.FOR.MARKING LABELSHADE.FOR.MARKING)) - (OR (EQ BORDER.FOR.MARKING 'DON'T) - (replace (GRAPHNODE NODEBORDER) of NODE with BORDER.FOR.MARKING)) - (OR (EQ LABELSHADE.FOR.MARKING 'DON'T) - (replace (GRAPHNODE NODELABELSHADE) of NODE with LABELSHADE.FOR.MARKING]) (NEW/INSTANCE/OF/GRAPHNODE - [LAMBDA (GN) - (DECLARE (USEDFREE NODELST BOX.LEAVES.FLG BOX.BOTH.FLG)) - (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* returns a second instance of the - node, boxing it appropriately. - No daughters.) - (PROG [(NEW (create GRAPHNODE - NODEID _ (LIST (fetch (GRAPHNODE NODEID) of GN)) - NODELABEL _ (fetch (GRAPHNODE NODELABEL) of GN) - NODEFONT _ (fetch (GRAPHNODE NODEFONT) of GN) - NODEWIDTH _ (fetch (GRAPHNODE NODEWIDTH) of GN) - NODEHEIGHT _ (fetch (GRAPHNODE NODEHEIGHT) of GN) - NODEBORDER _ (COPY (fetch (GRAPHNODE NODEBORDER) of GN)) - NODELABELSHADE _ (fetch (GRAPHNODE NODELABELSHADE) of GN] - (push NODELST NEW) - [COND - ((OR BOX.LEAVES.FLG (fetch (GRAPHNODE TONODES) of GN)) - (MARK/GRAPH/NODE NEW) - (COND - (BOX.BOTH.FLG (MARK/GRAPH/NODE GN] - (RETURN NEW]) (RAISE/TRANSITION/CHAIN - [LAMBDA (TC RAISE) (* kvl "21-DEC-83 10:25") - - (* raises a daughters transition chain by adding in the offset of the - daughter's box relative to the mother's box.) - - (for P in TC do (add (fetch YCOORD of P) - RAISE) finally (RETURN TC]) (REFLECT/GRAPH/DIAGONALLY - [LAMBDA (GRAPH) (* kvl "26-DEC-83 10:58") - (replace (GRAPH SIDESFLG) of GRAPH with (NOT (fetch (GRAPH SIDESFLG) of - GRAPH))) - [for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) - (replace XCOORD of N with (PROG1 (fetch YCOORD of N) - (replace YCOORD of N - with (fetch XCOORD of N)))] - GRAPH]) (REFLECT/GRAPH/HORIZONTALLY - [LAMBDA (GRAPH) (* kvl "10-Aug-84 17:23") - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - bind [W _ (IPLUS (MAX/RIGHT (fetch (GRAPH GRAPHNODES) of GRAPH)) - (MIN/LEFT (fetch (GRAPH GRAPHNODES) of GRAPH] - do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) - (replace XCOORD of N with (IDIFFERENCE W (fetch XCOORD of N]) (REFLECT/GRAPH/VERTICALLY - [LAMBDA (GRAPH) (* kvl "10-Aug-84 16:48") - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - bind [H _ (IPLUS (MAX/TOP (fetch (GRAPH GRAPHNODES) of GRAPH)) - (MIN/BOTTOM (fetch (GRAPH GRAPHNODES) of GRAPH] - do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) - (replace YCOORD of N with (IDIFFERENCE H (fetch YCOORD of N]) (SWITCH/NODE/HEIGHT/WIDTH - [LAMBDA (NL) (* rmk%: " 2-Feb-84 22:19") - (for N in NL do (swap (fetch (GRAPHNODE NODEWIDTH) of N) - (fetch (GRAPHNODE NODEHEIGHT) of N]) ) (DECLARE%: EVAL@COMPILE (RPAQQ LINKPARAMS Link% Parameters) (CONSTANTS (LINKPARAMS 'Link% Parameters)) ) (RPAQQ DEFAULT.GRAPH.NODEBORDER NIL) (RPAQQ DEFAULT.GRAPH.NODEFONT NIL) (RPAQQ DEFAULT.GRAPH.NODELABELSHADE NIL) (RPAQQ ScalableLinkParameters (LINEWIDTH)) (RPAQQ CACHE/NODE/LABEL/BITMAPS NIL) (RPAQQ NODEBORDERWIDTH 1) (RPAQQ GRAPH/HARDCOPY/FORMAT (MODE PORTRAIT PAGENUMBERS T TRANS NIL)) (RPAQ? DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7) (TIMES SCREENHEIGHT 0.4))) (RPAQ? EDITGRAPHMENUCOMMANDS '((Move% Node 'MOVENODE "Moves a single node in the graph." (SUBITEMS (|Move Single Node| 'MOVENODE "Moves a single node in the graph." ) (|Move Node and Subtree| (EDITMOVESUBTREE GRAPHWINDOW) "Moves a subtree of nodes relative to the movement of their root." ) (Move% Region ( EDITMOVEREGION GRAPHWINDOW) "Moves a group of nodes within a specified region to another region." ))) ("Add Node" 'ADDNODE) ("Delete Node" 'DELETENODE) ("Add Link" 'ADDLINK) ("Delete Link" 'DELETELINK) ("Change label" 'CHANGELABEL) ("label smaller" 'SMALLER) ("label larger" 'LARGER) ("<-> Directed" 'DIRECTED) ("<-> Sides" 'SIDES) ("<-> Border" 'BORDER) ("<-> Shade" 'SHADE) STOP)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: EVAL@COMPILE (RECORD GRAPHNODE (NODEID NODEPOSITION NODELABELBITMAP NIL NODELABELSHADE NODEWIDTH NODEHEIGHT TONODES FROMNODES NODEFONT NODELABEL NODEBORDER) NODEBORDER _ DEFAULT.GRAPH.NODEBORDER NODELABELSHADE _ DEFAULT.GRAPH.NODELABELSHADE NODEFONT _ DEFAULT.GRAPH.NODEFONT) (RECORD GRAPH (GRAPHNODES SIDESFLG DIRECTEDFLG GRAPH.MOVENODEFN GRAPH.ADDNODEFN GRAPH.DELETENODEFN GRAPH.ADDLINKFN GRAPH.DELETELINKFN GRAPH.FONTCHANGEFN GRAPH.INVERTBORDERFN GRAPH.INVERTLABELFN GRAPH.CHANGELABELFN . GRAPH.PROPS)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS HALF MACRO ((X) (LRSH X 1))) ) ) (* ; "Grapher image objects") (DEFINEQ (GRAPHERIMAGEFNS [LAMBDA NIL (* ; "Edited 11-Apr-2018 09:02 by rmk:") (* ; "Edited 11-Apr-2018 09:01 by rmk:") (DECLARE (USEDFREE GRAPHERIMAGEFNS)) (OR GRAPHERIMAGEFNS (SETQ GRAPHERIMAGEFNS (IMAGEFNSCREATE (FUNCTION GRAPHOBJ.DISPLAYFN) (FUNCTION GRAPHOBJ.IMAGEBOXFN) (FUNCTION GRAPHOBJ.PUTFN) (FUNCTION GRAPHOBJ.GETFN) (FUNCTION GRAPHOBJ.COPYFN) (FUNCTION GRAPHOBJ.BUTTONEVENTINFN) (FUNCTION GRAPHOBJ.COPYBUTTONEVENTFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) NIL 'GRAPHER]) ) (DEFINEQ (GRAPHERCOPYBUTTONEVENTFN - [LAMBDA (WINDOW) (* ; "Edited 1-Aug-87 14:54 by sye") - - (* ;; "Called on down transition in WINDOW. If GRAPHOBJ.FINDGRAPH locates a graph in window, it is copy inserted. Another callers of GRAPHOBJ.FINDGRAPH might also specify alignments to GRAPHEROBJ.") - - (PROG* [(GRAPH (OR (GRAPHOBJ.FINDGRAPH WINDOW) - (RETURN))) - (REG (GRAPHREGION GRAPH)) - (LEFT (MINUS (fetch (REGION LEFT) of REG))) - (BOTTOM (MINUS (fetch (REGION BOTTOM) of REG))) - (LEFTBUTTONFN (WINDOWPROP WINDOW 'BROWSER/LEFTFN)) - (MIDDLEBUTTONFN (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN] - (if (NOT (AND (ZEROP LEFT) - (ZEROP BOTTOM))) - then (SETQ GRAPH (TRANSGRAPH GRAPH LEFT BOTTOM))) - (COPYINSERT (GRAPHEROBJ GRAPH NIL NIL LEFTBUTTONFN MIDDLEBUTTONFN]) (GRAPHOBJ.FINDGRAPH - [LAMBDA (WINDOW) (* rmk%: "22-Dec-84 11:29") - - (* Get control on down transition, track until key goes up or mouse leaves the - window) - - (bind (DS _ (GETSTREAM WINDOW)) - (REG _ (WINDOWPROP WINDOW 'REGION)) first (DSPFILL NIL BLACKSHADE 'INVERT DS) - do (GETMOUSESTATE) - (COND - ((NOT (INSIDE? REG LASTMOUSEX LASTMOUSEY)) - (DSPFILL NIL BLACKSHADE 'INVERT DS) - (RETURN)) - ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE RIGHT))) - (DSPFILL NIL BLACKSHADE 'INVERT DS) - (RETURN (COPYGRAPH (WINDOWPROP WINDOW 'GRAPH]) ) (DEFINEQ (ALIGNMENTNODE - [LAMBDA (NODESPEC GRAPH) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* Returns the alignment node - specified by NODESPEC) - - (* Early implementation had *TOP, but documentation says *TOP*. - Remove earlier ones (*TOP) at some point) - - (SELECTQ NODESPEC - ((*TOP* *TOP) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) largest (GN/TOP - N))) - ((*BOTTOM* *BOTTOM) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) smallest (GN/BOTTOM - N))) - ((*RIGHT* *RIGHT) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) largest (GN/RIGHT - N))) - ((*LEFT* *LEFT) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) smallest (GN/LEFT - N))) - (GETNODEFROMID NODESPEC (fetch (GRAPH GRAPHNODES) of GRAPH]) (GRAPHOBJ.CHECKALIGN - [LAMBDA (GRAPH ALIGNSPEC) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (* Makes sure that the ALIGNMENTSPEC - is valid, putting it into standard - form if necessary) - (OR (AND (NULL ALIGNSPEC) - (SETQ ALIGNSPEC 0)) - (NUMBERP ALIGNSPEC) - [AND (LISTP ALIGNSPEC) - (SELECTQ (CAR ALIGNSPEC) - ((*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT) - T) - (GETNODEFROMID (CAR ALIGNSPEC) - (fetch (GRAPH GRAPHNODES) of GRAPH))) - (LISTP (CDR ALIGNSPEC)) - (OR (NUMBERP (CADR ALIGNSPEC)) - (EQ (CADR ALIGNSPEC) - 'BASELINE) - (AND (NULL (CADR ALIGNSPEC)) - (SETQ ALIGNSPEC (LIST (CAR ALIGNSPEC) - 0] - (ERROR "ILLEGAL GRAPH ALIGNMENT SPECIFICATION" ALIGNSPEC)) - ALIGNSPEC]) ) (DEFINEQ (GRAPHEROBJ [LAMBDA (GRAPH HALIGN VALIGN LEFTBUTTONFN MIDDLEBUTTONFN COPYBUTTONEVENTFN) (* ; "Edited 10-Apr-2018 11:01 by rmk:") (* rmk%: " 6-Dec-85 11:35") (* Constructs a Grapher image  object.) (* HALIGN and VALIGN specify the horizontal or vertical alignment.  Each can be a floating point number between 0 and 1, specifying that the  alignment point is located at that portion of the width/height of the  graphregion, or a list of the form (nodespec align)%, where nodespec is a node  ID or one of the atoms LEFT, RIGHT, BOTTOM, TOP, and align is either a floating  point number bewtween 0 and 1, or the atom BASELINE) (LET ((REG (GRAPHREGION GRAPH)) (OBJ (IMAGEOBJCREATE (LIST GRAPH (GRAPHOBJ.CHECKALIGN GRAPH HALIGN) (GRAPHOBJ.CHECKALIGN GRAPH VALIGN)) GRAPHERIMAGEFNS))) [IMAGEOBJPROP OBJ 'OBJECTORIGIN (CREATEPOSITION (MINUS (fetch (REGION LEFT) of REG)) (MINUS (fetch (REGION BOTTOM) of REG] (AND LEFTBUTTONFN (IMAGEOBJPROP OBJ 'LEFTBUTTONFN LEFTBUTTONFN)) (AND MIDDLEBUTTONFN (IMAGEOBJPROP OBJ 'MIDDLEBUTTONFN MIDDLEBUTTONFN)) (AND COPYBUTTONEVENTFN (IMAGEOBJPROP OBJ 'COPYBUTTONEVENTFN COPYBUTTONEVENTFN)) OBJ]) (GRAPHOBJ.BUTTONEVENTINFN - [LAMBDA (GROBJ WINDOW) (* ; "Edited 1-Aug-87 16:16 by sye") - (* the user has pressed a button - inside the grapher object IMAGEOBJ.) - (LET [(LEFT (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN)) - (MIDDLE (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN] - (if (OR LEFT MIDDLE) - then (GRAPHBUTTONEVENTFN WINDOW (CAR (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - LEFT MIDDLE) - elseif [MENU (create MENU - ITEMS _ '((Edit% graph T " Opens a window to edit this graph"] - then (PROG [W (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM] - (SETQ W (SIZE/GRAPH/WINDOW (CAR DATUM) - NIL T)) - (IMAGEOBJPROP GROBJ 'OBJECTDATUM (LIST (EDITGRAPH1 - (COPYGRAPH (CAR DATUM)) - W) - (CADR DATUM) - (CADDR DATUM))) - (CLOSEW W)) - 'CHANGED]) (GRAPHOBJ.COPYBUTTONEVENTFN - [LAMBDA (GROBJ WINDOW) (* rmk%: " 6-Dec-85 11:42") - - (* the user has pressed a button inside the grapher object IMAGEOBJ while a - copy key was down) - - (LET [(CBEFN (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN] - (if CBEFN - then (APPLY* CBEFN GROBJ WINDOW) - else (COPYINSERT (GRAPHOBJ.COPYFN GROBJ]) (GRAPHOBJ.COPYFN - [LAMBDA (GROBJ) (* rmk%: " 6-Dec-85 12:07") - (* makes a copy of a grapher image - object.) - (LET* [(DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - (NEW (GRAPHEROBJ (COPYGRAPH (CAR DATUM)) - (CADR DATUM) - (CADDR DATUM] - [IMAGEOBJPROP NEW 'OBJECTORIGIN (create POSITION using (IMAGEOBJPROP GROBJ - 'OBJECTORIGIN] - (IMAGEOBJPROP NEW 'LEFTBUTTONFN (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN)) - (IMAGEOBJPROP NEW 'MIDDLEBUTTONFN (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN)) - (IMAGEOBJPROP NEW 'COPYBUTTONEVENTFN (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN)) - NEW]) (GRAPHOBJ.DISPLAYFN - [LAMBDA (GROBJ STREAM) (* rmk%: " 2-Apr-85 10:56") - (* display function for a grapher - image object) - - (* Scale the streams position back to display coordinates, since DISPLAYGRAPH - translates the translation. Might be simplest to define DISPLAYGRAPH without a - translation, as locating the graph coordinate system at the current X,Y - position) - - (PROG [REG (BOX (IMAGEOBJPROP GROBJ 'BOUNDBOX)) - (SCALE (DSPSCALE NIL STREAM)) - (GRAPH (CAR (IMAGEOBJPROP GROBJ 'OBJECTDATUM] - (OR BOX (SETQ BOX (APPLY* (IMAGEOBJPROP GROBJ 'IMAGEBOXFN) - GROBJ STREAM))) - [SETQ REG (GRAPHREGION (COND - ((EQP SCALE 1) - GRAPH) - (T (SCALE/GRAPH GRAPH STREAM SCALE] - - (* Kludgy%: we have to scale the graph to get the real region, but then - DISPLAYGRAPH will do it again, cause it assumes screen points.) - (* Other kludge is that the - translation is also in screen points) - (DISPLAYGRAPH GRAPH STREAM NIL (CREATEPOSITION (QUOTIENT (DIFFERENCE - (DIFFERENCE (DSPXPOSITION - NIL STREAM) - (fetch XKERN - of BOX)) - (fetch (REGION LEFT) - of REG)) - SCALE) - (QUOTIENT (DIFFERENCE (DIFFERENCE (DSPYPOSITION - NIL STREAM) - (fetch YDESC - of BOX)) - (fetch (REGION BOTTOM) - of REG)) - SCALE]) (GRAPHOBJ.GETALIGN - [LAMBDA (STREAM GRAPH) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (PROG ((ALIGN (READ STREAM FILERDTBL))) - [if [AND (LISTP ALIGN) - (NOT (MEMB (CAR ALIGN) - '(*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT] - then (SETQ ALIGN (CONS [fetch (GRAPHNODE NODEID) - of (CAR (NTH (CAR ALIGN) - (fetch (GRAPH GRAPHNODES) - of GRAPH] - (CDR ALIGN] - (RETURN ALIGN]) (GRAPHOBJ.GETFN - [LAMBDA (STREAM) (* ; "Edited 7-Dec-88 18:38 by sye") - (* ; - "reads a grapher image object from a file.") - (OR (EQ (SKIPSEPRCODES STREAM FILERDTBL) - (CHARCODE %()) - (ERROR "ILLEGAL GRAPHOBJECT FORMAT")) - (READCCODE STREAM) (* Read the paren) - (PROG ((GRAPH (READGRAPH STREAM)) - IMAGEOBJ) - (SETQ IMAGEOBJ (GRAPHEROBJ GRAPH (GRAPHOBJ.GETALIGN STREAM GRAPH) - (GRAPHOBJ.GETALIGN STREAM GRAPH))) - - (* ;; "read leftbuttonfn & middlebuttonfn & copybuttoneventfn") - - [COND - ((NEQ (SKIPSEPRCODES STREAM FILERDTBL) - (CHARCODE %))) (* ; ") means extra props don't exist") - (IMAGEOBJPROP IMAGEOBJ 'LEFTBUTTONFN (HREAD STREAM)) - (IMAGEOBJPROP IMAGEOBJ 'MIDDLEBUTTONFN (HREAD STREAM)) - (IMAGEOBJPROP IMAGEOBJ 'COPYBUTTONEVENTFN (HREAD STREAM)) - - (* ;; "read imageobject origin") - - (IMAGEOBJPROP IMAGEOBJ 'OBJECTORIGIN (CREATEPOSITION (READ STREAM) - (READ STREAM] - (RATOM STREAM FILERDTBL) (* ; "Skip the closing paren") - (RETURN IMAGEOBJ]) (GRAPHOBJ.IMAGEBOXFN - [LAMBDA (GROBJ STREAM) (* ; "Edited 29-Apr-94 14:01 by sybalsky") - (* size function for a tedit bitmap - object.) - (PROG (REGION GRAPH HALIGN VALIGN ALNODE (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - (SCALE (DSPSCALE NIL STREAM)) - BMW BMH) - (SETQ GRAPH (CAR DATUM)) - (SETQ HALIGN (CADR DATUM)) - (SETQ VALIGN (CADDR DATUM)) - (OR (EQ 1 SCALE) - (SETQ GRAPH (SCALE/GRAPH GRAPH STREAM SCALE))) - (SETQ REGION (GRAPHREGION GRAPH)) - (RETURN (create IMAGEBOX - XSIZE _ (fetch (REGION WIDTH) of REGION) - YSIZE _ (fetch (REGION HEIGHT) of REGION) - YDESC _ [COND - ((NUMBERP VALIGN) - (TIMES VALIGN (fetch (REGION HEIGHT) of REGION))) - (T (* Must be a list, cause of checks - in GRAPHEROBJ) - (SETQ ALNODE (ALIGNMENTNODE (CAR VALIGN) - GRAPH)) - (PLUS (GN/BOTTOM ALNODE) - (COND - ((EQ (CADR VALIGN) - 'BASELINE) - (IQUOTIENT (IPLUS (IDIFFERENCE - (fetch (GRAPHNODE NODEHEIGHT) - of ALNODE) - (FONTPROP (fetch (GRAPHNODE - NODEFONT) - of ALNODE) - 'ASCENT)) - (FONTPROP (fetch (GRAPHNODE - NODEFONT) - of ALNODE) - 'DESCENT)) - 2)) - (T (TIMES (CADR VALIGN) - (fetch (GRAPHNODE NODEHEIGHT) - of ALNODE] - XKERN _ (COND - ((NUMBERP HALIGN) - (TIMES HALIGN (fetch (REGION WIDTH) of REGION))) - (T (* Must be a list, cause of checks - in GRAPHEROBJ) - (SETQ ALNODE (ALIGNMENTNODE (CAR HALIGN) - GRAPH)) - (PLUS (GN/LEFT ALNODE) - (TIMES (COND - ((EQ (CADR HALIGN) - 'BASELINE) - 0) - (T (CADR HALIGN))) - (fetch (GRAPHNODE NODEWIDTH) of ALNODE]) (GRAPHOBJ.PUTALIGN - [LAMBDA (STREAM GRAPH ALIGN) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (PRIN2 [COND - ([OR (NLISTP ALIGN) - (MEMB (CAR ALIGN) - '(*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT] - ALIGN) - (T (* Convert node ID to node index) - (CONS (for I from 1 as N in (fetch (GRAPH GRAPHNODES) - of GRAPH) - when (EQ (CAR ALIGN) - (fetch (GRAPHNODE NODEID) of N)) - do (RETURN I)) - (CDR ALIGN] - STREAM FILERDTBL]) (GRAPHOBJ.PUTFN - [LAMBDA (GROBJ STREAM) (* rmk%: "31-Dec-84 12:25") - (* Put a description of a grapher - object into the file.) - (PROG [ALIGN GRAPH (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) - (OBJORIGIN (IMAGEOBJPROP GROBJ 'OBJECTORIGIN] - (PRIN1 "(" STREAM) - - (* ;; " dump graph") - - (SETQ GRAPH (CAR DATUM)) - (DUMPGRAPH GRAPH STREAM) - (TERPRI STREAM) - - (* ;; " dump halign and valign") - - (GRAPHOBJ.PUTALIGN STREAM GRAPH (CADR DATUM)) - (SPACES 1 STREAM) - (GRAPHOBJ.PUTALIGN STREAM GRAPH (CADDR DATUM)) - (TERPRI STREAM) - - (* ;; " dump leftbuttonfn & middlebuttonfn & copybuttoneventfn ") - - (HPRINT (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN) - STREAM) - (HPRINT (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN) - STREAM) - (HPRINT (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN) - STREAM) - - (* ;; "dump objectorigin") - - (PRIN1 (fetch XCOORD of OBJORIGIN) - STREAM) - (SPACES 1 STREAM) - (PRIN1 (fetch YCOORD of OBJORIGIN) - STREAM) - (printout STREAM ")" T]) ) (DEFINEQ (COPYGRAPH - [LAMBDA (GRAPH) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (create GRAPH using GRAPH GRAPHNODES _ - (for N L in (fetch (GRAPH GRAPHNODES) of GRAPH) - collect (create GRAPHNODE - using N NODEPOSITION _ (create POSITION - using - (fetch (GRAPHNODE - NODEPOSITION) - of N)) - NODELABEL _ - (CL:TYPECASE (SETQ L (fetch (GRAPHNODE - NODELABEL) - of N)) - (BITMAP (BITMAPCOPY L)) - (IMAGEOBJ (APPLY* (IMAGEOBJPROP L - 'COPYFN) - L)) - (T L))]) (DUMPGRAPH - [LAMBDA (GRAPH STREAM) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (* Put a description of a graph into - a file.) - (RESETLST - (RESETSAVE (SETREADTABLE FILERDTBL)) - (PROG (BORDERS FONTS IDS SHADES (%#BORDERS 0) - (%#FONTS 0) - (%#SHADES 0) - (%#IDS 0)) - (printout STREAM "(" T "FIELDS (") - (if (fetch (GRAPH SIDESFLG) of GRAPH) - then (printout STREAM 2 "SIDESFLG " .P2 (fetch (GRAPH SIDESFLG) - of GRAPH))) - (if (fetch (GRAPH DIRECTEDFLG) of GRAPH) - then (printout STREAM 2 "DIRECTEDFLG " .P2 (fetch (GRAPH DIRECTEDFLG) - of GRAPH))) - (if (fetch (GRAPH GRAPH.MOVENODEFN) of GRAPH) - then (printout STREAM 2 "MOVENODEFN " .P2 (fetch (GRAPH GRAPH.MOVENODEFN) - of GRAPH))) - (if (fetch (GRAPH GRAPH.ADDNODEFN) of GRAPH) - then (printout STREAM 2 "ADDNODEFN " .P2 (fetch (GRAPH GRAPH.ADDNODEFN) - of GRAPH))) - (if (fetch (GRAPH GRAPH.DELETENODEFN) of GRAPH) - then (printout STREAM 2 "DELETENODEFN " .P2 (fetch (GRAPH - GRAPH.DELETENODEFN - ) of GRAPH))) - (if (fetch (GRAPH GRAPH.ADDLINKFN) of GRAPH) - then (printout STREAM 2 "ADDLINKFN " .P2 (fetch (GRAPH GRAPH.ADDLINKFN) - of GRAPH))) - (if (fetch (GRAPH GRAPH.DELETELINKFN) of GRAPH) - then (printout STREAM 2 "DELETELINKFN " .P2 (fetch (GRAPH - GRAPH.DELETELINKFN - ) of GRAPH))) - (if (fetch (GRAPH GRAPH.FONTCHANGEFN) of GRAPH) - then (printout STREAM 2 "FONTCHANGEFN " .P2 (fetch (GRAPH - GRAPH.FONTCHANGEFN - ) of GRAPH))) - (if (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) - then (printout STREAM 2 "INVERTBORDERFN " .P2 (fetch (GRAPH - GRAPH.INVERTBORDERFN - ) of GRAPH) - )) - (if (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) - then (printout STREAM 2 "INVERTLABELFN " .P2 (fetch (GRAPH - GRAPH.INVERTLABELFN - ) of GRAPH)) - ) - (if (fetch (GRAPH GRAPH.CHANGELABELFN) of GRAPH) - then (printout STREAM 2 "CHANGELABELFN " .P2 (fetch (GRAPH - GRAPH.CHANGELABELFN - ) of GRAPH)) - ) - (if (fetch (GRAPH GRAPH.PROPS) of GRAPH) - then (printout STREAM 2 "PROPS ") - (HPRINT (fetch (GRAPH GRAPH.PROPS) of GRAPH) - STREAM)) - (PRIN1 ")" STREAM) - [for N TEMP in (fetch (GRAPH GRAPHNODES) of GRAPH) - do [OR (ASSOC (fetch (GRAPHNODE NODEID) of N) - IDS) - (push IDS (CONS (fetch (GRAPHNODE NODEID) of N) - (add %#IDS 1] - [AND (SETQ TEMP (fetch (GRAPHNODE NODELABELSHADE) of N)) - (OR (ASSOC TEMP SHADES) - (push SHADES (CONS TEMP (add %#SHADES 1] - [OR (ASSOC (fetch (GRAPHNODE NODEFONT) of N) - FONTS) - (push FONTS (CONS (fetch (GRAPHNODE NODEFONT) of N) - (add %#FONTS 1] - (SELECTQ (SETQ TEMP (fetch (GRAPHNODE NODEBORDER) of N)) - ((T NIL)) - (OR (ASSOC TEMP BORDERS) - (push BORDERS (CONS TEMP (add %#BORDERS 1] - (printout STREAM T "IDS " %#IDS %,) - (for X in (SETQ IDS (DREVERSE IDS)) do (PRIN2 (CAR X) - STREAM) - (SPACES 1 STREAM)) - (printout STREAM T "FONTS " %#FONTS %,) - (for X in (SETQ FONTS (DREVERSE FONTS)) - do (SETQ X (CAR X)) - (PRIN2 (if (LISTP X) - elseif (type? FONTDESCRIPTOR X) - then (FONTUNPARSE X) - elseif (FONTP X) - then (* Mark it as a class) - (CONS 'CLASS (FONTCLASSUNPARSE X))) - STREAM) - (SPACES 1 STREAM)) - [COND - (BORDERS (printout STREAM T "BORDERS " %#BORDERS %,) - (for X (POS _ (POSITION STREAM)) in (SETQ BORDERS (DREVERSE BORDERS)) - do (TAB POS 1 STREAM) - (HPRINT (CAR X) - STREAM] - [COND - (SHADES (printout STREAM T "SHADES " %#SHADES %,) - (for X (POS _ (POSITION STREAM)) in (SETQ SHADES (DREVERSE SHADES)) - do (TAB POS 1 STREAM) - (HPRINT (CAR X) - STREAM] - (printout STREAM T "NODES (") - (for N POS in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (printout STREAM 2 "(" .P2 (CDR (ASSOC (fetch (GRAPHNODE NODEID) - of N) - IDS)) - %,) - (SETQ POS (POSITION STREAM)) - (HPRINT (fetch (GRAPHNODE NODELABEL) of N) - STREAM) - (printout STREAM %, .TAB POS .P2 (fetch (GRAPHNODE NODEPOSITION) - of N) - %, .P2 (CDR (ASSOC (fetch (GRAPHNODE NODEFONT) of N) - FONTS)) - %, .P2 (SELECTQ (fetch (GRAPHNODE NODEBORDER) of N) - ((NIL T) - (fetch (GRAPHNODE NODEBORDER) of N)) - (CDR (ASSOC (fetch (GRAPHNODE NODEBORDER) of N) - BORDERS))) - %, .P2 (AND (fetch (GRAPHNODE NODELABELSHADE) of N) - (CDR (ASSOC (fetch (GRAPHNODE NODELABELSHADE) - of N) - SHADES))) - %,) - (if (fetch (GRAPHNODE TONODES) of N) - then (PRIN1 "(" STREAM) - (for X in (fetch (GRAPHNODE TONODES) of N) - do (printout STREAM .P2 - [COND - [(EQ (CAR (LISTP X)) - 'Link% Parameters) - (CONS (CAR X) - (CONS (CDR (ASSOC (CADR X) - IDS)) - (CDDR X] - (T (CDR (ASSOC X IDS] - %,)) - (PRIN1 ") " STREAM) - else (PRIN1 "NIL " STREAM)) - (if (fetch (GRAPHNODE FROMNODES) of N) - then (PRIN1 "(" STREAM) - (for X in (fetch (GRAPHNODE FROMNODES) of N) - do (printout STREAM .P2 (CDR (ASSOC X IDS)) - %,)) - (PRIN1 ")" STREAM) - else (PRIN1 NIL STREAM)) - (printout STREAM ")" T)) - (PRIN1 "))" STREAM)))]) (READGRAPH - [LAMBDA (STREAM) (* ; "Edited 29-Apr-94 14:02 by sybalsky") - (* reads a graph from a file.) - (OR (EQ (SKIPSEPRS STREAM FILERDTBL) - '%() - (ERROR "ILLEGAL GRAPH FORMAT")) - (READC STREAM) (* Read the paren) - (bind NUM TEMP FONTS BORDERS SHADES IDS (GRAPH _ (create GRAPH)) - do - (SELECTQ (SETQ TEMP (RATOM STREAM FILERDTBL)) - (FIELDS [for F on (READ STREAM FILERDTBL) by (CDDR F) - do (SELECTQ (CAR F) - (SIDESFLG (replace (GRAPH SIDESFLG) of GRAPH - with (CADR F))) - (DIRECTEDFLG (replace (GRAPH DIRECTEDFLG) of GRAPH - with (CADR F))) - (MOVENODEFN (replace (GRAPH GRAPH.MOVENODEFN) of GRAPH - with (CADR F))) - (ADDNODEFN (replace (GRAPH GRAPH.ADDNODEFN) of GRAPH - with (CADR F))) - (DELETENODEFN (replace (GRAPH GRAPH.DELETENODEFN) of GRAPH - with (CADR F))) - (ADDLINKFN (replace (GRAPH GRAPH.ADDLINKFN) of GRAPH - with (CADR F))) - (DELETELINKFN (replace (GRAPH GRAPH.DELETELINKFN) of GRAPH - with (CADR F))) - (FONTCHANGEFN (replace (GRAPH GRAPH.FONTCHANGEFN) of GRAPH - with (CADR F))) - (INVERTBORDERFN - (replace (GRAPH GRAPH.INVERTBORDERFN) of GRAPH - with (CADR F))) - (INVERTLABELFN (replace (GRAPH GRAPH.INVERTLABELFN) of - GRAPH - with (CADR F))) - (CHANGELABELFN (replace (GRAPH GRAPH.CHANGELABELFN) of - GRAPH - with (CADR F))) - (PROPS (replace (GRAPH GRAPH.PROPS) of GRAPH - with (CADR F))) - (ERROR "UNRECOGNIZED GRAPH FIELD" (CAR F]) - (IDS (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ IDS (ARRAY NUM)) - (for I to NUM do (SETA IDS I (READ STREAM FILERDTBL)))) - (BORDERS (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ BORDERS (ARRAY NUM)) - (for I to NUM do (SETA BORDERS I (HREAD STREAM)))) - (FONTS (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ FONTS (ARRAY NUM)) - [for I to NUM do (SETA FONTS I (COND - ((EQ (SETQ TEMP (READ STREAM - FILERDTBL)) - 'C) - (* A font class) - (SETQ TEMP (READ STREAM FILERDTBL)) - (FONTCLASS (CAR TEMP) - (CDR TEMP))) - ((EQ (CAR (LISTP TEMP)) - 'CLASS) - (FONTCLASS (CADR TEMP) - (CDDR TEMP))) - (T TEMP]) - (NODES (RATOM STREAM) (* Skip paren) - [replace (GRAPH GRAPHNODES) of GRAPH - with - (while (EQ (SKIPSEPRS STREAM FILERDTBL) - '%() - collect (READC STREAM) - (PROG1 (create GRAPHNODE - NODEID _ (ELT IDS (RATOM STREAM FILERDTBL)) - NODELABEL _ (HREAD STREAM) - NODEPOSITION _ (READ STREAM FILERDTBL) - NODEFONT _ (ELT FONTS (RATOM STREAM FILERDTBL)) - NODEBORDER _ (SELECTQ (SETQ TEMP (RATOM STREAM FILERDTBL) - ) - ((NIL T) - TEMP) - (ELT BORDERS TEMP)) - NODELABELSHADE _ (AND (SETQ TEMP (RATOM STREAM FILERDTBL) - ) - (ELT SHADES TEMP)) - TONODES _ - [for X in (READ STREAM FILERDTBL) - collect (COND - [(EQ (CAR (LISTP X)) - 'Link% Parameters) - (CONS (CAR X) - (CONS (ELT IDS (CADR X)) - (CDDR X] - (T (ELT IDS X] - FROMNODES _ (for X in (READ STREAM FILERDTBL) - collect (ELT IDS X))) - (* Skip the closing paren) - (RATOM STREAM FILERDTBL))] (* Skip the closing paren) - (RATOM STREAM FILERDTBL)) - (SHADES (SETQ NUM (RATOM STREAM FILERDTBL)) - (SETQ SHADES (ARRAY NUM)) - (for I to NUM do (SETA SHADES I (HREAD STREAM)))) - (%) (* The closing paren) - (RETURN GRAPH)) - (ERROR "INVALID GRAPHER IMAGE OBJECT" STREAM]) ) (RPAQ? GRAPHERIMAGEFNS ) (ADDTOVAR IMAGEOBJGETFNS (GRAPHOBJ.GETFN)) (PUTPROPS GRAPHER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7072 111121 (ADD/AND/DISPLAY/LINK 7082 . 7784) (APPLYTOSELECTEDNODE 7786 . 8274) ( CALL.MOVENODEFN 8276 . 8625) (CHANGE.NODEFONT.SIZE 8627 . 9939) (DEFAULT.ADDNODEFN 9941 . 10739) ( DELETE/AND/DISPLAY/LINK 10741 . 12308) (DISPLAY/NAME 12310 . 12481) (DISPLAYGRAPH 12483 . 14854) ( DISPLAYLINK 14856 . 17409) (DISPLAYLINK/BT 17411 . 18433) (DISPLAYLINK/LR 18435 . 19458) ( DISPLAYLINK/RL 19460 . 20483) (DISPLAYLINK/TB 20485 . 21508) (DISPLAYNODE 21510 . 21858) ( ERASE/GRAPHNODE 21860 . 22967) (DISPLAYNODE 22969 . 23317) (DISPLAYNODELINKS 23319 . 24463) ( DRAW/GRAPHNODE/BORDER 24465 . 25384) (DRAWAREABOX 25386 . 26587) (EDITADDLINK 26589 . 26987) ( EDITADDNODE 26989 . 29078) (EDITAPPLYTOLINK 29080 . 31159) (EDITCHANGEFONT 31161 . 32333) ( EDITCHANGELABEL 32335 . 33876) (EDITDELETELINK 33878 . 34284) (EDITDELETENODE 34286 . 36987) ( EDITGRAPH 36989 . 37056) (EDITGRAPH1 37058 . 37816) (EDITGRAPH2 37818 . 39549) (EDITMOVENODE 39551 . 41128) (EDITTOGGLEBORDER 41130 . 42426) (EDITTOGGLELABEL 42428 . 43725) (FILL/GRAPHNODE/LABEL 43727 . 44555) (FIX/SCALE 44557 . 45113) (FLIPNODE 45115 . 45719) (FONTNAMELIST 45721 . 45940) (FROMLINKS 45942 . 46112) (GETNODEFROMID 46114 . 47133) (GN/BOTTOM 47135 . 47411) (GN/LEFT 47413 . 47686) ( GN/RIGHT 47688 . 48079) (GN/TOP 48081 . 48505) (GRAPHADDLINK 48507 . 49066) (GRAPHADDNODE 49068 . 49857) (GRAPHBUTTONEVENTFN 49859 . 52039) (GRAPHCHANGELABEL 52041 . 52484) (GRAPHDELETELINK 52486 . 53794) (GRAPHDELETENODE 53796 . 54328) (GRAPHEDITCOMMANDFN 54330 . 55714) (GRAPHEDITEVENTFN 55716 . 56427) (GRAPHER/CENTERPRINTINAREA 56429 . 57193) (GRAPHERPROP 57195 . 57739) (GRAPHNODE/BORDER/WIDTH 57741 . 58262) (GRAPHREGION 58264 . 59433) (HARDCOPYGRAPH 59435 . 66817) (INTERSECT/REGIONP/LBWH 66819 . 68095) (INVERTED/GRAPHNODE/BORDER 68097 . 68681) (INVERTED/SHADE/FOR/GRAPHER 68683 . 69315) ( LAYOUT/POSITION 69317 . 69496) (LINKPARAMETERS 69498 . 69950) (MAX/RIGHT 69952 . 70154) (MAX/TOP 70156 . 70354) (MEASUREGRAPHNODE 70356 . 70805) (MEMBTONODES 70807 . 71332) (MIN/BOTTOM 71334 . 71715) ( MIN/LEFT 71717 . 72092) (MOVENODE 72094 . 73337) (NODECREATE 73339 . 74119) (NODELST/AS/MENU 74121 . 75721) (NODEREGION 75723 . 76183) (PRINTDISPLAYNODE 76185 . 81243) (PROMPTINWINDOW 81245 . 84054) ( READ/NODE 84056 . 85170) (REDISPLAYGRAPH 85172 . 85614) (REMOVETONODES 85616 . 86137) ( RESET/NODE/BORDER 86139 . 87926) (RESET/NODE/LABELSHADE 87928 . 89443) (SCALE/GRAPH 89445 . 95731) ( SCALE/GRAPHNODE/BORDER 95733 . 96428) (SCALE/TONODES 96430 . 97311) (SET/LABEL/SIZE 97313 . 100259) ( SET/LAYOUT/POSITION 100261 . 100746) (SHOWGRAPH 100748 . 102547) (SIZE/GRAPH/WINDOW 102549 . 106033) ( TOGGLE/DIRECTEDFLG 106035 . 106665) (TOGGLE/SIDESFLG 106667 . 107155) (TOLINKS 107157 . 107323) ( TRACKCURSOR 107325 . 108732) (TRACKNODE 108734 . 109370) (TRANSGRAPH 109372 . 111119)) (111179 127796 (EDITMOVEREGION 111189 . 114992) (EDITMOVESUBTREE 114994 . 116771) (NOT.TRACKCURSOR 116773 . 119751) ( RECURSIVE.COLLECTDESCENDENTS 119753 . 121241) (MOVEDESCENDENTS 121243 . 123305) (COLLECT.CHILD.NODES 123307 . 124423) (CREATE.NEW.NODEPOSITION 124425 . 124965) (GETBOXPOSITION.FROMINITIALREGION 124967 . 126439) (COLLECTDESCENDENTS 126441 . 127794)) (127860 130149 (NEXTSIZEFONT 127870 . 129060) ( DECREASING.FONT.LIST 129062 . 129388) (SCALE.FONT 129390 . 130147)) (130373 169525 (BRH/LAYOUT 130383 . 132127) (BRH/LAYOUT/DAUGHTERS 132129 . 133075) (BRH/OFFSET 133077 . 133755) (BRHC/INTERTREE/SPACE 133757 . 135075) (BRHC/LAYOUT 135077 . 136933) (BRHC/LAYOUT/DAUGHTERS 136935 . 139889) ( BRHC/LAYOUT/TERMINAL 139891 . 140572) (BRHC/OFFSET 140574 . 141470) (BRHL/LAYOUT 141472 . 143696) ( BRHL/LAYOUT/DAUGHTERS 143698 . 145456) (BRHL/MOVE/RIGHT 145458 . 146601) (BROWSE/LAYOUT/HORIZ 146603 . 147327) (BROWSE/LAYOUT/HORIZ/COMPACTLY 147329 . 150135) (BROWSE/LAYOUT/LATTICE 150137 . 150993) ( BRV/OFFSET 150995 . 151858) (EXTEND/TRANSITION/CHAIN 151860 . 153131) (FOREST/BREAK/CYCLES 153133 . 154063) (INIT/NODES/FOR/LAYOUT 154065 . 155560) (INTERPRET/MARK/FORMAT 155562 . 156829) ( LATTICE/BREAK/CYCLES 156831 . 157535) (LAYOUTFOREST 157537 . 158238) (LAYOUTGRAPH 158240 . 161707) ( LAYOUTLATTICE 161709 . 163162) (LAYOUTSEXPR 163164 . 164235) (LAYOUTSEXPR1 164237 . 164939) ( MARK/GRAPH/NODE 164941 . 165671) (NEW/INSTANCE/OF/GRAPHNODE 165673 . 167042) (RAISE/TRANSITION/CHAIN 167044 . 167445) (REFLECT/GRAPH/DIAGONALLY 167447 . 168176) (REFLECT/GRAPH/HORIZONTALLY 168178 . 168704) (REFLECT/GRAPH/VERTICALLY 168706 . 169230) (SWITCH/NODE/HEIGHT/WIDTH 169232 . 169523)) (172845 174196 (GRAPHERIMAGEFNS 172855 . 174194)) (174197 175925 (GRAPHERCOPYBUTTONEVENTFN 174207 . 175186) ( GRAPHOBJ.FINDGRAPH 175188 . 175923)) (175926 178546 (ALIGNMENTNODE 175936 . 177358) ( GRAPHOBJ.CHECKALIGN 177360 . 178544)) (178547 194397 (GRAPHEROBJ 178557 . 180303) ( GRAPHOBJ.BUTTONEVENTINFN 180305 . 181732) (GRAPHOBJ.COPYBUTTONEVENTFN 181734 . 182171) ( GRAPHOBJ.COPYFN 182173 . 183097) (GRAPHOBJ.DISPLAYFN 183099 . 185914) (GRAPHOBJ.GETALIGN 185916 . 186655) (GRAPHOBJ.GETFN 186657 . 188162) (GRAPHOBJ.IMAGEBOXFN 188164 . 192180) (GRAPHOBJ.PUTALIGN 192182 . 193012) (GRAPHOBJ.PUTFN 193014 . 194395)) (194398 213550 (COPYGRAPH 194408 . 195956) ( DUMPGRAPH 195958 . 206214) (READGRAPH 206216 . 213548))))) STOP \ No newline at end of file diff --git a/library/IMAGEOBJ.~1~ b/library/IMAGEOBJ.~1~ deleted file mode 100644 index 0d316f53..00000000 --- a/library/IMAGEOBJ.~1~ +++ /dev/null @@ -1,302 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "22-Nov-94 16:43:50" {DSK}library>IMAGEOBJ.;3 31911 - - changes to%: (FNS BMOBJ.IMAGEBOXFN BMOBJ.BUTTONEVENTINFN BMOBJ.CREATE.MENU) - - previous date%: "19-Feb-93 16:15:56" {DSK}library>IMAGEOBJ.;1) - - -(* ; " -Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT IMAGEOBJCOMS) - -(RPAQQ IMAGEOBJCOMS - ((COMS - (* ;; "Bit-map image objects") - - (FNS BITMAPTEDITOBJ COERCETOBITMAP WINDOWTITLEFONT \PRINTBINARYBITMAP \READBINARYBITMAP - ) - - (* ;; "fns for the bitmap tedit object.") - - (FNS BMOBJ.BUTTONEVENTINFN BMOBJ.COPYFN BMOBJ.DISPLAYFN BMOBJ.IMAGEBOXFN BMOBJ.PUTFN - BMOBJ.INIT BMOBJ.GETFN3 BMOBJ.GETFN4 BMOBJ.CREATE.MENU) - (FNS SCALED.BITMAP.GETFN BMOBJ.GETFN BMOBJ.GETFN2) - (* ; - "GETFNs for backward compatibility with older objects.") - (RECORDS BITMAPOBJ) - - (* ;; "make ^O be a character that inserts an object read from the user.") - - (GLOBALVARS (BITMAP.OBJ.MENU)) - (ADDVARS (BackgroundCopyMenuCommands (SNAP (FUNCTION (BITMAPOBJ.SNAPW)) - - "prompts for an area of the screen to insert." - ) - ("Snap 50%%" (FUNCTION (BITMAPOBJ.SNAPW 0.5)) - - "prompts for an area of the screen to insert, scaled down by 50%%." - ) - ("Snap 50%% & Save" (FUNCTION (BITMAPOBJ.SNAPW 0.5 T)) - - "prompts for an area of the screen to save in *INSERT-BITMAP*, scaled down by 50." - ) - ("Insert saved" (FUNCTION (COPYINSERT *INSERT-BITMAP*)) - "Inserts *INSERT-BITMAP* in a document")) - (IMAGEOBJGETFNS (BMOBJ.GETFN)) - (IMAGEOBJGETFNS (BMOBJ.GETFN2)) - (IMAGEOBJGETFNS (BMOBJ.GETFN4)) - (IMAGEOBJGETFNS (SCALED.BITMAP.GETFN))) - (VARS (BackgroundCopyMenu)) - (FNS GET.OBJ.FROM.USER BITMAPOBJ.SNAPW PROMPTFOREVALED) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (BMOBJ.INIT))) - (FILES EDITBITMAP)))) - - - -(* ;; "Bit-map image objects") - -(DEFINEQ - -(BITMAPTEDITOBJ [LAMBDA (BITMAP SCALEFACTOR ROTATION DESCENT) (* ; "Edited 6-Jan-89 16:34 by jds") (* ;;  "returns the IMAGEOBJ which gives the functional information for a bitmap object in a tedit file.") (IMAGEOBJCREATE (create BITMAPOBJ BITMAP _ BITMAP BMOBJSCALEFACTOR _ (OR SCALEFACTOR 1) BMOBJROTATION _ (OR ROTATION 0) BMOBJDESCENT _ (OR DESCENT 0)) BITMAPIMAGEFNS]) - -(COERCETOBITMAP [LAMBDA (BMSPEC) (* ; "Edited 11-Jun-90 16:28 by mitani") (* tries to interpret X as a spec  for a bitmap.) (PROG (BM CR) (RETURN (COND ((BITMAPP BMSPEC) BMSPEC) [(LITATOM BMSPEC) (* use value.) (COND ((BITMAPP (EVALV BMSPEC 'COERCETOBITMAP] ((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 (SCREENBITMAP] (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of BMSPEC) (fetch (REGION BOTTOM) of BMSPEC) BM 0 0 NIL NIL 'INPUT 'REPLACE) BM) ((WINDOWP BMSPEC) [SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC 'WIDTH) (WINDOWPROP BMSPEC 'HEIGHT] (* 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)) BM]) - -(WINDOWTITLEFONT (LAMBDA (FONT) (* rrb " 1-Feb-84 15:26") (* reset type of function that changes  the title font) (DSPFONT FONT WindowTitleDisplayStream))) - -(\PRINTBINARYBITMAP (LAMBDA (BITMAP STREAM) (* rrb "23-Jul-84 15:16") (* * prints the representation of a bitmap onto STREAM in a form that can be  read back by \READBINARYBITMAP.) (PROG ((STREAM (GETSTREAM STREAM 'OUTPUT)) BMH) (OR (BITMAPP BITMAP) (\ILLEGAL.ARG BITMAP)) (\WOUT STREAM (BITMAPWIDTH BITMAP)) (\WOUT STREAM (SETQ BMH (BITMAPHEIGHT BITMAP))) (\WOUT STREAM (BITSPERPIXEL BITMAP)) (\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) 0 (ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP) BMH BYTESPERWORD)) (RETURN BITMAP)))) - -(\READBINARYBITMAP (LAMBDA (STREAM) (* rrb "23-Jul-84 15:17") (* * reads a bitmap printed on STREAM by \PRINTBINARYBITMAP.) (SETQ STREAM (GETSTREAM STREAM 'INPUT)) (PROG ((BMW (\WIN STREAM)) (BMH (\WIN STREAM)) (BPP (\WIN STREAM)) BITMAP) (SETQ BITMAP (BITMAPCREATE BMW BMH BPP)) (\BINS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) 0 (ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP) BMH BYTESPERWORD)) (RETURN BITMAP)))) -) - - - -(* ;; "fns for the bitmap tedit object.") - -(DEFINEQ - -(BMOBJ.BUTTONEVENTINFN - [LAMBDA (IMAGEOBJ WINDOW SELECTION X Y SELWINDOW TEXTSTREAM BUTTON OPERATION) - (* ; "Edited 22-Nov-94 16:10 by cat") - -(* ;;; "the user has pressed a button inside the bitmap object IMAGEOBJ. Bring up a menu of bitmap edit operations.") - - (PROG* ((OBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) - (OLDSCALE (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of OBJ)) - (OLDDESC (fetch (BITMAPOBJ BMOBJDESCENT) of OBJ)) - NEW.BITMAP COMMAND.MENU COMMAND PREVIOUS.BITMAP NAME TEMP X Y) - (COND - ([OR (EQ BUTTON 'RIGHT) - (AND OPERATION (NEQ OPERATION 'NORMAL] (* ; " If he's extending a selection, or is selecting for move/copy/delete, DON'T bring up the bitmap editing menu!") - (RETURN))) - (SETQ PREVIOUS.BITMAP (BITMAPCOPY (fetch (BITMAPOBJ BITMAP) of OBJ))) - (SETQ NEW.BITMAP - (SELECTQ [MENU (COND - ((type? MENU BITMAP.OBJ.MENU) - BITMAP.OBJ.MENU) - (T (SETQ BITMAP.OBJ.MENU (BMOBJ.CREATE.MENU] - (CHANGE.SCALE (* ; "Change the scale on the bitmap.") - (replace (BITMAPOBJ BMOBJSCALEFACTOR) of OBJ - with (OR [NUMBERP (COND - ((TEDITWINDOWP WINDOW) - (MKATOM (TEDIT.GETINPUT (TEXTOBJ WINDOW) - "Scale Factor: " OLDSCALE) - )) - (T (MKATOM (PROMPTFORWORD "Scale Factor: " - OLDSCALE NIL PROMPTWINDOW - ] - OLDSCALE)) (* ; - "Return the prevous bitmap, so we don't change the bits.") - PREVIOUS.BITMAP) - (CHANGE.DESCENT - (replace (BITMAPOBJ BMOBJDESCENT) of OBJ - with (OR [NUMBERP (COND - ((TEDITWINDOWP WINDOW) - (MKATOM (TEDIT.GETINPUT (TEXTOBJ WINDOW) - "New descent: " OLDDESC))) - (T (MKATOM (PROMPTFORWORD "New descent: " OLDDESC - NIL PROMPTWINDOW] - OLDDESC)) - PREVIOUS.BITMAP) - (HAND.EDIT (EDITBM PREVIOUS.BITMAP)) - (TRIM (TRIM.BITMAP PREVIOUS.BITMAP)) - (INVERT.HORIZONTALLY - (INVERT.BITMAP.HORIZONTALLY PREVIOUS.BITMAP)) - (INVERT.VERTICALLY - (INVERT.BITMAP.VERTICALLY PREVIOUS.BITMAP)) - (INVERT.DIAGONALLY - (INVERT.BITMAP.DIAGONALLY PREVIOUS.BITMAP)) - (ROTATE.BITMAP.LEFT - (ROTATE.BITMAP.LEFT PREVIOUS.BITMAP)) - (ROTATE.BITMAP.RIGHT - (ROTATE.BITMAP.RIGHT PREVIOUS.BITMAP)) - (SHIFT.LEFT (INTERACT&SHIFT.BITMAP.LEFT PREVIOUS.BITMAP)) - (SHIFT.RIGHT (INTERACT&SHIFT.BITMAP.RIGHT PREVIOUS.BITMAP)) - (SHIFT.DOWN (INTERACT&SHIFT.BITMAP.DOWN PREVIOUS.BITMAP)) - (SHIFT.UP (INTERACT&SHIFT.BITMAP.UP PREVIOUS.BITMAP)) - (INTERCHANGE.BLACK/WHITE - (INVERT.BITMAP.B/W PREVIOUS.BITMAP)) - (ADD.BORDER (INTERACT&ADD.BORDER.TO.BITMAP PREVIOUS.BITMAP)) - (RETURN NIL))) - (replace (BITMAPOBJ BITMAP) of OBJ with NEW.BITMAP) - (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP NIL) (* ; - "And clear any cached shrunk bitmaps so the display looks reasonable.") - (RETURN 'CHANGED]) - -(BMOBJ.COPYFN [LAMBDA (IMAGEOBJ) (* ; "Edited 6-Jan-89 16:19 by jds") (* ;; "makes a copy of a bitmap image object.") (PROG [(BMOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (RETURN (BITMAPTEDITOBJ (BITMAPCOPY (fetch (BITMAPOBJ BITMAP) of BMOBJ)) (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of BMOBJ) (fetch (BITMAPOBJ BMOBJROTATION) of BMOBJ) (fetch (BITMAPOBJ BMOBJDESCENT) of BMOBJ]) - -(BMOBJ.DISPLAYFN [LAMBDA (IMAGEOBJ IMAGE.STREAM) (* ; "Edited 29-Mar-89 18:38 by snow") (* ;; "Display a bitmap IMAGEOBJ on IMAGE.STREAM. Scales and rotates it if appropriate, and moves it down by DESCENT.") (PROG ([FACTOR (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] [BITMAP (fetch (BITMAPOBJ BITMAP) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (CACHE (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP)) [DESCENT (fetch (BITMAPOBJ BMOBJDESCENT) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (STREAM-SCALE (DSPSCALE NIL IMAGE.STREAM)) SHRUNK.BITMAP) (RELMOVETO 0 [IMINUS (FIXR (FTIMES STREAM-SCALE (OR DESCENT 0] IMAGE.STREAM) (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (INTERPRESS (* ;; "Printing to an Interpress stream, so use the specialized method.") (SHOWBITMAP.IP IMAGE.STREAM BITMAP NIL FACTOR 0)) ((DISPLAY PRESS) (* ;;  "This is the default case, press display and everyone else prints the junky shrunk bitmap") (COND ((NOT (SETQ SHRUNK.BITMAP CACHE)) [COND [(LEQ FACTOR 1.0) (* ;  "We're shrinking the bitmap. Create a shrunk image for display") (SETQ SHRUNK.BITMAP (SHRINKBITMAP BITMAP (FQUOTIENT 1.0 FACTOR) (FQUOTIENT 1.0 FACTOR] (T (* ;  "We're expanding it. Create a bigger one.") (SETQ SHRUNK.BITMAP (EXPANDBITMAP BITMAP FACTOR FACTOR] (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP SHRUNK.BITMAP))) [BITBLT SHRUNK.BITMAP NIL NIL IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM) (DSPYPOSITION NIL IMAGE.STREAM) (FIXR (FTIMES FACTOR (BITMAPWIDTH BITMAP))) (FIXR (FTIMES FACTOR (BITMAPHEIGHT BITMAP]) (PROGN (* ;; "This is the default case--Call SCALEDBITBLT") (* ;;  "changed OPERATION from PAINT to REPLACE as PAINT doesn't work for all devices. --was") (SCALEDBITBLT BITMAP 0 0 IMAGE.STREAM NIL NIL (BITMAPWIDTH BITMAP) (BITMAPHEIGHT BITMAP) 'INPUT 'REPLACE NIL NIL FACTOR]) - -(BMOBJ.IMAGEBOXFN - [LAMBDA (IMAGEOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* ; "Edited 22-Nov-94 16:41 by cat") - - (* ;; "returns an imagebox describing the size of the scaled bitmap") - - (LET* ((BITMAPOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) - (FACTOR (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of BITMAPOBJ)) - (BITMAP (fetch (BITMAPOBJ BITMAP) of BITMAPOBJ)) - (DESCENT (fetch (BITMAPOBJ BMOBJDESCENT) of BITMAPOBJ)) - (SCALE (DSPSCALE NIL IMAGE.STREAM)) - WIDTH HEIGHT) - [COND - ((EQ BITMAP 'NoneCached) - (SETQ WIDTH (SETQ HEIGHT 5))) - (T [SETQ WIDTH (FIXR (FTIMES SCALE (TIMES (BITMAPWIDTH BITMAP) - FACTOR] - (SETQ HEIGHT (FIXR (FTIMES SCALE (TIMES (BITMAPHEIGHT BITMAP) - FACTOR] - (create IMAGEBOX - XSIZE _ WIDTH - YSIZE _ HEIGHT - YDESC _ (FIXR (FTIMES SCALE (OR DESCENT 0))) - XKERN _ 0]) - -(BMOBJ.PUTFN [LAMBDA (BMOBJ STREAM) (* ; "Edited 11-Jan-89 17:00 by jds") (* ;  "Put a description of a bitmap object into the file.") (LET* ((BITMAPOBJ (IMAGEOBJPROP BMOBJ 'OBJECTDATUM)) (SCALE (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of BITMAPOBJ)) (DESCENT (fetch (BITMAPOBJ BMOBJDESCENT) of BITMAPOBJ)) (INTSCALE (FIX SCALE)) (FRACTSCALE (FDIFFERENCE SCALE INTSCALE))) (\WOUT STREAM INTSCALE) (* ;  "First word is integer part of the bitmap scale") [\WOUT STREAM (LOGAND 65535 (FIX (FTIMES FRACTSCALE 32768] (* ;  "Second word is 16 bits of fraction") (\WOUT STREAM (OR DESCENT 0)) (* ;; "Now write out the bitmap:") (\PRINTBINARYBITMAP (fetch (BITMAPOBJ BITMAP) of BITMAPOBJ) STREAM]) - -(BMOBJ.INIT [LAMBDA NIL (* ; "Edited 11-Jan-89 17:01 by jds") (* ;;  "returns the function vector which gives the functional information for a bitmap image object.") (SETQ BITMAPIMAGEFNS (IMAGEFNSCREATE (FUNCTION BMOBJ.DISPLAYFN) (FUNCTION BMOBJ.IMAGEBOXFN) (FUNCTION BMOBJ.PUTFN) (FUNCTION BMOBJ.GETFN3) (FUNCTION BMOBJ.COPYFN) (FUNCTION BMOBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) - -(BMOBJ.GETFN3 [LAMBDA (STREAM) (* ; "Edited 11-Jan-89 17:03 by jds") (* ;;; "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.") (COND ((IEQP (\PEEKBIN STREAM) (CHARCODE CR)) (* ;  "This is an old-format sketch with bitmap included. Skip the interfering CR.") (BIN STREAM))) (PROG ((SCALE (FPLUS (\WIN STREAM) (FQUOTIENT (\WIN STREAM) 32768))) (DESC (\WIN STREAM))) (RETURN (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM) SCALE 0 DESC]) - -(BMOBJ.GETFN4 [LAMBDA (STREAM) (* ; "Edited 6-Jan-89 16:33 by jds") (* ;;; "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.") (COND ((IEQP (\PEEKBIN STREAM) (CHARCODE CR)) (* ;  "This is an old-format sketch with bitmap included. Skip the interfering CR.") (BIN STREAM))) (LET ((SCALE (FPLUS (\WIN STREAM) (FQUOTIENT (\WIN STREAM) 32768))) (ROT (\WIN STREAM)) (DESCENT (\WIN STREAM))) (* ;; "Dummy words for later expansion:") (\WIN STREAM) (\WIN STREAM) (\WIN STREAM) (\WIN STREAM) (* ;; "Now read the bitmap itself and construct the object:") (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM) SCALE ROT DESCENT]) - -(BMOBJ.CREATE.MENU - [LAMBDA NIL (* ; "Edited 22-Nov-94 16:05 by cat") - - (* ;; "Creates the menu that comes up when you button in a bitmap image object.") - - (create MENU - TITLE _ "Operations on bitmaps" - ITEMS _ '((Change% Scale 'CHANGE.SCALE "Changes the scale factor used at output time.") - (Change% Descent 'CHANGE.DESCENT - "Changes where the bitmap lies vertically (bigger descent => lower)") - (Hand% Edit 'HAND.EDIT "Starts the bitmap editor on this bitmap.") - (Trim 'TRIM "removes the white space from the edges of the bitmap.") - (Reflect% Left-to-right 'INVERT.HORIZONTALLY - "inverts the bitmap about the vertical midline.") - (Reflect% Top-to-bottom 'INVERT.VERTICALLY - "inverts the bitmap about the horizontal midline.") - (Reflect% Diagonally 'INVERT.DIAGONALLY - "inverts the bitmap about the lower left to upper right diagonal.") - (Rotate% Left 'ROTATE.BITMAP.LEFT - "rotates the bitmap 90 degrees counter-clockwise.") - (Rotate% Right 'ROTATE.BITMAP.RIGHT "rotates the bitmap 90 degrees clockwise.") - (|Expand on Right| 'SHIFT.LEFT - "prompts for a number of bits to add on the right.") - (|Expand on Left| 'SHIFT.RIGHT - "prompts for a number of bits to add on the left.") - (|Expand on Bottom| 'SHIFT.UP "prompts for a number of bits to add on the top.") - (|Expand on Top| 'SHIFT.DOWN - "prompts for a number of bits to add on the bottom.") - (|Switch Black & White| 'INTERCHANGE.BLACK/WHITE - "changes all black bits to white and all white bits to black.") - (Add% Border 'ADD.BORDER "adds an arbitrary border in an arbitrary shade.")) - CENTERFLG _ T - CHANGEOFFSETFLG _ 'Y - MENUOFFSET _ (create POSITION - XCOORD _ -1 - YCOORD _ 0]) -) -(DEFINEQ - -(SCALED.BITMAP.GETFN (LAMBDA (INPUT.STREAM TEXTSTREAM) (* jds "30-Oct-85 11:29") (* reads in a scaled bitmap object with readbitmap and read) (PROG (FACTOR BITMAP) (SETQ BITMAP (READBITMAP INPUT.STREAM)) (SETQ FACTOR (READ INPUT.STREAM)) (RETURN (BITMAPTEDITOBJ BITMAP (FQUOTIENT 1.0 FACTOR) 0))))) - -(BMOBJ.GETFN (LAMBDA (STREAM) (* rrb "17-Jul-84 11:46") (* this is an old version of the get function for bitmap image objects.  It is left around so old tedit documents will still work.  |17/7/84|) (RESETFORM (INPUT STREAM) (PROG ((FIELDS (READ STREAM)) (BITMAP (READBITMAP))) (RETURN (BITMAPTEDITOBJ BITMAP (CAR FIELDS) (CADR FIELDS))))))) - -(BMOBJ.GETFN2 (LAMBDA (STREAM) (* rrb "17-Jul-84 11:29") (* * reads a bitmap image object from a file.  This version stores the binary data rather than the character representation  used by READBITMAP.) (PROG ((SCALE (\WIN STREAM)) (ROT (\WIN STREAM))) (RETURN (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM) SCALE ROT))))) -) - - - -(* ; "GETFNs for backward compatibility with older objects.") - -(DECLARE%: EVAL@COMPILE - -(RECORD BITMAPOBJ ( - (* ;; "Describes a bitmap imageobj") - - BITMAP (* ; "The bitmap itself") - BMOBJSCALEFACTOR (* ; - "The factor to scale it by when displaying") - BMOBJROTATION (* ; - "A rotation to apply when displaying") - BMOBJDESCENT (* ; - "How far below the base line to display it. NIL => 0.") - )) -) - - - -(* ;; "make ^O be a character that inserts an object read from the user.") - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS (BITMAP.OBJ.MENU)) -) - -(ADDTOVAR BackgroundCopyMenuCommands - (SNAP (FUNCTION (BITMAPOBJ.SNAPW)) - "prompts for an area of the screen to insert.") - ("Snap 50%%" (FUNCTION (BITMAPOBJ.SNAPW 0.5)) - "prompts for an area of the screen to insert, scaled down by 50%%.") - ("Snap 50%% & Save" (FUNCTION (BITMAPOBJ.SNAPW 0.5 T)) - "prompts for an area of the screen to save in *INSERT-BITMAP*, scaled down by 50.") - ("Insert saved" (FUNCTION (COPYINSERT *INSERT-BITMAP*)) - "Inserts *INSERT-BITMAP* in a document")) - -(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN)) - -(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN2)) - -(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN4)) - -(ADDTOVAR IMAGEOBJGETFNS (SCALED.BITMAP.GETFN)) - -(RPAQQ BackgroundCopyMenu NIL) -(DEFINEQ - -(GET.OBJ.FROM.USER [LAMBDA (TEXTSTREAM TEXTOBJ) (* ; "Edited 26-Apr-91 10:54 by jds") (* ;; "reads an expression from the user and puts the result into the textstream.") (ERSETQ (PROG ((VAL (PROMPTFOREVALED "Form to eval:")) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) BM) (CL:TYPECASE VAL (STRINGP (* ;  "Atoms and strings get inserted as text.") (AND VAL (TEDIT.INSERT TEXTSTREAM VAL SEL))) (LITATOM (* ;  "Atoms and strings get inserted as text.") (AND VAL (TEDIT.INSERT TEXTSTREAM (MKSTRING VAL T) SEL))) (IMAGEOBJ (* ; "IMAGEOBJs get inserted as is") (TEDIT.INSERT.OBJECT VAL TEXTSTREAM (SELECTQ (fetch POINT of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL))) (T (COND ((SETQ BM (COERCETOBITMAP VAL)) (* ;  "If it can be coerced to a bitmap, do so, then wrap the bitmap up as a nobject") (TEDIT.INSERT.OBJECT (BITMAPTEDITOBJ BM 1 0) TEXTSTREAM (SELECTQ (fetch POINT of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL))) (T (* ;  "Not a bitmap, nor one of the special cases above; complain") (AND VAL (TEDIT.INSERT TEXTSTREAM (MKSTRING VAL T) SEL)) (* ;  "(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT 'Not implemented to have ' VAL ' in documents yet.') T)") ))))]) - -(BITMAPOBJ.SNAPW [LAMBDA (SCALE SAVE) (* ; "Edited 19-Jan-93 16:08 by jds") (* * 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] (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) BM 0 0 NIL NIL 'INPUT 'REPLACE) [COND (SAVE (SETQ *INSERT-BITMAP* (BITMAPTEDITOBJ BM (OR SCALE 1) 0))) (T (COPYINSERT (BITMAPTEDITOBJ BM (OR SCALE 1) 0] (RETURN]) - -(PROMPTFOREVALED (LAMBDA (MSG WHERE FONT MINWIDTH MINHEIGHT) (* jds "26-Sep-85 16:46") (* opens a window with MSG in the title and returns the result of evaluating a  READ from that window. (PROMPTFOREVALED "HOW'S THIS?"  (QUOTE (600 . 600)) NIL 100)) (PROG (NEWVALUE WIN (FONT (OR FONT (FONTCREATE 'HELVETICA 12 'BOLD)))) (RESETFORM (WINDOWTITLEFONT FONT) (SETQ WIN (CREATEW (COND ((REGIONP WHERE) WHERE) (T (CREATEREGION (COND (WHERE (fetch (POSITION XCOORD) of WHERE)) (T LASTMOUSEX)) (COND (WHERE (fetch (POSITION YCOORD) of WHERE)) (T LASTMOUSEY)) (WIDTHIFWINDOW (MAX (STRINGWIDTH MSG FONT) (OR MINWIDTH 0) 125) 8) (HEIGHTIFWINDOW (MAX (ITIMES (FONTPROP (DEFAULTFONT 'DISPLAY) 'HEIGHT) 3) (OR MINHEIGHT 0) 100) T 8)))) MSG 4)) (CLEARW WIN)) (RESETFORM (TTYDISPLAYSTREAM WIN) (SETQ NEWVALUE (CAR (ERSETQ (LISPX (LISPXREAD T T) '>))))) (CLOSEW WIN) (RETURN NEWVALUE)))) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(BMOBJ.INIT) -) - -(FILESLOAD EDITBITMAP) -(PUTPROPS IMAGEOBJ COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 1993 - 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2830 7222 (BITMAPTEDITOBJ 2840 . 3379) (COERCETOBITMAP 3381 . 5425) (WINDOWTITLEFONT -5427 . 5774) (\PRINTBINARYBITMAP 5776 . 6567) (\READBINARYBITMAP 6569 . 7220)) (7273 22542 ( -BMOBJ.BUTTONEVENTINFN 7283 . 11679) (BMOBJ.COPYFN 11681 . 12240) (BMOBJ.DISPLAYFN 12242 . 15098) ( -BMOBJ.IMAGEBOXFN 15100 . 16221) (BMOBJ.PUTFN 16223 . 17431) (BMOBJ.INIT 17433 . 18368) (BMOBJ.GETFN3 -18370 . 19158) (BMOBJ.GETFN4 19160 . 20190) (BMOBJ.CREATE.MENU 20192 . 22540)) (22543 24005 ( -SCALED.BITMAP.GETFN 22553 . 22979) (BMOBJ.GETFN 22981 . 23516) (BMOBJ.GETFN2 23518 . 24003)) (25796 -31700 (GET.OBJ.FROM.USER 25806 . 28569) (BITMAPOBJ.SNAPW 28571 . 29472) (PROMPTFOREVALED 29474 . 31698 -))))) -STOP diff --git a/library/KEYBOARDEDITOR.LCOM.~1~ b/library/KEYBOARDEDITOR.LCOM.~1~ deleted file mode 100644 index 654248c1d0c82fc901ce62c92b06193c38c4d28b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 28406 zcmeHwU2J37eV<6}tYp`Eql4z;=@^)+^Pc|}sim`p^O`@{nMI z1(KpgyZ!zD=bU@bB`J;9ae@Gyu}$53?)m(m|L5=g@AYIhx9pU1@nxrwi#w%dS6nUU z>}=IuD&$1WDOGdjf>T+KiL2{&X3bs+6;2IJQo9UVRC8GoOU%WW>$l>INny=ipPj#+ zoR5jg*lzpYexq6UM7t$o;v2udo-5?87jIn8m2S9|Z+?Zk&$#8>s|9DNY?rrRUCV7R zxpq05%Q{uJJpJXwH-@G}%v$vOp1(emygsuK6St`A<`+HDK+nax*R06q|p zM;O^`y>LA-b3K)abx+>1;;YB4_~MMP=B}r#>oYSk@$1>j+Bd&)e0cC`v%OnuzS{Ka zuQnTp`@8J}y0~>vJGkFFUokr~KQ||K_iC-%^}``?)c)1$V)BMvu88p3GH$UlB_@|k z6>(#2DLb8UOUu()(4$~)V@Gm@Z2X2@*vR#HN?R4zy-kUs{e$|~8tvmlUNDA>C1-d! z3-iKC@LnwboXfGMhG-{fZqCX^*{(WnNnFn^3{5&>M#$olUCd31fr|qJ1CjJ|_#GG? zn4Ep$w1-MgVQ6w{C|G;-Q7)q?X&bkUKGit?uT=9LGL@92h;oe}Y=f)kBK#@>o{ zwcokaDY=(kMD^Rc`etWj=6Tdc{hiC5f_r&vXV|^WGsL|++|$Kqhiezy(FynR#JHM@ z!;9hhp!er=@5ktUsNl%%#$-zjG|_R#PR6~+NaT|H5*9h(PRJ?~SE7Tbf9j5P&D$G% z@9%jJ$M+^qM!g8t_uPq>{?MJ6Ku>7!XFQ{*J28Ic!NBk6v9~bxh$j*BH<-*C6QzJ%byn@63$$~4!@QmRV2?yErFm|>3>_|JlU5&LG&RgDBrH?N z+2u`WFH2<0xuSa`CsN4;QLS#nLO=zGlr<~VgJi;dkeu-!B<5%2P$a`nHeO{l6(r4aNMd`3Nh#4oe+OuAg;OHX_Mt68h8< zq;+S+7IbGyE77D@yrgA`o~&Ud6-dQ`oUma3^O=Ex3nLCvUeZv_fNPL|Y00wP5U!x9Owiew+DK&%DDXCPCLR9kR%c!!pA)l8m^ zcVI}t+c0Eg-=qjxsYD=a)SI@OmIYCR43VvqWdgn!X`!ks79by$bvT;^F%RujS+C}{ zsvG5;m`e%ieyS#^S@EV*s^F0tFPRWaP8B}DrjxDaMPgoL^0~~~D>T$AP7xk0L?Z!d zkyB=&wH6bK$1O;+6k2N*<0?16f;i}DFU~7ToS#D(Jhu#W2m(Sf`pMd|TNa9mmGh*1 zDnlZFr7zEid_L)dk#hkVcCzGvE7iqb2D=U<3U;*`_g#*eKnS$!=8rCB#S$E-Ww%s? zApFUN$Up?HhVfG^K|L9{6rf_27M_ys{`OeKdUOtek=JTtD*h%5?8vJ+LlkN)7f=i^g zu=bV*%73!~-3E`Wjx;Qtb45{qQw}^4gJuppDFP>#N6CzhG zgWVPafeRToW_&#eg&qz)E!elSbYC#~foEe zAY%$YSIp0=nNg=bEt?Omy*e7PXzQ{Aq5}7a9okGD~nsa4n8)P?Zf^Xcu9}y21v=&@l_(-Zcr#Lo-x`py;g$y{ARmp4=kb^R?Tz!+rs+D8CtbWP zYjTN$njBLs2%0Qbs(n`2ul4P7vO zVFeTuN;5VB9i7rd(16UAjG!01Hl1#zBrC=(w zeE@7sFLxbSQLZZz(MSl~+$^{NVG-B`7mK72@poR7E&M?shF?Gr_)VZHRiT(^g)U~K zMTjpK>=h<(XcAK*@?S0y$IL{1jyb*BV3Kyy5?|;rndSA~a5QogJQCSneQ!)v3q4i_ znLGGDA3YSkbvmmfBhRc2o?g7t_#@{e5qZ-YdvDC>qf=1Bu0`KC`6;QM3&rTj$frt! zr(eE8>gLahMUy!1u0Tgdula-u=fb`MnQ^BRiLP zO7Eo`TXJ#ch{Z_nN;~eQK82;|TMs_I4}fF!rT6}RzpmWNeOdwh*cpECaW%3t7D2;n zeH)JToy2H#XY|3xQ$RZ8I>*i!cB0>~I=b6_apzWa}g%X>|opTV27^QavX8eiHEL<>SOWVHF&7AW~3Q zv;I?vqHYZ3EHx}R+Mln*kqR}p{OMv8)dsUI>L42gL82)3?bh-OYrscCwygB%^+`&czY zPaN!5+>LU^7)CirJSJ?+zh^HgJ(%|X-GhOD>wP1+1s#ii3}+xs3p zc=VhtAF%qkd3uFyjaif){}w+x`K$EJj*MZpq{Ad{*dWQcWYxH4MZ^uaxm0RU84$_Z zY|dcGthw1nxD4bbUlrL zF%IOBfDGc^B^;csl--R|HqJh#Hss{evrQ&+geo(W>Ko}b5{s&?#4@B}skVFf_Cfo& z!NJp<<8#jv*bzvX(>U*GYJ7-yaJWyX5fs-3s49_ zpqhDww1U3I6XoeJtrX)x2NZ3SK=2*KKpp<;087>9JpKb{f#=bDf&Z|GjKF909H0!B zy~gMZ9q;bwvl?D_0^p!pKHtG=u$zG=NVD%3d~{BhD_Zj;WZ}tU_F$b#mYm31eB(vj8?4C0_czcEzn^a%MPEw z@k;FsEHKU-qzE$6!bDI9b)d0wz@J$4TuS?@!QVwCsc@qqpN^?y$QbzwhWu)rM+Sxl zzJDAzAI{Uc*=y`-Qw`nZHHhc_AVL~)wcopDXnpVDn+hWSo^-XP6#gzW`MxF-9BK5rtaZE>vl}QwbVx$gxb(^I@9p` zqr(gGVluTB<2%%ldr(IheoeS`I6Ce>r@h*dxZge&@6=jo+!oYH*hX~ox#G21ldbpw zSqeP!I;;f*M;=_$PRWD~@|G%jXPHtk6koDg@nIkZ4^azgVjzgjlB9mXi64B5;Gz9z zCD0>d2j#4=<@l<>LvN6C^v}J>57wfQA3Aw{{v*~W4?iQFB`$imkmkQ9uNO`~TZ}q5 zti*qrVF_Qr|BBJb#7QE$_hP5uMZX)3y!Gu89IjD1)--Fr{5z}PE<_{I-^35f$2)4w zlP?BJtYcg<`|~}IFOgmyU|8@Clvi(ooe%|Ad;}MeF3W*|KZ*s#!>oIxPaoGRNNOh- zxni!k1U-ddg4_2!1A%PxpiX2XdJEy#7>6a{qs0U{V=|LKouxpzh6@(7l&a0AIH}|o z+{_wt2pAUU8OA+gINyhv)=M)uu0l?JP{S@1TT|4q3J##gN2lk=d&q)OP8>@f}Dt;j9wPt$RL-diJicEEUA0 z#cDYS#^f=dvAij8|34gn9!`7u=lzWvLDvL2vVNaJ1C_MCk|c3!m?7d2}?}{A_dhr^qYeW7_76xZ(cTaKZx` z?+n8h%OP5kfx9D17Yp9nM-NM#;$`XvXIjnS(Tg4FWAb*6_8;_z-l{)nwE3bMviVtz z&>Z&IWxe~s&M*(`4nq@C`poGi_tM_PTR$$`egDmq-*PX#{KqGMiSt;*A8w{<7b;Z% zBrBW?5eTCuUTK3B5Kgb83r5B@$R{woE^F3wyDUKAA-|LOCg`1gO>CLU+<>+3b>k?0 z^xZfu>@1dDt)bPzLzyFKjjP*Kygr}i0#-e>Y2nPX@QGw0~d|LL^6Zi96WttZ_9i5D~P5d!;v>4 z($@U}Orrha@2#Ew_r}S8TaBI=3?{VzH)gZck@%`n&~3N=Sh8aC<2xheA$QnwFMR~V z`>#6g<;!$V+K(Nd5bgZfD}pcIVqsvuEJ?8#?`-qn%#dl@A^XgOPkd$o|Kv#k7ku;w z{D&*WAl?)J|1*2XSiCL&o3H&8sXQh!O zh!3Z)0ZgcYKswkp#LNdI5#nip5KQwrbl+qGk`)Y}fdj!zM7d4+tcnGoXm2U*iMz{j zs)zG=Vn9lQGPyt01^k5mom+k5QA)fB1kegaq{>|(l1f*lSKciodWGBv_&cHdxh{W$ zQCZGpl>Ubq0UPTeyObd45gE85+iukf7(^;lOw?fYZ`I+3i-Y>nL8JaPm~#}vEX6i! z4FHHsjiY)u><=>P=?Op*0T!7d|D)$b#eSmC=nBJ#~4I#2n} zFVHCoOU6wWq2Ip<$r{)h?#REFxUhLqLW7SX6g!vQ(T{%Dz5E;Q=$rh|l}8rb2N!(L zl_rEs{_&m1sx3cz+#G$pGu|P=8~5C?kA4@4kzXwo_dJ=PAw$MD(rawSR`~=?`TJaA z;E}=o9gn-_A8x@)BP}tbJ)M%l^@B!^j2yUt8*%f8zw8b>K}~+pkw~Xe%(HMW86{j% z_Q-VO8nWFThxLt7SuTQ*9k@VppMcAOy|J4>>;o~Y0NO^@k}oLarywQ4lu>iDfkUnX zud5>GfsZ{x;Am2(RFksBz!A**3F!ngnU%Vd)TB6Oo_0x~ae74s#4 zzIC-l=Mq=jgdF0)QXXn1U?gR+hFhwm}Jt|Tl0$T(C7@mNnC_^GmvluLbBA0oCX@5oLJ_E{~!m;Y`Y zO`~(&3zZ{6rzJzd(pfwK3uJJJR_Me7#8^@fC2=;UvuctF9HS9a&H#>fOJ4-va?KjpR|>r+9I4|gRHXYkEO_oSR6sQgF_3W=GHXS94F}@^1Oiai zFvvX<#ra<_)H#I0u2rz{xstL0df$k(f=<=?OtW`(pKJw@RUOL_fQ00rHJubhXJ-~P zMXa)4-)+2oAI6XpVA<&Tm8cbz~L1knM#nlG>HRS+AU*-dAXY-uj>o{HTzxk)nYN z-$JKk`~5(Xg(~PH8+D#Y!(+R+z+H zaK553pGqP^=y@|^U>uR^An>V?$bgBW-OYdc5`nHjiHrZWlazrB^5DLN zU5btj52R&uqTZEx^ci`+%GCJ~N4qR9gdA!u;K)&FNCHvGg_mlDN?wt88lfVrYFO0= zm=h)FaCtvq5KN0KPU=MiIwmJ*8W=8zzg$xVvhYLh{{fa4q2=)c3<*c9`m2$2kl5GB zBklZM6@+&3Dt_f8FH^UvWe3E@i83!mJ>WS@g6I^^ARCWPWqRJTQ0@JNDXZcud(cB4 z>>3M1sY#YIEUzNXEYkiZm_*(>B}O5ijHCKZkjTSnNu)V?rxp2UBZE;V|IzoaAjED? zjtpKX0PT5sZx|WJG80mHq%yYeICtOw!Ro#L@%|4_{!_6P`9oEuASundvr}jezyG6R z^Rw^&_~dk8l4B`KOMzn(3N8ta=bUzgs50pU7TK(UJVseVWtf<2?=gRB)kt%Z@^Iz} zfk97GPKZ3bk9>H5V|l~0J~^@UkMQ;pzmOJanr%C{enSb`!v#Pik6LRHDR(!SYEs;O zv4 zs=l5==i~vYWhI*ZRSUTxXRy1a(f&|sDVeaaI}NkQJ)AKBT)(phfUnMv0)f)+0!h_E zi9aNIK)961_9!VG!k9`*OK?ABM5kUnCN+?KL&5h7F{aj2NP-K#<>n>}fx^Ca6Tnr> zvj-ga1d*YU2%Id0IkE;lG@XhfVO8F$Q&(D!g{kV1uAca;wV zAEalch^YD$p5f$}5enSMa0-hemsWKR1P0lKs##NyPlywFP4G}+m zIkIK!STm+y5{W!+KBupvk;gJ;W!ro7yeAJQ$*SoXmc_7dybte|195Ob`1K)}=dOZ& z?k_T}_;nCJah=F!`U5)jJDXts8Hsjj5)zLlvLR6ja#6vn97HvqC^?~qf5SjMp96qy zIXV}=_@jaup#4TQeSc*GK18=2;bjKuW~)Rd9`^#t6OMOM2z}X z84cbt!Bs%*!ypO*!TXtprwQG_+z)PqNSm*k1B49NQBc?r(y{RQ6~2Kz44KgsA`!|f zWP0^KZ0)bfzy$0P)A=Pg#teYmV(;jrEEXJ1_TZ9TaI}(6I*cd~8q8j4nNCpo8d)P7 zbpHO!5ZS@>-4EpJe)do45=T;x!MQlTD7snS5tv+u3aM^Gt|XSNbqCSeEu*-CNtV~` z*I)P32!cm=hlak^P!Ttra&^Nl=*IL30%|HIza+l=WiiA7D?(4ojL4YpuN+dUC`D9W z{c!i7u}|-`P-I0#`+N5f8~8*5o!*LO4Y?0T*Tg$}jom#eIb`Hlp5WH-Ld`W%KiZv+ z;kyp}@dKJ;c+;gJ>HGRn@JJsVnJ<>~c~vz0+FWmQ&_O0r1dnJ!ec#G3x>s>p(5O$+ zKGrAUBM{yHzyrrRc%rGTB7Gt^NF}3DNx?(0j|1?-I$nVd2&K18_DC~*Qo^B}G}qL! zXrg31GxO=05Sd?-yaP^~_06v_M$gHE-)vev(gVnYiQuuGoj$WLj*N}|yK5D{3RQ3A|z&3@%rDkXPKbK(K ztd$@w;LB^aHavj@R^&RnR`(K%b>chs{xeV)jD zF*??2T2o8!h~IYFB(YJdF?0DEUGU&%r>-O-nHI*O4Vscz8@GzY>!F>0LLT=dy`~}I zU3})~^$oY06O(8&4VW^MtALACSwM?ky$QAiV-CeKwPy2>Evat z0G~QKlG%znZISG*nYwsQAQ>EpF{&dSQdw&L>_T8zkW59*y3-_)^BBnd9V7*w(&2B24lDgMH{|XUm#2{$;H2|e{=utV`D}WH`Z=%MrTWFR>vH{)s-Mjm z)6L_e;(EXVCBm-V?y z=qIo0^IDz4QYN1-!Ntov=a#!J>Z2d3?-=!i@)cDs`wtDNZkV2F5N*ZgAFLVVQ*`bs zcYeXqPwNLePJZ%I+(s44n z?{T^*Bs!;-9~kvkIwv{``D+}7oaF|JN&PM#K9W+xt25duyar%Mx|__1A%_`hP zKchEc@U>gQps|c2fsfQClRZ5oK4A|jxuHk(7Uj(pFtZl=C18dpmTw%?Zr571m>5dV z>B6h!(Z)!II; z5U#2!NR6`Q2-1nI)LZofAj(9sYJGRF#rU%BDS`YQIoA30EUHIy7>X4dw`)ho2lc~i zV&$N=4{#d2N628~=rDMB?FiqQ zep13&Uq0yv3c|wD`<(J+FMjij4$AqooZq;jJG?5!uYL7XTMTYJMOsY9@F^0asByN3 z{7F6Pr}c@XPw6Qc>u-e)%ZiDOKRm8&6sSusKdZj1BZGDXdUR{dU-!m;xqOKm^eOkd zAYm}-^CkVDr5r%^W0vP_y5n*eF*c&?0xIY2LQszAoU7nj+AIemfq(Ra{{4P_9;5|5 z<$-zdk8L0=KV!L%wDhgtFNVf?R|skGM+K~dTShzxY55t-F<*tWgzM8fxS!r}71Dwg zhMOp)<*!}-GaxOYfeobP7f{~2-t&>JGwKsh_55T0>?sY&OXz9l6C*19W`nZ4Mp|As z+(J616TfiJ=Byb!EoTb+!glm2J)hFk;DM)nC5iEr4o~S|h{Y#AlQ0__*H8KC?PkN#dip-F0&M2k{7B|_2JaIX9yyf`Z&3rjOIOYy~! zm<;W;?jO_})rx2}MM(U^RB`qIHrCZzgiJ>bh}{{lA>5j=W^+S z$XV<7^(HetJslF2@-e1hPH}!I8eNJkhAvn|d?^-Pip}<$^-SMc$Hi zihu?~y{XxMUeT!`8ZGJMSM1fzf>pAeyjV&t3{Bc%M#$p4l}k^Fffoh_1_Fr}@jEa) zFgYuyN;Rg{9GP9hdMQ&wc{@8aIW@#f;(E!9m0wL$jqpt?yP1{)ZGbt1RV-3@QQ&S~ zIAZlgpqj*2ZipK^He zOgxm$V2XBrOW1gtb2f`68e5`P#t1;K;^v7L)i^nqWV~m$6TyJ2`s6Iy9vQxrtxc@gTGZ?%Zu^a_{Y!MwmW^`qCU^VV!@zfS z!^!rD_(IkW1_NX71v}dBUTNo@E3csXU0r>vJu-6{wNZcfYCG#(9orptuJR0V?+kZ! zG1}(ZS!Z;@xjHefregDAcs}U;Mcw-edLPQ#vb!1M6Iz_W;>6hQ^~$4bj*z2?wsRd%u6K;K8&VSu2A$CNvQCI5C?5#!fR!@ONj z&Xz`ouTtlM-LIhIue|ypez@1~P$_OOnRO;g7Q1S%Swoj-=W4^eo&2Ciq8HaZw^4vX z7PGNP4`E!f(-0UbXS0y7WHxOTw#4jAM5GGooO3fR;;{u$D(yhsLj{OX;e0U;*|yn@z7;S;3nxX_^l8|iHT6U zd0agd&FTkgK}#VKi~7oGd6P#|VktBvqBC=5lS=jd@=4*q#B2G<79o7dF+W&L2{lN1XZ|2%G7dc0k+lYH~n&qI3cPjmy4 zW!AE_B+D_&d6G*qc9J!lrB%yo?Zm@@-wC{12?neuAEvl|FtF2J3*LJ8^xINHe3)3~ z^3z|}&3@2M$dP6J)76fO^G3yGOo#pj#)5&<>$2h>Czh$?)kjzAzvF2UIa|^t(K+HI zJ0F32w5WJWYL)0ryuYYN7Ut!{m2@eYVIAOESJ-oyIx>1vt|D`ajY$Bp6Rv?JP9edf zos|YwL}0H;H$XEfp1Afqv)cih^{yVp?F{UT-p^g1o>BbiVC^t zL{zD2Tw#Ie+bMFwmBwS|gr`LkWR*%`*HfACWJh~^?&xAxEW__waq=a2fPZr-Fc5%; zBAvi@&tFb3OEGJle9r;_Q`up}z=z;mQ{RfnVoX@66caSE5EITu8ZKUBex68cB{Q1yAybl5 z@o*MyDVssf>TwX4xipiuS2HCzwV;0opTeu1?__Rm6r@end#@t}0iz~0YCoGB73o3& z9Je6rb(uwy4G4p$mTl6gc_{q_p)N@<);5bJdu0daZC;dM>=zfbl_Rob;C-MC>~u0q zW*8nanQE`ou3#X(D8BvNAhj*+Y^1;ZZJ`Y*+ed90NPiH|v&owilarzK>H}e?LQ){7 z5MNS(v^qy2EwWUel2%HTkB;hhoA;~D~DYc=1m-#s}j zAHz0I_Y`csP#q-2#0m?sPj(|56`?AdL?V5G_;}M5Ea@Sq< zOlwhd1MJ~uF1O=pesYOqQ70F4D0S%Z)gWR@_(4*S-x-im<#q+0LM9j(&)_fptBv#4 zCg?hlAzi#9YjTN=njDQR_z?_5?MY{2=K}4*xPXAN3u%H_ZeZ>c1*L2h91&sV!x6J& z1FU2j<|SyIzs+`re;St>FE=(C>(VA*&TR^tU+ngLWrakSU1~6XMM^Y`ww-$3QJ%SF2VasTRNSyitB(Gyp5&-iCbcD z4LA(*Z69DB(?15P1&;OAa2Wy)atc}i0TtK<7mK72@poPnBKU(44!-~`@Eb){szTA$ zDqYM-ix6JPTB}T8-w^Pe|K69h56un51&2&G_v;UN59sqE9YvDR)9@*haWyI1$M^* zXn3P%!?B)|7!B@@K72X_j6|+;tk19$y@nkR?v6kF-~V%9G7dW~LxDKdtGc3)p2LGU z7!=qqZXgA^Fa`itK90dBS66TiRK*y=aa9OkTV27QQCA3JRmG^=PZXhpd>n;8t*++4 zz$!*@pF$LMW56F$!-AvT`9=^9%SI7*x)?>Z!ECeX{3>FD`33iCMm2!+>jh9q#KDoC zbYxLK>+d}&{f1e?ziEpPtJE|-*Kv*p23-FrOjej- zf}*ooNE*W^2T6{(0-ed)dOh!K`OIB%&70a#jm)Q#G+r;>Hxcu~gByP23WV0>ZD0#zXN=7Sd z#x<)aZn(pxQm@J|N!Df~2m3}4RF{7vLz1jh1lk@!Fk)?4uuzhQ6q@_Ppa`~58bn5tWUrKZsa~@3EDwl;P~4VB9JYe-lV`J0>CSu zx@i|mn^snH2&`&kRt>AmV2o8@LlbcdfFgh>Q~!rUM#}IFpx^ZIEZJLacZ_&a5nR)Fh`FnVrNI5EinNn40Z7t zfx3~tA~B}w3c)~BESLB8?;f^Jnw4C&d6I11zh7=vj_@ef@d(Vi6ATUn;qzGq=85gf zBfCNl-&wrPe**#L$R}rCX(s~Y0ZM0S=X{uN5;cjo|MNufm46lta$S^7yxy+uJx>nQ zthk+rWGAEKffu3ZoFrTjc>xL`GFCG$k}lBKc%u9plQAIqIm;vvG^!Y=!fPF1AMdpa z{{f)D^Ju)pe^>-Y;Hg$@U<+3(_0gBwmHpA@HK_0zFoSA&xsBDpqImuv&3;yIwh`LS z!7X${Tg_;^jFiKB3rCID0e#9S3Qz-quo&Q$orGJcc#T_7w_)1#BGip93hqszyps>Z zw=9I&qM&uD=&=)1>zjS4B|Tq{P)tkKBKw~-p8I$EkJY2+H4T}%pM}zxZ!5(O=-0sh;dLgA<(RX)INh+LY z$fs>82Qopfh9Pen=a-&&ftCsb-~(#G&E94Qn`-DLZ?nXj_!8u`F&Kcn!sGtvhN0#w zXUZ--`M&hHrP)}Pf8OMpwMwzZTQovz|ExOusCtK{Sa`;7$fV3k`=0ml}z{*KrcqYC6q0q0V|d(VEs?~6Fw zQAe`yp>RM2;8d63v4D#hDpngv7hsUZ1yzn);!ahZ9N}2Me1t53`ftjSV**er#e`5cx4LgO77$xIFMkBS+4g>o+xPqImIfgg1O zOC`xuA`cPW;CVOArJ8&jkY$r}M$uEA4D0_-Dbud*90| z59(}`4o1!Dum9fKA7q1p;BVmv<>PHN@agp}8O*iyU*`U;D?By>y))Xmj{wA14u1sR zFoNKs3*gQxI7x$5M7anMCBFl*pg5X!xl&qMJ4wX_`2}kg zM7s--0bv}m_)jSbYR)@ZC%Mkt0OmxxgmDki^>nPBr@>uCa^bxiRyONEpZQFV(zXx} zu4k|!d1G9r^$3Y<6c~D_RI46V1;e9a@8s|h0IWD-IfleS>ZV1qRz586(Lv+~kYGYl zC01LlxEN`F60_W7#U$1a!TfeV=8% zeDYmpp3}EFtE+>3_4qaY_`9;V-<6FYeSurQ0>^?QLkgaxzX^1aHfa+e4bG8qh18Ke zVViU<;DP7TB?}>#NR|p&0BXFOM9v71_(|EvwCrn&Jk&|q+mrye@ip}~B>--@cVb!% zIYqG6Bn`lWPV-os8&e1l#UzcVis=%?fVNRR!ZT1$vgRKiqnU#@zJ#$F!xeT{_dnSk<|#PCP<)hXbN;e(r8e>2PqOn{>dyEK$-Fq~{~B ztMUT!uM8~RtCJc!rS;q}ij#bPC@T?9C$RI0y=6D2NXIlGxm>dY9pQ^JIycIqymmG4l@3foGbqY_j1zjfpP~;GaA& z;DS&8g#U2G+AH?({$oQ5CfW&yY(GEU9k+O`4zjlVosqFZ*f!`^j>m9$q+F9C8%5%6^ugt%Dt4% ztBX`FXiyRniz%5dii*R24I@I~zXKhLYzqUKnoh#cV4kAfsaXS;z$wADVy3XO5~g}M z$R~cJBrDT+`?}D1PEw@I&VkD?H%AtcUBS8l!rm>Q5lq>WP=bU!f$s{%B1k0jOQ{dy z@rEaZ6-8JULfWlJwVGAJ1AzyHL>cbDohp2B9M>Kn)~nxyokuZ<6xu4+fg3K@kMEZc zj@UIv=B)A!j;hD*v4~u&0*+*=tUeK0fX}0%WF^XkBN@m7<#)POl#k2@C7k6ER;Ti0 zqa?ZsD3P*B$o1aZaOm6w5R6Po%31{^wz_@zQYu_ONCdt!M8_!q<|V-N0p|2uEE0e8 z0wiT%cepM8Ug5&V3ljT#3?|>b>WqH+`_9$hbVhIULq|Hd+y@tY-;s8NOaAe_$Eqzq zd)yd(ygS||K^m_(W1s#$GAX~2&DAP0FGGfj?@jtK>oo3V|FC${m5uQ|-`wlE|18`jlfMkqv zseGA`F^HDeOaY+2o|T1)A?Ht?b~Dq)5c+oX1miB#O=57WjjGYk>=V*9{r8uB6|kxU^|j-wk-E->$`PU7 zVnDFG&F#k%IJPl3MCU2E&V$@;1b{lPCWhdO@@itpOHDcXUoD9k_NkCAW~_}gq23^# zt{Vm6s4g9!c{8~naEpS|lUO3X7XgdKZFN!w>(nBOT<9x03mBgc3TRkB9qtf-wWI`T zZ5f5B>G4!<3uR5Y52tl15u{LGf`h&1E<<@#qqHOA&Ih{EOCDh}4vm-x?_Cqc37|LB z1%v`|irDycUU4Wk$Zh9!s@7*tzki=>5OE9|V!MVjHf(SxP2dtzh1PY75S^q&Ag`g~ zL3OYGzD{Z4Hf|+q1=#9?db85{zy~YAy3=bs8iMBFn9dKBjatE_-$fl*8bEemg0(NJ zOg1H~%{TbocodK&#zUx6uUx6`%~uJO$9ypL}%$xQ;09646h$4(whLjt?H;?RUMlF))sBbr8_g zNMOK3$@ViZUm;KxxQ~$u8!@xV84WOl79|F1$X@v_s{@?xlJZP1@?Bm*zKbQTt())S zZQ}(=FF5Bml3w5vdRRSPSAw%7lU`=KcZCpHsSc&Zz!o3@UIOnrNk(r^{{$FTG+hZW zx}BH%BJ1UErVFL8y%Hvr0|+ORiQ+RfFwh;|B*o=ks@vDFOTm%hfrN}K)QdEaz9k6pcoQ0sTYmv zn4F+#VE7d7a!nn_5)C-(?_+rZS{@6nA*qNmzZyt*xqIyl^3Ok1L1a6lB2UiaGL@HF zwnuCPM7$LBfafd;qO&x;ggZKd=}O{L?cIebv*BuU&;wDkB%_CGqtqlzAJeKxGmCcu zB%(x~`3?v2Hb>}NAQ8o|fyU^)X5gQW3rs3sog6Db1R(oox(%{Nr5XOCSH_^n73vXt309@LbHu zkiZd{+75FnYv3&xvj!BVtl@uoj`_dKzNu9slSRry-y;EoVN5w8oP+m~PYYn+J+gyn z>Zkzw)mxzc60aul+iISs*|EIqca@->EdbPb)Laipxx2+wlj8Q{HQ@Ha>>u*oZ}abX zTT0;R*H!aJ@%8hlnS0u{|4deCs~S2>m4FBK>}$gTH-i;ppZ!Z!Ur(WZ`jFJJ63yPK zC8A$*>Sp(d#_xUEqj=$W)d65LA}(J>c`p6&ty)JyC4$&#f5kxt1KpfL5u97gX(mo;H~O;;vpXha+m8F$Q&(Dyi4MwS%P*;R52f}?I7hE3}( z?B}!?$ItK+{dp#eTv{0-Ig=^Sm3Gph{(L?;i@)d5Vb$ZjYI#WKNupjM09W4%VYIpz zgLG%tTOp0ye-WKi^I~O!{QY~Q5mkkclFc?XIjd+ISH%)oN)p)%0XIWAux;#EBc$I0 z2|RARsIP;8$1*`>r}F4>MIJtqRfAK*q-8np8PMYtm_sjcfd3^TnCFgyUdicrb(!Dz zaC6g%Y^Faz)Sv*%pq*Z_?gs~T!=Iv^)JBpw-Rey&uUz6T+-?m+7!o8`fV5l zr5?d`=&cbHg>m4t!0hdwGizA-(g-E(}tiCnz3Q(n$vkS%Pxeh!*G=m9LQ^vWa)T z2YwkMJDAx2M85WC{gf_o8ub{Qi>Nr~q+CZ}asw))w1aq#Jcp8-96*fi6i{3QgB3Qc zci!po2(QV|cNvPJBSj8bjFZ$e1d|{eWIu zp~#Ag4r&jM>U%QNLNv-qb~wHvKB(3AYILZ3#3-*k#x3KWnH!>dyf+;h!pQpL2mVcG zUZA3BxYPd61$dA2A&~j*NRRhO{V&ILH-`e2nG@b4qG!(+FO2S0oaQy^k(ZD4Nqh)I zr*As&ia6H66HRS{+#r>FHAqtMNF3l4{HTieV?9E-_JVt4mG&9gg>uqdQ_G?WgL(a^ zr+qOnwyNLjt#%PUX@A$gBwOv7VjQ6vnx+(SK(xrBAxLQS4!8q7FF3 z=(96f&+E+GW+q{m8|T$^sp1AS!WhG}c1B3&HScony+=M*$LQ1N40zQI8|O2`J!^QD z$LQFv$-sV;xONlgXkyaqq(8bP@TTab(cJ}SS&>;(b^G+tGzGQAXJ>jpmuTB;BuZMu zZSQ`DL_@0TWEc~oYP0~aZburf&d|jgjj5ZbYXEDejP`mAb^h&jOjbi>avD8pwm0H0 z(!D+nAz2K1!Wbrp6Fr9 z5^bgdsV38S{Ysa4wCL8GU`sIOP$*e$H1I(nSW?#pR2kNt7F%_^MS)Kv-9I>%>4`c| zk!qW{iZ=u@zX1cII`SWtrRHxkc%34nikfxiMIy=3qi;WMneyP$5KUWt=c$-=tW>v8 zq5Tl<*4u$Ee{B-@|6**)>HRO$yV&Vlo=^1pm&`mXC%QbNgXE59ba+MwNr7i{_*Ycw;re-1Kb17foeXAj(R>oiRwAET zwybO_ZzXJJS=C?lm1kC$SLJ+GlUQ+f*}`w0ejH~-j@wl(>vI*~Pe#?}wc6R`WG0h` zi+N#ArSTo3{=-g3m|D5Ih#{Hb-CcC=V zn7?~%Ui2^TH7d&b`W5}^4=IG@ZNp)@zy~k&sD6Q`jbKPRPDb}#PB(=_7u0eCqwY!< zL`ObYSR3?v`}>5FsFfB4SG>Z&Izl~os0Jo0P&0DdQBZ`F@hh!kiBCm z`qnHh$X&7SouEjHXC!p$@}(~@rP#km4S$e|FA-VAq;0=p7o9hfNxOuX;#+tjS6GdM z8a^R}cUcgkZJadsj!*crKOsTz#!zStFYgy0+`rSp%p)RfR^cZ48NCjJPumg(jb$8* z8G5U}tB2_4>>(~U^tjrjyqPR!)d_pALfQJ=^6|-G_2`CJJuDvpoJQ~X_QZ|u1uC&YujZYM+AZk<;t#uvZ-MF-`4TF$Rs(cR{TdgrT$QetrH8PZ}phR=`?MUDO*^5^xapVcRlKBK2( ztp6u;SW!%D{NZseqd;A9dB6Iyjttrn=+Uh)f887Z~2(4*Y#f`q}S&zJOrmT~~u zk6E6v=#I-B#Mp?kv#6Z0vR*l&bFPAC39}rC1pd(v`gi;Jd5{+LlmX_!KbC>C{EX!; z($cejuNWHZT_vQ&9Tl(+ZW-|)q~&KQ$9xsi;;&EZ;C{NtRY(g~=x?HsmjCPWp8;v{ z4QwDSzku@Y^n|?ER zR?Zaoh3)7wdOoA4!2{3uN)qE49iGv_5R1=$CSf)z>% diff --git a/library/KEYBOARDEDITOR.~1~ b/library/KEYBOARDEDITOR.~1~ deleted file mode 100644 index 43b52aab..00000000 --- a/library/KEYBOARDEDITOR.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Jun-90 16:41:00" {DSK}local>lde>lispcore>library>KEYBOARDEDITOR.;2 50766 changes to%: (VARS KEYBOARDEDITORCOMS) (FNS VKBD.CONF.DISPLAY-FIELD-VALUE VKBD.CONF.DISPLAY-INFO-KEYBOARD) previous date%: "30-Jun-87 12:57:39" {DSK}local>lde>lispcore>library>KEYBOARDEDITOR.;1) (* ; " Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT KEYBOARDEDITORCOMS) (RPAQQ KEYBOARDEDITORCOMS ((FILES VIRTUALKEYBOARDS) (COMS (* ;; "Editor for Configurations -- the description of the physical key layout, which keys are assignable, etc.") (FNS EDITCONFIGURATION VKBD.CONF.CHANGE-KEY-VALUE VKBD.CONF.DISPLAY-FIELD-VALUE VKBD.CONF.DISPLAY-INFO-KEYBOARD VKBD.CONF.DISPLAY-KEY-INFO VKBD.CONF.EDIT-DEFAULT-ASSIGNMENTS VKBD.CONF.ICONFN VKBD.CONF.PARSE-CONFIGURATION) (BITMAPS VKBD.CONF.ICON)) (* ;; "EEditor for keyboard layouts per se:") (FNS EDITKEYBOARD VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU VKBD.EDIT.CREATE-COMMAND-MENU VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU VKBD.EDIT-KEYBOARD-COMMAND VKBD.EDIT.ASSIGN-CHARACTER VKBD.EDIT.ASSIGN-NON-CHARACTER VKBD.EDIT.CREATE-CHARACTER-SETS-MENU VKBD.EDIT.CREATE-CHARACTERS-MENU VKBD.EDIT.CREATE-DISPLAY VKBD.EDIT.DEFINE-COMMAND VKBD.EDIT.DO-MENU-COMMAND VKBD.EDIT.ICONFN VKBD.EDIT.INVERT-IF-LOCKED VKBD.EDIT.KEYBOARD-REPAINTFN VKBD.EDIT.LARGE-WINDOW-REPAINTFN VKBD.EDIT.MAKE-CURRENT-KEY VKBD.EDIT.QUIT-COMMAND VKBD.EDIT.STOP-COMMAND VKBD.EDIT.SWITCH-CHAR-SET-COMMAND VKBD.EDIT.SWITCH-CHARACTER-SET VKBD.EDIT.ROTATED-NUMBER) (INITVARS (VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS T) (VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS 15) (VKBD.EDITOR-WINDOW-HEIGHT 450) (VKBD.EDITOR-WINDOW-WIDTH 512) (VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES T)) (VARS VKBD.EDIT.BACKGROUND-MENU-SUBITEMS (VKBD.EDIT.CASH-MENUES NIL) VKBD.EDIT.CHAR-SET-NAMES VKBD.EDIT.MENU-ITEMS VKBD.EDIT.NON-CHAR-ASSIGNMENTS) (BITMAPS VKBD.EDIT.ICON VKBD.EDIT.MASK) (GLOBALVARS VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS VKBD.EDIT.BACKGROUND-MENU-SUBITEMS VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS VKBD.EDITOR-WINDOW-HEIGHT VKBD.EDITOR-WINDOW-WIDTH VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES VKBD.EDIT.CASH-MENUES VKBD.EDIT.CHAR-SET-NAMES VKBD.EDIT.MENU-ITEMS VKBD.EDIT.NON-CHAR-ASSIGNMENTS VKBD.CONF.ICON VKBD.EDIT.ICON VKBD.EDIT.MASK) (P (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU (LIST "Edit" '(ADD.PROCESS '( VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" VKBD.EDIT.BACKGROUND-MENU-SUBITEMS) "Keyboard")))) (FILESLOAD VIRTUALKEYBOARDS) (* ;; "Editor for Configurations -- the description of the physical key layout, which keys are assignable, etc." ) (DEFINEQ (EDITCONFIGURATION [LAMBDA (CONFIGNAME) (* ; "Edited 30-Jun-87 10:03 by jds") (* ;;  "Edit a keyboard configuration, given the config's name or a handle on the config somehow.") (VKBD.CONF.DISPLAY-INFO-KEYBOARD CONFIGNAME]) (VKBD.CONF.CHANGE-KEY-VALUE [LAMBDA (ITEM MENU MOUSEKEY) (* sm "14-Aug-85 18:05") (PROG (MAINW CONF WINDOW PROMPTW KEY) (SETQ WINDOW (WFROMMENU MENU)) [SETQ PROMPTW (CAR (WINDOWPROP WINDOW 'PROMPTWINDOW] (SETQ MAINW (MAINWINDOW WINDOW T)) (SETQ CONF (VKBD.GET-CONFIGURATION MAINW)) (SETQ KEY (WINDOWPROP MAINW 'VKBD.CONF.CURRENT-KEY)) (SELECTQ (CADR ITEM) (KEYID (PROG (NEW) (SETQ NEW (CAR (TTYINEDIT (LIST KEY) PROMPTW NIL "Enter new ID :"))) (DSUBST NEW KEY CONF) (WINDOWPROP MAINW 'VKBD.CONF.CURRENT-KEY NEW) (SETQ KEY NEW))) (REGIONS (PROG (CURRENT-REGIONS NEW-REGIONS) (SETQ CURRENT-REGIONS (FASSOC KEY (fetch (KEYBOARDCONFIGURATION KEYREGIONS) of CONF))) (SETQ NEW-REGIONS (CAR (TTYINEDIT (LIST (CDR CURRENT-REGIONS)) PROMPTW NIL "Enter new region(s) :"))) (RPLACD CURRENT-REGIONS NEW-REGIONS))) (DEFAULT (PROG (CURRENT-DEFAULT ASSIGNMENTS NEW) (SETQ ASSIGNMENTS (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONF)) (SETQ CURRENT-DEFAULT (FASSOC KEY ASSIGNMENTS)) (SETQ ASSIGNMENTS (REMOVE CURRENT-DEFAULT ASSIGNMENTS)) (SETQ NEW (CAR (TTYINEDIT (LIST (CDR CURRENT-DEFAULT)) PROMPTW NIL "Enter new default(s):"))) (replace (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONF with (CONS (CONS KEY NEW) ASSIGNMENTS)) (WINDOWPROP MAINW 'VKBD.KEYBOARD (VKBD.CREATE-DEFAULT-KEYBOARD CONF)))) (NAMES (PROG (CURRENT NEW MAPPING) (SETQ CURRENT (VKBD.KEY-ID-TO-KEY-NAMES KEY CONF)) (SETQ MAPPING (fetch (KEYBOARDCONFIGURATION KEYNAMESMAPPING) of CONF)) (for N in CURRENT do (SETQ MAPPING (REMOVE (LIST N KEY) MAPPING))) (SETQ NEW (CAR (TTYINEDIT (LIST CURRENT) PROMPTW NIL "Enter new NAME(s) :"))) (for N in (MKLIST NEW) do (pushnew MAPPING (LIST N KEY))) (replace (KEYBOARDCONFIGURATION KEYNAMESMAPPING) of CONF with MAPPING))) (LABEL (PROG (OLD-LABEL LABELS NEW) (SETQ LABELS (fetch (KEYBOARDCONFIGURATION KEYLABELS) of CONF)) (SETQ OLD-LABEL (FASSOC KEY LABELS)) (if OLD-LABEL then (SETQ LABELS (REMOVE OLD-LABEL LABELS)) (SETQ OLD-LABEL (CADR OLD-LABEL))) (SETQ NEW (CAR (TTYINEDIT (LIST OLD-LABEL) PROMPTW NIL "Enter new LABEL :"))) (replace (KEYBOARDCONFIGURATION KEYLABELS) of CONF with (if NEW then (CONS (LIST KEY NEW) LABELS) else LABELS)))) (ASSIGNABLE [PROG (ASS-KEYS) (SETQ ASS-KEYS (fetch (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of CONF)) (if (FMEMB KEY ASS-KEYS) then (DREMOVE KEY ASS-KEYS) else (replace (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of CONF with (CONS KEY ASS-KEYS]) (PROGN (PROMPTPRINT "ILLEGAL FIELD VALUE IN ") (RETURN NIL))) (CLEARW PROMPTW) (VKBD.CONF.DISPLAY-FIELD-VALUE KEY (CADR ITEM) CONF WINDOW MENU]) (VKBD.CONF.DISPLAY-FIELD-VALUE [LAMBDA (KEY FIELD CONF WINDOW MENU) (* ; "Edited 11-Jun-90 16:40 by mitani") (PROG (X Y) [for ITEM in (fetch ITEMS of MENU) when (EQ (CADR ITEM) FIELD) do (SETQ Y (fetch (REGION BOTTOM) of (MENUITEMREGION ITEM MENU] (SETQ X (IPLUS (fetch MENUREGIONLEFT of MENU) (fetch IMAGEWIDTH of MENU) 5)) (DSPFILL (CREATEREGION X Y (IDIFFERENCE (fetch (REGION WIDTH) of (WINDOWPROP WINDOW 'REGION)) Y) (fetch ITEMHEIGHT of MENU)) (DSPTEXTURE NIL WINDOW) 'REPLACE WINDOW) (MOVETO X Y WINDOW) (PRIN1 (SELECTQ FIELD (KEYID KEY) (REGIONS (VKBD.GET-KEY-REGIONS KEY CONF)) (DEFAULT (CDR (VKBD.FETCH-KEY-ASSIGNMENT KEY (MAINWINDOW WINDOW)))) (NAMES (VKBD.KEY-ID-TO-KEY-NAMES KEY CONF)) (LABEL (CADR (FASSOC KEY (fetch (KEYBOARDCONFIGURATION KEYLABELS) of CONF)))) (ASSIGNABLE (if (FMEMB KEY (fetch (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of CONF)) then T else NIL)) (PROMPTPRINT "ILLEGAL FIELD VALUE FOR DISPLAY CONFIGURATION FIELD VALUE!")) WINDOW]) (VKBD.CONF.DISPLAY-INFO-KEYBOARD [LAMBDA (CONFIGURATION) (* ; "Edited 11-Jun-90 16:40 by mitani") (PROG (WINDOW ATT-WINDOW MENU VALIDATED-CONFIG) (COND ((NOT (SETQ VALIDATED-CONFIG (VKBD.GET-CONFIGURATION CONFIGURATION))) (* ;; "Make sure the configuration name is legit.") (ERROR CONFIGURATION "is not the name of a known keyboard configuration."))) (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY (VKBD.CREATE-DEFAULT-KEYBOARD VALIDATED-CONFIG) NIL 'VKBD.CONF.DISPLAY-KEY-INFO)) (SETQ MENU (create MENU ITEMS _ '(("Key ID" KEYID) ("Key regions" REGIONS) ("Default assignment" DEFAULT) ("Key names" NAMES) ("Key Label" LABEL) ("Assignable? " ASSIGNABLE)) MENUBORDERSIZE _ 0 MENUOUTLINESIZE _ 0 MENUFONT _ BOLDFONT WHENSELECTEDFN _ 'VKBD.CONF.CHANGE-KEY-VALUE)) (SETQ ATT-WINDOW (CREATEW (CREATEREGION 0 0 (fetch (REGION WIDTH) of (WINDOWPROP WINDOW 'REGION)) (IPLUS 10 (fetch IMAGEHEIGHT of MENU))) NIL NIL T)) (ATTACHWINDOW ATT-WINDOW WINDOW 'TOP 'JUSTIFY) (OPENW ATT-WINDOW) (ADDMENU MENU ATT-WINDOW (create POSITION XCOORD _ 0 YCOORD _ 0)) (GETPROMPTWINDOW ATT-WINDOW 2 BOLDFONT) (WINDOWPROP WINDOW 'ICONFN 'VKBD.CONF.ICONFN]) (VKBD.CONF.DISPLAY-KEY-INFO [LAMBDA (KEY WINDOW MOUSEKEY) (* sm "14-Aug-85 15:38") (PROG (CONFIGURATION OLD-KEY ATT-WINDOW) (if (SETQ OLD-KEY (WINDOWPROP WINDOW 'VKBD.CONF.CURRENT-KEY)) then (VKBD.ERASE-FRAME OLD-KEY WINDOW 2)) (WINDOWPROP WINDOW 'VKBD.CONF.CURRENT-KEY KEY) (VKBD.FRAME-KEY KEY WINDOW BLACKSHADE 2) (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION WINDOW)) (SETQ ATT-WINDOW (CAR (ATTACHEDWINDOWS WINDOW))) (for F in '(KEYID REGIONS DEFAULT NAMES LABEL ASSIGNABLE) do (VKBD.CONF.DISPLAY-FIELD-VALUE KEY F CONFIGURATION ATT-WINDOW (CAR (WINDOWPROP ATT-WINDOW 'MENU]) (VKBD.CONF.EDIT-DEFAULT-ASSIGNMENTS [LAMBDA (CONFIGURATION) (* sm "15-Aug-85 10:25") (PROG (DUMMY-CONFIGURATION DUMMY-KEYBOARD) (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) (SETQ DUMMY-CONFIGURATION (COPY CONFIGURATION)) (replace (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of DUMMY-CONFIGURATION with (fetch (KEYBOARDCONFIGURATION KEYSIDLIST) of DUMMY-CONFIGURATION)) (replace (KEYBOARDCONFIGURATION KEYLABELS) of DUMMY-CONFIGURATION with NIL) (SETQ DUMMY-KEYBOARD (create VIRTUALKEYBOARD KEYBOARDNAME _ "DEFAULT ASIGNMENTS" KEYASSIGNMENTS _ (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONFIGURATION ) KEYBOARDCONFIGURATION _ DUMMY-CONFIGURATION)) (EDITKEYBOARD DUMMY-KEYBOARD) (replace (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONFIGURATION with (fetch (VIRTUALKEYBOARD KEYASSIGNMENTS) of DUMMY-KEYBOARD]) (VKBD.CONF.ICONFN [LAMBDA (WINDOW ICON) (* sm "15-Aug-85 11:02") [COND ((NULL ICON) (SETQ ICON (TITLEDICONW (create TITLEDICON ICON _ VKBD.CONF.ICON MASK _ VKBD.EDIT.MASK TITLEREG _ (CREATEREGION 5 15 80 75)) (CONCAT "EDIT CONFIGURATION: " (fetch (KEYBOARDCONFIGURATION CONFIGURATIONNAME) of (VKBD.GET-CONFIGURATION WINDOW))) (FONTCREATE 'GACHA 8] ICON]) (VKBD.CONF.PARSE-CONFIGURATION [LAMBDA (CONFIGURATION) (* sm " 5-Aug-85 17:05") (PROG (ERROR-FLAG REGS IDS) (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) (if (NULL CONFIGURATION) then (PRINTOUT T T CONFIGURATION " NOT A CONFIGURATION. ") (RETURN NIL)) (SETQ IDS (fetch (KEYBOARDCONFIGURATION KEYSIDLIST) of CONFIGURATION)) (SETQ REGS (fetch (KEYBOARDCONFIGURATION KEYREGIONS) of CONFIGURATION)) (if (NULL IDS) then (PRINTOUT T T "Null Id list. ") (RETURN NIL)) (if (LESSP (LENGTH REGS) (LENGTH IDS)) then (PRINTOUT T T "KEYS WITHOUT REGIONS : ") (for K in IDS when (NOT (FASSOC K REGS)) do (PRINTOUT T " " K)) (SETQ ERROR-FLAG T)) (for R in REGS do (for R1 in (CDR R) when (NOT (REGIONP R1)) DO (SETQ ERROR-FLAG T) (PRINTOUT T T "KEY : " (CAR R) " -- " R1 " NOT A REGION"))) (for KEY in (fetch (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of CONFIGURATION) when (NOT (FMEMB KEY IDS)) do (SETQ ERROR-FLAG T) (PRINTOUT T T "KEY :" KEY " IS IN THE ASSIGNABLE KEYS BUT NOT IN KEY IDS")) (for ASS in (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONFIGURATION) when (NOT (FMEMB (CAR ASS) IDS)) do (SETQ ERROR-FLAG T) (PRINTOUT T T "KEY : " (CAR ASS) " HAS ASSIGNMENT BUT IS NOT IN ID LIST")) (for ID in IDS when (NOT (FASSOC ID (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONFIGURATION))) do (SETQ ERROR-FLAG T) (PRINTOUT T T "KEY :" ID " DOES NOT HAVE ASSIGNMENT.")) (RETURN (NOT ERROR-FLAG]) ) (RPAQQ VKBD.CONF.ICON #*(93 93)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNG@HECI@HDCI@HDNALHD@GCHNG@HECI@HDCI@HDNALHD@GCHNG@HECO@HDCM@OONALHDNGCHNG@HDCO@HDCM@OONAOHGOOCHNGOOOOOOOOOOOOOOOOOOOOCHNG@BA@NDBAALDNA@IOBGOOCHNGGBA@NDBAALDNA@HGBG@GCHNGGCOOOLBAOOONAOOOOOFGCHNG@COOOLBAOOONAOOOOO@GCHNGOOOOOOOOOOOOOOOOOOHGCHNG@CHDCI@ILBCHHNBALHIGCHNG@CHDCI@ILBCHHNBALHIGCHNGOOHDCOOOLBCHINBALHIGCHNGOOHDCOOOLBGHINBALHHGCHNGOOOOOOOOOOOOOOOOOOOOCHNG@@@HDGA@HDGAALDCM@@GCHNG@@@HDGA@HDGAALDCI@@GCHNG@@@HDGA@HDGAALDCI@@GCHNG@@@HDGA@HDGAALDCI@@GCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (* ;; "EEditor for keyboard layouts per se:") (DEFINEQ (EDITKEYBOARD [LAMBDA (KEYBOARD SOURCE-KEYBOARD CONFIGURATION-NAME) (* sm " 1-Aug-85 17:55") (PROG (VKBD.EDIT-WINDOW CURRENT-EVENT KEYBOARD-TO-EDIT COMPLETE-KEYBOARD) (COND ((NULL KEYBOARD) (RETURN NIL))) (if (ATOM KEYBOARD) then (SETQ KEYBOARD-TO-EDIT (FASSOC KEYBOARD VKBD.KNOWN-KEYBOARDS)) (if (NULL KEYBOARD-TO-EDIT) then [if (AND (NULL SOURCE-KEYBOARD) CONFIGURATION-NAME) then (SETQ KEYBOARD-TO-EDIT (VKBD.CREATE-DEFAULT-KEYBOARD CONFIGURATION-NAME)) else [SETQ KEYBOARD-TO-EDIT (COPY (if (AND SOURCE-KEYBOARD (ATOM SOURCE-KEYBOARD )) then (FASSOC SOURCE-KEYBOARD VKBD.KNOWN-KEYBOARDS] (if (NULL KEYBOARD-TO-EDIT) then (SETQ KEYBOARD-TO-EDIT (COPY (FASSOC 'DEFAULT VKBD.KNOWN-KEYBOARDS] (replace KEYBOARDNAME of KEYBOARD-TO-EDIT with KEYBOARD)) else (SETQ KEYBOARD-TO-EDIT KEYBOARD)) (SETQ VKBD.EDIT-WINDOW (VKBD.EDIT.CREATE-DISPLAY KEYBOARD-TO-EDIT)) (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.KEYBOARD (COPY KEYBOARD-TO-EDIT)) (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.ORIGINAL-KEYBOARD KEYBOARD-TO-EDIT) (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.EDITOR-RETURN-EVENT (SETQ CURRENT-EVENT (CREATE.EVENT "VKBD.EDIT"))) (AWAIT.EVENT CURRENT-EVENT) (CLOSEW VKBD.EDIT-WINDOW) (RETURN (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.KEYBOARD]) (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU [LAMBDA (SUBITEM MAINITEMLABEL) (* sm "15-Aug-85 14:14") (PROG (MAINITEM OLD) (SETQ MAINITEM (SASSOC MAINITEMLABEL BackgroundMenuCommands)) [COND (MAINITEM (COND [(AND (CDDDR MAINITEM) (EQ (CAR (CADDDR MAINITEM)) 'SUBITEMS)) (COND ((SETQ OLD (SASSOC (CAR SUBITEM) (CADDDR MAINITEM))) (RPLACD OLD (CDR SUBITEM))) (T (NCONC1 (CADDDR MAINITEM) SUBITEM] (T (RPLACD (CDDR MAINITEM) (LIST (LIST 'SUBITEMS SUBITEM] (SETQ BackgroundMenu NIL]) (VKBD.EDIT.CREATE-COMMAND-MENU [LAMBDA NIL (* sm " 1-Aug-85 17:22") (create MENU ITEMS _ VKBD.EDIT.MENU-ITEMS MENUFONT _ (FONTCREATE 'HELVETICA 12 'BOLD) CENTERFLG _ T MENUROWS _ 1 WHENSELECTEDFN _ 'VKBD.EDIT.DO-MENU-COMMAND]) (VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU [LAMBDA NIL (* sm "13-Aug-85 11:09") (create MENU ITEMS _ VKBD.EDIT.NON-CHAR-ASSIGNMENTS MENUFONT _ (FONTCREATE 'GACHA 8) MENUROWS _ (ADD1 (IQUOTIENT (SUB1 (LENGTH VKBD.EDIT.NON-CHAR-ASSIGNMENTS)) 4)) CENTERFLG _ T WHENSELECTEDFN _ 'VKBD.EDIT.ASSIGN-CHARACTER]) (VKBD.EDIT-KEYBOARD-COMMAND [LAMBDA (NEW-KEYBOARD? ASK-FOR-INITIAL?) (* sm "14-Aug-85 15:11") (PROG (NEW-NAME KEYBOARD INITIAL-KEYBOARD) (if (NOT NEW-KEYBOARD?) then (SETQ KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU "Select the keyboard that you want to edit")) (if KEYBOARD then (if (EQ KEYBOARD 'DEFAULT) then (PROMPTPRINT "Can not edit the default keyboard.") else (EDITKEYBOARD KEYBOARD))) else [SETQ NEW-NAME (MKATOM (PROMPTFORWORD "Enter name for new keyboard :" NIL NIL PROMPTWINDOW NIL 'TTY] (if NEW-NAME then (if ASK-FOR-INITIAL? then (SETQ INITIAL-KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU "Select the keyboard to be used as initial keyboard for the editing" )) (if INITIAL-KEYBOARD then (EDITKEYBOARD NEW-NAME INITIAL-KEYBOARD)) else (EDITKEYBOARD NEW-NAME 'DEFAULT]) (VKBD.EDIT.ASSIGN-CHARACTER [LAMBDA (ITEM MENU MOUSE-KEY) (* sm "15-Aug-85 10:02") (PROG (WINDOW KEY SHIFTED CURRENT-KEY-INFO KEY-ASSIGNMENT KEYBOARD) (SETQ WINDOW (MAINWINDOW (WFROMMENU MENU) T)) (SETQ KEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) (SETQ CURRENT-KEY-INFO (WINDOWPROP WINDOW 'VKBD.CURRENT-KEY)) (if CURRENT-KEY-INFO then (SETQ KEY (CAR CURRENT-KEY-INFO)) (SETQ SHIFTED (CADR CURRENT-KEY-INFO)) (SETQ KEY-ASSIGNMENT (VKBD.FETCH-KEY-ASSIGNMENT KEY WINDOW)) [if (AND VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS (MEMBER ITEM VKBD.EDIT.NON-CHAR-ASSIGNMENTS )) then (VKBD.EDIT.ASSIGN-NON-CHARACTER KEY-ASSIGNMENT ITEM) else (if (NULL KEY-ASSIGNMENT) then (replace (VIRTUALKEYBOARD KEYASSIGNMENTS) of KEYBOARD with (CONS (LIST KEY (LIST (CADR ITEM) (CADR ITEM) 'NOLOCKSHIFT)) (fetch (VIRTUALKEYBOARD KEYASSIGNMENTS) of KEYBOARD) )) else (RPLACD (CDR KEY-ASSIGNMENT) NIL) (if (OR (NULL (CDR KEY-ASSIGNMENT)) (ATOM (CADR KEY-ASSIGNMENT))) then [RPLACD KEY-ASSIGNMENT (LIST (LIST (CADR ITEM) (CADR ITEM) 'NOLOCKSHIFT] else (if SHIFTED then (RPLACA (CDADR KEY-ASSIGNMENT) (CADR ITEM)) else (RPLACA (CADR KEY-ASSIGNMENT) (CADR ITEM] (VKBD.DISPLAY-KEY KEY WINDOW) else (FLASHWINDOW PROMPTWINDOW) (PRINTOUT PROMPTWINDOW T "There is no current selected key. Character was not assigned."]) (VKBD.EDIT.ASSIGN-NON-CHARACTER [LAMBDA (KEY-ASSIGNMENT NEW-ASSIGNMENT) (* sm "13-Aug-85 10:16") (RPLACD KEY-ASSIGNMENT (SELECTQ NEW-ASSIGNMENT (SHIFT '(1SHIFTDOWN . 1SHIFTUP)) (CTRL '(CTRLDOWN . CTRLUP)) (META '(METADOWN . METAUP)) (LOCK '(LOCKDOWN . LOCKUP)) (LOCKDOWN '(LOCKDOWN)) (LOCKUP '(LOCKUP)) (EVENT '(EVENT . EVENT)) NIL]) (VKBD.EDIT.CREATE-CHARACTER-SETS-MENU [LAMBDA NIL (* sm "15-Aug-85 12:13") (if VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES then [create MENU ITEMS _ VKBD.EDIT.CHAR-SET-NAMES MENUFONT _ BIGFONT ITEMWIDTH _ (ITIMES 29 16) ITEMHEIGHT _ (ADD1 (IQUOTIENT (ITIMES 25 16) (LENGTH VKBD.EDIT.CHAR-SET-NAMES] else (create MENU ITEMS _ (for I from 1 to 256 bind ROTATED-I collect (PROGN (SETQ ROTATED-I (SUB1 (VKBD.EDIT.ROTATED-NUMBER I 16 16)) ) (LIST (OCTALSTRING ROTATED-I) ROTATED-I))) MENUCOLUMNS _ 16 CENTERFLG _ T ITEMHEIGHT _ 25 ITEMWIDTH _ 29]) (VKBD.EDIT.CREATE-CHARACTERS-MENU [LAMBDA (CHAR-SET-NUMBER FONT) (* sm "15-Aug-85 12:15") (PROG (EXISTING-MENU-INFO NEW-MENU) [SETQ EXISTING-MENU-INFO (for CHARSET-FONT-MENU in VKBD.EDIT.CASH-MENUES thereis (AND (EQP (CAR CHARSET-FONT-MENU) CHAR-SET-NUMBER) (EQ (CADR CHARSET-FONT-MENU) FONT] (if EXISTING-MENU-INFO then (RETURN (CADDR EXISTING-MENU-INFO))) (PRINTOUT PROMPTWINDOW T "Wait. Bitmaps for character set " (OCTALSTRING CHAR-SET-NUMBER) " are being retrieved. ") (SETQ NEW-MENU (create MENU ITEMS _ (for I from 0 to 255 bind CODE bind ROTATED-I collect (PROGN (SETQ ROTATED-I (SUB1 (  VKBD.EDIT.ROTATED-NUMBER (ADD1 I) 16 16))) (LIST (GETCHARBITMAP (SETQ CODE (VKBD.PARSE-CHAR-CODE (LIST CHAR-SET-NUMBER ROTATED-I))) FONT) CODE))) MENUCOLUMNS _ 16 CENTERFLG _ T ITEMHEIGHT _ 25 ITEMWIDTH _ 29 WHENSELECTEDFN _ 'VKBD.EDIT.ASSIGN-CHARACTER)) (PROMPTPRINT "... Done. ") (push VKBD.EDIT.CASH-MENUES (LIST CHAR-SET-NUMBER FONT NEW-MENU)) (if (GREATERP (LENGTH VKBD.EDIT.CASH-MENUES) VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS) then (RPLACD (LAST VKBD.EDIT.CASH-MENUES) NIL)) (RETURN NEW-MENU]) (VKBD.EDIT.CREATE-DISPLAY [LAMBDA (KEYBOARD) (* sm "13-Aug-85 12:37") (PROG (WINDOW LARGE-WINDOW BM WPOS REGION-WIDTH REGION-HEIGHT NON-CHAR-WINDOW COMMAND-MENU NON-CHAR-MENU) (SETQ BM (VKBD.CREATE-KEYBOARD-BITMAP (fetch (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) of KEYBOARD))) (if VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS then (SETQ NON-CHAR-MENU (VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU))) (SETQ COMMAND-MENU (VKBD.EDIT.CREATE-COMMAND-MENU)) [SETQ REGION-WIDTH (MAX VKBD.EDITOR-WINDOW-WIDTH (IPLUS 8 (BITMAPWIDTH BM] (SETQ REGION-HEIGHT (MIN SCREENHEIGHT (IPLUS (fetch IMAGEHEIGHT of COMMAND-MENU) (if VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS then (fetch IMAGEHEIGHT of NON-CHAR-MENU) else 0) (BITMAPHEIGHT BM) VKBD.EDITOR-WINDOW-HEIGHT 20))) (SETQ WPOS (GETBOXPOSITION REGION-WIDTH REGION-HEIGHT NIL NIL NIL "Specify region for Keyboard Editor window")) (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY KEYBOARD WPOS 'VKBD.EDIT.MAKE-CURRENT-KEY BM)) (WINDOWPROP WINDOW 'REPAINTFN 'VKBD.EDIT.KEYBOARD-REPAINTFN) (WINDOWPROP WINDOW 'ICONFN 'VKBD.EDIT.ICONFN) (SETQ LARGE-WINDOW (CREATEW (CREATEREGION 0 0 VKBD.EDITOR-WINDOW-WIDTH VKBD.EDITOR-WINDOW-HEIGHT) (CONCAT "Edit of Keyboard : " (fetch (VIRTUALKEYBOARD KEYBOARDNAME) of KEYBOARD)) NIL T)) (WINDOWPROP LARGE-WINDOW 'CLOSEFN 'VKBD.EDIT.STOP-COMMAND) (ATTACHWINDOW LARGE-WINDOW WINDOW 'TOP 'CENTER) (if VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS then (ATTACHMENU NON-CHAR-MENU LARGE-WINDOW 'TOP 'JUSTIFY)) (OPENW LARGE-WINDOW) (WINDOWPROP LARGE-WINDOW 'RESHAPEFN 'DON'T) (ATTACHMENU COMMAND-MENU LARGE-WINDOW 'TOP 'JUSTIFY) (WINDOWPROP WINDOW 'VKBD.CHAR-SET-MENU (VKBD.EDIT.CREATE-CHARACTER-SETS-MENU)) (VKBD.EDIT.LARGE-WINDOW-REPAINTFN LARGE-WINDOW) (VKBD.EDIT.SWITCH-CHARACTER-SET 0 LARGE-WINDOW) (WINDOWADDPROP LARGE-WINDOW 'REPAINTFN 'VKBD.EDIT.LARGE-WINDOW-REPAINTFN) (RETURN WINDOW]) (VKBD.EDIT.DEFINE-COMMAND [LAMBDA (WINDOW) (* sm " 5-Aug-85 09:26") (DEFINEKEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) (PRINTOUT PROMPTWINDOW "Keyboard " (fetch (VIRTUALKEYBOARD KEYBOARDNAME) of (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) " was added to the set of known keyboards."]) (VKBD.EDIT.DO-MENU-COMMAND [LAMBDA (ITEM MENU KEY) (* sm " 1-Aug-85 17:34") (APPLY* (CADR ITEM) (MAINWINDOW (WFROMMENU MENU) T]) (VKBD.EDIT.ICONFN [LAMBDA (WINDOW ICON) (* sm "15-Aug-85 11:10") [COND ((NULL ICON) (SETQ ICON (TITLEDICONW (create TITLEDICON ICON _ VKBD.EDIT.ICON MASK _ VKBD.EDIT.MASK TITLEREG _ (CREATEREGION 5 25 80 65)) [CONCAT "EDIT KEYBOARD: " (fetch (VIRTUALKEYBOARD KEYBOARDNAME) of (WINDOWPROP WINDOW 'VKBD.KEYBOARD] (FONTCREATE 'GACHA 8] ICON]) (VKBD.EDIT.INVERT-IF-LOCKED [LAMBDA (KEY WINDOW) (* sm "13-Aug-85 10:01") (PROG (KEY-ASSIGNMENT) (SETQ KEY-ASSIGNMENT (VKBD.FETCH-KEY-ASSIGNMENT KEY WINDOW)) (if (AND (VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) (EQ (VKBD.LOCK/NOLOCK KEY-ASSIGNMENT) 'LOCKSHIFT)) then (VKBD.INVERT-LOCK-KEYS WINDOW]) (VKBD.EDIT.KEYBOARD-REPAINTFN [LAMBDA (W) (* sm " 5-Aug-85 16:12") (PROG (CURRENT-KEY) (VKBD.KEYBOARD-WINDOW-REPAINTFN W) (if (SETQ CURRENT-KEY (WINDOWPROP W 'VKBD.CURRENT-KEY)) then (VKBD.FRAME-KEY (CAR CURRENT-KEY) W BLACKSHADE 2) (if (CADR CURRENT-KEY) then (VKBD.INVERT-SHIFT-KEYS W)) (VKBD.EDIT.INVERT-IF-LOCKED (CAR CURRENT-KEY) W]) (VKBD.EDIT.LARGE-WINDOW-REPAINTFN [LAMBDA (W) (* sm "13-Aug-85 12:43") (for I from 0 to 20 as Y from 390 by -25 do (MOVETO 10 Y W) (PRIN1 (OCTALSTRING I) W)) (for I from 0 by 16 to 255 as X from 40 by 29 do (MOVETO X 420 W) (PRIN1 (OCTALSTRING I) W]) (VKBD.EDIT.MAKE-CURRENT-KEY [LAMBDA (KEY WINDOW MOUSEKEY) (* sm " 7-Aug-85 17:51") (PROG (CURRENT-KEY SHIFTED CURRENT-KEY-ASSIGNMENT CURRENT-KEY-INFO LOCKED) (SETQ SHIFTED (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN)) (SETQ CURRENT-KEY-INFO (WINDOWPROP WINDOW 'VKBD.CURRENT-KEY)) (if (VKBD.LOCK-KEYP KEY WINDOW) then (if (CADR CURRENT-KEY-INFO) then (SETQ CURRENT-KEY-ASSIGNMENT (VKBD.FETCH-KEY-ASSIGNMENT (CAR CURRENT-KEY-INFO ) WINDOW)) (SETQ LOCKED (EQ (VKBD.LOCK/NOLOCK CURRENT-KEY-ASSIGNMENT) 'LOCKSHIFT)) (RPLACA (CDDADR CURRENT-KEY-ASSIGNMENT) (if LOCKED then 'NOLOCKSHIFT else 'LOCKSHIFT)) (VKBD.INVERT-LOCK-KEYS WINDOW)) elseif (VKBD.ASSIGNABLE-KEYP KEY WINDOW) then (if CURRENT-KEY-INFO then (VKBD.ERASE-FRAME (CAR CURRENT-KEY-INFO) WINDOW 2) (if (CADR CURRENT-KEY-INFO) then (VKBD.INVERT-SHIFT-KEYS WINDOW) (VKBD.EDIT.INVERT-IF-LOCKED (CAR CURRENT-KEY-INFO) WINDOW))) (VKBD.FRAME-KEY KEY WINDOW BLACKSHADE 2) (if SHIFTED then (VKBD.INVERT-SHIFT-KEYS WINDOW) (VKBD.EDIT.INVERT-IF-LOCKED KEY WINDOW)) (WINDOWPROP WINDOW 'VKBD.CURRENT-KEY (LIST KEY SHIFTED]) (VKBD.EDIT.QUIT-COMMAND [LAMBDA (WINDOW) (* sm " 2-Aug-85 15:12") [REPLACE KEYASSIGNMENTS OF (WINDOWPROP WINDOW 'VKBD.ORIGINAL-KEYBOARD) WITH (FETCH KEYASSIGNMENTS OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD] (NOTIFY.EVENT (WINDOWPROP WINDOW 'VKBD.EDITOR-RETURN-EVENT]) (VKBD.EDIT.STOP-COMMAND [LAMBDA (WINDOW) (* sm " 2-Aug-85 13:04") (NOTIFY.EVENT (WINDOWPROP (MAINWINDOW WINDOW T) 'VKBD.EDITOR-RETURN-EVENT]) (VKBD.EDIT.SWITCH-CHAR-SET-COMMAND [LAMBDA (MAIN-WINDOW) (* sm " 5-Aug-85 09:28") (PROG (LARGE-WINDOW NEW-NUMBER) (SETQ LARGE-WINDOW (CAR (ATTACHEDWINDOWS MAIN-WINDOW))) [SETQ NEW-NUMBER (MENU (WINDOWPROP MAIN-WINDOW 'VKBD.CHAR-SET-MENU) (create POSITION XCOORD _ [IPLUS 34 (fetch (REGION LEFT) of (WINDOWPROP LARGE-WINDOW 'REGION] YCOORD _ (IPLUS 9 (fetch (REGION BOTTOM) of (WINDOWPROP LARGE-WINDOW 'REGION] (if NEW-NUMBER then (VKBD.EDIT.SWITCH-CHARACTER-SET NEW-NUMBER LARGE-WINDOW]) (VKBD.EDIT.SWITCH-CHARACTER-SET [LAMBDA (SET-NUMBER WINDOW) (* sm " 6-Aug-85 14:08") (PROG (MENU OLDCURSOR FONT) (if (WINDOWPROP WINDOW 'MENU) then (DELETEMENU (CAR (WINDOWPROP WINDOW 'MENU)) NIL WINDOW)) (WINDOWPROP WINDOW 'TITLE (CONCAT "Character set " (OCTALSTRING SET-NUMBER))) [SETQ FONT (FONTCREATE (fetch (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) of (VKBD.GET-CONFIGURATION (MAINWINDOW WINDOW] (ADDMENU (VKBD.EDIT.CREATE-CHARACTERS-MENU SET-NUMBER FONT) WINDOW (create POSITION XCOORD _ 30 YCOORD _ 5]) (VKBD.EDIT.ROTATED-NUMBER [LAMBDA (NUM ROW-NUM COL-NUM) (* edited%: " 3-Jun-85 12:47") (IPLUS (ITIMES (IMOD (SUB1 NUM) COL-NUM) ROW-NUM) (ADD1 (IQUOTIENT (SUB1 NUM) COL-NUM]) ) (RPAQ? VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS T) (RPAQ? VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS 15) (RPAQ? VKBD.EDITOR-WINDOW-HEIGHT 450) (RPAQ? VKBD.EDITOR-WINDOW-WIDTH 512) (RPAQ? VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES T) (RPAQQ VKBD.EDIT.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("New Keyboard, default initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" ) ("New keyboard, other initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will pop up a menu of the current known keyboards. The selected one will be used as the initial keyboard" ) ("Existing keyboard" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND)) "Will let you select a keyboard from list of the known keyboards, and will calls the keyboard editor on the selected keyboard." ))) (RPAQQ VKBD.EDIT.CASH-MENUES NIL) (RPAQQ VKBD.EDIT.CHAR-SET-NAMES (("ASCII/ISO/CCITT Roman Alphabet and Punctuation" 0) ("JIS Symbols 1 - Punctuation and Symbols not in Char set 0" 33) ("JIS Symbols 2 - Punctuation and Symbols not in Char set 0" 34) ("Extended Latin" 35) ("JIS Hiragana" 36) ("JIS Katakana" 37) ("Greek" 38) ("Cyrillic" 39) ("Symbols 3 - Miscellaneous Japanese Symbols" 116) ("General and Technical Symbols 2" 238) ("General and Technical Symbols 1" 239) ("Ligatures, Graphical Entities, and Field Format Symbols" 240) ("Accented Characters" 241))) (RPAQQ VKBD.EDIT.MENU-ITEMS (("CharSet" VKBD.EDIT.SWITCH-CHAR-SET-COMMAND "Pops up a menu of all possible character set number. Selecting one will switch the displayed character set." ) ("Stop" VKBD.EDIT.STOP-COMMAND "Exit from the keyboard editor. Returns the new keyboard, but does not modify the original one." ) ("Quit" VKBD.EDIT.QUIT-COMMAND "Exit from the keyboard editor. Modifies the roriginal keyboard and returns it ." ) ("Define" VKBD.EDIT.DEFINE-COMMAND "Adds the edited keyboard in its current state to the set of known keyboards." ))) (RPAQQ VKBD.EDIT.NON-CHAR-ASSIGNMENTS (SHIFT CTRL META LOCK LOCKDOWN LOCKUP EVENT)) (RPAQQ VKBD.EDIT.ICON #*(93 93)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@F@@@@@@@@@@@@@@@@@@CHN@@A@@@@@@@@@@@@@@@@@@CHN@@F@@@@@@@@@@@@@@@@@@CHN@@@@@@@@AOOOOOOOO@@@@CHN@@@@@@@@A@@@@@@@A@@@@CHN@@B@@@@@A@@@@@@@A@@@@CHN@@BAOOOOOOOON@@@A@@@@CHN@@BA@@@@A@@@B@@OOO@@@CHN@@BA@@@@A@@@B@@HAA@@@CHN@@OI@@@@GL@@OHALAA@@@CHN@@GA@@@@CH@@G@ALAA@@@CHN@@BA@@@@A@@@B@@HAA@@@CHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNG@HEBA@HDBA@HDBAAHD@GCHNG@HEBA@HDBA@HDBAAHD@GCHNG@HEBA@HDBA@HDBAAHDNGCHNG@HDBA@HDBA@HDBAAHD@GCHNGOOOOOOOOOOOOOOOOOOOOCHNG@BA@HDBA@HDBA@HEBA@GCHNGGBA@HDBA@HDBA@HEBA@GCHNGGBA@HDBA@HDBA@HDBAFGCHNG@BA@HDBA@HDBA@HDBA@GCHNGOOOOOOOOOOOOOOOOOOHGCHNG@AHDBA@HDBA@HDBA@HIGCHNG@AHDBA@HDBA@HDBA@HIGCHNG@AHDBA@HDBA@HDBA@HIGCHNG@AHDBA@HDBA@HDBA@HHGCHNGOOOOOOOOOOOOOOOOOOOOCHNG@@@HDBA@HDBA@HDBA@@GCHNG@@@HDBA@HDBA@HDBA@@GCHNG@@@HDBA@HDBA@HDBA@@GCHNG@@@HDBA@HDBA@HDBA@@GCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (RPAQQ VKBD.EDIT.MASK #*(93 93)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS VKBD.EDIT.BACKGROUND-MENU-SUBITEMS VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS VKBD.EDITOR-WINDOW-HEIGHT VKBD.EDITOR-WINDOW-WIDTH VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES VKBD.EDIT.CASH-MENUES VKBD.EDIT.CHAR-SET-NAMES VKBD.EDIT.MENU-ITEMS VKBD.EDIT.NON-CHAR-ASSIGNMENTS VKBD.CONF.ICON VKBD.EDIT.ICON VKBD.EDIT.MASK) ) (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU (LIST "Edit" '(ADD.PROCESS '(  VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" VKBD.EDIT.BACKGROUND-MENU-SUBITEMS) "Keyboard") (PUTPROPS KEYBOARDEDITOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3525 17380 (EDITCONFIGURATION 3535 . 3858) (VKBD.CONF.CHANGE-KEY-VALUE 3860 . 8485) ( VKBD.CONF.DISPLAY-FIELD-VALUE 8487 . 10260) (VKBD.CONF.DISPLAY-INFO-KEYBOARD 10262 . 12204) ( VKBD.CONF.DISPLAY-KEY-INFO 12206 . 12963) (VKBD.CONF.EDIT-DEFAULT-ASSIGNMENTS 12965 . 14346) ( VKBD.CONF.ICONFN 14348 . 15089) (VKBD.CONF.PARSE-CONFIGURATION 15091 . 17378)) (19706 42378 ( EDITKEYBOARD 19716 . 21964) (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU 21966 . 22892) ( VKBD.EDIT.CREATE-COMMAND-MENU 22894 . 23244) (VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU 23246 . 23709) (VKBD.EDIT-KEYBOARD-COMMAND 23711 . 25084) (VKBD.EDIT.ASSIGN-CHARACTER 25086 . 27760) ( VKBD.EDIT.ASSIGN-NON-CHARACTER 27762 . 28380) (VKBD.EDIT.CREATE-CHARACTER-SETS-MENU 28382 . 29421) ( VKBD.EDIT.CREATE-CHARACTERS-MENU 29423 . 32004) (VKBD.EDIT.CREATE-DISPLAY 32006 . 34854) ( VKBD.EDIT.DEFINE-COMMAND 34856 . 35258) (VKBD.EDIT.DO-MENU-COMMAND 35260 . 35470) (VKBD.EDIT.ICONFN 35472 . 36121) (VKBD.EDIT.INVERT-IF-LOCKED 36123 . 36556) (VKBD.EDIT.KEYBOARD-REPAINTFN 36558 . 37128) (VKBD.EDIT.LARGE-WINDOW-REPAINTFN 37130 . 37725) (VKBD.EDIT.MAKE-CURRENT-KEY 37727 . 39779) ( VKBD.EDIT.QUIT-COMMAND 39781 . 40134) (VKBD.EDIT.STOP-COMMAND 40136 . 40362) ( VKBD.EDIT.SWITCH-CHAR-SET-COMMAND 40364 . 41290) (VKBD.EDIT.SWITCH-CHARACTER-SET 41292 . 42075) ( VKBD.EDIT.ROTATED-NUMBER 42077 . 42376))))) STOP \ No newline at end of file diff --git a/library/MAIKOKEYBOARDS.~1~ b/library/MAIKOKEYBOARDS.~1~ deleted file mode 100644 index fbd19807..00000000 --- a/library/MAIKOKEYBOARDS.~1~ +++ /dev/null @@ -1 +0,0 @@ -((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (logic ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) ) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( 61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) ) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( 112 (47 61300 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( 180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( 133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( 61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( 61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( 119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( 120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( 124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( 128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (GREEK ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( 9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) ) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( 154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT ) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( 145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( 151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( 155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (SPANISH ((100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( 97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( 111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 (203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( 143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( 105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( 109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( 120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( 124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( 128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( 121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( 109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (STANDARD-RUSSIAN (( 100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( 10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) ) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( 10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO)) \ No newline at end of file diff --git a/library/MAIKOKEYBOARDS.~2~ b/library/MAIKOKEYBOARDS.~2~ deleted file mode 100644 index bf3f00b9c667bba0b880528005b4a1c802def325..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9256 zcmbW7TW?)g5yyG97eg7ym%^kMUxS!5L=0CG$`=Iof zHZMQ9bpJp)_Z{tbj&{p~^K-@O?s&3tT8d)fpcD&>@^jf5Z;X$h-aa{6-#L6(iX|!b z?%R_~zW?IdWDHd9$yE=nkIzk{I3N$n{G8LaKH6PFYOp6uUTS-E0c5x*3-@Hu+V0vG zU~0%cB1qvXg4qkm9SdmG*HnkIBPnAExmn^Gwp-Gg5p- zHqyScQY_06KR5RCH93=x+?L`A8K-?aQhbMb9!Y!8v7`Gr=>@MA;PY}K9lXon&YpbC zkEQ?1a(Z^`{G1f$%}XBegE8H&%h}n%QamEX=VU$YyC}sc1&eiVvGAxAKav-{1z_u= zjrQMRymjr|WPE0Ag%dY_eI1eHD({uzmR$GRapAY+mhV-+v9%-`aGUwLT5hL$ah!k4 z-_t%E=ZL)NwXR6f)Xy~^k*2IY~nH8Yksb&uNk`JQQWDie`VN19>aT@ z`c1=@Gi-F?BqpK+_6NVxb(Q;*$(>E)=I5ZjNL2XiTbZEIo4U+R58<3mecN;5H~8sjVr#Ue42EC*(Qg}XZ|YknIQA2bO$v_uwU>eon)=Tsb!k?L^XItWg{Ho0 z=)qZ3G1#H0-!<%v$6$%3{;^?YhQ&BSkomn|O$a{(rr+V_&OI@qrv8iReAMgQIXPL= zb0IeUHj_IaL*#Ef0ueR!b<^14r#ot>r>UPe^rL=02&k!V7}oU|EY#FLG_3F#Y}C}x z8g{^Au+oRbK(~q*;o-*b`{gTNy+p2%xcB#@_^13W?R!Rwf5`{4eTSLGvD*4%ZRAx0QJ z2-1UeW}<|l!+;J`lz5@&pkrv+Nl;7=@-sZFyL9V@{tc~ybd^Xe{oBj|?K+eIV6wU$ z{iSplK@c!J?5cFTno@mcrx3l$4a1JAnH`0ognb(x%%e)oLkej7sjwM0A)IYu;Swsh zSXkT8DsHB7n}xXz4;Ngy3x>ND?T00G-IA0$)bSFsA(L#AN^Lc<9PO-ZjHY?z!Xe=~ zn8?if{{Kai85Q2iutM(OrVEcq&9Xvfw7n+Q74Eka1gTBrML7FBQFti;n$;J&Clwkyv z=~e?*+6Yc1%+c*9mEB9b{o@qFdiG* z%k~X98`2qs5uI!v2s(@icG>M@=Rcm#1DV-aNYAasGI+&Gb`siw9|M`2G(;R)$5Ln8 zd7`-tvfV)GCRxSvuCh5G^`N`8m2AZP+;+(DtNvgSW4qTc(^%uRuteO;Z4~y`3F0mX znffWK*fNMo*7ovo$}QLARj;4u5jGIFNL+F&Ac6#)Q(+im@ zQes&v>FGeHk8uQs!ccC)NTt*8fsZ6-+md82-Y93B;4OhcI4uiiwmqe@4h6tOdL+fG z!IWHj*Ya4)FMUl=+|pYnYscgqM1pC@H50Xx>01_yu~TD&OHm_>skwv$%uF74dpT^u z(GIk9EdVYfBfX4A#bw$0yv16T!REtUC+U&3OcY~gcOR;VyXLavJfy$w?4W~J!s0S> zjyzDt5K`to99ckfi?I9(`$`TL9(YZDn)bDxKa7@Cx>PfIy=EmhQpq-v%q)Nx9KLUB z;055e$P;ei(-CyHmO1-)eSLHsQ`fvn)m20QJAatYsm0rE1j`JqV;g2|lc;`2%dOd} z+f0dv;W4ir7gw#_PA7lh;^LR3S1yunyEWnBZ^XN7x=x#rmz;hp^T{mD7%b@NF&b=B9~>ls;{lCOff^j+-n&JQ!`2Ck%Hos;Ue|ROJNQ z5)!lMT$y=CGAf51j8;cv=LIQUwf*L)5wxTtm7MZBgpA%Zb(yPeX#BBD)pruo+4Vs~ z`=rNE&pvTHR6@gXhpee07td@AR(c}rA)9TQQdKd*t}sM*UvSrR;mXsyvhpsF`2{Zq zh5jJSlo{>(9Q^r93aM_UkTnH+iTmKa;|2wS)j{2!yPb?Gx6iC>jkep=Xx|S?@ZW4L zKZy+g+xvZf4no|g%o$lnzpaFNq1({x`~F=Di5{MQMG0ST5?I}J=7q1N_XL+>rtBW- zpC13O@B3%n$1C$Ijb{7Qe~Dvn`|@voD?2M&t1FY$rOCPN?K{Pk9yi*jfJVyh5-bAU z0eR5xjNrzHOD%G{Eon@n+=V(wo(3oO*Qy|i1`Y0zfCM}RHOSBq+7gr-Hc?w9A;@K5 z@v13-YvJ52OKY1tEyT*SuKpB^fMSvsa-87&TnHvdM5{Co)S4(-wSLQs%xT5)4YZy5 zY?;uZppp+quHiD-s)i3$YzM({Bp?w)L23mwMBD__QYj$Ok;doXo60f@lP%H^=Mz~i zmFle2@Ys&aQbRnsB2J$vYCaTPfp^)wJ%BBixe1x+cc z6Oix`jm*|cTAsjKS=9yEA;6C*7+&9akbVVlTQPsehV^eCvRJ8wSJd(%rXg)e)J9)l z68&ovr*#@4O58#J6eGcvN3>?Es%<-5K%$yNTR~Dy8m=w@wQQ?U7ITr7)zYMtGU5tN1r-ro5ik-%K44Ckexgpo`L Qe<{di(vY3bfS$(w0|@2^A^-pY diff --git a/library/MASTERSCOPE.DFASL.~1~ b/library/MASTERSCOPE.DFASL.~1~ deleted file mode 100644 index 3ff8cf91880044a013216c68df3c56aeeb932310..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 70332 zcmeEvd0?Eyk?(hm4qvil3t@x|!)1)I4H$F80Wzb@Gty{2S&}WwHpsFq7}>IAe2@TP zBZ0XUKo%Gc5QxJZY{Vwnx5-<=`_-@dn{OnG zY&O~V-!o{w>gwvdySlo%x_iJXTv?R}SM_Y(+ST2;E!?wn$JU)Y!dLce3vch)xov%C z_)6fz*H<^!-*CzD?Va1UU$&`ZYj?+%%Mv~7JGw91+_|B<^V;(lUT|4=*Y>UJd$x4~ zShuZX+qIW9M4MY`nwqP;#+rp6T{NvZC%X09Iy-iBZV0z_ZrIYfeM85!^TUf4hrRVX zde$Kii_Sgo;`!n8E?lzcf+ZJRyl`4=v^k;K_@lyIwB)?=mz;mm!f79TW@wLdT91W) zS7m>u2vkyH6Fo^B#g=0a-Pd1K8&A|!HPu90YN``nm17Ov-CsPfxh0ycjy6>Yo%(q81bJ=0+hz z_NrT=m5K2lp~`4;&18G1KmYpV&hG9TEEL_U3`)(?vgjiOkC%cg$T~O%Btfw?)L(MJ zxbkk7plMf%>7IvT7NQW1OnrrqgAn*s(N6i zHJ~de&_!CL7(;_@x?HdtK~*f8Tv}5t0mmTD8ya+g46TSZNrsErb_-j)g_@~qcrzMg zvnt^=GndU0_gvI30wBAR@kDcrx{+h)K&)j$Ch<>hXl`smN2yILl?3nZ&s(7@vP+KMh;Dfj?~&QM)B7FB}EmPW0_Ft10W z=8~g=8>1~TgUwHSLxXv2p?qnHWOcd%>6pGIWt=RX&h$34mPp3k72pXk`UwYzhE zxMRbH?dla?-?L@=j%_>F??9YAh_-8c7z`Y)o!h&%Topz|R#%(GGd-vhmkHP zJu@k#KwUfO^QC*Dz~x$3euadj{!k5|x6$O2o2#0lEht%YOagUe`*aRkTE4KlrYaF_ zs#!wVOSWJRY18hN-w>^8@?;_1!hpKYeq@woOuq^{I|6S9NX}8Z6YI+R!Xj z8w}Mc3Nl7SI7yu-qQtI__`>Fea7|Sgn6%d^cVY6C)aIgv z$TmWlXTWLPwDj3Q<_9t6vT5PB$N;dDnwM8Lw}9&)tgxz(c-fOA5Gp`&KP86Pyrwo8 zVd=#jNa@97B2#llyKvs39QVqaD)t%4@o{m<@z!mf$ST^iXY=NcEgO*KDQr;iXikoe zO*JjeH7$}S9}|TG3>#I!L5}_eM4^-}hRIwh8)_OVv%$nm9flLKCOAb%cNLdp6x{-h zgB${`e2<(M(-QLo-jU4@e2Z4pG*v2}H<5uC>7)-|;rJ3)O+#Z#8{E_Bs`Z+*H%K1A zW}3YOIv5(HM;bU!klJTt1Qein981VoJlRx}h*JJQrX_=3qqu|)N$F6g;DGj#=?r;6 zyEKTrVq*8XC?`7hTd?Mucgglu`qtXYY zr_hzqUKFCos&qxVVv6|Q>!6=5TD$d5NbV?K5=M|joxk7M(&Gj zI6pGln_9UyRa_`S%}8{2D$^2KEAV9bfwLw;A!@BS%N(2NmAhk^1ry-gcE>ZvO@JRr z6-TNnH;&%NsCMy}QrJ|9b$w{}J}aZL+UUa(dUUC%micJqK&rQE_s{5wav%>zlr7k+_~_s3QVCEFLvYO`0sjN&{G?Y2 z=|!Ax20pLCCsY+pBm|#Qf;KX2EnE6UG1 z3)OWNKkt_F^HxZr`}R=(%<%e-Eobfsuj};Xlntkd*8vRp=ALcaum;?b!g6!x7EDk* zTf*WuG}J%im{8$QNgqRwk{&A>Ac`jIRfzMN0bROT!7 zSZYp^?AC(kH`X|X3MZotHBJHGNwp$P%5>@E!&1tXuEB=G~QZV<~VjFURgCQ4|G;>YcZ<4 zB%D|0UNMmD%e2{-i+|MjXYdlcz$>z!@`@b$0Du{L!BQLSR5>ektwaNMs|+U+Wm<@< zH+CQqJKc7Q>zqTGN2NNY+VZ03o_FC#9395LaYQ)DZ>nito@n91ehLS=sdA}BOrg;P zs=#6|GV`P*j4U7Xb5m7~Wy?xknh0GG6(P;w7NW*y7v}IdR@4vW*PhJZN&GG3Z-M+; zFZC5%pI*HkamXr}`G`vf)-`vo)%E!2y81qr( zE59*?w$M%|nVGF|i)Ed>awHXdztkE@q5JEMR)!8;9Dh8*+CONf4$`Q91*V}d#h$kY zQny8n@8|<@QoHba4PIZ;*-5)Q+&cZNvouN|w0mgJa7OPpp?g!S_csRZN{GV*AyVb# zY~<15xdBCas=UMwNij%PYHd>T1tT+W)|omdp;flSkfXzwk}Ah*1B>?nlCd4;5jh#C z?~P~y>THHnhp8iY7f0gd?0@Cdf!OF|p`qRVQ|F;e)wDoBYiOP~G=K@LxefZQhV)73 z^R}7y9Jb95F{#PY&UArd=^?_%3(je3Ohl`M3)`o{T_}>2NJ@ez69Q<7WO*oV8TBFb z1aVmJil;cR0v7knaOacxk%bEDE{HbQ%UWH$?-chMkIH6uQr#MFXpP1> zP3j%(}owXK#bsv9KDpR!> z`U`st2G7Pw(MTL>u-#AvE>E^%3SEFUXn_)F9^)!?PywQ^6Yb6NCP>Rj5NbGQ=^|S+ zTx{anCa)nhgY=dwTi_Wd6s=Kpe%YvO-sbExv8>sAa z5qGa`BR5mn88t_m5kw*pJqC^4_EgW#?hWBMmip0ZNqh~|h+BF@tGjc{21m%ALpF;2 zR$5>(PleN(#+Iho@?`y@htekx?Qtd9zSM!#!IEMpQt8-^eJ_6P-c*$iI+baAbEZ93 z-D>+ly<;D&w^#43&zxsyhvz8sSu=cMB*EZ@zX#*+#uVi7;gch=XwK-btOA!Xd}1VX zHb=RUeE)z1oGPyS+&=4XP1*nt)je6iH#585UbDuze4wE(VIS69%xXAcq~3Wl^E&fU zSAK}!NPHmP8#`vgTTw<|WSUbjs7A3LyuRn-qxS8=Kw zNZnZ7n<{TCUvG_=Rq0Swqf-WaS8r;#s@pXo$j-VQ9pjC*Gdw3JzUnc)fk$zQ|5>iZ zaz$L5U-aae-5s0PZRiL?X`I#JTaHBmNH`;wo%up*$@B}sw*g$ZxmkX&Spwa$tTi#g zRzdJ;B;8AWQ-%D~bg;ADh&nAytVqZ*Z_)K|m_3>uO0prxyXA7h**($=^Pw`Xs%bta z-9{P>Cy*>keE`&Z6te>!>4ALSz)w&HCyJ1=nbfV#K_d6yMIvMUv4pUGAwSqLD?~0TR61p>%8bc|WPHxcYrm zT^CA^tEsJpfHPMyrvWnw8rJG~74*BuDN-~I1!jNDmc(8WF-w4dlVAJegx}+OT--Mf z?Fq^EI*}w~Jzi2AQdwXms#5sq<@?vJMR==g^orfdOs#?2iw3=-%*9cxAKMIJd-0%G zoH-+Ix0a2j(VIO~Qam{tiR#dpS-HQ}M0)w|hRj^T=ZA++ zBCzR46#X{7H;}rM2s(RHX(M19%IKPa9dh(RevAkbr6U#Ts+^W@;op-Cf4E_9rnJGn z;)+PLo*nkd2Ip|*=k#NM`ZA~D0G*Q6%lEGcyr5c$4cF$Tk-4~T{|T{y*zJ{jT4yPv zz2DDS>_H9?lbgCRu1Gxx>Ig=OGdVri38m+{Q_yykA^J5ynFCqdoyr!A@b|_kj^!Fb zLfaFgD8Du->x3cEM~odyY~`2wrbyGu;sOeAQTW%0UP^EqNg%A%)=o!IJKpPpU6duT z{+$`%SbPOh6+$Z|nkiWunW0D){Z|a}`c9BQ+27c-RG6a()!~UoQSKIQnIt%$!GA8` zDe1-XsYox9PqBVP?V<}SF3KnoV`EwLd9@T0-b_;f_#xt6lbnO^j%^di}>n5G+D)Y~^N5sha)=cgsIiYg%(uWgh4jg~gF)k(k> zNr8bB;T@>spsC2$jcUs38^HDEhowX-hWe+5=dupNTeo(eg?%uQ84NLN`(|hjgml16 zBtJHNYB06W`Uf4Km{1-cGkZAfQGYUOqKPB*WbAYC%(9rh<|(r-;8^h0?HJ29LQ(f* z-Mw}7CyeyfAFOu=AZhHWr<`#}CW3EFke_wd9xXy|>i0TH*aH(S)iFu1Q@qqSO{#E*tQ6soYn5zOmDCYq3T_)A8JbNzIqLMv3}0bk7#}; zo8DQQY!pS*1k(V77$^){YAB~XBO#TaKgmdL7WeG|c9&u~-B?E{7h3Of*0GLWM!%al z`B+EKrfZkVsz+yOIH-^`7r_{YvOU-2VUOJtafcft_Db@mQ7q#eTlr1|3|b*JaB=Lv zr07@LUv1pg6+!d!mdwk^jnC>5)~pz>OjKe-qW zLWR{!VV9DNLPM57%M;buy&|qxS>5L^R0^5jrX;H4nDe0CuBtgn(WUxvSEkRJhX%LL zE|lK|qGvk;qvZsOuOn-bn8l)I`E2?O!7+=y5(hHllpu|QhG?T~QrJYk=}b+}(WTm3 z66YKpfp%G>YjovcY@hYCPAh9AGJhb*{?dX8@T+#$WsaKwFZ4Ud;C1i{{pAzjMM$fe z053w?*mN}>nMcQ_tN7vS=y=I(ot2J8QYyL?N6lQ7J8zk7tEky>DvqXDbk5xvy>l?N z9@FkFbW{+T>uYo~LM1tHa;f!~@ndTbc}3j6Bla}`e?^e9$a>jsw<`+9bT_;Kv}PHy*h@K0bEx_JH>`hx0ql(~nSE@^;+4m#rQgQC>x#~KNpLeuoj%t?PbtLj%4E0Y7Z|K_I zff=G>Tc_^G{6lvA!EpZuF;2|Mrn0>#7>SbV7(+NjXY9f(J3oCE^i+ei29WY`msx;} ziTe)$Uz22Qa%KBoX5noNpgizo*p1xX@9I8%NcQk_PJ=?fwzjE;8|5F82&4R#j6+f4 z3M~W(#%LUc5}ih(THLq)Ku$GNjPq~!%f4bii|o+3D;rjw@(U%d@x3YQn*~V5=C$7S zW6*3M6uYsV(MaffGorEx`8904@6)mN;FKC`ffb=vQ3%2cyNG=+*v;8!&db(HgFzmT z=~mZVyUnq&N6;S!FDL&M!StTnv(6EjX@8J19Uy(Si{NAV+cDWS2EhOw}5l zi__=W>2oYKNz~vY=0n!W2uC*RhkZ;H2;;$Q&nvm;!%Y$$vC=4n9=XMXW_=Fp=N~Zpc1x zH+Yy4<26lLguneHag%~NMU3_oXTJ&XYre$z%p4bGUtTkixHanPsCvNY+*ap7i$1)d zdqM7Os6AgL+haz7${Z6U`9FyoC!o{G0%>KAN$SsB3rrB#egiN_(MYPjcqHLc%g~p(00sedqjdDwxkFxYUBy6`Y+ejxj`NB^oxBf*0dtaLrHrL3eSG+fKu2*cg7qu6)&Z@x1`JG--Ag12u6~)RA?DC4@&DifucE?MIWIrXM0rppT)nG{O&joLZ zDCo*Q>V!5%K5Li7pZk4Kg=9BX9Gr%o;{|-2T&`EZy#!@_=-w58*9oY!TLRD{f#?|B z1q2xbMKzls#We+WHNto)ws8sS{0D;x)_F4k|4~4u=6o_6uR~QFBXhO|ShHZ20I48` zQ`l~C^Zpy+<&=xpp&-hy5PVgz_bGUTengi%fo{MTNLt}- zjFn|fXitBgMRY1I)%eBuU@C;&rWQznVt68A$D}nFN;scV-FUoE*?po8bN`yKD4X3h z1Iu#6y%+R(wKXu^7S}C-M;|;OeT!Lx7}vRV5^+`v5=>b@T*A1&C0L5ITmU)Rd!7T< z;Ye2O&q(`%V1Js8!FiF`Zwq#9fL%?jsOOx902?DH3UX&jfW3gUe|YWqi#vNyfE^%K7J~MM z0NYNGsVxhz34%=RvH<%L0X4O=1MD1PnVK$4rA6(T#B$mBSeDlMEJ1E6d^*71M(~}T zirLD~yR01R=wxx(FN=oC{StPwuI%dU-mrZMHnjw^6PT;Id)9Sy3ra9B>YluFJ5DlO zxvjHPHf$Z322NgwT}lQL8pj0&XUn>AKy2N$+|<3Wn-X zaldGGDKa&gDo#%a_tB>4O!%tM=+d03*+YmSTA_hO-P z7R%X%$q5YdL``yOOYC$F%PwwTJxwDdhqJG?*MZiaFUlwh3NvY|uJZoMsEU2npJz$d z6^@LlmD!mSBeo%7fp4!iuFN}C_g5L%FYk$HpFC4urYc*tT3#9gVVgElQ;X8)HN}_4 zSPM0c%;Zabd7O}}BNu9>=koLViTcS?q%HdZc34-Ms;ywv{}HtL#2OD~j!g^T%Hw%O;q&=w zRHi1!uPF;S!r9wC(b4(ub=5HZ#-1_Mf3mT~l_KitEDok?I=Z?$)^&HDqN*SkA-f>| zL#iN0``2$olRN7Y*?b>!FtoWX*%Do8dY%24nlM_QQ;jhD9<;)DdO6#mkrNUVKpYZ1G?$A7Cp`yJ|Wkro;lY}9f`WTqnUZC@f-zsa`eGy zAp72xld43?$TZ%VQB6-at8SxswjYCf`k4JQ?m`EPc^qC0)YNEQ>jCy&QCM321SvI8 z%(32Bo4%GK-Y%|01x_1tHmppkRgHY0P$IZbh-7K)uktCP+zKod8d=;Hxbt}IX?40> z=gFfNOJw%@oTHsK_C9B&b3OEY@h#VMba!nC@94xSG924&6vc%k_Aa6+)T673HnVR3 zE%?SHvyEhSU49GFV+Z`(bhjAqf#@AM&CI@_15Pj%0Mpu+7U?{Vyx&r9LvRzhWeo^hU0exRYn;T9gyxE>gd& ztK$P?f6m>?{toD3=)fr?d6O*k5ym%J;=5PDt>~%tilubyy+}WPi@2D+mPG6Ws2eSy z>cXO!Ut(>tPjX9qFfNrk#$oDC=R3!B!9K@}^*I$Vw$P4_F&<=*1D`c5%Ns4b2wbYy z^pcS2C10)_s8l23m9ETYu|do?>@HR8E>(lDlZHG0L%L6-s(fW`4{EeOWW*hp9dL)@ zb!N;dO6@)CaNLKTuH1}K8IWIA3bnS9$&VGQT_S{8?-=7eJ@@B#0j%O+Eepv7M*|BX z6ne=v92!=hR3M+n86P(-wH@yk?5EL|g==txrY2dv=;Ne+nSH^zyM?X;y7qrFU#K4e zwTmGB3x73qOtY!UgH5JQEcF~^O_&Nxlu zDvoRrkWH2SQa=hg0gZhw-DHxBCCstp0vK8vuu$fYEZp4W!;@>4$w6%T=u~UtsJ~3< zA(_&pJg}86G_$Wc7J>qCRyG^yulmlHS(Vd_(~(n}+za#%KBJKx*#s^`zDzAL9(%ta zkzOv+c}`+;?(t)L0W?!Iw`0hz@uz)Xv=G@t3Xs>}t*HJOf{V5g!U>y-a)}6W(dsNh zuM)u)n!h2&geOb9(w4qUfqNhoDdg|{I)c(TrdBSGC#unT&@#)Ag=ut~rh-Lz_Ne#O z@RSophK{@6gb{ak$5QUOkYlqFF1t@URr-!U%}Wxw?(=}a*_3G3AJNGobgGZw{v?p- zx+0zxEse&LG@s_dDoIEN=h315Q*l$l_RjG7o!ho`ZW(*$#fFX@9qZsJ^{^O`;Jhs| zX;u%P0|&n}`e+ws&D4R&!T7^*cTe0t5O)sV90&L7y(<>wfHsriYldyfTu6>@7A>E1 zCSc;cb|!cI=IHd1I-R+G*_kh2`*SK!)38TM^QNAovHqC}n>9&a#D#6$-{x+Fw-!}= zk=bc2DqmkT(%s7p>Ara6aYM;C$j0SVYfN`muCUkG2|EHqA=#CzNZ3~>ztXc!wNGpe6?gAoVtJVLFfXmg)ZqA`y5FJ(>6vnRNSiEd~@dzUYG-D*Lx$2^D zRe&}q9S{q2F0Z@=_lS=DA9C?)eMB zIrm6EniC>#5>aP<#b322r?ADKp_5&ZI>#(Yn-a0*f?TP7Y zjg+cv^(e#wBy{qzdZ01v89lDvZ0d>_*R2O2OdG}a#*1OuxW;`bVYBTpd8W#5O&Ive zIIJ3TtNR}<$(4H?Ocjq2B0^1`2enwCFF^^V*q3pBvA@Ex`fey`>BSVE*96 z2iBb_RY0+G9W=cv(#8Dfpdbh%?K+Vn`!Wmc)td7PICs@M4wNpLnf0pqJP@gmX($l| zzZ;3Oo2}k|e58xL#T3&&$(zba268#tUb6ND&EP~uHpa&R8Olp};3h#?FJD8SY3=fH zo+U?h4#bK4e1(z}(p6H(u4BEmh1jEA{Je94e4J-aRpjyfyhYu%bC^85KIye4eev+X z(4NApB2h;N6V8`MD&f%b!$y6$uCm0o<9}H&$;zA%w^x(CrskFfn7m{YNAhZyI&5_} z?64}`Q+Q51A6us2<~-A!hmFhSa-K~nAVNcSxL<98T=(@b5CQv z;B0xD0M7T%=jVGfK-u5(yh{v9@_b2xN?PBvVx%Y4IZpE+-6aM94ctUl}A z6MWE4PM&PA_RRn>$DokbJA#xd)azGDeWzX+hx2(Fk#ll3v=h#P_P1~~n@Q>I$tU>H zKL>@gV(q^vJ;?`O2(Zs6*brcz4Zv>);I1I0n+PJKd9)t)U4_k!HC1Al4Jo zA*Yjpk?g^!-A5GwC6?>HJ5-BF#CPN+qLnpSFGy{;5Guzzdk4*e9ORT{ED&%P5AMpS z_2VfNTrOf#9QIZ49K+`tZr= z`{hPFDgm!PMyH!yv+%(mxpVV5I|vih7@_pA!w0o?X5}7qy(X%q)(;m1c=c z-d-GW(-AwOi{4^rr9Yn4O3RLqua*|O>QWOow8gg=a0twuvHMo>62_+!m4cyrIFgDY zs}Nk*StI*CI4u&jqmp+YF(Z&MOiQZ5tjuAtqP|O_Uo;jaIXihQ3K_gZ_2JB$&S+38 z6ze96W_Zjp-u)Do@#AI+Y}u(y;zA~Yqa_+onAR_nx#0>r-Vo3e&=E^$TpWO3i&$=~-{^*bk>I>*qpM zEkp{65b0vwA?T9??Fl zA7i7-QYrHt>~Jx2#ZYD)+va+_Hap%SlE#xzSK#JU77T(yREzdee)`TO`VDGB?GoK^ zb$jizG1cP|s54u_l{H~M2BY=*TNr>|q(xAURpQuj2kOU6xK89M+s?TmfEgc|DIzFE zC(hImm}--Ycm<585?U!43ABpB5H`TzFBx#Sa;#i9;q~5{epm_PF(fgaDI=Z4O_(cPyilu>? zqeh=5E%0+=B;!7ysx5Bhi6!#toq`$g?>Vtpbi5lfgp0p$&r+ z1z#xyC{8Fs%IOrJ?BX-krCRG(L80Tq)&s}Rv*=`T|G?%zwuiCAm_^zSRz3pN`|h~Y zXG&htKgMY);`;+!H%eO0v(5zPcFpnaoc@(3J#Nvl{mkV8+V(VqO9Hd}P5<5s$i#V{IE^Vj-AbUuNp{UvuIyE=f zrBNNBZP+5p%_tN2iZ;6YRb5lLU&H2~R01>MeCxlFMVAUm>t!DD#WDg~teWw8dk&NE zv@tV(5EoF#}5F=N}4QeNhXxa<7?se}wbAU*zWzZAo{Y4)`B;hhFMl^rCML z8Y4>)+KHlepOOS5YT0$2ta^dw_^O(0b-n;C%=Dir=r6v ze3S{Y+;^KG=Ezz$L|6X3dW?v3NztD?iT<4{Y-xi1>$K69M=c;s)U zNp4DR{_OV^YyV~p_NeCCe#KyiBYuR&bPJt#SI_#I*V3zp=447^G5Rh?ykSGk=#JyI$+&cM@n{{zFu5Y9ys7Cr$3MgiCg>uES*T_rQ+>Zc}FUk&$ z=qx(rel#YjYlM9glJl4StbjVrz6j9y-^>%ulSi4#OM*R0tk62&BlwJf&y#?`o+0)H z!5$=*!F1vlqgLk$Vt*pwXGzN#ZYTIRg1wOhjOT>|bQ_MZj(bb!4@!D~>WLah3D_rylQS?{lBfFG?Q#Z9Wlyh)pD zjV`3$J&k_J3WUbZK`q$qE>;ZBn?Mv`k*&9hq(ET*4Pj3Iw&{w*Jj-9{&F*2}Rw_4K z&~4qX`Z7gMm`4oGJzwH+d6LH8x3zQVdd9}BxzV^~%(xN%IHBfN^Z7!Mw{v{~hP!U; z!tQa$=Er&2#|8Oz?)Pz~4v?OMok=dR#?+C?FH_A4kAsV@;0&!&ad1``A6s+%ZHAN~ zZvWH|^DaZaqv6HpTSJ4Y_!#5k>-OF?fSjdfXBBz^=$Z!eoDcks54_+5&lmtUg-Yz4 z>;qu|8hn2oB-ZG0nppwq0``+|;eSiuFVS*AJ^#Gi$dT!sL>@$Y7zExHQ6G*g`%bt7 zA+v$~i4U#9l-x285*A+8$6@kS~L{rd*o#rb_*KB)-cOg?ruPbz4ffZ%e_S_kB+G%VW8 zer{tvcx`^A+;!Nft5Ih%m-fzNb{0{m%JS+07LX+#eaIL`>ekYSd5A~@rPCiU*m34c zHl2H>>nEQ|IA@aP^BpdYok^TRoXN^3j6o0br0e!y4DHF6UhsJ=ltkM$h_Bjhm7L;4 zY_^AJu(%0$6|SSiCLqfYlUr1BFNr6%;WG_l<$hbk`NewkQ(DomSm>N(8%GVXLNPoKj_7?5>201()`Zzzm8{}ghZA+hDDKiybc!IU*rL6K- zE)ub!s=B&qK56^pREK-|>F4?N`>)u9mCy%|t=|%xCCpZ`Q&Q~WsEg3#Qtc zRGobVZl2b9n6SFNqDQ+el8%z0{8L#lku zlcIyXxBQ^icsyI;oaR|WVUv3L`Qa>SmaV}`pz&udX@D8U$rh< zz6dvMjIRmi$QOIS93`RodPhWP;h0wYSL_S@!B(q~NE~go#~ATLpOBArbW{3#%3PuI z5~O*B{4unMT3+i_6%lXeNDZBDnhRIM?Qt%~wKl^i8(RbagL5yb_4y;Z8C)F6YDqXi zs3C!6sg|fn4-C2-l-4VbGrk1SZbn;h^#SvVp2tyZ-{sC`J`Yo8ZXGS4w{Mr@{D-*( z^Y2QEt;q0kFc#XIIWDdPbVPKp@97pA7fG5cb_500Z!PM@5_THb+Yhe*J0*@9rh!Zx zMo41uBc}&onAl7#&{JxPRs{Z7keGYR>JcLf3bx9?`gHs$@yjA?%Xy z8)16CwVd%wS#&2_P4Egy<_4DW3k9&RK9la(!|FOgU6kAGt0$=o<s$U2L!xXz>xPT_3TmCL$y>Pq_Jw%UW`QIt7B6{tZ^~<+!O)`;)_RM2 z1M96T={i~?A7>?J8s{)uF;q+LyxI}+%uxTFdGqGs(pfw{w6$YL7mmQ?K2;VLTg0#! zBbJLaiHWL`kK<%b*eIu*%KFSPdQlD%U@4TG|KV1|c8TQEe%q-?FQ?Gq{HJ?7#n&lGztT)Wr2)W2p2hT!|cuU`@E1$?LB~4BMg>_yd~aC!x;Ca3Xn@^vdb&OvoBs5@0m<{WsDvXn2SmduQqqA%tSOMX}!Ya=k;a}JvS?> zRU|i8vHp=h!+O4vJip#NFq3qi-uJ;&vg47B8&yb%W$&iJ1-L9_(rqu>?UnUqw%YBb zt*4T#y=>4c%Ul{qiBs+6_^TN4X1VPr?eBKV=#%WWmlsbY8;TLKFB{6$Esp5NPFypFYszJp*;gTjhDn6(0cih9;&w6u{yYGW zAd);@9Vs3Ze_T;n*XSr4p;zLD zb_=MA3}S!6auWMp0p0yVFp@q|KAhz2M+Ll5={SM9`&Dk=U7bFOD_OgOm-bRTwnss3 z&k}O`ZTTU0B32DxQ~~lH6XVSOIzj46|3$%sd_vvl$j3gr9OdFmuuGe~<&7$9eaaQD z-@^Q$77q#wjI%28QpSP>;(%rnjwxGu!t1(w)^7?g2pcwW&(I!evBE{Ik=DwHZN#F~ zQ?1plwXLz%y4FN%vg8vpV=fMb$A-(hp2lif&ED@=i(0T6*x3$8oc6gR-rUdavzK{u z?e=-?^I(2&S9tS$JFy13!BK-dKzlqu`@(y@h5M`Ty>m0$vd%?=-lELZ<1bzV5=U6`rKIximdF3wz-buJn7mSoP%IxiXYF3HTwIxpMpU3P2MwQ&C;lp`3S zBbigZd0v<${ERm*$KzJPm$!#el~SSme*d*tI-)#p1kulV*qcLYbJZs}4Om9lRK0Vy zsrqO|`~3Z=SZ_u}`@%1eNg$T?=0%KggQq7NS#ACusH-MI{y8`na@ir)kOqYtI=cL-_p|`p1^LKmm zZ`^1941?DzM+X}8=4U#*d8S1c4tfhSP2Ri)7i}e@s1}uSDq2d0&=SB!73~~9eoZh3 z+CnFK^Ry)|-tAp{r#J5#Ffw6now<9Ty=`nUwPpVt+_<8nepBrW@pmr%7U6F(`kvc< z;co9jIeO8)*b7(e#pJsfp5D1b-nrhQIiS7GTZGB?T!i%4MwxGW3s;GvpMwZ$yLY`oUdb^Q%`bi}Q5xFs6e;!vF!y4swd z+U=<3atH3_hQty2q(ea{bUmI<5cf3>)jOfkOf=4a4K>DnDu%UCA*%VP-) zZTm8O3g^=y`np0U&U@(!iy)8TQPdpyw)vc36%XP9*}N}=tsm?=cs#n`*V%{)mL6|AXU1#OL3gcNu}j3lb$YS%32pAIaIq&-c__qY- z2=-ureL_I%Rl(jBfZGFbWdL591w;QNATt^IhX8y&0G}l&Sr26bkorXCH*{Noy#iY$ zxCKgI7MJP_QH5&H2I&40)rq5vV_MyJ$<~@^cZBZcY})RN0T|@d4f5$~J|%PR|H@_~ z_x8(A2Us>bE0bn8$B)a3uMd*Al0m481k_Mr6adfTjwwJ^y(GbO96t`w`9OlPH5~Q` z1({t1zZwwSi+IO(=s?9Ku~A#ZMsn6MYrTS1l_Wv7tr9eoK&r&~SOA_KfX4@*lLhTx ze0b~BCXJE~aoVp*5Y~s@0IuLe2#u39W2z?CMRlG8=XlgG?3%hNRc#oTi37}%*Z^6# z2n*SLjPXjF8Lf2yc;q9J4DOrhWw`mR4j*wC5y=XF9z7hNGnO?)8s{I zHQ{Fjdt*R*18HRyoqriYS)AsdDNIIdhK9)$-`kC2qzmiSR zWsYpghMNws%#khGaBmK<%#lrNpV|N$6_6FL#%-)1=idZNTIVNOT8F9t#_N0|z_PBG z2j}qs%l2Y^9X1jRi9fgH_)w1J+n*Mt`_Vd+WEX+dNs5i4!0GrH1p(x!=?{ktr! z{TtFszqOYO82XfeO9_5Lz>5i9Bj8yCuNSbK;0*#!A$To7>puxfTj;~#q3Z-xek%P| zA1-3`SvrZ3mYkDTXLu$EWXyxAJKXA3>80muvOJz;oNUYZDLaQTH-G zyl&@?aL*P5%X?|4|5Bma(7C=_-iMeU-qLvuo~m0XFNwm@le1@mTjF+h&JW{u&kelY zv-?_H-zky&{ZRiri6k2cmve@*40oas!$bYE$0j>A)-a-VuNvxKV4ga~o8o3V3C|@Z z%HlsH-q9WI*ml)fD4qm52d|Cuwo%*QE4t?Z*bd-cYDQsnM_Ju@|f7M-@fmI4Rx%gGSd#o^4K;TXhvW@-eH|?n+Tt2spl_%_pr1zkC;0osq`YGVcwY7AOYvrVOQ<2gmq?@E z!JslR+nWNA+Etyo7YkNFO^lN`CuWKx)^~(J!RG>y+()sTt|>`cUm}5sF4j;0a#FDS zu2xJ;KA}e!rQ4XEJ$tH<|FvMrXRUn%-xW8fJ;grE&^HP8o`CjFVs~+pw~n%&?3=sP ze*-`7FTfl)CB8I?XXJRYyHL>1st|r{Tm!t2BX3I>Tx;94!hm*!%~ioyZtIb8wY_UY zCx>r#Ty`E4DmO&W&K+ZeDATeFhWandO)HFNQ!%=Ai%uLlEMdN%2V7&^g`vKKtPgLN zp53)&N9VRJK9|Vyr0~bPcBHV6jFao(t=oFGc5d5otr`Ab)Zy>+wc!N20A|_UJ>cWe(_C%T!1!uw1=R0+F6PF4)=PF97uyx92J7}&4=4*-i}uEQ zRXPy=CsEAexF6hqlR8}QVso%BQ)*uh*0!f%prN#ykBx+m%>3lMH zenPbA^=^CVZm+a20~Oc|6dATd-VE7~ECP4)is#_%iCes4Xj+P%mRk6J@-W`b!voiS z4F?+Z-Mj{>Qx3tRXx|5O*Po;v=i%0Jme_xzOSqkKw;K$1+hVxewQi9NNpQRA{E|^{OK5ZYm8qS;7zmaIAge%g z#yLUx>i;GI`6?Hqiv7m`o5O=|7i{R!Ps+!AmYH)hZHjDAWQDpo`MA#>C)s^lP~^1s z>jY(M(Eee7{T@N#%4*-Qw1)+&H^hG}p#37TyTt3E0DC{NHw#uC<(?MUAm9c}!E!OH z-2QzA$s++yEc0JO6W;$9BVHDVY!?{-L` zS$>?Att7%;waO{<1EL_4e0ZJ^w1P>4tp|nk;|(w9Z zIO9=jRS9!T$L7xChx+Gl-nkvJX!myPoa)5KOM-%_1~G~>%Rpw1!8O~HktJtF*66at zcGe<~*6>VzRM|`L&Th3tATMfz-Lf%It2>qx{>i9uZ0}%Q>q!-Va%6v8z;Q{^`Bcd% z1^V>TNZeR>l#8JVOc6GJP_H7WF#&lqVF*qz1e?bCzvV}8A^l72$zEw|Ma6KLSDL7J zpbpj+r5axY__bH6^$l|pK7{jpQe=AEIeJrTxNCH%^;9uO=Hu#3k}UUBi+wAPkI6Jp zfoWi&H$%6l+snG0(e_#UXM1IvKNxK<-(Oni&0qnCycueH;ajr6JY22PX3mtk@BLrP zGr{N?p>3+$4sBQ6cBn^n+o7#$BOco9aP&KS&1A4eCj+-mb#l;omq-i=LwZEd@BoD|0e+dogjHXIkWP9vSS66 z2a`Y6Qu8d+8$_h#fQgCUvN3_B{np)cUh z{c-l}c;;iJ_{kXr3M=+(o3p2LiXZnQYMJY7g-Hp{0q{|B5huCh)qT>BXjT=&D_t>En4Plbx-n`tVge~ek!M${^-K_rOMV2OLTdn+x^k|?@c(L1gsXO!|u+^Nj>TJi)M=n;lt-O`C(J=9BW)tT5jvQhf3eke( z;2Mrap&BMg$uRc&jQMovk!fHeWADenODM2|HNBP+@>)8M$k-6`((!D}x1kk(@&WGk znLP+GI5UbQ@OF&yvvnZW1lhz#pmQ2!m zUAg)ZDzB|0EW34tC3G%uB=o=NTkXnpGn9o^L&LgI^r#N5e7D6W&B1*$lkt#I_|#M7 zS1>1mC`@~`_k402DpG^%K^wwwEd~wkw7FQ;uagH;!kyc;^=vyUe2HRvwr{5mxxqrO zTR2UgE9yMUH+Xw_XpbD2vO8L5+$%~jJQ8_+YbkqOYjI@sK0eeDsuh}??;|F&pAeUg( zep8}5G?6pVv%INEhEb7`W> z#DGV`h&>zFGZX3VkYRx*)^GGf)vHkFJ8?p5-v=pqprb%~PH3}B9aCtVQSWV6^&VuK zu?yg>;}*bIn+5O|#_}=_=NvPngI7*wNRx7_P^FE81`;e~B*k9LuKX3ja^6y`OWId} zHG_etCY~a#2qi|3N056glus<(VqX;jxxtC#^5XZxB|{TSAQPUd{l;pb+^DO z0&uKZ?|)J;ALr*?j&bYg265Rptx&&ZbnU8A*JX6w96Eid|1>OXM037Am0hE3$EHEo zmaCu|HyZ~SXVYX8LKZGu_skmVuMotzZGfzQ5uO>r;%dxgm1eQ?dCc^SqU;qSNJPi< zaAOE3$68gj7SUm($6P|6cQEM33$E1R%3(+r4OfDZ!Gs>=9+BNg!8r5|4t6P?$L!a zPLXBh>v8c8hkg@(N-*x=-43c;?25S(o!!UD!tTp!5vOxXSU%R#6PZ>u*@bnK!_uww zB}%+lY%PxrFN?Utr4h$}7ELd2%)Arb^rLmo#`hjELX0_?mN_N5QA&JgG|%0meY7|A z0Gn3XShP55y5c+b1YJ?eV2*|3#h`lT@(9OT=yUVvdi^x{n8)5i?^t#%EU?3!JJy@F zdK5DDhN}CjqUFeGw3%F*8KRKI2UKha_o!D6pBInWW%53FOqHfFNP@O~urjX7-c|c6 z;+4!a;~2R!9&;)lkKwoc1n!-%x@=Clp-0^b9)xhB^5h#%0O1!m>J9ZzUAA2Agz=Jc zeLqWsQ+S>L?tV%|lIB!N@ z)hz1^PN5s54)Qp3^H?o;?ED6E7JU_?zGT>WT=3^Dr0+TW#Z@APT_YvjWy5*Bg%_^| zxxmdexDYqm!dDg$8hY)^)7>~U#;C68(+-?BcW94Dr`8YT+RK$AYXSZd+B(N*>o}S> zZtRM^Uuun{@QZmw7cYQABPFL5R1P1n<;iym#+-aV z%HO#tL4ldnm6byq6{>C0N5%}%5{-brWT<(U5dMh#La!hqx}IUxWz1c~^JHru!6#Du zyw<_b5#`Nayii=u1#{%%&YUTq(5rPOU#-nzniPg4pxcSDJ0T|5y2sG_f_(Y;QEr_cYrnb56L~!I}HaIyCI?3jCN* z8`vde!%S`uE{{F$Y#arzzYBmngdgmuQvrE`1i`bF{!3iq!W&y7Ks)S7x3H&;+_>+9 zjj4khBSj-3XKQO*pmTL-vy{p{$CZOx0%6qgpkTkd^n!~-)o&JeulIUp=X ztV4t0j}u#ToOh-Y9uJDru@uT~W@rr9u~>w2QHb+@fddvWr^=V@i-5F*in;04+o0@^ z0EuQaNHgX$_v-j4e;rFXl{>m(c4e+>6wHqqXA6=>EA{ zE3Kz)dU5@!<7bGG)(S^)t*0Jrtw^_4*yeCw<$ds4UooOn$RQ&%L|RYMX?i1$8#x`V z60cW5NFh2 z{<+YU90r9_y?nP<-j_KCr$gB!a`IvpkA@D((a<^2j@{;!VRu!}LQ-A-f;Z#x_F0b= z%(C{`mG#5X*3*X~t*0}Q-qaQCvj)9cnFS3JNf~YiJ`E}~(Xui6x);0iUu>QG9?okb zS_d?lpQMJDw}!Q;8OQo?t|lvqS5DcPQst(h?S4fV=P|uY@@0Lo&MU%}@JJ-?caH`s z@T|R=**E~3z&TGD``U3*Pnlz%M`mWOj;)oEF`Dkq(}*+eF}W3`w+rj{TQ>FdfM$F0yEk``L^2l4PI}7+um$8ObI%V>_ z3v_28??RWOI`1-M9BSOO_}?}uG|qIHpDsHh|++HF$m$jC*c@{x%N+%_0E3Ho`7i*$dsY?_bIIk zfK<~Q8{hMkiI>&P8-y0dOQA>cENfjglO2&g+7 z_XXfR0eEKs-V%VE?YOgHZy{Dx3-;;&B>Pr^3j*w^0XUVQ=qdDCV9f((ZdF;lpC!<% z`4s!BYz)?`0r;H&JQRSR55RjByiPvW%WL>K&@7+4c_P$RjBQlY!bTX?J&SE(qcnb^ zp)`9sqdUTl80!dSN$a%}5I64Ly<7@-EeVbas7g}q+g}-ARa|&i2$(6VU37`3`}SP% zD3;=kUZcMth+(dP+(}ofRi)+9Nbe>5S(es%iy-&yUktGSL{Rcz{at`%S79Ek;Q;#; zf^P`zBLPzTfWrT-2vxW9!`Dqw0w|8P0`9_?>5rqPin0 zSFz&+R-&16>uo~t^>-qgd9waAX8GRi(@A)W!gWBL6NeJB$vzLSjT`yl2^ zpJ)<;>~rkaVr*dSiL@4z`92Ua64XBXXl|?{h*M>yvgHCnR=UF^AWlS)Sn>a-U&~@8 zPW01;9XE4jQn|f~bIWIM_bWSdom_WxgiVs!qMxfGE3hlxtP|sK-2`HTJaVyM0=!7H z$4!7&kyg)&_nKyATG(w5R7;q6%;G{-OPFYMg1S`I#%8@RFEoMulWGcs=f3AkH&>QJ zwy%=ytAah3!-ODrW%SSr1!w0Z5ZFgZAi-=7)jTq7j!$KnIzGuppX5Lz_}2lbGAprP zCYGF^8RE(o;s2U1VQRA+Ih&TQxUHaQ!UIyso#*SCECS!TO8PR8Wh z!W>OzWzQwX>SeRhKU`w;50@JK13O0E*$94&E-xPs_%_uvvI_9p!>1rAOuT4a%yH$f zZokMu6cA5*2GNWe3aqsH`|C$NE*dQPlzV)wpPmY!q`(XT&IS zWrb*0Mxs!3Zfe%bX!-xs(jSX6 zf5~_W{v-gO55WD|gsraz;1dBzR>th8tf!#LdW=^Eygo{{b{|DqyDzCJaLm|!l>4oh zxu&xYXwA(NizPcObjqYoBuFMTEx;BMB$N7G7Hj=RKxI-#1FX)LWKur}u-_#unbbD| z>{G;wp{un!zvoHw*Vb2XuALfzlx?(H5nr7ZA*=rFo0y2>Xk@ zE#CyPkHg~NlP0}3RH`)IZOgjL-+yoTBi$X#UR>Gz!F%_sdLfgFb${f&2iJnaigi!^ z(f2Z~vF>xTHq&PWW+ z!79wVn3-*}vE@T;b1y3v`^DFRhvzj$tLnMnoK%I!YNA!R=zRtQ^x()6rexypL!& zYl6NKY>I}MjI&sK#_K9O9AP6^PgwR;G{R-b0UE$MBNElETX*;bfA5ofxK7k;fy%>N z={5&q(=i+B@g!nm0mWi(db$lw^-#KEXitH(>wTSgvuRUD%-HC4JMw61{8s~+;~P4j zs=v2BG3Uu$xXyC*p@vOAIGj0JS5R!1I0dbxPoZYNqyQ>Pj z8(L6=W--;Vp_RrphBSzPiVIsqxuQulF`6mL-*eb|Vw}wAXlBOA^Cg-^)VL)xuT5g+ zWoFd(|Nh^(RYiB}ti(r zVf{(TR@T4k(ZTvZdUUY+4;}wkj#=H zAbbtz3`d*)UrU+sC$3`G&k~t%MJ6n51$qg#5Qm!Ko3{vfv?Aixsk`C}>?5?ed)3ay z?3if7i^E@*8#%;|w#6D=9E!VLcl-T!HoQ3L#i5S^P|v-{6X>%-3EaS~Em1ojclR=nZ;6GfnM3uQRtI=RsVc z8F_fl;UJHS=%B!bnGNT#QGcF<+S07yf`<9hmtz?m3UKdomhcwtY$?+=&5I}VZL&ui zZojGyIai^LvJRjVX-(C3PEsmd6?U1TW)fs8b&NIDz}jPQzhI1=iJ1-D>g$^snS~>@$9QO@VODJwzGD|jTO>Z?LlKYZw!Tm<2sP-Wf6LL3O z{6w>ho2MB-tcdHSC}nq=jV=l)YXA4JHS`<3FK&O?&6y2rI9A=)@DaKaW8^hXtBEyJ zW}{>w!37EZIyJN5bcJ|wamEKOmDk|YV#udNSH)bNB{|cPL1=N6wNLMw9_hSpT^DS^ z^5kkd^7Z-s-p|B-hpb8^fy4*ww8?LouiW2t+Q1p}4U9ul$6#J{E>_%;2V-)<8z&dM zqCPX?szP&oyN=;Z?XMB6lFT>ULHaV-q?4(nX&!w<0cXJPdV$;*n48(47l3ZAb34R- z!tA;XZ8#;-tiHq{6p}uVBM;&i6{5RFY+dNIq|H&#>CrTCfy&ajaZYB z3|Xbz=k$^2(Z)v_-JVAK2u?0r8lf}0F6F^zOd%sh)D z8;O%af>?mAd*;g@LFJhZC4&r$8pl#WvSD)X(V18n7qO^e{SHGgWCo};VjvvG-X)9| zNOI1s*JLKsVpXvK`i}~syfu<#XJr{GyfNKfy**D^cC?Q`FLL;-tC!hiX2g} z7PiqB)JV8pHA^476WfndDCDio21)pf%!aSaN9WobnZ>r&%!W&myd*YvQ5=Vq8Gya& zrc^_1QqN=Cc%*!B-}V_bZ5q}y&>9a))fTl>}3tN874oQgyUHzE=5gu#mzNa*GlV+0ct?ztU& zwEtb@l%mfpM@&ocl$dQkq@pP*gA|v;`KAN*cWej=X7F6Fe^Y~fhdA1JU9&+P#^A)ba%ThF?-qwh83-Wqyb>lIA;h9Dxlw@3RP@7i z{V=<}+}V7x1r%lq4l2x)y^1kRniO(^#0-OoLJp^o)~k~GEL&q%VU^vjdgH9Jvm>iY zmW^5z1L2tYaQ5#tGiJ@qa?^?zNTK?9c`Yeh(`V293!)ZsRv+oek#%4envW=oe|kkU zH>tRlg9wZ1)}!|xdla}ND>C0K8RUK`>yy*?jg2Jy{3~Bh$fS9fpe!Ht5ElHUfW0!k z)eo(_J}oo9F%_F@^pGDcq~Bdge^&v#4GGHf6J4^nu8^d?5N}xlY$Eun#JyNRt;ksd z+EwxsluESL)i%}A>zwthyvr)nN?A|gy>wB$X?{F8k2-gcN?NjVl*$yOJU?%JcGY^# znD-0oQxZFzEETR);!7pvjjXN)&N+CueveFux}-{K`Y8C3fd9Z^$x`@n z0X)u3Xb|ZTLB`!k@Xby>PVh)!{jMytLC(VVoBOtZtu@vJLum77M5OV>g0aX>ylWePNu7g=0puZbHSAp3bF$HpqlnC|g zQbCNOham3|n=QLxZCBfkCct_NJ8hMbxzkmt%Ofx5CJnJ?IQSt{B-VD}ELG=lT79K? z6+?R+S^kA$XidhNll75cSKXfMOSGg*MWDBti(M~NT+{!KfXPj znRN+zeCDiasg>)e%{*5m0+~qUUuU6xrF!_qraudNzE3m6wRA+$T?;cK5lhZxLR_w$ z%vjXpq0CsMua3f8k}F5-=q}tmyVJatatPIEsM!ZT_ZWhb$KpgifO<7Z`8WtF3&&I> zNE~9FxPb3(oz2GyE;H+`(O69523{Bw%{V#KHZ6d`8Owpysxi|et#zr0_?&2toK@6j z7zDel<(BK>0dQc7S?{_ zxa`H^ePcO#(BC6X-=q&0CW#mXILbJ!mEnpCFL7wCJJDD$0Dm!kq(=7UC6Zwj2~*^#R3pJpl^4btJGn@U1f`q0P&pS44l3~b+|itVG$*V4;E|yXjH7}EYxc#F41$RnYx8_c8%oYtrC5RwSObF z^O%6LhuX^o;=W|<7jPc}1I?JZ@^TkmoK(YYlHMD)MjzZE?dA3OHk9?Miz9y1;`7iO zBef%^75AH@vMYzN4!hmC&_q}^Ju(sEJ@H1Y+@ZxY7RywMg`Nfx-2X}+j6vRGMpQiL z31LV$Ag3!1;Ak@tC%e0rBb629l#w{InIbn+qvj^Z+}y+%q#L)#Y(rn#6tm^nd9TKR zM&ahPxHgpgc`ST|y;!psX%b^Ps85cR5j7*!CuGG+1Irc3fDbX1FJ!&QeP9s-7KysF z@*!3Z?-hL|VoPTw1qjtU5GE_R=`~V-Ri}) z0&itG<9QMBCQQMXp*1oGWD+*T78?`~bc-)AP1>ITR)o*6-jx4e{({_6p?-h39%jAE z{tcR<+W9%(qxFtzpRniOFAbef#diFU`|6!)Mdcl3#0(+dTh`Sker{B~!@R3k1bPie zVzc@7g<0n+{e;A06boorlomUJ zxq3M|*y_v8Xrxm9W7$cM`cD^6^QjMIXi1A}^`Tz;z zF_P3qQoRhMRGdu&Bvj1!XGUNDhpCX?iKymwspfIikTtEahb51Sn!X50H~I!gR!POG z^EG3oP_hV6)33~E->(b|RKc%Im{m_zvG?-6WyF4fR^*>kV;)F}MJw1cAJMy6*egA$ z5uuJD{kqut)_^XSzrG za?5;DVM`smn8CiAjHNph*=d7>i%j;YLBdh?9g3y|NlF{L)2PH2)W;N~eo4El$KYN{ zBaGrtX+&@0@nm*p!oEtEpUhr5Q5rF}cT;M_aoCrT9?KXL4l<+BW3L>ncLpH<q&wAA# zy)!UP6lZYq%E~Qz#T`DB@bfAf&fMZO`iG-|^f6XJNx8nNj>s4%Oke~|M6tU@O~|`^T@DY%VfnDwG533CH>-% zy}!sXA>M&8x?_IZm_!#(U+(&oo0e~J0)tK*0!$)qrXI)Q24(`b@SBku!|vUk8Y9PY zL~7jAn5q&lTvalksyK!A8ZQ7xjoFcd$uG!P8}t8{uRr+xdO3G$zK;rh{O6iMM|WB#t0SS>7aXPT^l=%D1duJp*Ayd_V#NkT=BP-SWBfAxT^ZZ0 zPGHR>jrpT1PtfnF32YFoyw2O>vgAKVA|vM?O-8_YuSg>MnCvX5fFKgbzKT`qTUNCz zRh1pB^f4H+f)$!A<|WsRXi;0RrC>__paYpMVJFZM7(+ydhQBC|W8#FRN*DV%FF|T8 zKc_(n?a#j4nG8n0e5UcIet-GeP8Yz2eCNl}z{3aZU%?WPDFBNH4%1AYdpnHPALfA$ zt0K^sn`VR(I9{j`TYs;#mrmW3r_YbsS!w_Keb~!Sicp*hb13h8jWbhq_NM};mI znAwF>+#l4}#jC}Lf#C#8Lvx*`+;sYgAPzQO9K*o|QYCC4iElW($^N{JF6m?rZOopk zbIVvdV*`$4Uv9_`nvNNk8fsry!5?oll`b6IPCi-oI~(q34|SAk3!+Xv*6qi2Mhw__ z%o&E0Z)vIpL_wTzRT2WByn%V=yA}9ap2UrE;exr)_T_1MCL~)1u;^SlALH(|K=t4y zBKWJqpeR>qZc!vEmn&m<;4vE~@)jJ(=SmdHr;(je-XgiULQyO)7toeG%KlgY-w`k< z)V(qxIS$I@uB~aHx|2jAA0kml@xo*OO6Eb9p(jK1@@JK%El7|r;PB8jcBhfs+ zwuRjLxwSQtq^FRC6k%4Ogmh{Jt8mW_)GDLM``digyzk@_dUr7NTgcAiMVSe`X@yXo z3esu8|Cvt~BvXlTgF6bLn+l-bx@E+ImlZB9CFlw1J`gIzWiy$X%P~~&Lnf2naXD0; zjJJEQgfd@uGjn)TLRHR^AZM;>L%hcvx+THi5tLS_{{Sj5ILii~xrt^mdb;`5@) zX{F|^*h4l4LDe9x%@<>@BDfLBY%+44p9<(oD3e)S2F%QQrVzS~;A~dieul!9_9>hP z-fSebHsPoI`x420K|r}O2mDpLhk66$>=w*L+ z@Og|ePryooj6w9`afREN^YO8i+=AA+cuk$W{RTNu$SM{WzDVh-k~ApPhSHY^&Jplf zA@m1@&?g9rVZ+i#1Y|L#dkIQYN<~1Yq&bzStxL7ayG|()87{pRp8`OQG6zcMGfBOG zQv`Ik2}pr^_f7%Hf^qKxSn^RmZpjbXpppX&kxnh)!g7Bh;0}gLAC%mt@i=?f`6bCh zl1mC8S5iRQQ!+}E$QI(TW4t#do_jBTJR%F$#(SBeQeE$_2+9QV9xZ^o3*Z$6kjxuS zw%{*0zk)C8gS;6|v*2?Y!X|0R!;%39K6p1lX>;(l0(gA^BnDv})eemoc9BF-kPAq` z30l%!EKPM>daDKwBaqeShIOJNg2c4Qi^sflW zesS2voNz`>`JfDj9&tDMFdjY}=WS#(Ew%R+~$@jIj0sZkIs(}(L^$R2LYj-b`Cj)CK)aam!sm=;rd7F-JW__RdEh)tw%jK9k6SZ zcA|&j^w9*hV`yve9mYqvuAu4z|L!v@4Z=H(tXB#ns2Be~3LhK5h~i>Xxz*Oormz7EC{O zIl6GbIo-&KLduy3c9<0?IGH9BnViVW;5m9d4m zvpnW8*;)Zd5&Q-~sJzS<5Af-j9Dl0J##Cuj8oOc%%CsaM11KB-A({es0+Rv)@s`@e zN#)q3k{wnJE8+U91_Bv9*63(V+obnsBRR}bu%1Hp1BO_yVkIq2i{*5N;)J_m8f5dt z>&-MG@M?<6i}_t2g>3FAI=k3^y)fivQJS$jHdmz5n$a4m>G>9|$biwiD9;JsSz@G+V9b)QI)95&xvYt^m3Y z3dNelqF%GCMq!d0Q*e7?P2rURA~Le$y$;ni^46&Ko2LlvX?t+%g8dNMOjh)JsNYh* zo919x;!s`0EHvuiQ|u)+>9(+GKGx8D>&?37%-hj^P((Fftvg%?>wuiNQ8+vim2Gy% zoWLLxr6jdLEXl!Zrr=q>!-!eEnJ&*{!458>ASB^sT&iuz`Fa8d*}+E9TccjgaGq{p zZA$U-#VY*nB*3~ zE6mE$N+!M03KHbDt6x`#^QsOzMda-Qnnt=w_xq((p)w+tXkl!phv*a43Cb z6P%XR=c?lT%1H<|XwjC?oxbXcIEfj(>7%h@iANG{Pr^P5M7=culR`+|V~AJ6HmEc( zQTJv#S1|~p@o05!NxTm3npUL2`WKtj)k35BZ%kj0PlXz_cn<3WDRI{%djY69f14Vf z8x;qpz9-(un)^8Uv#Sn#7G{HT4Rv6M%tz-QhE(q(aknRKi&K*=@x$pu8?)z_?vhPw zV9#}@b;CZgG5g~NvO4xgbF09M90WHuROe=;k5v2pa|HdfC2=HuY-9E`r8&jb0_Xm% z=!0)brL(X3EaKw2XP?NPSDl-lK3qLWbx+kgs?@$|Z1!~^SLzMPe7qQf1OpJ1ZaNUk z6vTwdT_%zMf)h!(z#(F&U<95Px#c*VzII4Ld8*RTp)#ErYX3n%M{X7NB8GMgxIjSN zzr?)X5Jf#S9F&98-9U0r!CT ze89UI5xH&;FGs7b_P)LKKIh9I%G{SgUDu@z^15WK`fNn3WQ+FtIJKvq2V97Ak2EYY z)?)n_xF}Volhf>{$t6W5aCwXwg>l&9WOM{|_eF+BFA) zO{ULK>(}ZXqtT6Sk=jFgSSx>W-M`X01$h&R9T#h0TKUuLUc?C{Vw0Szm^k% zRQ4&n^`URU8bTj~{n6`lA99luED2HuI(yBC=G3db3?qhTN6hSN;)7>>VGOg#zH zX={onaz2UmGe60kddC+D%MX@el@f=28|YkIfEZNm<1ie&{2US(`yxyZ!5qArxfOa; zJdwcrUn-X3>hR)e+mx)Q6R`gdv^y%Z!X2&qv3sg!=#ud5-O11y zqXGk^ufH-YA^YohK=B^J8&>l)!wc|uaJRYr?qvqTQSeB#($KpkG_X`cZx_%K{*t!_ zl{|eQQ;8({d8sB9*B64cNBWj##nY4{8V}yoLRM7*dOPqF{6s)oNQ%J^^AUn47`jeE zdG^t`FECUp9z4RhZwW|>uqBEG!KVs2=&6Wt*@oa`iSQ+f;9MY}Xkre+N=!84sIp+8 z5X=J~Bg*)JEjBL4YaxreSfc&!%o*}HkrDeQfq#}FJUP7uq5`rX0&|cREGG`+$Tg=L z7YX0MFqovtfyvB5x+gFZ>BX{#SrxlpK+WtTR>kJL(U9@{$f|G=l9gyz zFe6rl)F@_e2*#4VwVM%sBj9F&zZPCG3}{nXu1SKtotN>;Z)arYUMTMyNHF(q;YVQy zcq<7CmE4<0D!F%xgt%Mr6MO|3md>qhu4#%_%ajU!hu@^C!3PN10&ZiuV3?aNie|SvpbP2 zpu9k-Uf>BS!hKV~{Q`RR0`6hKQba&2$yG&KI!g=08CP&lfC!SDn80uer5cdSxyVqL zMOg3RlVP+H)Q*=9RYRyO*qtaj*b60eEQ^qia(=b%{_P%I^d_h`>AcD>56G8;nJRfa z$Pl>@Iu|nsS+LG|1WCMpm;3>n%oSee>}DB^STfeQc!`u@5wGb@Pnh^+5P>gzyo>oy zUndXOp3i(cFUZWCKqy<8nO~Y|FUQB={{W4@b{!0;P=V3?D`R==-6&j5z>1`GTxm7S zQ6e1I+C0yR9Qm|C!bK*0)F9y!|Av#oRf0z1FC8RYnN3BF%Ynxf-6E z5NjRY8fw+kb!(-bU-!fog;x$$Z9Ek>_wF+8Fv?t|j^3@VZa`2dXGd<|w>{j^wr0hu zHc_IQvM?#;E<}>QrM9MJiWgK;rP#(6Cw`KI)ZP9Zi!%A}8WE~l@G_5$QY^vynfA?_ z^+7~qy;-Mk=juaI$(t3D@+T4$6k>#mxs%IgJu9JV%alt*LpkN_%@TJTbD|pB?TmXn zm$UUAiRIRZ#PHU8&5ZU*RAbNK`?ZZ?H!kmL7nO!N-?grs8GJBZ3{~P>KH+QZR_tom*^P2Xr-mq?UL~LuQ z+O4>V?^3O|)op91MROI4T-nML67ujHUt+z(VA!(bgv;CaeMsNIC3YrTUc+k@=fht+1Ha6 zX1z5_1J96$^X_T#u)B#wy&fV^uLnm!bmZxm!|v7eecR2j$&ppuxQg`_4BToA;rcXq zi(L_ak+?jSxY?;zjhzU+OhQ$fM{=mD;hq%^F9^c{&~nUe zrEY*OXtAPX3wb*Sv*Q#H5*^zHi(kaT&IRL`s8cNEm*8|KG1x@Ale`1_9rw%lG+e?( z<)pDTIlrZjJ!8L3c7=?&&VgN+1L!L2ec>;$W*{TH@p%KMt>Nr2wC>StAAgt{jf9MA z{9(SRmos7g#UCxii)$QCDxF!miy8g=$i9wpLa%oh5xQ6zC8k~x<_k$F%&-pxr!!UL zUHdgRdXTzrOdA>)Sh>=5-Y&=Lr_Lo5R%3x$HgNcsliw5a^G^ijC}bVWjFrbT5@O4V zQ{8hpS?+*NmOGh~o$B{KOsD8IqWN?L4N;jv8J1>FQ0qjc<}Db-`jNoSF#&Td;A{ao z`Rpm*WXP0jkd1v-o4j}p3mA4zjXo%<;5~m4VmPVfObt9M6AlXG94nE`UV`^xgMQX_ z=Gp39k(*@NU(>$_0xG}@i^*}#6QyN3C%V&J)xHGj}-C*Fg=p)N!x zm8RPRO7=}KwIb?^(>Di`|p8e5YACre*CEVBq{}_fEx4ih%vk!E)c3gLL>tF z98VB>aXV;%ZXB+;Xo(IUq^6`lftv!{YP?++WX_nJIc=nbf?vtr_Nx8mwOf~$-D>Ri zC|N?*nlO}rX|MFo`UuS$Qrr^+WRv62pQP4MiAYOLZqnEFt!)fz<;XR!B41DOge()5G-+{ z)o`@&vFt64_EJsGm1jCW0q=#nFXU-SA_koN79<2N21T?|T^R2M#ZJ@(K>rK%q(UiZ zoNNXe5JawiIwzn)gL3-3<}T_*Tct(1ns7lVpigx|V&rhV0uucG2p!H>{4F8M$Khy3U&; zHJ$6O>s$w=`_8qfK}oOt{EhtlP=215pC8GOocBt8EI%*G&r9<2R$d{z*OH5d_s(aZ F{a@jbGe!Ua diff --git a/library/MASTERSCOPE.DFASL.~3~ b/library/MASTERSCOPE.DFASL.~3~ deleted file mode 100644 index 9e2378f8078fde74121fd43c4fb7e1d426f2c676..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 70313 zcmeFad0?EykvIGtGm?A>`9K&Uo8dCHu?-k=gex#chZ4QOavI$|co6WVbA#u2Zfg~&5?B?BM1AM>wRX_8L zWRbnH|GfsyQ(awscUMRB)vUA(I z&dAlkM{cNTuD|ipW!pQqZNGeD$JXwS&6lUPtn28$d{gK8?#}DZTXg>A-Cf(auG_M$ z6TsSS9ow$Eydl=y5^rj*_8Q}hE?F|AxgffA+d4aTbgqvyckI}?ZGFde3nJ%!B+}fu zbw}r>waCQca~7YoAo7um&tG!!`R6X0QX6YdX*T|A;Xb&3aG!J977PEb$^T3eXzEm( z=n3K|vmATyuD;URWGY_W6pyvUYf@gdV-0?$uWWvEODtUzYpPk8OgAoTnLpT9c5YewO$!w452pC z&LjjV@|LwA$|8UhYLZQH26ko+4hW{WF;-n4TN)qin~+SS7E{UQMj=G@YFc7dsj(iR zs#tS;qCMDGbVGV)clV7Jif&Z}rDkba^kIT0NWm3k9UKFapv)TVn|l73@@|))Syzhb zo{M6Zpb(8sUSsndI3`G8n^Rt_rVOrP;}yCTj?#wani%qqj8=OM%_jkMTtOERT#+9G z2;6b}we1lp}lH{(;XtWhXy(}0T`n&UOemRdnKG%t;}p!NYzZfH(> zEy-#$1u6|0Y-nyyc&*Et#WAU&*^hxG@tyEOZqun)LsdfCFS`d8|n?T*kIr)Z#7DOx3`f(IA`EDX*EiY?ip^ zqJ9wo*_Di^np@P397_jcEgLe4e_}&(V-q?`ZEC3`_?f=&70bL9DWbhdbKp}{r&}xp zgimp-riR&KLhw(-niH%gB1&WFSgLJh95vO1+Fl^3orqv1LekRK7)N)Uj7DpOlU@82 zO$hDKh{Bq>Hj$JM4jiYc+Vc^IbIB!xeH9HIU7K}S3%4m~Xk=M37-lK6HQBhjL(&`N23;!qk`_3>BRAf0-PX?SksXcXVHOednS`B;{d1HZ(6_(9TbEY}(r0xggT9e*Jd!imcnR zdHarSJJ;<%oLdlW*Y*e)I9xlocWu5Vf{LuEF^y+>P)RbKY|#!QT~2ytT1tVscCzP5 z_e6m!w66RL2}%8-8bEKO$tN~fH^o{|vgU*Y>d5!$0<^SzNlm;u6>ExLOxR1eU=C^1 z?p4$ft8VgSERBkc4JGy6HQ0CDrjBhJr4Z{f9hTzS*kV|s*@CCjEHc8 zI#EQ4T^-3q&5PigtS&HVuSo{EaFuwxW?8y9wwyg(A>m3W*Tq_{a`Y@29gA9$4e>?Q zURvgo7E)kzOC6SKgc>=xm{er;MyWAW4GGv!P2{Piy@)vbslkCzc8g>pzC4zSnnbc& zCG^LDo`lM8MK(D`2PT*nkcyenwHf`UW8IFfk9S74VW#ie+__y+n~N4A+X!Kv0jF`Z z(q{*lAH-P5riI^X-a-L5kzCkoYKXOfyg2Q#$Pye?A?28qK)ha4n~b&W5)P^C60(!Y z1>;_LaA|>iMZB85NAiArQu4laTPHG&mff;xQ^)4@$owQWEx0wO$;PI5OLJT@f$pi8 z7#v{Ts1y!&^eiAsq?`#%>q^-WZ>Y)#6EAfbp2#}kWFZ|_T#`|A5U>#P3b=|q@?=a< z%n!IoK0oj+T^?_$QjTvT16R`NAHKr-C9ZfwV@n&{$I(^mHEF+)Jc8jgdnt4^G|d)i z>aZZS_sCc%M)5eRkgsIADV~Z^5<#XVgI=S!gbqpRpr#0c_K}GVc|p50h~#2o_xUNO zJoaJf!jMeZ@21pXM6&P6JdX%UYrHXC5hJ;r}%p87K%!_hAN7UH^8 zvKuEG|J7_~qnQegtS_2bBU#m4p)^gJZl=s~WuUu|y0RxZwiOZy5&wrFj7*rLJusFU z>~p~8`XM@Pt@XQ>;zU#{-RFDk7;!)({j0E5f(i6t9((-(w0#1^hRli_%^dnD87w?^ZpKu#WphOQ1_%45 z9TO_@XVS-zqqN7028iN`u#i0w1H5u@U$KO}t8=PtZR|)K${fx-nR%+)nQDg{lE3NC zozT$nRQ;XxsX0&XPGu@q9d6k8!>4m^))kl8Q=Q`08Bb-NoEn*sa#!}(_2xXgecEu^ zn`XC{vCBV{yU3fy0X#A^o!_)qTA`yMcT(Cb%LD`4D}|dwd^lZ}a-Pb4r5=mU36kAf z@chQOQ=)J>))04!0Z*tExl*P}rwGn)Eq#RR+bgg#1=Ef-Ev@#JrCZ#I*|piqiMF%r z1N`Ht>tS`j+{^mjBf%xI_$RaLHi{$G*qCZ-1XP5fg7NCC^+{@1W-IJ#Wg3ub`#=2s z4Lm~<9u+!kaNk7n8JHTem93B~u+Vnf(2QhjS-Iob(PUNilrZS5veq(G`P4|b&b_KX z-J5H(uN427@6X^i9d-0-Bh{MBBsz-3RPgS7nym| z5=K^p`MIe&ZrQSCmnK3NL`6t5xFx9ZStSKLjurJ|`L!qUcOri$@V7*Mt(SX?Z^*9N zjyPn!%zPvz1FIXBi%1~TXb~G`{^<-=b{sGw%K4MIEPJPLW#wbsjg0xI@|EA3LR)C3 z*=A;I+-zAVuNclG-kV_!XVCq1Mk_~$E=xWZW$hm_QwM3(zY^2X6N%@o{>-gW<2!Os zlGHA|UV+yWIy-51hg+wgwU$N+gmw?@8P3SvCUj3`)q%#KT?uiRAVj93f{i>fG&i8A z$W%EWO5B6gMYi@(4t06lZecm?np2N2J zF(x%xC##1#N z%ZqxLHbXE6ndf-|J_t{{O`v-vlA6|JLu)L_X=)#-=6^Cf zb1}S%C5M;{r)3w0h5Yv-QJQs=vv6T{E2$;Z)(@d6o3{plbr*kCDpLg+`U`st2G53Q z>2MMXvAs|VE=#v!3SEdcXn{ItKI1yxK?R8BPV_j-njkGBK`7)xOBXM`&=zeM8@aa0 zYY0tahK+)8DmD&Ih5L$hS}*f#Pr ziQQ52q**~E64B?Oz1yDIva@@AB#C8ztVR-F4VB{NEu!Jwxp}=KWZyg`o~>vQKC+MzkhepU~i6iqR>;qbvo+?9buK6G+45i1z~Rn_1VhEojZ&f+*XvhN>} zfiq=w5AV1B%A^hOP~DUD59KQB?bXhe{SCb-`)SR@%!U((>zyZauQMBU6^HqaCi{~; ziDPEG<>mBc9+bXIGDk4*p*MfxcM}`0&@Lvl8J0!^^Os2Rz+Z(gi0t=Ga zsU((etHtbJ!&#|FG@7+(w+Qpn$wjtRWOxuemZkGj)nH$VkWs|$D;7`|xr&tOy+95x z@nsL`O_;e#rQvtd@k;?WvzL*X6%m{&Seu~8s#cD)uL}4jf)t4F55T(u@D_qU<0NL! zUWvjLv#X|?Woc}EiG*qi$m58AtUVC zqM37&BsvYCn`*p5Xl6?Cc7yzs67&FCe_*D5E8s|WrF@PeOn5%3eZIK-YE&;g>9kw)}Evs?oG~vniVijUtuc=8m20R;k z1i#SW)A1`5@0@lTV{R4S>FR6y+8DIv73$jyZ|jl4KASVbX9oK!t0`_@-L-jrq$9Gv z6F?UQYtg%2hdmMrkTtRu2FD$Z2WD;9V0zsZ$^hAc6|Angx2BqNWq)Q@O;4txv0|My zY?h^i)s0R$@LfHbq3UkegdjKTc65k0+Ro6Ng7|7i`34?k8UAOv7RwcLwTGc6Pw(#7 zw03<*1p4E=I^S|ENEYv}FE;}(swIP0|&N&osZ z__>h!RI+~DjxoqGVX4-w$k>fjwm>}^i9~JySH=$5$%B1v_NeXvh&|S!>{tS6TciQS1a`elR^`4kuiQPrbQK_DV9f zQ5ld~U}4>{_|Z`hRO_gvC=01}|XJJRNeg-it zuYO?dpc_!{AleDAyg2rBsL+B0fw{U0YFm=M+$+M2_0L+P0=}M|C7-_|<`n_|A^;yy z@J6&ucv%`6woeGc?%l2*<&wQ!@GcQSN>pyk>9wm`Kj-L&e8S!(idrY@^D@Av9-_){+v1m+3$MmWLttQ?p_cr9_5phjP;!?5m=&dUn|-8=R+e zzoHlE>&u6Q8cy*J@bp-G0Ur_i~7s%+!r? zMe8|KhcQl^iP^bMC_C5H<*IU{n|*&$(+`y}TuX5sCOQEmLqx5} z8P?G(r~DV;;X?l+s23QK_1F3tW<=IkvKNZq7uEHEy6)D`9g5tQUEGRjrsz%=)%DF6 z%c5%{B=H7l*Rc2z`K5@H)Wx!vno2NP+a|jlEo~r}4Q#2@0gxiV19d#~6-BynEt89V zHCW$*h(Id_`zA-`vRWfsw|36EMkNtL%m&zF#%RBpOX*`lr;{^ zWbjwxWM{3lPfO5~d0!_AyMMg(IwlHslb3s^NE?0+RSf-VuyH6NoAoVL*De9SDhi?$ zOkKqBS;cSSr#GXYb^75Tuy@rf$wm4(LqDSaooM=NZMso<-Z)bM1Q}=zTH=&dh9#u( z^uvr~kGO9Qus11|Q;v0%vZ3`3XCCY5<@DRl3CKEn7F{>1yn1w|hJzkSa}kVcXxs}e zAokf?qV7;*)LudEG=i0!V=L#0f=MgH_AN{NhZNnamMM$%XZ9Ek3^qGr6!&#SO7W*{QH4V(S;quDvO7&d~vAmq)usRtzNeThHjcvPL5FH=ksa zY2i5dm3!-Q$B%;-`kkZjI(CKr%5m@_sKv*@i=Z|-U5!U3($VQEeyAokR(e}&Wnb>y6av2(fE@AGD=Ou@vPL};`qAO_3I~++ z3fHWhZ>={a+UH3mvyp1JbSxhbtj)3fAPFe7-AnAvLVL^z-@R4oHuCe%3UxK}^L|ua zD$>0*S6!#^^S0K^QO(jjTm=4Vuy0Caeb@F5Ob{L0I(1v-@A7L9hWiafIk7IA%=V&W zBzmf2?BbADV8kDbC&U4@rcPiQ=nRG`T{Hxt=i^M~OtIk*F&7tv`}e%@pJOCV!vh z?{j`}Z_bA${$}~L-tm2R=Y8`4$#yH51~J4Eirv`WU*Nk3z82{w`gHI6bgVt=eb!hD zj0!;jI0W&9UBtcLiaMy=DkKQm22(jw~n(oan@PryAUF_n;nIgfMPH*Y5*<0z-}Ib$6(wmlyaBv+rbdQf5ClaC978o$9X{MD+{fq{TUK96aa1aqz33V0>n# zi?K(q?oZtUr553PjP`9+80z$)h20Aa=S1!QD&HP67F6;WC&@o0YK)XlCkv!iIx4CE z;eueCxc)1tYgZT*$^Q^FUg}R}p3XdzX)hhlw3iL1Tq+xSbLYc0pl*bYzB+f%E32#Q z?~+}N{@n3i8K~2D!A4-tGdFvsnTo5P7DIsN8a}KV|FpSAHodZka*Mn&yS=n^MkRL8 zZ}& z)5}#4ej2r-#YSeChkw%E4UGjiId@q231J*O~vtb##%1m<4nF+z|RwuMWDMk06!JbZVN!20A>sAd8B0w zR7lta=LOi)2{PWPdC+-30N)9~e-zM>oH@IQmB^eM1CW9#lW?{N*v$kb31?LRQf#$} zJwL#n8i1t&YHG^TB{lm45)h(AUhR+9|=Ge2uQ#^S@sZnvJh}ZpqpB{IQWCenz1VCq*ypb zzs=aTONgH^+#vyffbLTa15;ROahskB1Ls8X`Ua`E$T&do6~R)%w+P;(STXS(M+x9d z9#_KK7%A7n9#hx%uTzEVoOGF{A*KeCA=NguK-?2E6Ok__tcD&B=Td4KPY^15*9G`> zRfiy&W%qstmUV|a2>Nhs946c1x-Iay86FU`#fU*n>0CL1F(EJR2&OV1)^xrt*a-nv zd(iX1I={_h9SRBd3xa(u!2V1?`@4d@I>2@iD;stW#}`*nj*ffLhC62UBOq5m_BRDw z7{tH@k^QV-D*`Mv+xBz7+DG$PTeI`NV1E=~zen&L!Twc%eOf?!xBPr9z$)*MRh&&- zIP+`YOEgs58^gHe@qylS{hs=QQW z*xKv3y?eXCLJEd6}xH@U*1X8s#q5qPIPTZ&`(z(s4&-IM#|;asfCsG=mmE%xv-eO zR<%KWA@+r0!WH*m@z}Hwt}qWV$|O*v_GKqaOxCNap?a-^u~$0h@%y^!8GdU+nmXB- zZJJxo0o}vmN79qbZ|6>XvM{D=DqR*XqscgfKIxX7VmTrlyFul%x zOsyHMhgC1kz6ag#Z3WJQiLR0U%)waVU!XpY3Ea~)^s%Y~ORgB2uHtG!_6T(EZw-oU z4V_qMU(cLtr;f(ly|LVU)q9QrJUMo6ERcThC`eVJWMmp|!YHUGnzgr4KiiK%Nqx+| z8uz1vB|T0w2Fhw_lY7`QqPDd92p$r!hu|A)ve$9M+f%Dhfm22u7-Q$K4yiKvP>F=P zONeBF?XUGI!`uQa)Ear*X1K#V3$-d+kzhhcFOrY_KE+UHC3~OK=G*{nUvl%uJG#5p zM{r^nr-65L;uHq*n3f3t^MzyBI~jL z-E@Lsw9nAlF@Mhi?GrJZ3j;AHH-ilsv)lTUy)mah2IG|61*R$Yu@Q4;VuyhTDgGS& z1ay0hcYo}*f@Wr4(19r$v7xgP#*|?MCq8DWmBPrq2?u5lyUD@#==iPZNgP7FD-V>n z7_0E8jA?Uv0``NhZ1Yc$9=}4)M6rJVJ#@@6#uzN*I|!Qt3{RT#FQtZI`{l{uGeHbM zGR0}gbaOX+05rC7TCg8m%V2Lz5TY+@QUYc{rp7^gNbnA4cxM%bC})*U6DKHdc!%?X z(@nw6S>;?gPTOB%bd79#XVD^w)H#7XK`rE1H>`f6!2hG_VxC?of|WF+48thiQx5#T zjgvu+o_=zn+G0Yh{GJCJPi0vvOQRp=*+-i5aLU<_gYgYl!;|k9VdS zWtBPnrgf%)!u72%_hgcw(y?&80c9x4&SW8LA0^_i_uJ@av9}6vruunuBO!68uyN@-yLSj2rZv`7rc(5e@+4n8Z!z!Mr`^>HfgB1HC= zsvn!n`b8)K8YuVt(V}zQi=sps{dZME^QxN5R}3AWaH2DzpLVMG>(tD&%c`Q)H8K(_nk&{7 ziLH?9X4i5w;&7dmReQhViXEArUCN6iMUAOtO|rREgkyb6Idp2d_{$!F%>#XD>NCEDl%Rb z%Yv$X5O!r11yf%^mm01*T!(XWb#@#1<**#c7_nT6U(TH@vKt;}1}w?zkkO5dei=4; zMXCd4jlJAU)^&i9*wPmtC7#n_mf#`5?pExLiXroJKC8^{(B+Ceg`Z!LfqqV4M+{di z&EKT0=%@DbrNlpcp?>@Z31RZOIBFk6)o1}#7Z$_pl4z5?l0C_Rq}1sshp9T9?VON{ z1jh>X1r;#5(2kBUS5CCZ$Eh^pVwhi^$)p%b&s$|sAJ!@Ny)=@i>DxJ8P+87BG&@`JksglPhr z0!dzu5eLJ=z60oqw7DWuCK}m`lEBuRK5$f~D6=brt(uxD?Dw>^^$Ic9OU_=zavUs6 zmo>nyNDmHUm&nhAOlhT~jvZ0OV2cd{F6YPxfpfBKnfg)4NoZ_!={}QOHDQh?7sKAt zfF&|{=M4^&n5ow~#LC(=%4xmgJCD#8V@D_K zZy}%D4)hN|qpqB93ljMw-jjg-GXliOuQvV|xKKlQg%Z$owO8wl7zR;2{D@ zxWQXq^HBsBT_PkCHWmEDjpLU!d4ygrf?YI!PmBpe`q8Tae3urgA0m-L{`RjUD2-!s z)v{!&2Au~ja|N<6g>KVSFf7j>`TiI@Z0fwo7qBC6@O`bg}}S>?62E2_(9%$Y!NWW63nFsCmFj5|aLWbg=JK++DD}GqP^y zwr!o8N8f_6zGFwnT6ju5EI}kVcZ*D#rNbj&;FrZ7>B5|uIT$^Zd?4xWOWFsM&Y_!= z;C?-KBw}ljf;rQid&RIVnF-18&5Gp_XB-~Ri)acLZ;s9$U8ghGM;z6{J)*+&n`Tb2 zexXLN){mL6S&;NbU0BzBvv4oGwY2haW~a5ZVqNKQcMmh9TjSBk3?<_r8<*3q3Efz^ z%3f`!>?mx7WJ|I#WnZQIO3yfbI_1EZ96RMWuzQ_JS~&}I2M{S+jsJH6u24(6Ifr*c za9DXr7`qB%$?|n&!;BQrwBe-Ys*9qP%v@!omZjL}bxVN7ic^-y94_tzAkfF5oTi&q z_KRZoSYfop?<^#FxtC1;9&tGRpVE)?vkAg8sC1`^+~1N~6xr6Z0@{=t{*vI_?F`n| ztsj-^_kNVFXD*PB_2%i>>rTpEXGBzGt0Ji)p_7kQ0*zwNq9-#ux+27N>p2M1Mu~@# zWeIz=dtb_C(_!w+RNRs>@RLc{H5S(P_bthdTMlEzV?>BhljlJtR^rP~%=gQ^4yPCU zs~kGcn~u>6pFwY5*v9n1`wy(!Gpc-I-#TPERkVxwQ89)fOttGogzU{Nv{z})E8*N- z?>JDn@233{(;_1K{61^(ex;+{U!e1F4fqQ9akR680SH&CSFf<%Dm&eLe#|d#WN& z;O9+>?9MY};q_^+HSG(BhX(hRbVg&2jwKv3k5<8<<%gyEP@-z8Z6_Zso?zu>Che)V zgKpuNb1>7vfpTvorrK^j32+(>XI)cOm5-+ih~zZdE2tSBX0}&4E>8T-IOFuwF*V`Z zrKaYVg_yZyZ%1-!AMbD?a8Geqk?yHHEM5flJXkpoHixmNxlGPAL%5Jp*WALbRo`sR zIfP0dqpgydU9MJKb|F`p8xEMaikI^Pl~?~^8naMJS&7oRn2D*HO(kavNeZ&rl_l-# zQq~cOPz86CiJJD0T|wqhH)X#?Ny>gJOySOX_H1TsFEi>qqwW4S8`F6vbiU3sT&c@s z!)(u;KRB>>@J^j=-Z{|+ZExa4gSGbn!~}yPTWnc+M2{y3b`(}kgZfY|ry*2SfKlTtbz>z=D7g;ZUEjKq_mqLG8(4wxbG@y zZj4upU6PN$iCb8P=P@kf`}t_BH+;G&q!YWiQMB#?5NOrdbMw#G~{$5Fp@pkwEL)Hpu}+9cZX^*gZPecDpnQGdqHHw{ZIwo`HN^4 z79b}zV|9QFd2nGytshT`;0h5FlCZami!HuSG7(IEOem3n-pnF;V z)C9Zx1u{3?6U`a)HBSdmqp!d)Q;+cw+!m&YxC-8+3NB2(PCCT!^90W@g4&Xg10kv z-zZ+f_;jL8Fmw+@GcjZpLhD*f2dMPqhM^6n$11@eVyNL7`UJ1kbrcS-b%N24TX zCyz!UgSV+7oO#pf3>t+p-96C^k6OaJJy^nznJAz&RDr~WKmtcgESWN`Un;ZHRdl=| zpeLXshS0b?0KXQo+;6ZB308#_f}B?rOC171>tFIQ;Jgh&xIGl<+@7n&WtVj*a=Ct( zp7n-U%Ghm!vUm=tCICf%bg||TirIp84hTr|Xy;)G@t$Dqcf0zjlhmk7Ub9cDqV?U*mR<`)M;OusYvoHDEt1KiFe8>sB^IA?Q_;_TgyN(9AkV zuDvSU-GcJ2w@w>B!8VswQtt1tv&Fnkg&OPFCf5VD`QZ+6G?|8`0@tWYAc$w7C`0#h zZnk%EZnoYiBXXK_m%W4a^dh83;wKxY84`*`a&|@EpCAD60s72OLZ(&_fwru0b z-OVu_T(RZ+qJ1)DXrJbo(WFTO{7RJ7Ojwm@?x3ny-FtB6U+`IMCKQ~B4%9Mk2xS3< zITfwajhvCe61|}fLlos+Aq3J)T>aQ(Y#)2-nG9FPX0l!Zg^mhy;@Ei(T`cLJ*zC{u zFBW*A6u9bhP`U3-I=!agm3^a}rXIfE&lRJj_M1=)Y64y&&2VT zs{qXfCVP#XIHB~+OtK8$LK(&k5y89r`J3bK*W_0!oK|Q*I7>e)&u|-**1H###aGcu~7FzmlkBvvs0s1e%j8esUlQH~*5z?J+)A<8mX8$^!Kk|K_r!!D<()pt4ifveBa;DpW(X={qe}zRO2_nNyMo%-<;Q0NTtCLWVT^laY^Zh&YUvpF zg=5@jj&YxW{7pB>O)AWv{hng&e;tK=Q*&(}G1#G~AEEL18{ch$|HT;hV^X#DgT{Ao zROGjrICgzln$wyi{Tpu0>|p@hxCDKrzqF7&#WL>I?sAXx5exeP|J!8uv5Ut(lG74X3zhEEgxreJrG;3WaCBldX#w-L+8x&+k7 z))LFexF%BjXx54nR0p)G`FlyiQX{T8n@j>Z*Pxd!x)PcF2UHfGDlkW=1@jxUi`?HX zZEF95$%-=GW-Yi%7y(0dWGe)71u;xq zu7Glqq`OS8j^xfhCje<5>c#~-gTV+=hIg4in^*z$VhUodcZq#Tut%krnLEnGeS}_e zqlESS0HhS6rq=A>3O+^x>Fd`00@~7V^@bMr9|ipL0J}%QkE28-Sn}~EiVcFZ-d`sl z_n%ghVz;U=cWZN9sjKLBPNSbE7uMtEpcd?MmnmkJ1pOYiP{nDzMI;3R`l6_ecHE>Dhy|6#s90mOi>W#a|Y)wk=WeD@`D{{XKdVCM#rtW(YR&IxKaNo zq2^ZesX1ic&hZ5p9iGxb+~bc;$N8C$3-ayU?c+=xAgqHeNv^L()sZO|^Ii}hhZbGI z8Cs>{@UApIw&wb~3@Jn0{;4149fo{c!;8gT1)oecr7yh>deu5?oe~R4LqZ7Fo z?O{@N7yAG&ZMj{O=WJkq;zO%2BiGC$i`E~lLW@T%Rs@L^)PeaAL!~yMF3|K)WiR=fZ(3Y8ayNx zCs?zYjoii}@Y~yl1CabISSwNO}np`(0e|v2RHye+ zCF{i1lRP|Kb`tMK%=QSb|J7tN74!uTL}rf>_lBn&vNG%*O5=va5QCaCr}kW`LZJ6( z8nr(D^|2cOY|P*D7s8)zy}e0uzP*C9@BcVIz3WJFbVc^Om`qf7>j@^N)PXubzd)ph z>YAFSvq-y3j&iuCpMI`iz5k5eR~cjnj;-FQHcObVV`plai<`!#mWAs+Utc`g&aJJ( zZflWN!??AbzCX>{PLHnbG-|3R&2Un&_><4Hr|a)bHOzTxcSELP^^>A{yr<%j)^##p z*RT?-sL0o~-0N*OIbrPQmYV%soXC;wCKmR1-ZebU_~<3p3w?z;_IYI=c*-bW6O6Me znvTOGv`{aG2%SBuz5clvEpV((#$1bn_NtV~9Br@9G2;6vLRv?!$(~06F|@dzG(V5a zCv@J$^08h~+3+?F(a;jpP}a|(Gq@0U*$ka*%nSSvj=5yk6%FeSa9PyXj*wANGXhIe zEzogB1xgvl`nltbEdZ37u@+o+znNplY>b%!`a4x-SbsgW z%!&>j59^?Za>pmtl3`d>ukY%%85c*ID>l7?>PH46Y&5C29$pDHN*onS{ka6Jj>N=A z&I-T|w`=5cb!Iz?1jD(LqjDMTiMWgw9>k^8M@Hl71=Y6%bpaLK>KAJ%%e!}{GMIQd6wfJ7gLGX zTsvZ>f9Ky#tKmF}b3trqapQsMS7=+|0#b8GPt~}-OSOl_Mbji|LPJ%0nP?~`*>Qdk z4eyu<3bjH*2_D2?o?!;RNC11=nRLG%QP+v;qPS*no1iX~>pp=ToLdn&$$Ej!W^T%& zsV-Y^r0wy7uBA=uj}5aYOXMnO5^k;6AVU>IwLO&EmL%lA5%PBZ8l+^w0A7zJf}%0m zMI1LS)nt6N7>Mmj4d4#7p3LE7!ry1e6cFZ~Wv=|2hndQQy}94*|6m9DnHEg0HzW(` zVUhKkU|!!H5_3N(w47AINkg1<;Q={8eUZen_R}NJ&LIIQFohcbOg*>AC)9YQeC)?s z)zzRMvYAk$cB5aM3?>+oLuqmi`_vWjCU3<;*c0L{n}w3B7`cS;;*{4=EU7#qQCM$Y zub->=IZF2Bw2@ml&#)CkOT~W8UgZdRZm@68{Q2{7*DM|#+S;+B3+LSmA1jN9?O{ZW z4=Y57!~|8vM{)8dYZOmTWqlUdxhMk(u#`p4`*5pad#YsDe#@!ME~BjByyu=ksr5Ks zYNB?Dp}POYoekibS+4VO>Frh;2kD;Dvb{| zX|Q5Q6HQ5ZqAkp#yo+Fy@mfLN+DB4?+s`P87G%5S8(Ig85}kYH#Xv#*SFCV_-i6dC zOGUV%_1l~MOVM75}#3vpq|E}X!?M#C+n zmK}#@(%_2krg4Rcj;6v3P1Nl0P-}!&j!eU~BQx+?t$~|7?UazvJ3v{=5GaUrU{m856 z&sBOeq*BUotBp5p4r<_5Z(63JowwRJ&*X0NN>>hjG&!Uf@ZkewhU_Izl~l z{HVG)T2WV#Nb2O2lq#O_Q0@e82A^_}ozuZ`g<3I4-W0zO~dX!vQX`#n6rH zuve9hClrdgu`d+LHLy73e^=j0t4Hxmx!E$$J%xsIT&N$Q{m&A&vtPiY0r)dS66QUT z;&BUeBswa4RRB`kWp5Ykg6tXciHN7F945=qle~%jI~bvOe319n$9F;lf_)>vz9^t# zUl7p!x)3~>JxM+)r$72BrBUhY>z=x*va?SX$ety~o@~l2_PYXd{c67@AZ24>t=}>B zII#Km2mVGg*1R$8lML2I1pyqP4Cy)ta9A ziRlR!=e`p|69dS9&`~D(%zo>LH`?Rx z>GAY_>u-FI_CIW*zJo_mF?%?siUX7Ma)TM z`(n7h>Mhc_U2uy9wwyQL54XTUP3(XF zx8nu>pWwz+x0#&(6T?QNrrsV)0I!Hp?8>NnHA2!H3`Z!!Lspy#>m7wq*ekh2x-OT0)W-lp-Ez|%Wt z&^yOlJO{M5dW$jPo`aAc+bH+9-lCPFS7?{+`1E)g)VjE4TrXBxYFsbY?78E5u?@<{ z^BS6Nx?tS~y{{xU&s4JCH|tCnyTd2+yPRPv$3@ZZ8Q~i9U6jdNg0@fE?Q?}?UnD$a ziE>;m)tR2}WJzY`os0H*i*E5<;LPtyACqd9>PF=)_B)pKnhx{@cX|u(B9ONzS=oNU zo!$let*?wX6#vw?F}*^2=S9fl#rV5)*t^JW7k=HFtF+rMMVGk8yL7L2DVqCYNM;u~ z?H3K_e(GI}gE#&Vo@@IRx>yRl{{wJa2UQAo?Nttagp2t0xf@2>=kN9A|G76e?B4Co zQkR0A8+T6;I*6vH%GZ9^Jx#;uiJ8z1?iqAntEXu~ zpLEZpTgBJ@NXb|uGiaf7t*$TL`^#Yo1e1y@@F|%?$7=#|W1FhF5;w zj@XJ<*RF(iMhriSlS1X3FQ8mXR6Zt~MjHU{BFfvmPO#`T38di90+88I><@|ECBeQC zfL{(kT9WWyz#{I|5e&a91ffUq6aL!(e45~yf;|vm9}$pu^o4H?z)b_pwnQfQZ;4BFhA4vDV&veyh3dr7#8Iv8yJQDV zv^he@Wdw8NexFhI3O2~68|2f~d`jlrujR9$7SOCgmunvdRk52~HgfUt1^*`dD z2;w?dKsJFZ3kW=eJE{PAb&>?rarp&+4woow4Tn8KL1tIMFG{=$%1QaL!y!;p{5?LHqqYt^G$@r#5Yra)?v!$Yg!kUzN}b z-h(3G^vtNLDRfbNC&51zgrQR1eNM2Qd93vrW=V{N^x_O>KZme=3N>fW2_K<9xl0kp z1aA&3`WDf0+hWl{0Ts*PVaf8b=+OYHOHoOph}#27dplzgn~0)M2DH}_E14|1h@dP> zi{=aHis4p~+Uv-wvxsb(Ytit%`53}FQY40OPk_CFkx6P{7M^(suOU`)7UsZFY@ETQ z6ydXj7?=lJN*wx&JT|nSF??IF4+q%$iG5zMcLdl^6DzhJA!U8xjm{Nqg(5hwH z6H{#qWq>4kUt#p_+1tRUx?f>m?2ALnVEe;`(h=L9)(SXa!0ny6_E_mWof>#&hnAZKY1 zSrtKP1HFJwgDqk(X)lKg48>LuD{ZSYwqmIl*LypEn~zto9cL@r&4LZ};KyeDhOQIv z0%ETfkYhOXNdadP`zZk@5WF6sZjdtTYS0n7L9m=eRB^%q!|KyB=Ss^_qGn{|O3Z`a z@#e-?WS5@D6nYoxM_wT-IRz>bKHO7Mj;F5|j`=r5w&{xB!W}6WM=qCt;{2geu-c+o zDc*^PJ};GjktCncE1X7M++g2)i6kEg zH*ZGr40pT`Umon6H9FbRvC2qrI|lm}ng>nscDR{NB6CTJviJ{%cXUTOwp}w1#gjnu z@Txek62;}8>rG)0f@--JaWSZ*ibuxz;<(XJePOUKQlNil?Fd;%WLqa9XPqHx8#kGj zBB*Mvc3j)Fu2ZmUuw%4y^R~`)TdvvMb-h$G?)J*pwW(NaByHJjR9%k`?h8vmXtMZ7 zGnYAB53~)Pl?0l5$GeiYJ5&*EomPoE?vK~|nn={2+09$V@7JT&z7j?#`!lyhTW9k5 zGc2Oc#RJfVIsskTt{4aR-$sqMsClv;tFZg9yB&q`%1tTUKHlGTSUy9irxKMzH$+=2 zDz7}SBidSCdDVeUT8NbDgmYI_nTysN-1f4)URiJMGN}7wa?Sr4QM?$=^oCBvz2RI5 z3(0LMAK#N1^h)=7r9EBG?3M@Do=$&xRP5MZ-~T~p9V@Avm2|KAGgf&gP46oXeagrk zTlBrO(Dg1SBFOVoIAX8k@8c7~$I9=#=g}A9&2E-ZLwuhqZO$1&XZQ__MWiRYUO=6= z$r=>YM1?@jOeu|6f!JmRVw58Mno zrj^o+w5+QO{h42fr-@Zj0c$*_&THCG@{<9-ut^vM!+ZGvC+q>3xa`fhh<@#en z6^7WdbI0f)%CqdE!M@82(~976R19w2krPJ&M_AzJ0ap}vVWjUM=Zg*Yoz=B@N9VT9 zK9k6^q{y{hJ2Kcd#@Y19)@@t1c5d5oof-X4=;(L;Odj*QCDuAq`}B;MSZX~{a3|$( zthL-8xv#a{0bOf_D)8>itScY>a|znpT5%Unt-%R8#xd$-XKO`k`QFy@-6Wy6T(NgD zjv|>9S3WW7!hf7me5JJ#42kc-?AmYr#BSqKyK?0~-G1vHWk74t+<1^m$Kjt6#T<_L z!RrB0mnencZ zy8#dG|KQZt3h<{9mhBKY@ZrqU$w%Uc++G9vJ||{E1QE?CH8n_P_vXiBbD&|^wW43506;)HXLlwckvpi zIXMjTq5U7sTQ^&~%>%6!EU^Cum+-ntGVs9bl+A20yzP3ol=vIm<`on`OHW9C=D$aDdA#111a{$jF4uZu-O!w(>xRd?QDgtSHN+N3`V}Y9U^F+8|MWp z$>X1?2~LS05Cxgw!}4&qy&NnWOg$)^A8&v`aq}!%^7ja=y%A41e#Np_iW!{EUwP8X zO}EGsWMQ$(6tk8hIrbTsD+F+xVBdVCWDGFI%pZA)(wD$-iPNd;_)0ef+qGLTS8%?g z$g1My=8jFBCk*y2*tByy1kvv8*f7;;kCy-i6AfY%QI>(s41)`_<(QQ-(YLR}okVMp zMQdm}KdM?Kczd^69*`B`x*}tX_P@y4pG>ySuKZKRKTcfZ@!6-Qo>E+=C9gLI9W%u$ zWZI?=j76NW_jog9yicI_#?ih<{lH7$I~BW!Gg>PvhswPfsmgnjFsqoMf@}l$v^PVO zgWU)pw|OBgf;{dKy{R?QH8R+Gs+b$|;q)d+lAEYyzB$K7h5c88{V(#SsRc!QdABpt zKJ&mVuYA)7BkdIjW+c67Ea{*(O}E#4la<5M>(umY`gED{-ur_*0E`|H+O7)i&<<5- zhqkIhJM=N-%%RO{MeICmCV?$F3ApvJy+C*%UM1qCJm1ZOmTK@QN&hau{tH10)#S*^{>g?FRNhMhWw-<>8Z!wa z8Z+KKLA<>h?`Hk1(oaG^XUWH%!Ko?q%1p`ZAF|!}Sgb_lp>L8_lvdVD0xFi;ajNN# zc{rSh{;UH5?N=GYvl8~f0DCX7&t0dO9dv!0Gpcp8gRbYB)h|ug3r44O30>b^lI@-& zkn^3{+3xAt?#bD1V+5)S&$h+a`CH)80*lf4)ciOsO@%5UgPxJ7@A$vPhHSRsCL zy0ny}vsG8)MEtlPRP$SB11v~j<?IB7PVvgR zMjjZAysdyB38`^F-v3I9wZpWbS>81FK5rW0g3AH!b_!}TjC-+zRi=aASSjbe$A!4! zgd{;GgGkB{iLfCvc5lbSVPe@;CXtxH-ZTw2DiYnk!=aOG+Xd9fbhkt@Y4oHI z3HU05y((akn)Ubj$jrOilA3jQfW1vXo7kI(eVvlB^;%467U+jll5>G0q5o0eW8ce= z`zie_gFa{6cIlgPvI)L{f~LvMzkR;)Dlq0 zPMM2k{91YZB+|KU+m>zfB9|(5%l7Rw5jWT~aZk+@d3vaGo^RQ9WN_aENnuUvv^z!V zg$EzcYn{QK*jg4Hxr@*p{52Xq92=@=Ei=3OnRU~!bp3B@=>Bs7IXcGt9PD-viLP$2 zwbIzRCJuuYSc7%;s@75xuih|%!v(jeAdp~{ep9MDG;-yEk6{>(+}RyEl)EOiab)Ps zdI)^?w9cq+EmPU3zT0UnRWJ$4p;*_U++{fFrZG4pSz^xu_RLhaJ7jp@N%b52Q1$i1 z`A(d^+W$e9ytPp*%^%wAa$*l{H`=@%s?CE?GkV4Qu`w&&ZDz&0g|QsL(VJsNbnsxw zG-**C-IOirHIQJd1+<9euCV=8!BV-VSckMf7plJ_?I8i55>Q2jCj#)X0OWX7g8Kq2 z$Bl|0yNTUp^m+XS=m&a`Yf$V!C^9gMq5L5xxQ z=lx6ZVhC1Kqi&xxtD7%kieDUK4-g3=HmZXgvo|@bs+zQ@jv_t868fTpF+WyfrOH;0 zII^I)<%|3!^r&t+?b6ozlA4%UN7;_Jf$WUIzEd`JU6a{C73Jnm=>4%u#Tu<6vVCjk zx{r5k!%Ed;8OPz=a~t~`{fjp6P)8R|Fh#GZScltmIP#nLD+dN+evb8eiO^PabZMs^ zj0>%zq6L%IeU@vmR0if@bXGrcvu$2 zE!Q|3H%j)4wm=_W)`c+~lI&uk5#~2;EWh+ig4kLX9l9dw4$X)<{tIV%9b@jT*v6OE zIvd{ooRMJ6xwG6Uu?Zw$R&_T?`FBDZoj z9IwbpqG@U7L1DBSd0*&Zw9buM>*m>KT+=BJbPaVBR5w=vI69*5stqf}L%G=>PLlg+ zbV%oBZ7|cYL4Y#Fm{xokt$55VA!Rnjo2V@Hbt6DgcnUpC)@;4Th7LXaQPRGqi-X3y0dTtV=FEX zmg^QK@+=uH`EQK1B*cWL#DH?F$%hv!?4^aM053OI7S&)ajq^qVc{qitN15U&uT^e? z=L6z+4~VhT91V}==;@%)ron+y1jDg4`l>2fUk(p_N(vw5$~{bG9A@Ph3*!TSpF_Z9;)@udvrzjaS~`DfvgO zOFW^?;^|*eDda68zZc_@l_tE0DxR_BUa|({0yoET#ciyGZzdo#3=*!)cH>AGqq??N zJ8*d3;64#ft)IwEmMezW0Q`^jbGFgXaWHS#(3N;^hBchQFQyS)x&RIhPd%-uYUp_O zS+k%qPY@=a4~b%`^dX!XD88FAFJS#R{XW&6 zP;mR^MkbS3I6OU5JOz8T{=)!XDNgXP7u)5kZ3>^S+NSUYdZH(Mp{)lRy!WWq{ z?3=A3Hs8e-CxP%~csfQp#7D8+D&Nb&IOTf@hMs&cI2@EWhBnBB+~#HC)VmhIofYf*4DT{r|i&X zDV2SWD`&C~uH5XlW957&|0 zoUkvKgTxb7;}y-svUL3t&N$%)y?nyGP^~svE1!%Vn5)&&dg{g(*PW_O6wDOEt(A`A zT2DRHTA6LFw9PTTs=MH|u5wtXlEY?>iMGzx>3RbW7&#rSm0f&xeyUv@-Sk27rPkTH zW@?>-HCX>BsaI$0|78^OHr~&E>yA-Lt8Dncj2bT^#2HPPfBrKg$3CG|uh{EV^ybdS zDNr_voVS?CL!g6l2y_lqWVd?d*jCk3kJQ(H$D4L#`^?W5&$Ra2RrN!$*3$>0t*0}Q zp3GJ4GY7nxxrGf9NjWb4Jq>y^gjSt@-HY8tFSgEo7bi0jtpl3e%bB5Ntr2Z%#<4C^ zsLo2`;Zk;{OoeG^yH63uc}(w;d|8jzd8OD39*$yH#ou{AfoDFHn}wsUDV*q(!LL4< zr_2G*SEuJbmRKVrVX|_dSV%%X{a5W={yR0&=CVm-8_>-4IuBTR^ap!B$GJbpe)&!Z5Lo z#4@#N0hwWk6BskBR+5gC)Bb?8j|=z>0mEkrc#nX(%W+o#el`Ga55PSE*h^40F>K}R z1Xl%EvTrILY)*d)o*EEL4kBaIYaTdts}|$EJb~W3r`X@*W3YZ6fZq+k!vXk(0K8Md z>*Zq|S{kfBA@P1Lz-nLOHhy1#y+uHKPZ+;0 zZguCA?9MMmiz?Q#&W%2*o~V=ITx5jcvy3g&#;8g;D+Ut#on^~$$Mps?*_DFls;;po z^FVYBvSX=`vfo)4>(AV_?Cz*OeudO?*}_>=31l*dnKoq2S4rCb?$n( z)96*UNN%%!u8A(ku6VP~i$iteNDcCO#lms$BGDc{4qioCJsRF)TA68Kw>{7>Vcs!| z3)L`Tp3(W~a@8K2^}<=9aqON{VHiB%Jy&`;Iiqs@r5qZs2v(;af+qx6@<2zf)@Kk=O!?RatpX4|r_!j}VKLEc>kc^s>kg{ZD>cnmj2-XB(LjYb#kVz~K zKyo3?j&dOqoE8ww4q}*;2Mtq~g!N7XX2+Pa5<48wDwC19%YWT~{<9wEir+eNvXV^Cp2QW2b?6KbIcvz7oo4-flr+Mior?+b;K7*zmJ^rtwh&M- zAtP0@3EIBe|Dv4!SNeH0AJW#Wli~LVSmlpo_`2TV31#>{4X`>-NFJ>31X%5eHw*SJ z11#qWd(Wq`SFXxlIX8QyQOboEC_A@qr@kQSlso#;oIrWhvB05jm6|h$r_Lx&e4z{S zZ2iH^lL^&b9Ii84x@wQJA+0lm*?~Rk`<8RVH%Xr4+rhk*&WoLw7>k$9Mh9`3(Lr2p zbP%dTSb*TisPl^OAa7G#1u;D0a07&d@z<+Mu3{CLh3yj@K<jA=THe>DvM2uuzodeR8@ez6&J~og<{%SA2qsMSsdE2Xbif}jm=sWE&p#u`eQQ^ zuJ}76X(l7y@i&sd)ghSZMfEWl^=nZ~VmWp&HK@Lca#(mHG#bY!>dlhFMYFQaU+$GF zS?r8<00Gl%>Wu=%1XT9PZl>UWlGT!LtCUAjNk0t)ks7%Cz<_3bFPs7R}zp>alkz<2<5F^N`luSu|FPNJ7e=P9jMD zG$p{65Tro*`#jeAR{@njy%}I%B}o4C!vOpDq$PiPHo!hbEQR8|0rt-czW-;6xt^bQ zbb7%pmrS!w{aW~WqgGwod^ew`F3vgj9)GN+vES09TA-%x883>f&N zeCc5Bm)J#83v69(M{Pa>#uf7I1?yxT@92qa=CCe$)6O`iP(`{TWu~xKlp^q&P86?k z!nR(UsYsijSMBNYwfEy%?Y`r1zAUl@+OMm-w_FPo2ka(Ta}}LGc?J^+Bc`v0TJ6** zag}T9gljen)*Vtd|?L{V#eLR*0pET*MM5Q7w>((o} zE8cr|=p)@7SG>5Q`-6AyR>eXtlj#1)yZ5dEg_Y=@_|o@st%>e)-g|dYG2hE2;Cv}p zg<#zkFOLd&#@LWE81ilt@+Jw0KtJI$a_|bM^_<}ZnuAps{s=R>(#EC_70o^3hSu1< z9xOcE7^|+IFH6k{)p&v?R*n1Hr!l~;&<0@3R(qQ}t1}(jVmr2Ms>1z&E9iOCIr^ap z6~4*uSF2D3a~g3&X(O{zxQD2HM6Itj;)xvHCk|7r39quo=_|puXo$%;=WEY+UB!mi z*a+6+mOUAba5);G4Gn%qG^U%k?$C+;?k9I~otW7KmDjeiZ4M-+W46?jX~e_=im~2t z**4VEec8&vebfWr)rpswHg+V8d0w|O)ebi#f772kp`qic`aA1WbDrFd>nc|rZrJ$4 zr*m)C6~ollDQ=zdROZR4kqIdmtFqplCq{E=8sM>t9?D(hP2;#5G2<@{-59-wb0?*7 zXo9_!mz8*>aO<@t>9UmbRPHPF{%(c!TfO|j`oF5Mvi?ma2kUn#Iat5f%fhUGhgr$m zY~@7Uj{O1tjp`6`n9171-tpciv+GpUd;kCM>`TDoDz0?z(tRa)L$c+qk?poIU>t8? zLjq<|OBPm3y%8+iZuPu=d8C78^!{PjJzZmp-PPF0Kt7vK6BQ~2isbm z4%xovaJBzs{gGd6pbAr<=tf0To72+fwgB~NNjitMz<-9dv36Pc2-y~iEjz``qkI5s z1~FZ@R5CV^ELU74%YlUvtoFaE>;|n@BK4%!URVYnDXC z#pnJmuNj&W$!4inup3lMx&;G<&yne?Ve#~|k!`*(p1?A=W&2hvS;A9FjWY(>($OqR zYm_L#ZVy3PsJ^QK^RI9;s+u;Nt8LebJ|wtXr9#pm7(QKCa3}Y=t=l)ZqbA06lvT7K z-Nr+j_0d`BwkhfLI>$d6m0s_q*FfP-q%v?7kG~Bt%Qmh3wszc*YN^r5)+%FOkGDn}a?rcj<_!k7EfD#}DJGS-d+lKW}DdJu*g_~9_ z!vh94BaKOJV9syIGM75#5B_q!y>{pF46uU&&YN)R_H+7FFarDsh=0KAI8O>NB*U7|mb+3&D8Ow&DkIPzSJ5B z3S5-l@g+9u-)5q=v|qTaeyQMcGK0$kT)v#Er^%~xcZs&?%4j0jCVQL_`Rl>cS%Wqr zZV>k%tvTAxnaYBzz(P~dOoD8s_OYfKT6=Wv7xb|+BfW#G9hMM^qpePZY-b8?D{R=h zrTxa1EjPB0HMMkjxOLw&wZvU*N)~r&O}}n>Bzu;w!l(62LG4RTOeo*%_7h!F*gVYu zx<#BX1t~jHY;-|LLHnP^-s801`{MSO+?w98nSIrH9Uo;^qmR7U-0Dap6*r2O6I>S8 zuXEBnrYpqFi!&u~xx5CST_|0vvtkJm8GPO#GPoUxY@OFWFT8cz_V#sy5&6rdr@fye z_eDT5C4s~T?6k;liGQEJ{mh{w=C9BXaqWYes%&K;B9BJIihBi)cm*gk8mq!^e7~0A zOzck)Op^3pxx=6`*q~#nsNqUFe*(#XGxa>LFHoJ{!QHjpN#>DVMl@k?U5+N45pPrn z;ZO`oAdx{3oJ(~TiGhIa8{4N3M#rywqq{optfLrrJIt8-QI3LP$BV}|}hM^*NGbYRlJ}kqOG9yv(k&k=x@$O9DA-Y7t8dyJHRxRQ7ltudB zsn~v^nB}K;$m7lQj&I0Er|o8Dv8Oq`LxxaMWXXyswkY!fdsPj|`kI99$o6nk`EpO! z{OXprw(#;qV`N1Q&@$^hQ9Nzi+Okm=@%gy8uAk&yBlKxE&y&(#fKiO_EveQGsc@?0 z=1t)Zsg^BY-L#S49><S`Df7=%A6RRKWs)NmA`clX1bSF2%J`Tl}dYdDFBZJ$5$9C4+cZnm7 zH#8f>VGIt8tM}K#t8QV4lz{-!&Z}X>5gIJ|k{u7o3`IXo=MS?R$ezb1TR>%|;IPU} znQIusq)8$tsLL>jB&08OqE0WSFS0de1!mcOdRd%RcJ^iTYGq7|Vj%o2_htT8Gh^1w zEIYSwg5;~8Q`(ZUHGO8mUl28)vwA*9j;sT-(0t@}_@^r?voi}@IgG}bt~`43u_r)8 zvOaxB(J&`WnV%fSZ+4RP^9f(x#fUO@nPvLeFG^_eEdl#wc&mR|dHtS@{8%!w#9Tgp zD4+fyL8iYq58jRhCAonvS!~NEY0bx5n+F>RekO4*6;LapRGhMypj4u{wx*$m?&PfJ zTTp~*8>%2_0WT%y3#46aOSM2i?b%kXT$U3MW26ubaWf| zp~p&mSi&QXb@0pS9rM}9k7lQL%p|m@LIXIQtUY?n+%*c@s#<^h_DFisWj$RZ&%bzX zMJ5oHCvKQ4-s96d=cPE09Cu2{2+ChKV^060GF^;K7kYvPq z_d>qEcOD<_a;91DiPiZjLywH{#wa)u4a;C=2GZf4u1WL4&9%v}IF@J(pIgx8ik_}3 znr_<$-y<#UIE=S%fDxH6hWchK^6fGkcvt4uO&iQz8+o1QN0<}dH1DfM$-+8foRYm< zxOA)o2K{By;3n0VA0}{8mO8;W&E=u8GB18?i#-laMcT{WMHY3&906# zRoBi1CYLuP<}RzAE%=A0EaA6|nhh66HBDDt8H+6S!-c$`F?(4t@ny_$c>a-vxFZP zP?k}9tw4`5@Q8pt2n;l0Sld#k+fUH4#+6ht2T=G4Xe%vHpVF; z=N95kQrY82vxtN45^T)Z&I`|gc26{hnLDa*#A2FCvAC{568FDTMz)WOPC^ifkw^Fin!Ss5hyoyMQp=i+8MEB=lM;Ifs2K^ zQsTByPUw-)N_&-NFWMx=V$gu>D#L0%VnFzcH>-Gq_pwgFcL($>JxxR7nRr;Uev1+-{V>4D8bN1^hptJ&j`zf zwAh)lK!R{5WLdH?M&fHvr`r0D^bTw<%Vf{Xh9%H`i|HvYE_NE zce9*nJd1eY+4wT5TE>73!iLByL*zkj@dfrsPiKJ@&@;?8mH&@;Q4XrOe&1IITizxA zjQgUB{H*V-dS8{#+VhW?hSR5NJO0O>I;ToWd0Po7L#gi)>sk{(JHF0g-c{=Z{YEUY z%Y6I7th42QLeep+2DObCR0s|(SDUQz^@Xp@-6jy6Q1R^MoWPHL624DTr^?ET3q8JE zyABAp2D0;Gyq13?GgHJB<^AykxM{x=eot6+w$RuR$ow+1)Q^0*Mov(}SZ-`U!FZA+ zwUJcM14-3p69oy?GXA-_v;V_nsgFcdvrDRZ3N>U+%k0sK6LM8wbfjax!I6zpv8r6n zSSge&`qOkEGr@Nt1H)8sAQNKMlNH2X&WViJ5YUSJLvqrCNwH)F1LkAFndl}X(=jwGJYg8DQ;hz45!cvt_bi>AvXR#NQV7}W|JB-Rf?FW zsuFC%wb=y;?FEpXnMjOQLf$dJb?W|Px!Z#`7%1!@sp!CSU%XT@KGrtsw5r;^d;4s8 z)wh~w)M*!Nn1S1HDZdT{b;t182J;Lyf_C8vV-!{BiaQN25Vg74&=`O>)Hy3z%Zlt; zpIO*cOB6HM_l&V-e>^jHm~c_a9zRSt%Dzj=*p2#_V$|tqN7W=8O=)^j zY(pkl=e@vZ? zVWKpHgI8v5!7GmOrEx#6g6_<&N&!FY4Wy5-x@(LFno<+&Xz;ZI*_q4{5g`H@SX=%* zffy9W?McQijq3pQi^`rixLQ(=T+MRCt@q!aY8!J}%j_I6JgsFi;|p4b#*`-f;*h;R z$uJ<^hY`Aye%qKtC(l6kYlEAXYjGT%P8tGABL1Wv$K(cO0=4j)k(@;I9!yS>Z8;*v z4#koc;%=)###04{&|zcx|Aa9;ay0P;`D$bS|MK-a|1>OTC+2XJ$MOHIPL;NuF$l}q zOLR*r%`->^V9SfGzvjhpLLmvo13lgAKJTwsVKX9_?Hb`7?T#OS_t=h9sIS-U@}q6` zD|)fy|A_qL`=cWzgVm8x#RYq*BXvr8BMxGV{x!u&rC6~ck=ZL!<|MyNe^thEs{>dw zNn!lx%oFlEF^&a-mDh25N~ZjW31sB_y~zj^?^Q`;pOlpa6%az=*w?U118XY|Br7r# zltl(ZRe`pDt@QG1ICy>>4eaZ+--0C|QvfCpJfoRB54RbsKg>0S-2h%3%XZoWS8t*5^I+Jtt$RGc!@gma%lk z1{}})v_98q+Gm(*sC|A0|GCptI=^unyt6!QZ@90uw5?cMQ0dfR-u}7Pa!O@q>^$y_ z#?H4m*#y2IcDSkzfl!{nyhUyqzK%%XM7ey~5?uP_Zh9fqTZRbfT-hJv?6nNXC2Z)q zOMkOdWE3M_kQd$~8X-r<(9mr*cH~XikS~$gR8pfvV?>iAbSFsYh+G~ef69aJ3m6mz zUx{!Xhm~{JRM+#ilSCpf&s!*9PcHA0dj-_c>yZmQHk^J8NG62oD9NtP$GwQ)WfDqh zF>@&XcL`-^vTnnNXd>+YHsA zAV>@TESD@uxf0_B_vJ%(=0QDmi*cCX75UI}1*A%5fI5-PA@E)&`>GzT`5pvyi~@FOM@Jh<#C zPx{;ari3zIcNa^0M?zKEk|0N}I_vl?bC6Mh+f?}F*l>0e+$o{rP-d8s8*dateljy8 z5)Z0OYX44>5^pv;L9apFkSoUCn9JLyI;Zn9Db~#;QZf#Ri1QZL|a z0o{89q|&{6uYi=oxc31p`h6~L(GS_6qF#oOY;a<^zmj&Z4Ta^2fvmFNkLdgHAka`T`Un4ds2bpmV42;d~|^*d*sq0ut5EF9=FIoWCP#oV`SbL%}66=v3#U zeuRa^L|Hgn@@Cf-YirTfz2^cqeH>%iF>`Am&GRvy-; zE`9^+db$?EDpgCE9T~m_LO<0>R7+Jb(9j}=8roWK5DQzr_;0!-#kJCs=9cYSAk@1= z#C!qppo_wnT^>#*M0r8VfCVcj7NL!)<=BhvOYL6n@Miq}%FLWfFe_7iwJx*|J2O-4 zzUADstJ&Y~x_xyWt;cqWKIyNchayd(4aK6RqBlffQZC4*X!D*548!MzO|BSreDyUX zx1umgsjRoqRuc7+NU~5z?+Qq>@U%Ax^R#MT)vk4@xYbwpNS)hVXCH&+z}^zx)w z@Y`!ZoJx05%{F^}OxQv2!XXYdIx}ILxykOHAv+Vb6%X8*s0|&JW8fQ^bulmy;EP&g zH`r_7rdOgKNRG)&!$Amk4#{!rs&rv;rVN#D=2Y~=>{^%%+uf>M{)2c89Tf*3pZ+oO{M4vPV7OZpn1pm4}O-DrwJ)tMW1SQW_olcpS-J1M=x(cOuR}yT2FIE1`ZTU z-$LhE9#=BiRsqKoq(;!6(@Sp#DO2Ym+^qz*&gAFKCGxQ6_(NqehDwX_*lim!59Kcw z4wc<9R5~+@iC4pFJH)efN6H{2s^g~~?iS&z#jdU7Sy6D9`6Tm#kD|pv6l|ojj?}_} zRUJ9X5Pq}MX%N7R=v1HJE|yn!+MIOg976AyIzxG)+Zv;%GA&8_0Jjc65KRHxfk^>@ zXj4smP&sO>8MB6!aQ#_hi5BUE%80f}&(TJAn7v>Wni^Kg?hM6=bj38t z=8o4}X!PLKB9&L=qdo%d+%t4^5r6%#=Vno#u`04e6w?~f8o|gSi$-K1=v|SM1bGqE zCSV#%${~&QYGIj54WfBUMoCUQ-N%Dq6iJ58&y1SEvpzco92@Z&$rIZdyc$)tw%*$^R?Q(S{MoBz^#Ov z6S=ZYgkBmLW}p-$mx)0+(G3KaSq~tLl+|14a!(fA%t;j7JcZd*+tBp&1Pl_v!Al8q zT`x2S1#44EmoHQGcP9?frIM-adClc$82A_`qL0^QCPnQv_KCWJYb(-@-$ELdI<^iS zZef`l~)VtmF_A$)N zyX%joj_>TXeqNWYi1I53A;h2sOF~ELn(su(%;-;@h@6Z+5_h}f_6ZQ`yW_AZgyh|Z zc_m_las!ie@1jo?Lm*-&sycILMJYRBEb*> zrHc;qGKDZWCfY3x=$!?TT1nw5Oa!m<@szL+bZ z{c$eTK0r{m&GsH$1J|b);|+HLWJOfd_1vSwzZFCD>?8SDJc8MC+9eNr4);;+v_v{| zVR~^u!n~zE**OC@iO!~yYGt_|1e?;0%b}>dyeTit2Og&MbdQm`J%g>~%a$(zr<#FbmtzR; zHsB#JpL@Mq5s~w@Zyj1~wGJGv^Ce$~P-f2pcU`A8*z1z9UTPy@rC7Azr>Wg_+~7i^ zdz=xGk>p4@rMzo}m_{rQ9`E3ZZr@6L1orjAbuwo=xNVLI$wW6Ez>% zE#obQtN8Xn!93q3d$wOC$H=0C^3N+2*ZGFnO`TX1HYjs$T*TNg-Oii*zHxSQ&Huxh zwxXst*kEvmTEAZBsErX3I!W!JK&+J?T=%au&qm%PVyDCym{$Hw`&0~9YX^D~(2p1T z1hpj^{(9@bTJ^d(J8U33y|Af6n>ZtWDsd!Jo`9Le)>KUUOK|mZu62PMP3xp9at*a# zfx5A+!XLB{A{Iw1ElO9ET`&ed?|QAr6FMvsI$}ttfuXxZhhVB1MTM11L4M9kH_r>T z@XVFwUb6;)MHR49_9-k%0=Ezi0ml%3^!w6>?5sFTf|da#Fnoz8r2dm2XI?u=qzGthTm{2x zL;VRxQHn}6hUC~I8R|+*WrIkYAyk-}3?(Ne%Tvh-=CT4pDngJ$-kqGPxbk%+Vp&aD zKq#1ragMH-7^8M43ebBba}Keatf+Xte3;_s6e9DBakI`V z^nS`Wx~bl3Sk+$Vn*3mh*2yUKM>BAf90P|BvtZEEUc~B5wO-1WKcS2@iCSojl zzAip!7U`l?fN<5cV`2zY*bx-p0QYsY_nVvgMhGOM?_~V3`=KJBxRhhy?~`L5QqrQo z%&!i%Kh~BW_WfZLgk>l5#eAXkt$9vp!<_y^Iu~nC4jMi%_xTHe(M2GpmMX&L`obRR z_r;t+lulbyIFNHmte^Wy7S}nx-OXHQ8Br-|*pndV;sV5wYM+K-A?1SF784uiPbdB70cpK-)@|(y9}?~DPxN9 zxc3S^?2=@n#u?3pb%ZktAw}?M(Tt_l5fje5BrAIhJzCiiPcrdDcYJ!iJAuh2xDz!) zmyB=kUWP6h9~i2Dy>P+BqEzX98!YdUJYqG@HNpUoJ9k_3=)A+sK?EZnxmFs=d;`}? z=$#V5dPcy_sO9vbQYG@}uS_;TB@S0Yg}LsL!KGPoJLOE2&^h_6Dg^ZQ<0tqZtbte- z3VxJ}5PXNB?Gmb-LB@TNp;GbSamIa5K(d6bw*`DUpM!3T7?*7bo+lB`k_gU40?K8~ zVPuK%M(kCVEfNQ5c!-sR*oi5>#+1k81Nr6@3%OC0IgB#nikgNh+@pwA*Z5MU zKQQ^nNbdY?9{dr(PbHL{KuMT$7en8dP%Tx)l%rxtX{p0Tvt3SzmDG#$8p63?bBFxz z%;;Stfzc`aGJE?i0U6ikfYG@Bn2-C@d|VDAO?Ep&r7HG10XZh^IsrAai&+($<3>ZK z@*}IlSx8x;UB--LJSwk?*&B|rWN#g0gntrn7s0nhSPVnjyfCMHq61g(%g6K6OJs<8 zJIFEjZj(?lro9aWg-z~VNjAB6hJ?6#@DqF$85S?8X{>IDR>_bGew*KIJ?d`MM(03p^&ES1;fpmL^36w33`v0Oe1bMW-1ZW2k4@>U6ZPx8|bGdF{4@FjlHjL66d8%*j-DliljBtyIxGr^hW83Dg z!u>s6p|+OI>o>N@MXK4$6Jqc}RQa1~s+(qeV%t!93)h+oUHA6ratLt+HR;Ly1OL8o_t)c zc=j$%XX^uU%dOw7)bEXae9E=S`d~5NJ|ywAJ|LO1J}T9iBl-B9C4v{RSn6HZA~(t8 z?MYbd$Ic=MA706Z{avH=8id&hNitjR@;Uc`^BBHlw7mZ_+)y`e-7a3M)wSn!tzW%q z`=+p%*U+oC;uyYNZ@z76*)lIIsZRBDjUSY%1>U4@`#Nvq+V1Cl+ywJFqaibM=7nY2 zxg<39<>SG2{R{7&>CP>8+w5U!l6M&CZ>}_a+Uz6<47f9d$}XRrM5UsHM+gk%L3gYw z%?`Hz26N!7bi`^+;byuJE<7I_9`9iX7&%?q5L|)F)+Ec2o{eOW+taRR&%Mjl!g{Zn zZ)*L@-cDwi_1+>4JX;>lZ_kv6-AN+q9VP+w4qJgWK;-nRVEt-dPnYR7*|UoOR6Vr%7Cw=AImP)o{=X zg_ecj2xuL~wz4=N^tT_dQM<GZZxc)TMcCa*3^vi;M&W_| z8~4ljG)BVZ&Pl8$v9zg{n6cki8nDghp&i5+kjy_20n<7F7WfFi{Jf6S)^KzfX7>cP zk3UR}MncIo`Ypbwvon$XMIX(_i)tJWDjiwbOBsD(xTkFdp*K1TI9;raa#L4^_(EO^ zGaLZN=^WL0SG;B?3{&^clwpEFmMf_A4m#Fp_qj$165eKK$N~-*bMh;@GIjN=`=68P z$rAD`}!jtJ=Vas_mHxso}(bA0T>dWs$+8mA*@q$&+cw={BqTJM&#nD>ODSU+Y~ zrv%KhfY}1xL-0#?=;JzMW1rh1FJ5dJ!{$`$gE9^8#}^}plT2Kof#;?}L4ll8MUvSo za9eE1&z7w@xq5r}78&-}ZM|s=-C7x%G+k1B7q>gj1y38+p50CDqy1ONg`BOd`9sDd ztoJZzs0-amW$Jc=m3<4Wt;qewd6L;ab05^6y~055z3}}NP88OK_kP!J+O!240i=x^ zr<*yqA9Jp{tklwJhpV5Igepe`q^CnvLTisjAG?2${m0)|4PsMZ2&hRfk6Sx$zl&LI zh)_UK<%>MQ>BZ@w376w=&P7YK^Po1xNU)Z}rN%pWVfyS@=`+VkCuR}V$ z>}F%SNBI&m*F>TON_(}hFrA%Q?>Lahf}?r0tz-LPgse7jCX~udG{T#Q3c?}&c|K8T zB4wwM6$5*h>(CBMFDh`h_JgmXbD(t~&5uxmO=$$V+>wt|>C{i|M>X)DckSRT)G6d0 z!FmX$xVhGFB6cKmTg+ag$vN{BjK<-_P}hYVGfDJ-6Hh=z;8L(e%hk>CL9p!Pz5p12 zrQONWB(9w70v`}uuG21^fDH}S>5nvbxnFd*v`A<3A+S7#tRn?d>yhXhTel~2wzJuB zROVD8iPqE7?f=4l<=N&Vf^zt=eoau0d1jX)Iaqf|sJ-nQ{P=N7-(0>u!x{0Kz}|xr z_eGv-)EkP1+^-*R)(4k3@4eC@sJ72z8eLR4;_Z4e8*$G&`fjB!1 zj^Mv1!Xq zo5JUWS8m$A_119p*6rK2ZpX#@ty@roqJH`Lf&BbXetslBKbD^t<>x2z^RoQBB0oY; Ti{8&&3;%&781jDe*=PR`zOFGG diff --git a/library/MASTERSCOPE.~1~ b/library/MASTERSCOPE.~1~ deleted file mode 100644 index 1ce6011f..00000000 --- a/library/MASTERSCOPE.~1~ +++ /dev/null @@ -1,759 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 8-Sep-94 17:08:28" {DSK}library>MASTERSCOPE.;2 194113 - - changes to%: (VARS MASTERSCOPECOMS) - - previous date%: "23-Jun-93 10:29:58" {DSK}library>MASTERSCOPE.;1) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT MASTERSCOPECOMS) - -(RPAQQ MASTERSCOPECOMS - [ - (* ;; "Main file for MASTERSCOPE.") - - (FILES MSPARSE MSANALYZE) - (PROP FILETYPE MASTERSCOPE) - (COMS * MSDATABASECOMS) - (COMS * MSAUXCOMS) - (COMS * MSDBCOMS) - (COMS * MSCHECKBLOCKSCOMS) - (COMS * MSPATHSCOMS) - [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) - (VARS MSBLIP) - - (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") - - [INITVARS (MSFNTYPES '((FNS FNS GETDEF] - (COMS (* ; "SCRATCHASH") - (INITVARS (MSCRATCHASH)) - (DECLARE%: DONTCOPY (MACROS SCRATCHASH] - (COMS (* ; "marking changed") - (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS - ) - (ADDVARS (COMPILE.TIME.CONSTANTS)) - (VARS (RECORDCHANGEFN 'CHANGERECORD)) - (INITVARS (CHECKUNSAVEFLG T) - (MSNEEDUNSAVE))) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) - (COMS (* ; "interactive routines") - [VARS * (LIST (LIST 'MASTERSCOPEDATE (SUBSTRING (DATE) - 1 9] - (ADDVARS (HISTORYCOMS %.)) - (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) - (* ; "Interpreting commands") - (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST - MSHASHLIST1 CHECKPATHS ONFILE) - (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) - (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) - (FILES MSCOMMON) - (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) - (NLAML) - (LAMA MSEDITE MSEDITF - MSEDITF]) - - - -(* ;; "Main file for MASTERSCOPE.") - - -(FILESLOAD MSPARSE MSANALYZE) - -(PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) - -(RPAQQ MSDATABASECOMS - ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK - MSCOLLECTDATA) - (FNS UPDATECHANGED UPDATECHANGED1) - (VARS TABLE.TO.NOTICED) - (FNS MSCLOSEFILES) - (VARS (MSFILELST) - (MSOPENFILES)) - (VARS (MSPRINTFLG '%.) - (MSPRINTCNT 0)) - (ADDVARS (MSHASHFILE) - (ANALYZEUSERFNS)))) -(DEFINEQ - -(UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Update the analysis of a particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) ((NIL PRINT) (printout T "Sorry, the function " |.P2| FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) - -(MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) - -(MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) - -(MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) - -(MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) - -(MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) - -(MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) - -(MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) - -(MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) -) -(DEFINEQ - -(UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) - -(UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) -) - -(RPAQQ TABLE.TO.NOTICED - ((BIND (- (- (- (- (+ BIND ARG) - REF) - SMASH) - SET) - TEST)) - (REFFREE (- (- (- REFFREE SETFREE) - SMASHFREE) - TESTFREE)) - (REF (- (- (- REF SET) - SMASH) - TEST)) - (PREDICATE (- PREDICATE CALL)) - (EFFECT (- (- EFFECT CALL) - PREDICATE)) - (CALL (- CALL NLAMBDA)) - (0 TYPE) - (APPLY (+ APPLY STACK)) - (ARGS ARG))) -(DEFINEQ - -(MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) -) - -(RPAQQ MSFILELST NIL) - -(RPAQQ MSOPENFILES NIL) - -(RPAQQ MSPRINTFLG %.) - -(RPAQQ MSPRINTCNT 0) - -(ADDTOVAR MSHASHFILE ) - -(ADDTOVAR ANALYZEUSERFNS ) - -(RPAQQ MSAUXCOMS - ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) - (ADDVARS (DESCRIBELST)) - (GLOBALVARS DESCRIBELST)) - (COMS (FNS MSPRINTHELPFILE) - (VARS MSHELPFILE)) - (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) - (FILEPKGCOMS TEMPLATES)) - (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) - (INITVARS (MSCHECKFNS NIL)) - (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) -(DEFINEQ - -(MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) - -(MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) - -(FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) -) - -(ADDTOVAR DESCRIBELST ) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DESCRIBELST) -) -(DEFINEQ - -(MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) -) - -(RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) -(DEFINEQ - -(TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) - -(GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) - -(SETTEMPLATE [LAMBDA (FN TEMPLATE) (* lmm "16-FEB-78 14:56") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) -) -(PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM - MACRO - [X (P * (MAPCAR 'X (FUNCTION - (LAMBDA - (FN) - (LIST 'SETTEMPLATE (KWOTE - FN) - (KWOTE (GETTEMPLATE - FN] - CONTENTS NILL) - (TYPE DESCRIPTION "masterscope templates"))) -(DEFINEQ - -(ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) - -(MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) - -(MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) - -(MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) - -(MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) -) - -(RPAQ? MSCHECKFNS NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) -) - -(RPAQQ MSDBCOMS - [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) - (ADDVARS (MSCHANGEDARRAY) - (MSDATABASELST)) - (INITVARS (MSDBEMPTY T)) - (VARS MSDATABASEINIT NODUMPRELATIONS) - (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) - (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) - [P (MAPC '((GETHASH GETTABLE) - (GETHASH TESTTABLE) - (PUTHASH PUTTABLE) - (ADDHASH ADDTABLE) - (SUBHASH SUBTABLE) - (MAPHASH MAPTABLE) - (MAKEHASH MAKETABLE) - (EQMEMBHASH EQMEMBTABLE)) - (FUNCTION (LAMBDA (X) - (MOVD? (CAR X) - (CADR X] - (FNS MSVBTABLES MSUSERVBTABLES) - (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) - (MSANALYZEFNS (MAKETABLE 2))) - (FNS BUILDGETRELQ BUILDTESTRELQ) - (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) - (COMS (FNS MSERASE)) - (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) - (VARS DATABASECOMS)) - (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) -(DEFINEQ - -(MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) - -(MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) - -(GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) - -(MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) - -(STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) -) - -(ADDTOVAR MSCHANGEDARRAY ) - -(ADDTOVAR MSDATABASELST ) - -(RPAQ? MSDBEMPTY T) - -(RPAQQ MSDATABASEINIT - ((CALL 25 . 50) - (BIND 10 . 10) - [NLAMBDA 10 . 10] - (NOBIND 10) - (RECORD 20 . 10) - (CREATE 2 . 2) - (FETCH 10 . 10) - (REPLACE 10 . 10) - (REFFREE 10 . 1) - (REF 10 . 25) - (SETFREE 1 . 1) - (SET 20 . 30) - (SMASHFREE 1 . 1) - (SMASH 1 . 1) - (PROP 1 . 1) - (TEST 1 . 1) - (TESTFREE 1 . 1) - (PREDICATE 10 . 10) - (EFFECT 10 . 10) - (CLISP 10 . 10) - (SPECVARS 10 . 10) - (LOCALVARS 10 . 10) - (APPLY 10 . 10) - (ERROR 10 . 10) - (LOCALFREEVARS 10 . 10) - (CONTAINS 10 . 10) - (FILE 10) - (ARGS 10) - (USERTEMPLATES NIL . T) - (0 10 . 10) - (FPTYPE 10 . 10) - (KEYACCEPT 2 . 2) - (KEYSPECIFY 2 . 2) - (KEYCALL 2 . 2) - (FLET 2 . 2) - (LABEL 2 . 2) - (MACROLET 2 . 2) - (COMPILER-LET 2 . 2) - (SENDNOTSELF 2 . 2) - (SENDSELF 2 . 2) - (IMPLEMENT 2 . 2) - (GETNOTSELF 2 . 2) - (GETSELF 2 . 2) - (GETCVSELF 2 . 2) - (GETCVNOTSELF 2 . 2) - (PUTNOTSELF 2 . 2) - (PUTSELF 2 . 2) - (PUTCVSELF 2 . 2) - (PUTCVNOTSELF 2 . 2) - (OBJECT 2 . 2))) - -(RPAQQ NODUMPRELATIONS (CONTAINS FILE)) -(DEFINEQ - -(PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) - -(PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) - -(GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) - -(MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) - -(TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) -) -(DEFINEQ - -(ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) - -(SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) - -(MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) - -(MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) - -(EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) -) - -[MAPC '((GETHASH GETTABLE) - (GETHASH TESTTABLE) - (PUTHASH PUTTABLE) - (ADDHASH ADDTABLE) - (SUBHASH SUBTABLE) - (MAPHASH MAPTABLE) - (MAKEHASH MAKETABLE) - (EQMEMBHASH EQMEMBTABLE)) - (FUNCTION (LAMBDA (X) - (MOVD? (CAR X) - (CADR X] -(DEFINEQ - -(MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) - -(MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) -) - -(RPAQ? MSUSERVBTABLES (MAKETABLE 2)) - -(RPAQ? MSANALYZEFNS (MAKETABLE 2)) -(DEFINEQ - -(BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) - -(BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) - -(PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) -) -) -(DEFINEQ - -(MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) -) -(DEFINEQ - -(DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) - -(DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) - -(READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) -) - -(RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) - -(ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) - -(RPAQQ MSCHECKBLOCKSCOMS - ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE - GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR - MSMSGPRINT) - (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC - MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST - DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS - U LF1 SHOULDBESPECVARS) - (NOLINKFNS . T) - (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS - LOCALFREEVARS DONTCOMPILEFNS ENTRIES) - (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) - GLOBALVARP)))) -(DEFINEQ - -(MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) - -(MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) - -(MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) - -(MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [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)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) - -(MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) - -(GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) - -(PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) - -(MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) - -(UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) - -(NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) - -(SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) - -(SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) - -(DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) - -(MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY - -(BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE - PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT - (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) - (NOLINKFNS . T) - (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS - DONTCOMPILEFNS ENTRIES) - (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) - GLOBALVARP) -) - -(RPAQQ MSPATHSCOMS - [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) - (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) - MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER - MSPATHSPRINTFN - (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE - AVOIDING SEPARATE) - (GLOBALVARS MSBLIP MSCRATCHASH) - (NOLINKFNS . T]) -(DEFINEQ - -(MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) - -(MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) - -(MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) - -(MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) - -(MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) - -(DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) - -(DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) - -(BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) - -(MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY - -(BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) - MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN - (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING - SEPARATE) - (GLOBALVARS MSBLIP MSCRATCHASH) - (NOLINKFNS . T)) -) -(DEFINEQ - -(MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) - -(MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) - -(MSEDITE [LAMBDA ARGCOUNT (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (ARG ARGCOUNT 3)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) - -(EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) -) - -(RPAQQ MSBLIP "sysout and inform Masinter@PARC") - - - -(* ;; -"List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." -) - - -(RPAQ? MSFNTYPES '((FNS FNS GETDEF))) - - - -(* ; "SCRATCHASH") - - -(RPAQ? MSCRATCHASH ) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) - ([LAMBDA (ARRAYNAME) - (SETQ MSCRATCHASH) - (PROG1 (PROGN . FORMS) - (SETQ MSCRATCHASH ARRAYNAME] - (COND - (MSCRATCHASH (CLRHASH MSCRATCHASH) - MSCRATCHASH) - (T (HASHARRAY 20 (FUNCTION MSREHASH]) -) -) - - - -(* ; "marking changed") - -(DEFINEQ - -(MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) - -(CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) - -(CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) - -(CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) - -(CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) - -(MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) - -(UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) -) - -(ADDTOVAR COMPILE.TIME.CONSTANTS ) - -(RPAQQ RECORDCHANGEFN CHANGERECORD) - -(RPAQ? CHECKUNSAVEFLG T) - -(RPAQ? MSNEEDUNSAVE ) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) - (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) -) -) - - - -(* ; "interactive routines") - - -(RPAQ MASTERSCOPEDATE " 8-Sep-94") - -(ADDTOVAR HISTORYCOMS %.) -(DEFINEQ - -(%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) - -(MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) - -(MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) - -(MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) -) - - - -(* ; "Interpreting commands") - -(DEFINEQ - -(MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) - -(MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) - -(MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) - -(LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) - -(MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) - -(MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) - -(MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) - -(MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) - -(CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) - -(ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) -) -(DEFINEQ - -(MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) - -(VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) - -(MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) - -(MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) - -(CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) - -(MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD GETHASH (ID HTABLE . BADMARKS) - ID _ 'GETHASH) - -(RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) - ID _ 'INRELATION) - -(ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH - MARKING) (* CHECKPATHS assumes that this is - an ASSOCRECORD) - ) - -(RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) -) -) - -(FILESLOAD MSCOMMON) -(DECLARE%: DONTCOPY - -(RPAQQ MSCOMPILETIME - [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) - (FUNCTION (LAMBDA (X) - (PUTHASH X 'MACRO USERTEMPLATES] - (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) - (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) - (NOLINKFNS . T)) - (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED - CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE - GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC - MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC - MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED - MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE - MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 - READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED - UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE - MSADDMODIFIER MSADDRELATION MSADDTYPE - (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE - MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 - MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE - MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS - UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE - ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) - (RETFNS MASTERSCOPE1) - (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) - (NOLINKFNS . T))) - (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT - FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY - MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE - MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES - RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE - ANALYZEUSERFNS) - (DECLARE%: EVAL@COMPILE (P (CLISPDEC 'FAST]) - -[MAPC '(GETRELQ TESTRELQ SCRATCHASH) - (FUNCTION (LAMBDA (X) - (PUTHASH X 'MACRO USERTEMPLATES] -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY - -(BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) - -(BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) - (NOLINKFNS . T)) - -(BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS - DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION - MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 - MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET - MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE - MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE - SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN - VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE - (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION - MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET - MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE - TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE - ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) - (RETFNS MASTERSCOPE1) - (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) - (NOLINKFNS . T)) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH - FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT - NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT - MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT - TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) -) -(DECLARE%: EVAL@COMPILE - -(CLISPDEC 'FAST) -) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA %.) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) -) -(PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 -1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3538 20186 (UPDATEFN 3548 . 5042) (MSEDITF 5044 . 6044) (MSGETDEF 6046 . 7452) ( -MSNOTICEFILE 7454 . 9847) (MSSHOWUSE 9849 . 15352) (MSUPDATEFN1 15354 . 16042) (MSUPDATE 16044 . 18470 -) (MSNLAMBDACHECK 18472 . 19354) (MSCOLLECTDATA 19356 . 20184)) (20187 21086 (UPDATECHANGED 20197 . -20560) (UPDATECHANGED1 20562 . 21084)) (21660 22083 (MSCLOSEFILES 21670 . 22081)) (22764 27196 ( -MSDESCRIBE 22774 . 25562) (MSDESCRIBE1 25564 . 26627) (FMAPRINT 26629 . 27194)) (27289 27729 ( -MSPRINTHELPFILE 27299 . 27727)) (27779 30879 (TEMPLATE 27789 . 29210) (GETTEMPLATE 29212 . 29347) ( -SETTEMPLATE 29349 . 30877)) (31749 36673 (ADDTEMPLATEWORD 31759 . 32431) (MSADDANALYZE 32433 . 33931) -(MSADDMODIFIER 33933 . 35014) (MSADDRELATION 35016 . 35763) (MSADDTYPE 35765 . 36671)) (38174 43395 ( -MSMARKCHANGE1 38184 . 38978) (MSINIT 38980 . 40161) (GETVERBTABLES 40163 . 40716) (MSSTOREDATA 40718 - . 42397) (STORETABLE 42399 . 43393)) (44796 49866 (PARSERELATION 44806 . 45406) (PARSERELATION1 45408 - . 46863) (GETRELATION 46865 . 47894) (MAPRELATION 47896 . 49030) (TESTRELATION 49032 . 49864)) (49867 - 51507 (ADDHASH 49877 . 50355) (SUBHASH 50357 . 50585) (MAKEHASH 50587 . 50731) (MSREHASH 50733 . -51186) (EQMEMBHASH 51188 . 51505)) (51846 58061 (MSVBTABLES 51856 . 57635) (MSUSERVBTABLES 57637 . -58059)) (58144 60355 (BUILDGETRELQ 58154 . 59260) (BUILDTESTRELQ 59262 . 60353)) (60526 60914 (MSERASE - 60536 . 60912)) (60915 64147 (DUMPDATABASE 60925 . 62262) (DUMPDATABASE1 62264 . 62609) (READATABASE -62611 . 64145)) (65229 94288 (MSCHECKBLOCKS 65239 . 69059) (MSCHECKBLOCK 69061 . 77681) ( -MSCHECKFNINBLOCK 77683 . 80683) (MSCHECKBLOCKBASIC 80685 . 83105) (MSCHECKBOUNDFREE 83107 . 85006) ( -GLOBALVARP 85008 . 85175) (PRINTERROR 85177 . 88393) (MSCHECKVARS1 88395 . 91348) (UNECCSPEC 91350 . -91628) (NECCSPEC 91630 . 91977) (SPECVARP 91979 . 92506) (SHORTLST 92508 . 92964) (DOERROR 92966 . -93676) (MSMSGPRINT 93678 . 94286)) (95432 110260 (MSPATHS 95442 . 98844) (MSPATHS1 98846 . 103081) ( -MSPATHS2 103083 . 106493) (MSONPATH 106495 . 107723) (MSPATHS4 107725 . 108807) (DASHES 108809 . -109335) (DOTABS 109337 . 109578) (BELOWMARKER 109580 . 110043) (MSPATHSPRINTFN 110045 . 110258)) ( -110646 113916 (MSFIND 110656 . 110931) (MSEDITF 110933 . 111933) (MSEDITE 111935 . 112818) (EDITGETDEF - 112820 . 113914)) (114922 123523 (MSMARKCHANGED 114932 . 116656) (CHANGEMACRO 116658 . 117363) ( -CHANGEVAR 117365 . 117681) (CHANGEI.S. 117683 . 119016) (CHANGERECORD 119018 . 119889) (MSNEEDUNSAVE -119891 . 120883) (UNSAVEFNS 120885 . 123521)) (123962 127452 (%. 123972 . 124112) (MASTERSCOPE 124114 - . 124640) (MASTERSCOPE1 124642 . 125510) (MASTERSCOPEXEC 125512 . 127450)) (127491 165150 ( -MSINTERPRETSET 127501 . 154994) (MSINTERPA 154996 . 155530) (MSGETBLOCKDEC 155532 . 158045) (LISTHARD -158047 . 159265) (MSMEMBSET 159267 . 159412) (MSLISTSET 159414 . 159779) (MSHASHLIST 159781 . 159948) -(MSHASHLIST1 159950 . 160276) (CHECKPATHS 160278 . 160918) (ONFILE 160920 . 165148)) (165151 188317 ( -MSINTERPRET 165161 . 182014) (VERBNOTICELIST 182016 . 183126) (MSOUTPUT 183128 . 183445) (MSCHECKEMPTY - 183447 . 184651) (CHECKFORCHANGED 184653 . 185173) (MSSOLVE 185175 . 188315))))) -STOP diff --git a/library/MASTERSCOPE.~2~ b/library/MASTERSCOPE.~2~ deleted file mode 100644 index 23c96585..00000000 --- a/library/MASTERSCOPE.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "24-Oct-2018 16:25:58"  {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;2 194331 changes to%: (FNS MSEDITE) previous date%: " 8-Sep-94 17:08:28" {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MASTERSCOPECOMS) (RPAQQ MASTERSCOPECOMS [ (* ;; "Main file for MASTERSCOPE.") (FILES MSPARSE MSANALYZE) (PROP FILETYPE MASTERSCOPE) (COMS * MSDATABASECOMS) (COMS * MSAUXCOMS) (COMS * MSDBCOMS) (COMS * MSCHECKBLOCKSCOMS) (COMS * MSPATHSCOMS) [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) (VARS MSBLIP) (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") [INITVARS (MSFNTYPES '((FNS FNS GETDEF] (COMS (* ; "SCRATCHASH") (INITVARS (MSCRATCHASH)) (DECLARE%: DONTCOPY (MACROS SCRATCHASH] (COMS (* ; "marking changed") (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS ) (ADDVARS (COMPILE.TIME.CONSTANTS)) (VARS (RECORDCHANGEFN 'CHANGERECORD)) (INITVARS (CHECKUNSAVEFLG T) (MSNEEDUNSAVE))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) (COMS (* ; "interactive routines") [VARS * (LIST (LIST 'MASTERSCOPEDATE (SUBSTRING (DATE) 1 9] (ADDVARS (HISTORYCOMS %.)) (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) (* ; "Interpreting commands") (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST MSHASHLIST1 CHECKPATHS ONFILE) (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) (FILES MSCOMMON) (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) (NLAML) (LAMA MSEDITE MSEDITF MSEDITF]) (* ;; "Main file for MASTERSCOPE.") (FILESLOAD MSPARSE MSANALYZE) (PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) (RPAQQ MSDATABASECOMS ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK MSCOLLECTDATA) (FNS UPDATECHANGED UPDATECHANGED1) (VARS TABLE.TO.NOTICED) (FNS MSCLOSEFILES) (VARS (MSFILELST) (MSOPENFILES)) (VARS (MSPRINTFLG '%.) (MSPRINTCNT 0)) (ADDVARS (MSHASHFILE) (ANALYZEUSERFNS)))) (DEFINEQ (UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Update the analysis of a particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) ((NIL PRINT) (printout T "Sorry, the function " |.P2| FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) (MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) (MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) (MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) (MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) (MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) (MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) ) (DEFINEQ (UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) (UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) ) (RPAQQ TABLE.TO.NOTICED ((BIND (- (- (- (- (+ BIND ARG) REF) SMASH) SET) TEST)) (REFFREE (- (- (- REFFREE SETFREE) SMASHFREE) TESTFREE)) (REF (- (- (- REF SET) SMASH) TEST)) (PREDICATE (- PREDICATE CALL)) (EFFECT (- (- EFFECT CALL) PREDICATE)) (CALL (- CALL NLAMBDA)) (0 TYPE) (APPLY (+ APPLY STACK)) (ARGS ARG))) (DEFINEQ (MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) ) (RPAQQ MSFILELST NIL) (RPAQQ MSOPENFILES NIL) (RPAQQ MSPRINTFLG %.) (RPAQQ MSPRINTCNT 0) (ADDTOVAR MSHASHFILE ) (ADDTOVAR ANALYZEUSERFNS ) (RPAQQ MSAUXCOMS ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) (ADDVARS (DESCRIBELST)) (GLOBALVARS DESCRIBELST)) (COMS (FNS MSPRINTHELPFILE) (VARS MSHELPFILE)) (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) (FILEPKGCOMS TEMPLATES)) (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (INITVARS (MSCHECKFNS NIL)) (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) (DEFINEQ (MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) (MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) (FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) ) (ADDTOVAR DESCRIBELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DESCRIBELST) ) (DEFINEQ (MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) ) (RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) (DEFINEQ (TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) (GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) (SETTEMPLATE [LAMBDA (FN TEMPLATE) (* lmm "16-FEB-78 14:56") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) ) (PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (P * (MAPCAR 'X (FUNCTION (LAMBDA (FN) (LIST 'SETTEMPLATE (KWOTE FN) (KWOTE (GETTEMPLATE FN] CONTENTS NILL) (TYPE DESCRIPTION "masterscope templates"))) (DEFINEQ (ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) (MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) (MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) (MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) (MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) ) (RPAQ? MSCHECKFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) ) (RPAQQ MSDBCOMS [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) (ADDVARS (MSCHANGEDARRAY) (MSDATABASELST)) (INITVARS (MSDBEMPTY T)) (VARS MSDATABASEINIT NODUMPRELATIONS) (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) [P (MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (FNS MSVBTABLES MSUSERVBTABLES) (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) (MSANALYZEFNS (MAKETABLE 2))) (FNS BUILDGETRELQ BUILDTESTRELQ) (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) (COMS (FNS MSERASE)) (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) (VARS DATABASECOMS)) (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) (DEFINEQ (MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) (MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) (GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) (STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) ) (ADDTOVAR MSCHANGEDARRAY ) (ADDTOVAR MSDATABASELST ) (RPAQ? MSDBEMPTY T) (RPAQQ MSDATABASEINIT ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] (NOBIND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) (REPLACE 10 . 10) (REFFREE 10 . 1) (REF 10 . 25) (SETFREE 1 . 1) (SET 20 . 30) (SMASHFREE 1 . 1) (SMASH 1 . 1) (PROP 1 . 1) (TEST 1 . 1) (TESTFREE 1 . 1) (PREDICATE 10 . 10) (EFFECT 10 . 10) (CLISP 10 . 10) (SPECVARS 10 . 10) (LOCALVARS 10 . 10) (APPLY 10 . 10) (ERROR 10 . 10) (LOCALFREEVARS 10 . 10) (CONTAINS 10 . 10) (FILE 10) (ARGS 10) (USERTEMPLATES NIL . T) (0 10 . 10) (FPTYPE 10 . 10) (KEYACCEPT 2 . 2) (KEYSPECIFY 2 . 2) (KEYCALL 2 . 2) (FLET 2 . 2) (LABEL 2 . 2) (MACROLET 2 . 2) (COMPILER-LET 2 . 2) (SENDNOTSELF 2 . 2) (SENDSELF 2 . 2) (IMPLEMENT 2 . 2) (GETNOTSELF 2 . 2) (GETSELF 2 . 2) (GETCVSELF 2 . 2) (GETCVNOTSELF 2 . 2) (PUTNOTSELF 2 . 2) (PUTSELF 2 . 2) (PUTCVSELF 2 . 2) (PUTCVNOTSELF 2 . 2) (OBJECT 2 . 2))) (RPAQQ NODUMPRELATIONS (CONTAINS FILE)) (DEFINEQ (PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) (GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) (MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) (TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) ) (DEFINEQ (ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) (SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) (MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) (MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) (EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) ) [MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (DEFINEQ (MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) (MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) ) (RPAQ? MSUSERVBTABLES (MAKETABLE 2)) (RPAQ? MSANALYZEFNS (MAKETABLE 2)) (DEFINEQ (BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) (BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) (PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) ) ) (DEFINEQ (MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) ) (DEFINEQ (DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) (DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) (READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) ) (RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) (ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) (RPAQQ MSCHECKBLOCKSCOMS ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT) (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP)))) (DEFINEQ (MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) (MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) (MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) (MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [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)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) (MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) (GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) (PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) (MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) (UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) (NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) (SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) (SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) (DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) (MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP) ) (RPAQQ MSPATHSCOMS [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T]) (DEFINEQ (MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) (MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) (MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) (MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) (MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) (DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) (DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) (BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) (MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T)) ) (DEFINEQ (MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSEDITE [LAMBDA ARGCOUNT (* ; "Edited 24-Oct-2018 16:25 by rmk:") (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (OR (ARG ARGCOUNT 3) 'FNS)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) (EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) ) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." ) (RPAQ? MSFNTYPES '((FNS FNS GETDEF))) (* ; "SCRATCHASH") (RPAQ? MSCRATCHASH ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) ([LAMBDA (ARRAYNAME) (SETQ MSCRATCHASH) (PROG1 (PROGN . FORMS) (SETQ MSCRATCHASH ARRAYNAME] (COND (MSCRATCHASH (CLRHASH MSCRATCHASH) MSCRATCHASH) (T (HASHARRAY 20 (FUNCTION MSREHASH]) ) ) (* ; "marking changed") (DEFINEQ (MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) (CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) (CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) (CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) (CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) (MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) (UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) ) (ADDTOVAR COMPILE.TIME.CONSTANTS ) (RPAQQ RECORDCHANGEFN CHANGERECORD) (RPAQ? CHECKUNSAVEFLG T) (RPAQ? MSNEEDUNSAVE ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (* ; "interactive routines") (RPAQ MASTERSCOPEDATE "24-Oct-20") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ (%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) (MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) (MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) (MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) (* ; "Interpreting commands") (DEFINEQ (MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) (MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) (MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) (LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) (MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) (MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) (MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) (MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) (CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) (ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) ) (DEFINEQ (MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) (VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) (MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) (MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) (CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) (MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GETHASH (ID HTABLE . BADMARKS) ID _ 'GETHASH) (RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) ID _ 'INRELATION) (ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH MARKING) (* CHECKPATHS assumes that this is  an ASSOCRECORD) ) (RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) ) ) (FILESLOAD MSCOMMON) (DECLARE%: DONTCOPY (RPAQQ MSCOMPILETIME [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T))) (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) (DECLARE%: EVAL@COMPILE (P (CLISPDEC 'FAST]) [MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) ) (DECLARE%: EVAL@COMPILE (CLISPDEC 'FAST) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %.) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) ) (PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3597 20245 (UPDATEFN 3607 . 5101) (MSEDITF 5103 . 6103) (MSGETDEF 6105 . 7511) ( MSNOTICEFILE 7513 . 9906) (MSSHOWUSE 9908 . 15411) (MSUPDATEFN1 15413 . 16101) (MSUPDATE 16103 . 18529 ) (MSNLAMBDACHECK 18531 . 19413) (MSCOLLECTDATA 19415 . 20243)) (20246 21145 (UPDATECHANGED 20256 . 20619) (UPDATECHANGED1 20621 . 21143)) (21719 22142 (MSCLOSEFILES 21729 . 22140)) (22823 27255 ( MSDESCRIBE 22833 . 25621) (MSDESCRIBE1 25623 . 26686) (FMAPRINT 26688 . 27253)) (27348 27788 ( MSPRINTHELPFILE 27358 . 27786)) (27838 30938 (TEMPLATE 27848 . 29269) (GETTEMPLATE 29271 . 29406) ( SETTEMPLATE 29408 . 30936)) (31808 36732 (ADDTEMPLATEWORD 31818 . 32490) (MSADDANALYZE 32492 . 33990) (MSADDMODIFIER 33992 . 35073) (MSADDRELATION 35075 . 35822) (MSADDTYPE 35824 . 36730)) (38233 43454 ( MSMARKCHANGE1 38243 . 39037) (MSINIT 39039 . 40220) (GETVERBTABLES 40222 . 40775) (MSSTOREDATA 40777 . 42456) (STORETABLE 42458 . 43452)) (44855 49925 (PARSERELATION 44865 . 45465) (PARSERELATION1 45467 . 46922) (GETRELATION 46924 . 47953) (MAPRELATION 47955 . 49089) (TESTRELATION 49091 . 49923)) (49926 51566 (ADDHASH 49936 . 50414) (SUBHASH 50416 . 50644) (MAKEHASH 50646 . 50790) (MSREHASH 50792 . 51245) (EQMEMBHASH 51247 . 51564)) (51905 58120 (MSVBTABLES 51915 . 57694) (MSUSERVBTABLES 57696 . 58118)) (58203 60414 (BUILDGETRELQ 58213 . 59319) (BUILDTESTRELQ 59321 . 60412)) (60585 60973 (MSERASE 60595 . 60971)) (60974 64206 (DUMPDATABASE 60984 . 62321) (DUMPDATABASE1 62323 . 62668) (READATABASE 62670 . 64204)) (65288 94347 (MSCHECKBLOCKS 65298 . 69118) (MSCHECKBLOCK 69120 . 77740) ( MSCHECKFNINBLOCK 77742 . 80742) (MSCHECKBLOCKBASIC 80744 . 83164) (MSCHECKBOUNDFREE 83166 . 85065) ( GLOBALVARP 85067 . 85234) (PRINTERROR 85236 . 88452) (MSCHECKVARS1 88454 . 91407) (UNECCSPEC 91409 . 91687) (NECCSPEC 91689 . 92036) (SPECVARP 92038 . 92565) (SHORTLST 92567 . 93023) (DOERROR 93025 . 93735) (MSMSGPRINT 93737 . 94345)) (95491 110319 (MSPATHS 95501 . 98903) (MSPATHS1 98905 . 103140) ( MSPATHS2 103142 . 106552) (MSONPATH 106554 . 107782) (MSPATHS4 107784 . 108866) (DASHES 108868 . 109394) (DOTABS 109396 . 109637) (BELOWMARKER 109639 . 110102) (MSPATHSPRINTFN 110104 . 110317)) ( 110705 114129 (MSFIND 110715 . 110990) (MSEDITF 110992 . 111992) (MSEDITE 111994 . 113031) (EDITGETDEF 113033 . 114127)) (115135 123736 (MSMARKCHANGED 115145 . 116869) (CHANGEMACRO 116871 . 117576) ( CHANGEVAR 117578 . 117894) (CHANGEI.S. 117896 . 119229) (CHANGERECORD 119231 . 120102) (MSNEEDUNSAVE 120104 . 121096) (UNSAVEFNS 121098 . 123734)) (124175 127665 (%. 124185 . 124325) (MASTERSCOPE 124327 . 124853) (MASTERSCOPE1 124855 . 125723) (MASTERSCOPEXEC 125725 . 127663)) (127704 165363 ( MSINTERPRETSET 127714 . 155207) (MSINTERPA 155209 . 155743) (MSGETBLOCKDEC 155745 . 158258) (LISTHARD 158260 . 159478) (MSMEMBSET 159480 . 159625) (MSLISTSET 159627 . 159992) (MSHASHLIST 159994 . 160161) (MSHASHLIST1 160163 . 160489) (CHECKPATHS 160491 . 161131) (ONFILE 161133 . 165361)) (165364 188530 ( MSINTERPRET 165374 . 182227) (VERBNOTICELIST 182229 . 183339) (MSOUTPUT 183341 . 183658) (MSCHECKEMPTY 183660 . 184864) (CHECKFORCHANGED 184866 . 185386) (MSSOLVE 185388 . 188528))))) STOP \ No newline at end of file diff --git a/library/MASTERSCOPE.~3~ b/library/MASTERSCOPE.~3~ deleted file mode 100644 index fee7bc50..00000000 --- a/library/MASTERSCOPE.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Sep-2020 09:37:04"  {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;3 194301 changes to%: (VARS MASTERSCOPECOMS) previous date%: "24-Oct-2018 16:25:58" {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1994, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MASTERSCOPECOMS) (RPAQQ MASTERSCOPECOMS [ (* ;; "Main file for MASTERSCOPE.") (FILES MSPARSE MSANALYZE) (PROP FILETYPE MASTERSCOPE) (COMS * MSDATABASECOMS) (COMS * MSAUXCOMS) (COMS * MSDBCOMS) (COMS * MSCHECKBLOCKSCOMS) (COMS * MSPATHSCOMS) [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) (VARS MSBLIP) (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") [INITVARS (MSFNTYPES '((FNS FNS GETDEF] (COMS (* ; "SCRATCHASH") (INITVARS (MSCRATCHASH)) (DECLARE%: DONTCOPY (MACROS SCRATCHASH] (COMS (* ; "marking changed") (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS ) (ADDVARS (COMPILE.TIME.CONSTANTS)) (VARS (RECORDCHANGEFN 'CHANGERECORD)) (INITVARS (CHECKUNSAVEFLG T) (MSNEEDUNSAVE))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) (COMS (* ; "interactive routines") [VARS * (LIST (LIST 'MASTERSCOPEDATE (DATE (DATEFORMAT NO.TIME] (ADDVARS (HISTORYCOMS %.)) (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) (* ; "Interpreting commands") (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST MSHASHLIST1 CHECKPATHS ONFILE) (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) (FILES MSCOMMON) (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) (NLAML) (LAMA MSEDITE MSEDITF MSEDITF]) (* ;; "Main file for MASTERSCOPE.") (FILESLOAD MSPARSE MSANALYZE) (PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) (RPAQQ MSDATABASECOMS ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK MSCOLLECTDATA) (FNS UPDATECHANGED UPDATECHANGED1) (VARS TABLE.TO.NOTICED) (FNS MSCLOSEFILES) (VARS (MSFILELST) (MSOPENFILES)) (VARS (MSPRINTFLG '%.) (MSPRINTCNT 0)) (ADDVARS (MSHASHFILE) (ANALYZEUSERFNS)))) (DEFINEQ (UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Update the analysis of a particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) ((NIL PRINT) (printout T "Sorry, the function " |.P2| FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) (MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) (MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) (MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) (MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) (MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) (MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) ) (DEFINEQ (UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) (UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) ) (RPAQQ TABLE.TO.NOTICED ((BIND (- (- (- (- (+ BIND ARG) REF) SMASH) SET) TEST)) (REFFREE (- (- (- REFFREE SETFREE) SMASHFREE) TESTFREE)) (REF (- (- (- REF SET) SMASH) TEST)) (PREDICATE (- PREDICATE CALL)) (EFFECT (- (- EFFECT CALL) PREDICATE)) (CALL (- CALL NLAMBDA)) (0 TYPE) (APPLY (+ APPLY STACK)) (ARGS ARG))) (DEFINEQ (MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) ) (RPAQQ MSFILELST NIL) (RPAQQ MSOPENFILES NIL) (RPAQQ MSPRINTFLG %.) (RPAQQ MSPRINTCNT 0) (ADDTOVAR MSHASHFILE ) (ADDTOVAR ANALYZEUSERFNS ) (RPAQQ MSAUXCOMS ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) (ADDVARS (DESCRIBELST)) (GLOBALVARS DESCRIBELST)) (COMS (FNS MSPRINTHELPFILE) (VARS MSHELPFILE)) (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) (FILEPKGCOMS TEMPLATES)) (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (INITVARS (MSCHECKFNS NIL)) (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) (DEFINEQ (MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) (MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) (FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) ) (ADDTOVAR DESCRIBELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DESCRIBELST) ) (DEFINEQ (MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) ) (RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) (DEFINEQ (TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) (GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) (SETTEMPLATE [LAMBDA (FN TEMPLATE) (* lmm "16-FEB-78 14:56") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) ) (PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (P * (MAPCAR 'X (FUNCTION (LAMBDA (FN) (LIST 'SETTEMPLATE (KWOTE FN) (KWOTE (GETTEMPLATE FN] CONTENTS NILL) (TYPE DESCRIPTION "masterscope templates"))) (DEFINEQ (ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) (MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) (MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) (MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) (MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) ) (RPAQ? MSCHECKFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) ) (RPAQQ MSDBCOMS [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) (ADDVARS (MSCHANGEDARRAY) (MSDATABASELST)) (INITVARS (MSDBEMPTY T)) (VARS MSDATABASEINIT NODUMPRELATIONS) (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) [P (MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (FNS MSVBTABLES MSUSERVBTABLES) (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) (MSANALYZEFNS (MAKETABLE 2))) (FNS BUILDGETRELQ BUILDTESTRELQ) (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) (COMS (FNS MSERASE)) (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) (VARS DATABASECOMS)) (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) (DEFINEQ (MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) (MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) (GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) (STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) ) (ADDTOVAR MSCHANGEDARRAY ) (ADDTOVAR MSDATABASELST ) (RPAQ? MSDBEMPTY T) (RPAQQ MSDATABASEINIT ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] (NOBIND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) (REPLACE 10 . 10) (REFFREE 10 . 1) (REF 10 . 25) (SETFREE 1 . 1) (SET 20 . 30) (SMASHFREE 1 . 1) (SMASH 1 . 1) (PROP 1 . 1) (TEST 1 . 1) (TESTFREE 1 . 1) (PREDICATE 10 . 10) (EFFECT 10 . 10) (CLISP 10 . 10) (SPECVARS 10 . 10) (LOCALVARS 10 . 10) (APPLY 10 . 10) (ERROR 10 . 10) (LOCALFREEVARS 10 . 10) (CONTAINS 10 . 10) (FILE 10) (ARGS 10) (USERTEMPLATES NIL . T) (0 10 . 10) (FPTYPE 10 . 10) (KEYACCEPT 2 . 2) (KEYSPECIFY 2 . 2) (KEYCALL 2 . 2) (FLET 2 . 2) (LABEL 2 . 2) (MACROLET 2 . 2) (COMPILER-LET 2 . 2) (SENDNOTSELF 2 . 2) (SENDSELF 2 . 2) (IMPLEMENT 2 . 2) (GETNOTSELF 2 . 2) (GETSELF 2 . 2) (GETCVSELF 2 . 2) (GETCVNOTSELF 2 . 2) (PUTNOTSELF 2 . 2) (PUTSELF 2 . 2) (PUTCVSELF 2 . 2) (PUTCVNOTSELF 2 . 2) (OBJECT 2 . 2))) (RPAQQ NODUMPRELATIONS (CONTAINS FILE)) (DEFINEQ (PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) (GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) (MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) (TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) ) (DEFINEQ (ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) (SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) (MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) (MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) (EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) ) [MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (DEFINEQ (MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) (MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) ) (RPAQ? MSUSERVBTABLES (MAKETABLE 2)) (RPAQ? MSANALYZEFNS (MAKETABLE 2)) (DEFINEQ (BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) (BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) (PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) ) ) (DEFINEQ (MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) ) (DEFINEQ (DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) (DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) (READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) ) (RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) (ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) (RPAQQ MSCHECKBLOCKSCOMS ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT) (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP)))) (DEFINEQ (MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) (MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) (MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) (MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [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)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) (MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) (GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) (PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) (MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) (UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) (NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) (SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) (SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) (DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) (MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP) ) (RPAQQ MSPATHSCOMS [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T]) (DEFINEQ (MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) (MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) (MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) (MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) (MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) (DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) (DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) (BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) (MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T)) ) (DEFINEQ (MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSEDITE [LAMBDA ARGCOUNT (* ; "Edited 24-Oct-2018 16:25 by rmk:") (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (OR (ARG ARGCOUNT 3) 'FNS)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) (EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) ) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." ) (RPAQ? MSFNTYPES '((FNS FNS GETDEF))) (* ; "SCRATCHASH") (RPAQ? MSCRATCHASH ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) ([LAMBDA (ARRAYNAME) (SETQ MSCRATCHASH) (PROG1 (PROGN . FORMS) (SETQ MSCRATCHASH ARRAYNAME] (COND (MSCRATCHASH (CLRHASH MSCRATCHASH) MSCRATCHASH) (T (HASHARRAY 20 (FUNCTION MSREHASH]) ) ) (* ; "marking changed") (DEFINEQ (MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) (CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) (CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) (CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) (CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) (MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) (UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) ) (ADDTOVAR COMPILE.TIME.CONSTANTS ) (RPAQQ RECORDCHANGEFN CHANGERECORD) (RPAQ? CHECKUNSAVEFLG T) (RPAQ? MSNEEDUNSAVE ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (* ; "interactive routines") (RPAQ MASTERSCOPEDATE "19-Sep-2020") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ (%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) (MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) (MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) (MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) (* ; "Interpreting commands") (DEFINEQ (MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) (MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) (MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) (LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) (MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) (MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) (MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) (MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) (CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) (ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) ) (DEFINEQ (MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) (VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) (MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) (MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) (CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) (MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GETHASH (ID HTABLE . BADMARKS) ID _ 'GETHASH) (RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) ID _ 'INRELATION) (ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH MARKING) (* CHECKPATHS assumes that this is  an ASSOCRECORD) ) (RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) ) ) (FILESLOAD MSCOMMON) (DECLARE%: DONTCOPY (RPAQQ MSCOMPILETIME [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T))) (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) (DECLARE%: EVAL@COMPILE (P (CLISPDEC 'FAST]) [MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) ) (DECLARE%: EVAL@COMPILE (CLISPDEC 'FAST) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %.) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) ) (PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1994 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3560 20208 (UPDATEFN 3570 . 5064) (MSEDITF 5066 . 6066) (MSGETDEF 6068 . 7474) ( MSNOTICEFILE 7476 . 9869) (MSSHOWUSE 9871 . 15374) (MSUPDATEFN1 15376 . 16064) (MSUPDATE 16066 . 18492 ) (MSNLAMBDACHECK 18494 . 19376) (MSCOLLECTDATA 19378 . 20206)) (20209 21108 (UPDATECHANGED 20219 . 20582) (UPDATECHANGED1 20584 . 21106)) (21682 22105 (MSCLOSEFILES 21692 . 22103)) (22786 27218 ( MSDESCRIBE 22796 . 25584) (MSDESCRIBE1 25586 . 26649) (FMAPRINT 26651 . 27216)) (27311 27751 ( MSPRINTHELPFILE 27321 . 27749)) (27801 30901 (TEMPLATE 27811 . 29232) (GETTEMPLATE 29234 . 29369) ( SETTEMPLATE 29371 . 30899)) (31771 36695 (ADDTEMPLATEWORD 31781 . 32453) (MSADDANALYZE 32455 . 33953) (MSADDMODIFIER 33955 . 35036) (MSADDRELATION 35038 . 35785) (MSADDTYPE 35787 . 36693)) (38196 43417 ( MSMARKCHANGE1 38206 . 39000) (MSINIT 39002 . 40183) (GETVERBTABLES 40185 . 40738) (MSSTOREDATA 40740 . 42419) (STORETABLE 42421 . 43415)) (44818 49888 (PARSERELATION 44828 . 45428) (PARSERELATION1 45430 . 46885) (GETRELATION 46887 . 47916) (MAPRELATION 47918 . 49052) (TESTRELATION 49054 . 49886)) (49889 51529 (ADDHASH 49899 . 50377) (SUBHASH 50379 . 50607) (MAKEHASH 50609 . 50753) (MSREHASH 50755 . 51208) (EQMEMBHASH 51210 . 51527)) (51868 58083 (MSVBTABLES 51878 . 57657) (MSUSERVBTABLES 57659 . 58081)) (58166 60377 (BUILDGETRELQ 58176 . 59282) (BUILDTESTRELQ 59284 . 60375)) (60548 60936 (MSERASE 60558 . 60934)) (60937 64169 (DUMPDATABASE 60947 . 62284) (DUMPDATABASE1 62286 . 62631) (READATABASE 62633 . 64167)) (65251 94310 (MSCHECKBLOCKS 65261 . 69081) (MSCHECKBLOCK 69083 . 77703) ( MSCHECKFNINBLOCK 77705 . 80705) (MSCHECKBLOCKBASIC 80707 . 83127) (MSCHECKBOUNDFREE 83129 . 85028) ( GLOBALVARP 85030 . 85197) (PRINTERROR 85199 . 88415) (MSCHECKVARS1 88417 . 91370) (UNECCSPEC 91372 . 91650) (NECCSPEC 91652 . 91999) (SPECVARP 92001 . 92528) (SHORTLST 92530 . 92986) (DOERROR 92988 . 93698) (MSMSGPRINT 93700 . 94308)) (95454 110282 (MSPATHS 95464 . 98866) (MSPATHS1 98868 . 103103) ( MSPATHS2 103105 . 106515) (MSONPATH 106517 . 107745) (MSPATHS4 107747 . 108829) (DASHES 108831 . 109357) (DOTABS 109359 . 109600) (BELOWMARKER 109602 . 110065) (MSPATHSPRINTFN 110067 . 110280)) ( 110668 114092 (MSFIND 110678 . 110953) (MSEDITF 110955 . 111955) (MSEDITE 111957 . 112994) (EDITGETDEF 112996 . 114090)) (115098 123699 (MSMARKCHANGED 115108 . 116832) (CHANGEMACRO 116834 . 117539) ( CHANGEVAR 117541 . 117857) (CHANGEI.S. 117859 . 119192) (CHANGERECORD 119194 . 120065) (MSNEEDUNSAVE 120067 . 121059) (UNSAVEFNS 121061 . 123697)) (124140 127630 (%. 124150 . 124290) (MASTERSCOPE 124292 . 124818) (MASTERSCOPE1 124820 . 125688) (MASTERSCOPEXEC 125690 . 127628)) (127669 165328 ( MSINTERPRETSET 127679 . 155172) (MSINTERPA 155174 . 155708) (MSGETBLOCKDEC 155710 . 158223) (LISTHARD 158225 . 159443) (MSMEMBSET 159445 . 159590) (MSLISTSET 159592 . 159957) (MSHASHLIST 159959 . 160126) (MSHASHLIST1 160128 . 160454) (CHECKPATHS 160456 . 161096) (ONFILE 161098 . 165326)) (165329 188495 ( MSINTERPRET 165339 . 182192) (VERBNOTICELIST 182194 . 183304) (MSOUTPUT 183306 . 183623) (MSCHECKEMPTY 183625 . 184829) (CHECKFORCHANGED 184831 . 185351) (MSSOLVE 185353 . 188493))))) STOP \ No newline at end of file diff --git a/library/MASTERSCOPE.~4~ b/library/MASTERSCOPE.~4~ deleted file mode 100644 index ca13170e..00000000 --- a/library/MASTERSCOPE.~4~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Sep-2020 09:54:51"  {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;4 194460 changes to%: (VARS MSCOMPILETIME MASTERSCOPECOMS) previous date%: "24-Oct-2018 16:25:58" {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1994, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MASTERSCOPECOMS) (RPAQQ MASTERSCOPECOMS [ (* ;; "Main file for MASTERSCOPE.") (FILES MSPARSE MSANALYZE) (PROP FILETYPE MASTERSCOPE) (COMS * MSDATABASECOMS) (COMS * MSAUXCOMS) (COMS * MSDBCOMS) (COMS * MSCHECKBLOCKSCOMS) (COMS * MSPATHSCOMS) [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) (VARS MSBLIP) (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") [INITVARS (MSFNTYPES '((FNS FNS GETDEF] (COMS (* ; "SCRATCHASH") (INITVARS (MSCRATCHASH)) (DECLARE%: DONTCOPY (MACROS SCRATCHASH] (COMS (* ; "marking changed") (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS ) (ADDVARS (COMPILE.TIME.CONSTANTS)) (VARS (RECORDCHANGEFN 'CHANGERECORD)) (INITVARS (CHECKUNSAVEFLG T) (MSNEEDUNSAVE))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) (COMS (* ; "interactive routines") [VARS * (LIST (LIST 'MASTERSCOPEDATE (DATE (DATEFORMAT NO.TIME] (ADDVARS (HISTORYCOMS %.)) (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) (* ; "Interpreting commands") (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST MSHASHLIST1 CHECKPATHS ONFILE) (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) (FILES MSCOMMON) (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) (NLAML) (LAMA MSEDITE MSEDITF MSEDITF]) (* ;; "Main file for MASTERSCOPE.") (FILESLOAD MSPARSE MSANALYZE) (PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) (RPAQQ MSDATABASECOMS ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK MSCOLLECTDATA) (FNS UPDATECHANGED UPDATECHANGED1) (VARS TABLE.TO.NOTICED) (FNS MSCLOSEFILES) (VARS (MSFILELST) (MSOPENFILES)) (VARS (MSPRINTFLG '%.) (MSPRINTCNT 0)) (ADDVARS (MSHASHFILE) (ANALYZEUSERFNS)))) (DEFINEQ (UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Update the analysis of a particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) ((NIL PRINT) (printout T "Sorry, the function " |.P2| FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) (MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) (MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) (MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) (MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) (MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) (MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) ) (DEFINEQ (UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) (UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) ) (RPAQQ TABLE.TO.NOTICED ((BIND (- (- (- (- (+ BIND ARG) REF) SMASH) SET) TEST)) (REFFREE (- (- (- REFFREE SETFREE) SMASHFREE) TESTFREE)) (REF (- (- (- REF SET) SMASH) TEST)) (PREDICATE (- PREDICATE CALL)) (EFFECT (- (- EFFECT CALL) PREDICATE)) (CALL (- CALL NLAMBDA)) (0 TYPE) (APPLY (+ APPLY STACK)) (ARGS ARG))) (DEFINEQ (MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) ) (RPAQQ MSFILELST NIL) (RPAQQ MSOPENFILES NIL) (RPAQQ MSPRINTFLG %.) (RPAQQ MSPRINTCNT 0) (ADDTOVAR MSHASHFILE ) (ADDTOVAR ANALYZEUSERFNS ) (RPAQQ MSAUXCOMS ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) (ADDVARS (DESCRIBELST)) (GLOBALVARS DESCRIBELST)) (COMS (FNS MSPRINTHELPFILE) (VARS MSHELPFILE)) (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) (FILEPKGCOMS TEMPLATES)) (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (INITVARS (MSCHECKFNS NIL)) (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) (DEFINEQ (MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) (MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) (FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) ) (ADDTOVAR DESCRIBELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DESCRIBELST) ) (DEFINEQ (MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) ) (RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) (DEFINEQ (TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) (GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) (SETTEMPLATE [LAMBDA (FN TEMPLATE) (* lmm "16-FEB-78 14:56") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) ) (PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (P * (MAPCAR 'X (FUNCTION (LAMBDA (FN) (LIST 'SETTEMPLATE (KWOTE FN) (KWOTE (GETTEMPLATE FN] CONTENTS NILL) (TYPE DESCRIPTION "masterscope templates"))) (DEFINEQ (ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) (MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) (MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) (MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) (MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) ) (RPAQ? MSCHECKFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) ) (RPAQQ MSDBCOMS [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) (ADDVARS (MSCHANGEDARRAY) (MSDATABASELST)) (INITVARS (MSDBEMPTY T)) (VARS MSDATABASEINIT NODUMPRELATIONS) (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) [P (MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (FNS MSVBTABLES MSUSERVBTABLES) (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) (MSANALYZEFNS (MAKETABLE 2))) (FNS BUILDGETRELQ BUILDTESTRELQ) (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) (COMS (FNS MSERASE)) (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) (VARS DATABASECOMS)) (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) (DEFINEQ (MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) (MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) (GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) (STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) ) (ADDTOVAR MSCHANGEDARRAY ) (ADDTOVAR MSDATABASELST ) (RPAQ? MSDBEMPTY T) (RPAQQ MSDATABASEINIT ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] (NOBIND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) (REPLACE 10 . 10) (REFFREE 10 . 1) (REF 10 . 25) (SETFREE 1 . 1) (SET 20 . 30) (SMASHFREE 1 . 1) (SMASH 1 . 1) (PROP 1 . 1) (TEST 1 . 1) (TESTFREE 1 . 1) (PREDICATE 10 . 10) (EFFECT 10 . 10) (CLISP 10 . 10) (SPECVARS 10 . 10) (LOCALVARS 10 . 10) (APPLY 10 . 10) (ERROR 10 . 10) (LOCALFREEVARS 10 . 10) (CONTAINS 10 . 10) (FILE 10) (ARGS 10) (USERTEMPLATES NIL . T) (0 10 . 10) (FPTYPE 10 . 10) (KEYACCEPT 2 . 2) (KEYSPECIFY 2 . 2) (KEYCALL 2 . 2) (FLET 2 . 2) (LABEL 2 . 2) (MACROLET 2 . 2) (COMPILER-LET 2 . 2) (SENDNOTSELF 2 . 2) (SENDSELF 2 . 2) (IMPLEMENT 2 . 2) (GETNOTSELF 2 . 2) (GETSELF 2 . 2) (GETCVSELF 2 . 2) (GETCVNOTSELF 2 . 2) (PUTNOTSELF 2 . 2) (PUTSELF 2 . 2) (PUTCVSELF 2 . 2) (PUTCVNOTSELF 2 . 2) (OBJECT 2 . 2))) (RPAQQ NODUMPRELATIONS (CONTAINS FILE)) (DEFINEQ (PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) (GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) (MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) (TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) ) (DEFINEQ (ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) (SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) (MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) (MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) (EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) ) [MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (DEFINEQ (MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) (MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) ) (RPAQ? MSUSERVBTABLES (MAKETABLE 2)) (RPAQ? MSANALYZEFNS (MAKETABLE 2)) (DEFINEQ (BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) (BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) (PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) ) ) (DEFINEQ (MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) ) (DEFINEQ (DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) (DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) (READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) ) (RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) (ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) (RPAQQ MSCHECKBLOCKSCOMS ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT) (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP)))) (DEFINEQ (MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) (MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) (MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) (MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [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)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) (MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) (GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) (PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) (MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) (UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) (NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) (SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) (SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) (DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) (MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP) ) (RPAQQ MSPATHSCOMS [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T]) (DEFINEQ (MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) (MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) (MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) (MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) (MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) (DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) (DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) (BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) (MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T)) ) (DEFINEQ (MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSEDITE [LAMBDA ARGCOUNT (* ; "Edited 24-Oct-2018 16:25 by rmk:") (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (OR (ARG ARGCOUNT 3) 'FNS)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) (EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) ) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." ) (RPAQ? MSFNTYPES '((FNS FNS GETDEF))) (* ; "SCRATCHASH") (RPAQ? MSCRATCHASH ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) ([LAMBDA (ARRAYNAME) (SETQ MSCRATCHASH) (PROG1 (PROGN . FORMS) (SETQ MSCRATCHASH ARRAYNAME] (COND (MSCRATCHASH (CLRHASH MSCRATCHASH) MSCRATCHASH) (T (HASHARRAY 20 (FUNCTION MSREHASH]) ) ) (* ; "marking changed") (DEFINEQ (MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) (CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) (CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) (CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) (CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) (MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) (UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) ) (ADDTOVAR COMPILE.TIME.CONSTANTS ) (RPAQQ RECORDCHANGEFN CHANGERECORD) (RPAQ? CHECKUNSAVEFLG T) (RPAQ? MSNEEDUNSAVE ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (* ; "interactive routines") (RPAQ MASTERSCOPEDATE "19-Sep-2020") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ (%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) (MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) (MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) (MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) (* ; "Interpreting commands") (DEFINEQ (MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) (MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) (MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) (LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) (MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) (MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) (MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) (MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) (CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) (ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) ) (DEFINEQ (MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) (VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) (MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) (MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) (CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) (MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GETHASH (ID HTABLE . BADMARKS) ID _ 'GETHASH) (RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) ID _ 'INRELATION) (ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH MARKING) (* CHECKPATHS assumes that this is  an ASSOCRECORD) ) (RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) ) ) (FILESLOAD MSCOMMON) (DECLARE%: DONTCOPY (RPAQQ MSCOMPILETIME [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T))) (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) (DECLARE%: EVAL@COMPILE (FILES (LOADCOMP) SEDIT-DECLS MSPARSE) (P (CLISPDEC 'FAST]) [MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) ) (DECLARE%: EVAL@COMPILE (FILESLOAD (LOADCOMP) SEDIT-DECLS MSPARSE) (CLISPDEC 'FAST) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %.) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) ) (PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1994 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3574 20222 (UPDATEFN 3584 . 5078) (MSEDITF 5080 . 6080) (MSGETDEF 6082 . 7488) ( MSNOTICEFILE 7490 . 9883) (MSSHOWUSE 9885 . 15388) (MSUPDATEFN1 15390 . 16078) (MSUPDATE 16080 . 18506 ) (MSNLAMBDACHECK 18508 . 19390) (MSCOLLECTDATA 19392 . 20220)) (20223 21122 (UPDATECHANGED 20233 . 20596) (UPDATECHANGED1 20598 . 21120)) (21696 22119 (MSCLOSEFILES 21706 . 22117)) (22800 27232 ( MSDESCRIBE 22810 . 25598) (MSDESCRIBE1 25600 . 26663) (FMAPRINT 26665 . 27230)) (27325 27765 ( MSPRINTHELPFILE 27335 . 27763)) (27815 30915 (TEMPLATE 27825 . 29246) (GETTEMPLATE 29248 . 29383) ( SETTEMPLATE 29385 . 30913)) (31785 36709 (ADDTEMPLATEWORD 31795 . 32467) (MSADDANALYZE 32469 . 33967) (MSADDMODIFIER 33969 . 35050) (MSADDRELATION 35052 . 35799) (MSADDTYPE 35801 . 36707)) (38210 43431 ( MSMARKCHANGE1 38220 . 39014) (MSINIT 39016 . 40197) (GETVERBTABLES 40199 . 40752) (MSSTOREDATA 40754 . 42433) (STORETABLE 42435 . 43429)) (44832 49902 (PARSERELATION 44842 . 45442) (PARSERELATION1 45444 . 46899) (GETRELATION 46901 . 47930) (MAPRELATION 47932 . 49066) (TESTRELATION 49068 . 49900)) (49903 51543 (ADDHASH 49913 . 50391) (SUBHASH 50393 . 50621) (MAKEHASH 50623 . 50767) (MSREHASH 50769 . 51222) (EQMEMBHASH 51224 . 51541)) (51882 58097 (MSVBTABLES 51892 . 57671) (MSUSERVBTABLES 57673 . 58095)) (58180 60391 (BUILDGETRELQ 58190 . 59296) (BUILDTESTRELQ 59298 . 60389)) (60562 60950 (MSERASE 60572 . 60948)) (60951 64183 (DUMPDATABASE 60961 . 62298) (DUMPDATABASE1 62300 . 62645) (READATABASE 62647 . 64181)) (65265 94324 (MSCHECKBLOCKS 65275 . 69095) (MSCHECKBLOCK 69097 . 77717) ( MSCHECKFNINBLOCK 77719 . 80719) (MSCHECKBLOCKBASIC 80721 . 83141) (MSCHECKBOUNDFREE 83143 . 85042) ( GLOBALVARP 85044 . 85211) (PRINTERROR 85213 . 88429) (MSCHECKVARS1 88431 . 91384) (UNECCSPEC 91386 . 91664) (NECCSPEC 91666 . 92013) (SPECVARP 92015 . 92542) (SHORTLST 92544 . 93000) (DOERROR 93002 . 93712) (MSMSGPRINT 93714 . 94322)) (95468 110296 (MSPATHS 95478 . 98880) (MSPATHS1 98882 . 103117) ( MSPATHS2 103119 . 106529) (MSONPATH 106531 . 107759) (MSPATHS4 107761 . 108843) (DASHES 108845 . 109371) (DOTABS 109373 . 109614) (BELOWMARKER 109616 . 110079) (MSPATHSPRINTFN 110081 . 110294)) ( 110682 114106 (MSFIND 110692 . 110967) (MSEDITF 110969 . 111969) (MSEDITE 111971 . 113008) (EDITGETDEF 113010 . 114104)) (115112 123713 (MSMARKCHANGED 115122 . 116846) (CHANGEMACRO 116848 . 117553) ( CHANGEVAR 117555 . 117871) (CHANGEI.S. 117873 . 119206) (CHANGERECORD 119208 . 120079) (MSNEEDUNSAVE 120081 . 121073) (UNSAVEFNS 121075 . 123711)) (124154 127644 (%. 124164 . 124304) (MASTERSCOPE 124306 . 124832) (MASTERSCOPE1 124834 . 125702) (MASTERSCOPEXEC 125704 . 127642)) (127683 165342 ( MSINTERPRETSET 127693 . 155186) (MSINTERPA 155188 . 155722) (MSGETBLOCKDEC 155724 . 158237) (LISTHARD 158239 . 159457) (MSMEMBSET 159459 . 159604) (MSLISTSET 159606 . 159971) (MSHASHLIST 159973 . 160140) (MSHASHLIST1 160142 . 160468) (CHECKPATHS 160470 . 161110) (ONFILE 161112 . 165340)) (165343 188509 ( MSINTERPRET 165353 . 182206) (VERBNOTICELIST 182208 . 183318) (MSOUTPUT 183320 . 183637) (MSCHECKEMPTY 183639 . 184843) (CHECKFORCHANGED 184845 . 185365) (MSSOLVE 185367 . 188507))))) STOP \ No newline at end of file diff --git a/library/NSMAINTAIN.~1~ b/library/NSMAINTAIN.~1~ deleted file mode 100644 index bb81cffb..00000000 --- a/library/NSMAINTAIN.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 10:29:28" {DSK}local>lde>lispcore>library>NSMAINTAIN.;3 46263 changes to%: (FILES DES) (VARS NSMAINTAINCOMS) previous date%: "21-Aug-89 18:30:21" {DSK}local>lde>lispcore>library>NSMAINTAIN.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSMAINTAINCOMS) (RPAQQ NSMAINTAINCOMS ((COMS (* ; "Main entry and utility fns") (FNS NSMAINTAIN \NSMT.HELP \NSMT.READFNAME \NSMT.LOOKUP \NSMT.COLLECT.NAMES \NSMT.GET.REMARK \NSMT.GET.PASSWORD \NSMT.LOGIN \NSMT.CHANGE.DOMAIN \NSMT.PRINT.LIST \NSMT.PRINT.OBJECTS \NSMT.PROCESS.LIST \NSMT.SHOW.RESULT)) (COMS (* ; "Ordinary user commands") (FNS \NSMT.CHANGE.PASSWORD \NSMT.DESCRIBE.GROUP \NSMT.DESCRIBE.OBJECT \NSMT.DESCRIBE.PROPERTY \NSMT.LIST.OBJECTS \NSMT.LIST.CLEARINGHOUSES \NSMT.LIST.SERVERS \NSMT.SHOW.DETAILS \NSMT.GROUP.FILTER \NSMT.LIST.ADMINISTRATORS \NSMT.LIST.DOMAINS \NSMT.TYPE.ENTRY \NSMT.TYPE.MEMBERS)) (COMS (* ; "Administrator commands") (FNS \NSMT.ADD.ALIAS \NSMT.ADD.GROUP \NSMT.ADD.USER \NSMT.CHANGE.ADMINISTRATORS \NSMT.CHANGE.FORWARDING \NSMT.CHANGE.GROUP.COMPONENT \NSMT.CHANGE.REMARK \NSMT.DESCRIPTIVE.PROPS \NSMT.REMOVE.ALIAS \NSMT.REMOVE.OBJECT \NSMT.REMOVE.USER)) (FILES (SYSLOAD) DES AUTHENTICATION) (VARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM*) (ADDVARS (CH.PROPERTIES (ALIAS 1)) (*NSMAINTAIN-DESCRIPTIVE-PROPERTIES* 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10023 10024) (*NSMAINTAIN-IGNORE-PROPERTIES* 6 7 10027 20003 20002 20101) (*NSMAINTAIN-PROPERTY-FORMATS* (4 CLEARINGHOUSE . NETWORK.ADDRESS.LIST) (8 RECORD (SIMPLE BOOLEAN) (STRONG BOOLEAN)) (30 . NSNAME) (31 CLEARINGHOUSE . MAILBOX.VALUES) (10000 . STRING) (10001 . STRING) (10002 . STRING) (10003 . STRING) (10004 . STRING) (10005 . STRING) (10006 . STRING) (10007 . STRING) (10008 . STRING) (10009 . STRING) (10010 . STRING) (10011 . STRING) (10012 . STRING) (10013 . STRING) (10014 . STRING) (10015 . STRING) (10016 . STRING) (10017 . STRING) (10018 . STRING) (10019 . STRING) (10020 . STRING) (10021 . STRING) (10022 . STRING) (10023 . STRING) (10024 . STRING) (10029 . STRING) (10030 . STRING) (10032 . STRING) (10034 . STRING) (10035 . STRING) (15002 . STRING) (20000 CLEARINGHOUSE . USERDATA.VALUE) (20001 GAP . RS232CData) (20006 SEQUENCE NSNAME) (20007 . NSNAME) (20102 GAP . RS232CBack) (29965 . STRING) (30005 . NSNAME)) (*NSMAINTAIN-MEMBER-PROPERTIES* 20006)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM* *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* *NSMAINTAIN-IGNORE-PROPERTIES* *NSMAINTAIN-PROPERTY-FORMATS* *NSMAINTAIN-MEMBER-PROPERTIES* CH.PROPERTIES) [P (CL:PROCLAIM '(CL:SPECIAL *USER* *LASTDOMAIN* *LASTNAME* *LASTGROUP* *LASTLIST* *LASTSTRING* *SERVERTYPES* *ALLTYPES* *DEFAULTDOMAIN* *REAL-NAME-CACHE*] (LOCALVARS . T)))) (* ; "Main entry and utility fns") (DEFINEQ (NSMAINTAIN (LAMBDA NIL (* ; "Edited 21-Aug-89 16:36 by bvm") (PROG ((*STANDARD-OUTPUT* (\GETSTREAM T (QUOTE OUTPUT))) (CREDS (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) (*REAL-NAME-CACHE* (HASHARRAY 10 NIL (FUNCTION (LAMBDA (OBJECT) (* ; "Use first part of name to produce hash bits") (STRING-EQUAL-HASHBITS (fetch NSOBJECT of OBJECT)))) (FUNCTION EQUAL.CH.NAMES))) *USER* *LASTNAME* *DEFAULTDOMAIN* *LASTDOMAIN* *LASTGROUP* *LASTSTRING* *LASTLIST* *SERVERTYPES* *ALLTYPES* FULLNAME) (* ; "*STANDARD-OUTPUT* setting is to make sure T for FORMAT and PRINTOUT are the same (yecch).") (SETQ FULLNAME (CH.LOOKUP.OBJECT (SETQ *USER* (PARSE.NSNAME (CAR CREDS))))) (CL:FORMAT T "[Default login: ~A~:[ (not a valid name)~;~];~%% Default domain: ~A]~%%" (NSNAME.TO.STRING (OR FULLNAME *USER*) T) FULLNAME (NSNAME.TO.STRING (SETQ *LASTDOMAIN* (SETQ *DEFAULTDOMAIN* (create NSNAME NSDOMAIN _ CH.DEFAULT.DOMAIN NSORGANIZATION _ CH.DEFAULT.ORGANIZATION))) T)) (if (AND (SETQ *LASTNAME* FULLNAME) (NOT (EQUAL.CH.NAMES *USER* FULLNAME))) then (* ; "Canonical name different from current login, so be helpful and canonize") (RPLACA CREDS (NSNAME.TO.STRING (SETQ *LASTNAME* (SETQ *USER* FULLNAME)) T))) (NILL (SETQ CREDS NIL)) (* ; "Just to avoid leaving these on the stack (NILL so compiler doesn't throw it away)") (do (TERPRI T) repeatwhile (NULL (ERSETQ (bind CMD while (SETQ CMD (ASKUSER NIL NIL "CH: " *NSMAINTAIN-COMMANDS* T NIL (QUOTE (AUTOCOMPLETEFLG T)))) do (COND ((LISTP CMD) (APPLY (CAR CMD) (CDR CMD))) (T (CL:FUNCALL CMD))) (TERPRI T))))))) ) (\NSMT.HELP (LAMBDA NIL (* ; "Edited 21-Aug-89 18:14 by bvm") (* ;; "Give more compact help than ASKUSER's default") (PRINTOUT T T T " You need type only the initial letters of most command words. Use Control-E to abort a command." T T) (LET ((LINELEN (LINELENGTH NIL T)) *LASTSTRING* LASTN EXPLAINSTRING UNPRINTED CMD LEN TAB) (for ITEM in *NSMAINTAIN-COMMANDS* unless (EQ (CHCON1 (SETQ CMD (CAR ITEM))) (CHARCODE ?)) do (* ; "Handle all commands but ?") (if (AND (NOT (SETQ EXPLAINSTRING (LISTGET ITEM (QUOTE EXPLAINSTRING)))) *LASTSTRING* (> (SETQ LEN (NCHARS CMD)) LASTN) (STRING-EQUAL *LASTSTRING* CMD :END1 LASTN :END2 LASTN)) then (* ; "This command has same prefix as previous one") (if UNPRINTED then (PRINTOUT T (SUBSTRING *LASTSTRING* 1 LASTN) "{" (SUBSTRING *LASTSTRING* (ADD1 LASTN))) (SETQ UNPRINTED NIL) (SETQ TAB (ADD1 (POSITION T))) (* ; "An aesthetically pleasing tab stop puts command directly under next command")) (PRIN1 "," T) (if (> (+ (POSITION T) (- LEN LASTN) 3) LINELEN) then (* ; "No room left on this line, so tab to reasonable place.") (TERPRI T) (TAB TAB NIL T)) (PRIN1 (SUBSTRING CMD LASTN) T) else (* ; "New prefix.") (if *LASTSTRING* then (* ; "Clean up previous command") (PRINTOUT T (if UNPRINTED then *LASTSTRING* else "}") T)) (if EXPLAINSTRING then (* ; "Explicit thing here for ?") (PRINTOUT T EXPLAINSTRING T) (SETQ *LASTSTRING* NIL) elseif (SETQ LASTN (STRPOS " " CMD)) then (SETQ *LASTSTRING* CMD) (SETQ UNPRINTED T) else (PRINTOUT T CMD T) (SETQ *LASTSTRING* NIL)))) (if *LASTSTRING* then (* ; "Take care of the last line") (PRINTOUT T (if UNPRINTED then *LASTSTRING* else "}") T)))) ) (\NSMT.READFNAME (LAMBDA (PROMPT DEFAULT DOMAINFLG ...FLG CHECK *OK) (* ; "Edited 21-Aug-89 17:31 by bvm") (PROG ((COLON ":") NAME COLPOS FULLNAME REALNAME) RETRY (COND ((NULL (SETQ NAME (PROMPTFORWORD PROMPT (COND ((AND DEFAULT (TYPENAMEP DEFAULT (QUOTE NSNAME))) (* ; "Make it fully qualified") (NSNAME.TO.STRING DEFAULT T)) (T DEFAULT)) NIL T NIL NIL (CHARCODE (EOL))))) (printout T " xxx" T) (* ; "aborted") (RETURN NIL))) (SETQ FULLNAME (COND ((AND (SETQ COLPOS (STRPOS COLON NAME)) (NEQ COLPOS (NCHARS NAME))) (SETQ COLPOS (STRPOS COLON NAME (ADD1 COLPOS))) (* ; "Find second colon") (COND (DOMAINFLG (* ; "Wants domain name--a 2-part name") (COND (COLPOS (* ; "too many colons") (PRINTOUT T " Invalid domain" T) (RETURN NIL)) (T (PARSE.NSNAME NAME 2 *DEFAULTDOMAIN*)))) (T (COND ((NOT COLPOS) (* ; "Org defaulted") (printout T COLON (fetch NSORGANIZATION of *DEFAULTDOMAIN*))) ((EQ COLPOS (NCHARS NAME)) (* ; "Trailing colon after domain") (printout T (fetch NSORGANIZATION of *DEFAULTDOMAIN*)))) (PARSE.NSNAME NAME 3 *DEFAULTDOMAIN*)))) (T (* ; "Completely unqualified (or only a trailing colon)") (COND (COLPOS (* ; "User typed, e.g., %"Fred:%"") (SETQ NAME (SUBSTRING NAME 1 -2))) (T (PRIN1 COLON T))) (COND (DOMAINFLG (printout T (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) (create NSNAME using *DEFAULTDOMAIN* NSDOMAIN _ NAME)) (T (printout T (fetch NSDOMAIN of *DEFAULTDOMAIN*) COLON (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) (create NSNAME using *DEFAULTDOMAIN* NSOBJECT _ NAME)))))) (COND ((STRPOS "*" NAME) (COND ((SELECTQ *OK (:ANY (* ; "Any old * is ok") NIL) (NIL (* ; "No * is ok") T) (PROGN (* ; "* permitted in first part only") (OR (STRPOS "*" (fetch NSORGANIZATION of FULLNAME)) (AND (NOT DOMAINFLG) (STRPOS "*" (fetch NSDOMAIN of FULLNAME)))))) (PRINTOUT T " ... Invalid use of *" T) (SETQ DEFAULT FULLNAME) (GO RETRY)))) (CHECK (* ; "Canonicalize the name") (SETQ REALNAME (\NSMT.LOOKUP FULLNAME)) (COND ((NULL REALNAME) (COND ((EQ CHECK :OK) (printout T " (non-existent name)")) (T (printout T " ... No such name.") (COND ((NOT (COND ((NEQ CHECK :CONFIRM) (* ; "Must be valid name") (TERPRI T) NIL) (T (* ; "Accept non-names") (CL:Y-OR-N-P " Use it anyway? ")))) (SETQ DEFAULT FULLNAME) (GO RETRY)))))) ((NOT (EQUAL.CH.NAMES FULLNAME REALNAME)) (* ; " show real name") (printout T " = " (NSNAME.TO.STRING (SETQ FULLNAME REALNAME) T)))))) (COND (...FLG (PRIN1 " ... " T))) (RETURN FULLNAME))) ) (\NSMT.LOOKUP (LAMBDA (NAME) (* ; "Edited 21-Aug-89 17:31 by bvm") (* ;; "Like CH.LOOKUP.OBJECT but caches results (well, at least the positive ones).") (OR (TYPEP NAME (QUOTE NSNAME)) (SETQ NAME (PARSE.NSNAME NAME))) (LET ((CACHE (GETHASH NAME *REAL-NAME-CACHE*)) FULLNAME) (if CACHE then (if (EQ CACHE T) then NIL else CACHE) elseif (SETQ FULLNAME (CH.LOOKUP.OBJECT NAME)) then (PUTHASH NAME FULLNAME *REAL-NAME-CACHE*) FULLNAME))) ) (\NSMT.COLLECT.NAMES (LAMBDA (PROMPT CHECK *OK) (* ; "Edited 14-Aug-87 15:14 by bvm:") (* ;; "Prompt for an arbitrary number of names. CHECK and *OK are the corresponding args to \nsmt.readfname.") (bind NAME while (SETQ NAME (PROGN (TERPRI T) (\NSMT.READFNAME PROMPT NIL NIL NIL CHECK *OK))) collect NAME)) ) (\NSMT.GET.REMARK (LAMBDA (DEFAULT) (* ; "Edited 11-Aug-87 12:24 by bvm:") (* ;; "Prompt for a remark (an arbitrary string used to describe an object). DEFAULT if any is usually the previous remark.") (PROMPTFORWORD "Remark (terminate with CR):" DEFAULT NIL T NIL NIL (CHARCODE (CR)))) ) (\NSMT.GET.PASSWORD (LAMBDA (PROMPT) (* ; "Edited 11-Aug-87 13:39 by bvm:") (* ;; "Read a password, prompting with PROMPT. Ask user to retry password to verify that it was typed correctly. Loop if the retype mismatches the original. Return NIL if user declines to enter a password in the first place.") (PROG (PASS) LP (COND ((NULL (SETQ PASS (PROMPTFORWORD PROMPT NIL NIL T (QUOTE *)))) (RETURN NIL)) ((STREQUAL PASS (PROMPTFORWORD " (retype password)" NIL NIL T (QUOTE *))) (RETURN PASS)) (T (PRINTOUT T T "Mismatch. Try again." T) (SETQ PROMPT "Password:") (GO LP))))) ) (\NSMT.LOGIN (LAMBDA NIL (* ; "Edited 18-Aug-89 17:20 by bvm") (bind LOGINFO FULLNAME until (OR (NULL (SETQ LOGINFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|) T))) (COND ((SETQ FULLNAME (CH.LOOKUP.OBJECT (SETQ *USER* (PARSE.NSNAME (CAR LOGINFO) 3 *DEFAULTDOMAIN*)))) (RPLACA LOGINFO (NSNAME.TO.STRING (SETQ *USER* FULLNAME) T)) (* ; "Make login canonical") (\NSMT.SHOW.RESULT (NS.AUTHENTICATE (NS.MAKE.SIMPLE.CREDENTIALS LOGINFO)))) (T (CL:FORMAT T " Invalid name ~A~%%" (NSNAME.TO.STRING *USER* T)) NIL))))) ) (\NSMT.CHANGE.DOMAIN (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " (for name entry) to be:" *DEFAULTDOMAIN* T))) (COND (DOMAIN (TERPRI T) (COND ((CL:Y-OR-N-P "Set this default globally as well (i.e. for use outside Maintain)? ") (SETQ CH.DEFAULT.DOMAIN (fetch NSDOMAIN of DOMAIN)) (SETQ CH.DEFAULT.ORGANIZATION (fetch NSORGANIZATION of DOMAIN)))) (SETQ *LASTDOMAIN* (SETQ *DEFAULTDOMAIN* DOMAIN)))))) ) (\NSMT.PRINT.LIST (LAMBDA (LST PREFIX) (* ; "Edited 27-Jul-87 13:10 by bvm:") (COND ((EQ (CAR LST) (QUOTE ERROR)) (\NSMT.SHOW.RESULT LST)) (T (COND (PREFIX (PRINTOUT T .FONT BOLDFONT PREFIX .FONT DEFAULTFONT))) (COND ((NULL LST) (PRINTOUT T "(none)")) (T (MAPRINT LST T NIL NIL ", "))) (TERPRI T)))) ) (\NSMT.PRINT.OBJECTS (LAMBDA (OBJECTS) (* ; "Edited 18-Aug-89 17:12 by bvm") (for OBJ in OBJECTS bind *LASTDOMAIN* LASTORG do (COND ((AND *LASTDOMAIN* (STRING-EQUAL (fetch NSDOMAIN of OBJ) *LASTDOMAIN*) (STRING-EQUAL (fetch NSORGANIZATION of OBJ) LASTORG)) (PRINTOUT T ", ")) (T (PRINTOUT T T "[In " .FONT BOLDFONT (SETQ *LASTDOMAIN* (fetch NSDOMAIN of OBJ)) ":" (SETQ LASTORG (fetch NSORGANIZATION of OBJ)) .FONT DEFAULTFONT "] "))) (PRIN1 (fetch NSOBJECT of OBJ) T))) ) (\NSMT.PROCESS.LIST (LAMBDA (ITEMS DOMAIN LISTFN) (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;; "Display a list of Clearinghouse objects. OBJECTS is the result of some sort of listing call. If the result is a list of strings, DOMAIN is supplied so that future %"Show Details%" commands can use it. LISTFN is a function to call to print the list; it returns a possibly new list of objects to be saved for later.") (COND ((EQ (CAR ITEMS) (QUOTE ERROR)) (\NSMT.SHOW.RESULT ITEMS)) (T (COND (LISTFN (SETQ ITEMS (CL:FUNCALL LISTFN ITEMS))) (T (\NSMT.PRINT.LIST ITEMS))) (COND (ITEMS (* ; "Save list for Show Details command.") (SETQ *LASTLIST* (CONS (AND DOMAIN (SETQ *LASTDOMAIN* (create NSNAME using DOMAIN NSOBJECT _ NIL))) ITEMS))))))) ) (\NSMT.SHOW.RESULT (LAMBDA (RESULT PART FIRST SECOND) (* ; "Edited 21-Aug-89 17:14 by bvm") (* ;; "Used to show the outcome of a typical clearinghouse operation. If RESULT is T or NIL, it succeeded, otherwise we print an error code. FIRST and SECOND, if non-NIL, are the actual names we used in the call, in case error has a FIRST or SECOND identification.") (COND ((OR (EQ RESULT T) (NULL RESULT)) (printout T " done" T) (* ; "Return T for success") T) (T (COND (PART (PRINTOUT T " " PART))) (PRINTOUT T " failed: ") (if (EQ (CAR (LISTP RESULT)) (QUOTE ERROR)) then (PRINTOUT T (CADDR RESULT)) (LET ((CULPRIT (CASE (CADDDR RESULT) (FIRST FIRST) (SECOND SECOND)))) (if CULPRIT then (PRINTOUT T " " CULPRIT))) else (PRINTOUT T RESULT)) (TERPRI T) NIL))) ) ) (* ; "Ordinary user commands") (DEFINEQ (\NSMT.CHANGE.PASSWORD (LAMBDA NIL (* ; "Edited 18-Aug-89 17:23 by bvm") (LET ((NAME (\NSMT.READFNAME " for user:" (NSNAME.TO.STRING *USER* T))) PASS) (COND ((NULL NAME) NIL) ((NULL (SETQ PASS (\NSMT.GET.PASSWORD " to be:"))) (printout T " xxx" T)) (T (PRIN1 "..." T) (COND ((NULL (SETQ NAME (CH.LOOKUP.OBJECT NAME))) (PRINTOUT T " no such name." T)) ((EQUAL.CH.NAMES *USER* (SETQ *LASTNAME* (SETQ *LASTSTRING* NAME))) (* ; "Changing own password") (COND ((\NSMT.SHOW.RESULT (AS.CHANGE.OWN.PASSWORDS (\ENCRYPT.PWD (CONCAT PASS)))) (\INTERNAL/SETPASSWORD (QUOTE |NS::|) (CONS (NSNAME.TO.STRING NAME T) PASS))))) (T (* ; "Changing someone else's password. Only way to do this is to delete the old keys and create new ones.") (\NSMT.SHOW.RESULT (AS.REPLACE.PASSWORDS NAME (\ENCRYPT.PWD (CONCAT PASS)))))))))) ) (\NSMT.DESCRIBE.GROUP (LAMBDA (NAME PROPS EXTRA BRIEFLY) (* ; "Edited 31-Jul-87 11:36 by bvm:") (COND (EXTRA (PRINTOUT T T T NAME " is also a ")) (T (PRINTOUT T " is a "))) (LET ((P (CONSTANT (CH.PROPERTY (QUOTE USERGROUP))))) (COND ((MEMB P PROPS) (CL:FORMAT T "User Group (~A)" (CADR (CH.RETRIEVE.ITEM NAME P (QUOTE STRING)))) (SETQ PROPS (CL:DELETE P PROPS))) (T (PRINTOUT T "group")))) (COND ((NOT BRIEFLY) (TERPRI T) (\NSMT.PRINT.LIST (CH.RETRIEVE.PROPERTY.ACL NAME (QUOTE MEMBERS) (QUOTE Administrators)) "Owners: ") (\NSMT.PRINT.LIST (CH.RETRIEVE.PROPERTY.ACL NAME (QUOTE MEMBERS) (QUOTE selfControllers)) "Friends: "))) PROPS) ) (\NSMT.DESCRIBE.OBJECT (LAMBDA (NAME BRIEFLY) (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;; "Identify name by type and show its interesting properties.") (PROG ((NAME&PROPS (CH.LIST.PROPERTIES NAME)) MAINPROPS PROPS ALIASES DESCR FORWARD GROUPP) (COND ((EQ (CAR NAME&PROPS) (QUOTE ERROR)) (RETURN (\NSMT.SHOW.RESULT NAME&PROPS))) (T (SETQ NAME (CAR NAME&PROPS)))) (FRESHLINE T) (printout T T .FONT BOLDFONT (NSNAME.TO.STRING NAME T) .FONT DEFAULTFONT) (SETQ PROPS (CL:NSET-DIFFERENCE (CADR NAME&PROPS) *NSMAINTAIN-IGNORE-PROPERTIES*)) (for P in (SETQ MAINPROPS (CL:INTERSECTION PROPS *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*)) bind GOTSOME do (COND (GOTSOME (printout T T NAME " is also")) (T (* ; "First prop") (printout T " is"))) (printout T " a " (CL:STRING-CAPITALIZE (STRING (OR (CH.NUMBER.TO.PROPERTY P) P)))) (COND ((SETQ DESCR (CADR (CH.RETRIEVE.ITEM NAME P))) (* ;; "Description of object is stored as string on this descriptive property. Sometimes the value is null, which is why we didn't pass STRING to CH.RETRIEVE.ITEM. CONCAT is so that we don't get an ugly line break after the open paren.") (printout T (CONCAT " (" (COURIER.READ.REP DESCR NIL (QUOTE STRING)) ")")))) (SETQ PROPS (CL:DELETE P PROPS))) (COND ((MEMB (CONSTANT (CH.PROPERTY (QUOTE MEMBERS))) PROPS) (COND ((MEMB (CONSTANT (CH.PROPERTY (QUOTE USER))) MAINPROPS) (* ; "Both USER and group? This is kludge to get NS mail forwarding.") (SETQ PROPS (CL:DELETE (CONSTANT (CH.PROPERTY (QUOTE USERGROUP))) PROPS)) (* ; "describes the forwarding, but is pretty uninteresting") (SETQ FORWARD T)) ((NULL MAINPROPS) (SETQ PROPS (\NSMT.DESCRIBE.GROUP NAME PROPS NIL BRIEFLY)) (SETQ GROUPP 0)) (T (SETQ GROUPP T))) (SETQ PROPS (CL:DELETE (CONSTANT (CH.PROPERTY (QUOTE MEMBERS))) PROPS)))) (COND ((NOT BRIEFLY) (TERPRI T) (COND ((SETQ ALIASES (CH.LIST.ALIASES.OF NAME)) (\NSMT.PRINT.LIST ALIASES "Aliases: "))) (for P in PROPS do (\NSMT.DESCRIBE.PROPERTY NAME P)) (COND (FORWARD (\NSMT.PRINT.LIST (CH.RETRIEVE.MEMBERS NAME) "Forwarding: "))))) (COND ((EQ GROUPP T) (\NSMT.DESCRIBE.GROUP NAME PROPS T BRIEFLY))) (RETURN (SETQ *LASTSTRING* (COND (GROUPP (SETQ *LASTGROUP* NAME)) (T (SETQ *LASTNAME* NAME))))))) ) (\NSMT.DESCRIBE.PROPERTY (LAMBDA (FNAME CHP) (* ; "Edited 13-Apr-89 11:34 by Briggs") (* ;; "Called by \NSMT.TYPE.ENTRY to show one particular property.") (LET ((PROPNAME (CH.NUMBER.TO.PROPERTY CHP)) (VAL (COND ((MEMB CHP *NSMAINTAIN-MEMBER-PROPERTIES*) (CH.RETRIEVE.MEMBERS FNAME CHP)) (T (CADR (CH.RETRIEVE.ITEM FNAME CHP))))) PGM HOW) (PRINTOUT T .FONT BOLDFONT (COND (PROPNAME (CL:STRING-CAPITALIZE (STRING PROPNAME))) (T (PRINTOUT T "Property ") CHP)) ": " .FONT DEFAULTFONT) (COND ((AND (SETQ HOW (CDR (ASSOC CHP *NSMAINTAIN-PROPERTY-FORMATS*))) (NLSETQ (bind PGM while (AND (LISTP HOW) (LITATOM (CDR HOW)) (CDR HOW)) do (* ; "Reduce to a less qualified name") (SETQ HOW (\GET.COURIER.TYPE (SETQ PGM (CAR HOW)) (CDR HOW))) finally (SETQ VAL (COURIER.READ.REP VAL PGM HOW)) (COND ((EQ (CAR (LISTP HOW)) (QUOTE RECORD)) (* ; "make records humanly intelligible") (for PAIR in (CDR HOW) as V in VAL bind (PREFIX _ "[") do (PRIN1 PREFIX T) (PRINTOUT T (CL:STRING-CAPITALIZE (STRING (CAR PAIR))) ": " (SELECTQ (CADR PAIR) (BOOLEAN (CL:IF V "true" "false")) (TIME (GDATE V)) V)) (SETQ PREFIX "; ") finally (PRIN1 "]" T))) (T (PRINTOUT T VAL))))))) (T (* ; "if all else fails, print raw numbers") (PRINTOUT T VAL))) (TERPRI T))) ) (\NSMT.LIST.OBJECTS (LAMBDA (PROP LISTFN) (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;;; "given a clearinghouse property, lookup all objects with a user-specified pattern that have that property. Default pattern is * in recent domain.") (LET (PATTERN) (COND ((AND (OR PROP (SETQ PROP (ASKUSER NIL NIL " having property " (OR *ALLTYPES* (SETQ *ALLTYPES* (CONS (QUOTE ("" "any" EXPLAINSTRING " - list ALL objects" RETURN (QUOTE ALL))) (CONS (QUOTE (* "" EXPLAINSTRING "* - list ALL objects" CONFIRMFLG T RETURN (QUOTE ALL))) (SORT (DREMOVE (QUOTE ALL) (MAPCAR CH.PROPERTIES (FUNCTION CAR)))))))) T))) (SETQ PATTERN (\NSMT.READFNAME " by pattern:" (AND *LASTNAME* (create NSNAME using *LASTNAME* NSOBJECT _ "*")) NIL T NIL T))) (\NSMT.PROCESS.LIST (CH.LIST.OBJECTS PATTERN PROP) PATTERN LISTFN))))) ) (\NSMT.LIST.CLEARINGHOUSES (LAMBDA NIL (* ; "Edited 21-Aug-89 17:10 by bvm") (DECLARE (USEDFREE *LASTDOMAIN*)) (LET ((DOMAIN (\NSMT.READFNAME " serving domain:" *LASTDOMAIN* T)) (CHSPART "CHServers") SERVERS) (COND (DOMAIN (SETQ *LASTDOMAIN* DOMAIN) (TERPRI T) (SETQ SERVERS (LISTP (CH.RETRIEVE.MEMBERS (create NSNAME NSOBJECT _ (fetch NSDOMAIN of DOMAIN) NSDOMAIN _ (fetch NSORGANIZATION of DOMAIN) NSORGANIZATION _ CHSPART)))) (COND ((EQ (CAR SERVERS) (QUOTE ERROR)) (\NSMT.SHOW.RESULT (COND ((EQ (CADDR SERVERS) (QUOTE NoSuchObject)) (* ; "translate this error") "No Such Domain") (T SERVERS)))) ((SETQ SERVERS (for S in SERVERS collect (COND ((AND (STRING-EQUAL (fetch NSDOMAIN of S) CHSPART) (STRING-EQUAL (fetch NSORGANIZATION of S) CHSPART)) (* ;; "Clearinghouse names are usually of the form server:CHServers:CHServers. The domain here is thus junk--print the name only. Hope for not too much confusion if user tries to type name by hand, rather than using Show Details command.") (fetch NSOBJECT of S)) (T (* ; "An aberrant name--punt by printing all full names") (\NSMT.PROCESS.LIST SERVERS) (RETURN NIL))))) (* ; "Show short names, preserve domain for Show Details") (\NSMT.PROCESS.LIST SERVERS (create NSNAME NSDOMAIN _ CHSPART NSORGANIZATION _ CHSPART)))))))) ) (\NSMT.LIST.SERVERS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;; "List Objects specialized to servers. We offer as choices those properties with SERVICE in their name, plus the oddly generic %"SERVER%". CLEARINGHOUSE.SERVICE is excluded because its name space doesn't work as you'd expect.") (LET (PROP) (AND (SETQ PROP (ASKUSER NIL NIL " of type " (OR *SERVERTYPES* (SETQ *SERVERTYPES* (CONS *NSMAINTAIN-ABORT-ITEM* (SORT (CONS (QUOTE ("Server" "" RETURN (QUOTE SERVER))) (for P in CH.PROPERTIES when (AND (STRPOS "SERVICE" (CAR P) -7) (NEQ (CAR P) (QUOTE CLEARINGHOUSE.SERVICE))) collect (BQUOTE ((\, (CL:STRING-CAPITALIZE (SUBSTRING (CAR P) 1 -9))) "" RETURN (QUOTE (\, (CAR P))))))) T)))) T)) (\NSMT.LIST.OBJECTS PROP)))) ) (\NSMT.SHOW.DETAILS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (COND ((NULL *LASTLIST*) (PRINTOUT T " (no previous list)" T)) (T (DESTRUCTURING-BIND (DOMAIN . OBJECTS) *LASTLIST* (COND ((NULL (CDR OBJECTS)) (* ; "only one, describe it straight away") (TERPRI T) (\NSMT.DESCRIBE.OBJECT (COND (DOMAIN (create NSNAME using DOMAIN NSOBJECT _ (CAR OBJECTS))) (T (CAR OBJECTS))))) (T (COND ((NOT (STRINGP (CAR OBJECTS))) (* ; "Turn ns names into strings") (RPLACD *LASTLIST* (SETQ OBJECTS (for N in OBJECTS collect (NSNAME.TO.STRING N T)))))) (bind (CMDS _ (CONS *NSMAINTAIN-ABORT-ITEM* OBJECTS)) NAME while (SETQ NAME (PROGN (TERPRI T) (ASKUSER NIL NIL " name: " CMDS T))) do (\NSMT.DESCRIBE.OBJECT (COND (DOMAIN (create NSNAME using DOMAIN NSOBJECT _ NAME)) (T NAME)))))))))) ) (\NSMT.GROUP.FILTER (LAMBDA (NAMES) (* ; "Edited 11-Aug-87 15:47 by bvm:") (* ;; "List function for List Objects -- NAMES is a list of objects that have a members prop. Filter out those that also have a USER prop, assuming that these %"groups%" are merely for forwarding, and print the rest.") (COND ((for NAME in NAMES bind (PREFIX _ " ") unless (CH.RETRIEVE.ITEM NAME (QUOTE USER)) collect (PRINTOUT T PREFIX NAME) (SETQ PREFIX ", ") NAME)) (T (* ; "Print %"none%"") (\NSMT.PRINT.LIST) NIL))) ) (\NSMT.LIST.ADMINISTRATORS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " of domain:" *LASTDOMAIN* T T))) (COND (DOMAIN (\NSMT.PROCESS.LIST (CH.RETRIEVE.DOMAIN.ACL (SETQ *LASTDOMAIN* DOMAIN) (QUOTE Administrators))))))) ) (\NSMT.LIST.DOMAINS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " by pattern:" (create NSNAME using *LASTDOMAIN* NSDOMAIN _ "*") T T NIL T))) (COND (DOMAIN (\NSMT.PRINT.LIST (CH.LIST.DOMAINS DOMAIN)))))) ) (\NSMT.TYPE.ENTRY (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (NAME) (COND ((SETQ NAME (\NSMT.READFNAME " name:" *LASTSTRING* NIL T NIL T)) (\NSMT.DESCRIBE.OBJECT NAME))))) ) (\NSMT.TYPE.MEMBERS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (NAME ITEMS) (DECLARE (USEDFREE *LASTGROUP* *LASTSTRING*)) (COND ((SETQ NAME (\NSMT.READFNAME " of group:" *LASTGROUP* NIL T)) (SETQ *LASTSTRING* NAME) (SETQ ITEMS (LISTP (CH.RETRIEVE.MEMBERS NAME (QUOTE MEMBERS)))) (COND ((EQ (CAR ITEMS) (QUOTE ERROR)) (* ; "Failure. Translate the %"Missing%" error into English") (\NSMT.SHOW.RESULT (COND ((EQ (CADDR ITEMS) (QUOTE Missing)) "Not A Group") (T ITEMS)))) (T (SETQ *LASTGROUP* NAME) (COND ((NULL ITEMS) (PRIN1 "(No members)" T)) (T (COND ((CDR ITEMS) (CL:FORMAT T " (~D members)~%%" (LENGTH ITEMS)) (\NSMT.PRINT.OBJECTS ITEMS)) (T (* ; "Just one") (PRINTOUT T (CAR ITEMS) T))) (* ; "Save list for Show Details command.") (SETQ *LASTLIST* (CONS NIL ITEMS)))))))))) ) ) (* ; "Administrator commands") (DEFINEQ (\NSMT.ADD.ALIAS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (OBJECT ALIAS) (COND ((AND (SETQ OBJECT (\NSMT.READFNAME " for object:" *LASTSTRING*)) (LET ((*DEFAULTDOMAIN* (create NSNAME using OBJECT NSOBJECT _ NIL))) (DECLARE (CL:SPECIAL *DEFAULTDOMAIN*)) (* ; "Read the alias by default in the same domain as object") (TERPRI T) (SETQ ALIAS (\NSMT.READFNAME " Alias:" NIL NIL T)))) (OR (\NSMT.SHOW.RESULT (LISTP (SETQ *LASTSTRING* (CH.CREATE.ALIAS ALIAS OBJECT)))) (SETQ *LASTSTRING* OBJECT)))))) ) (\NSMT.ADD.GROUP (LAMBDA NIL (* ; "Edited 18-Aug-89 17:25 by bvm") (* ;; "Create a new group") (LET (GROUP REMARK RESULT MEMBERS OWNERS FRIENDS) (COND ((NOT (SETQ GROUP (\NSMT.READFNAME " New group name:" NIL NIL T)))) ((LISTP (SETQ RESULT (CH.CREATE.OBJECT (SETQ *LASTSTRING* (SETQ *LASTGROUP* GROUP))))) (* ; "Failed to create object") (\NSMT.SHOW.RESULT RESULT)) (T (* ;; "Assume if user had access rights to create the object, then calls below don't fail. Gather all the info before taking the time to call the Clearinghouse, since sometimes these update calls are very slow.") (TERPRI T) (SETQ REMARK (\NSMT.GET.REMARK)) (CL:FORMAT T "~%%~%%Enter names of members, owners and friends, one per line, terminated with a blank line.~%%") (SETQ MEMBERS (\NSMT.COLLECT.NAMES "Member:" :CONFIRM :ANY)) (CL:FORMAT T "~%%(If you enter no owners, the group will be owned by the administrators of ~A.)~%%" (create NSNAME using GROUP NSOBJECT _ NIL)) (SETQ OWNERS (\NSMT.COLLECT.NAMES "Owner:" T :ANY)) (SETQ FRIENDS (\NSMT.COLLECT.NAMES "Friend:" T :ANY)) (TERPRI T) (CH.ADD.ITEM.PROPERTY GROUP (QUOTE USERGROUP) REMARK (QUOTE STRING)) (COND (MEMBERS (PRINTOUT T "Adding members...") (\NSMT.SHOW.RESULT (LISTP (CH.ADD.GROUP.PROPERTY GROUP (QUOTE MEMBERS) MEMBERS T))))) (COND (OWNERS (PRINTOUT T "Adding owners...") (LET ((SELF *USER*)) (* ;; "Have to make user be first owner, because as soon as we add one administrator, we override the default administrators, which means user is no longer empowered to add the rest of the owners! Stupid @#&#!!@ Clearinghouse design.") (for NAME in OWNERS when (EQUAL.CH.NAMES NAME SELF) do (COND ((NEQ NAME (CAR OWNERS)) (* ; "make it first") (SETQ OWNERS (CONS NAME (REMOVE NAME OWNERS))))) (RETURN) finally (CL:FORMAT T " (including ~A)" (NSNAME.TO.STRING SELF T)) (push OWNERS SELF))) (\NSMT.SHOW.RESULT (for NAME in OWNERS thereis (SETQ $$VAL (LISTP (CH.ADD.MEMBER.TO.PROPERTY.ACL GROUP (QUOTE MEMBERS) (QUOTE Administrators) NAME T))))))) (COND (FRIENDS (PRINTOUT T "Adding friends...") (\NSMT.SHOW.RESULT (for NAME in FRIENDS thereis (SETQ $$VAL (LISTP (CH.ADD.MEMBER.TO.PROPERTY.ACL GROUP (QUOTE MEMBERS) (QUOTE selfControllers) NAME T))))))))))) ) (\NSMT.ADD.USER (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;; "Create new user") (LET (NAME PASS ERROR DESC ALIASES) (DECLARE (USEDFREE *LASTNAME* *LASTSTRING*)) (TERPRI T) (COND ((SETQ NAME (\NSMT.READFNAME "New user's name:" *LASTNAME* NIL T)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) (COND ((LISTP (SETQ ERROR (CH.CREATE.OBJECT NAME))) (* ; "Error") (\NSMT.SHOW.RESULT ERROR)) (T (* ;; "Having created the object, get all the other parts. We assume that if the creation succeeded, we'll be able to do the rest, so gather all the info first, then do the calls.") (TERPRI T) (SETQ DESC (\NSMT.GET.REMARK)) (SETQ ALIASES (LET ((*DEFAULTDOMAIN* (create NSNAME using NAME NSOBJECT _ NIL))) (DECLARE (CL:SPECIAL *DEFAULTDOMAIN*)) (* ; "Read the aliases by default in the same domain as user") (\NSMT.COLLECT.NAMES "Alias:"))) (COND ((NULL (SETQ PASS (\NSMT.GET.PASSWORD "Initial password:"))) (printout T " (no password stored; use Change Password to create one)" T))) (PRIN1 "... " T) (COND ((SETQ ERROR (LISTP (CH.ADD.ITEM.PROPERTY NAME (QUOTE USER) DESC (QUOTE STRING)))) (\NSMT.SHOW.RESULT ERROR "remark"))) (COND ((for A in ALIASES thereis (SETQ ERROR (LISTP (CH.CREATE.ALIAS A NAME)))) (\NSMT.SHOW.RESULT ERROR "alias"))) (\NSMT.SHOW.RESULT (AND PASS (AS.CREATE.PASSWORDS NAME (\ENCRYPT.PWD PASS))) "password creation"))))))) ) (\NSMT.CHANGE.ADMINISTRATORS (LAMBDA (CHACCESSFN OPERATION) (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;; "Add/remove a domain administrator") (LET (DOMAIN INDIVIDUAL) (DECLARE (USEDFREE *LASTNAME* *LASTDOMAIN* *LASTSTRING*)) (COND ((AND (SETQ INDIVIDUAL (\NSMT.READFNAME " name:" *LASTNAME*)) (SETQ DOMAIN (\NSMT.READFNAME (SELECTQ OPERATION (ADD " to domain:") (REMOVE " from domain:") (SHOULDNT)) *LASTDOMAIN* T T))) (\NSMT.SHOW.RESULT (CL:FUNCALL CHACCESSFN DOMAIN (QUOTE Administrators) INDIVIDUAL)) (SETQ *LASTSTRING* (SETQ *LASTNAME* INDIVIDUAL)) (SETQ *LASTDOMAIN* DOMAIN))))) ) (\NSMT.CHANGE.FORWARDING (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (* ;; "Change the %"Forwarding%" list for a user. Since NS doesn't really have forwarding, it is faked by giving an object a MEMBERS property--the mail system, finding no mailbox, looks at the members and sends the message to all of them.") (PROG (PROPS GOODPROPS NAME REALNAME RESULT OLDFORWARDING NEWFORWARDING) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME* *LASTGROUP*)) (if (SETQ NAME (\NSMT.READFNAME " for user:" *LASTNAME*)) then (TERPRI T) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ REALNAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (MEMB (CONSTANT (CH.PROPERTY (QUOTE USER))) (SETQ PROPS (CADR PROPS))) then (* ; "Ok, it's a user") else (PRINTOUT T T REALNAME " is not a User") (if (NULL (SETQ GOODPROPS (\NSMT.DESCRIPTIVE.PROPS PROPS))) then (RETURN (PRINTOUT T ", or any other type I know about." T)) else (PRINTOUT T ", but a " (OR (FIXP (CAR GOODPROPS)) (CL:STRING-CAPITALIZE (CAR GOODPROPS)))) (if (CDR GOODPROPS) then (PRINTOUT T " (also " (CONCATLIST (CDR (for P in (CDR GOODPROPS) join (LIST ", " (OR (FIXP P) (CL:STRING-CAPITALIZE P)))))) ")")) (if (EQ (CAR GOODPROPS) (QUOTE USERGROUP)) then (RETURN (PRINTOUT T " Groups %"forward%" to their members." T)) elseif (NOT (CL:Y-OR-N-P "Are you sure you want to change the Forwarding? ")) then (RETURN)))) (if (MEMB (CONSTANT (CH.PROPERTY (QUOTE MEMBERS))) PROPS) then (* ; "There's already forwarding, so fetch it") (SETQ OLDFORWARDING (CH.RETRIEVE.MEMBERS REALNAME)) else (PRINTOUT T REALNAME " does not yet have Forwarding." T)) (SETQ *LASTSTRING* (SETQ *LASTNAME* REALNAME)) (PRINTOUT T "Type one or more NS names, separated by commas." T) (SETQ NEWFORWARDING (TTYIN "Forward to: " NIL NIL (QUOTE (STRING NORAISE)) NIL NIL (AND OLDFORWARDING (CONCATLIST (CDR (for NAME in OLDFORWARDING join (LIST ", " (NSNAME.TO.STRING NAME T)))))))) (if (OR (NULL NEWFORWARDING) (NULL (SETQ NEWFORWARDING (bind (START _ 1) COMMA when (> (NCHARS (SETQ NAME (CL:STRING-TRIM (QUOTE (#\Space)) (SUBSTRING NEWFORWARDING START (COND ((SETQ COMMA (STRPOS "," NEWFORWARDING START)) (SUB1 COMMA))))))) 0) collect (* ; "Parse names out from between the commas") (PARSE.NSNAME NAME) repeatwhile (COND (COMMA (SETQ START (ADD1 COMMA)))))))) then (* ; "No new forwarding...delete old?") (if (NULL OLDFORWARDING) then (PRINTOUT T " (not changed)" T) elseif (CL:Y-OR-N-P "Remove forwarding for ~A? " REALNAME) then (SETQ RESULT (CH.DELETE.PROPERTY REALNAME (QUOTE MEMBERS))) (if (EQ (CAR RESULT) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT RESULT) else (PRINTOUT T "Forwarding removed") (if (AND (MEMB (CONSTANT (CH.PROPERTY (QUOTE USERGROUP))) PROPS) (EQ (CAR (SETQ RESULT (CH.DELETE.PROPERTY REALNAME (QUOTE USERGROUP)))) (QUOTE ERROR))) then (* ; "Failed to delete the %"group%" comment") (PRINTOUT T ", but failed to remove the forwarding comment because: " (CADDR RESULT) T) else (PRINTOUT T "." T)))) elseif (AND (EQ (LENGTH OLDFORWARDING) (LENGTH NEWFORWARDING)) (for O in OLDFORWARDING as N in NEWFORWARDING always (* ; "See if the lists are the same. Could use EQUAL.CH.NAMES, but want to be able to recognize case differences") (AND (CL:STRING= (fetch NSOBJECT of O) (fetch NSOBJECT of N)) (CL:STRING= (fetch NSDOMAIN of O) (fetch NSDOMAIN of N)) (CL:STRING= (fetch NSORGANIZATION of O) (fetch NSORGANIZATION of N))))) then (PRINTOUT T " (not changed)") else (* ;; "Change membership. There is no command to replace group membership, so the easiest thing when prop already existed is to delete the old one and add the new one") (if (OR (NULL OLDFORWARDING) (NEQ (CAR (SETQ RESULT (CH.DELETE.PROPERTY REALNAME (QUOTE MEMBERS)))) (QUOTE ERROR))) then (SETQ RESULT (CH.ADD.GROUP.PROPERTY REALNAME (QUOTE MEMBERS) NEWFORWARDING T))) (if (EQ (CAR RESULT) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT RESULT) else (PRINTOUT T "Done, forwarding set to ") (\NSMT.PRINT.LIST NEWFORWARDING) (TERPRI T)))))) ) (\NSMT.CHANGE.GROUP.COMPONENT (LAMBDA (CHACCESSFN OPERATION SELF/LIST) (* ; "Edited 21-Aug-89 17:40 by bvm") (* ;; "Add or remove a member from to/from a group. CHACCESSFN is the CH function that will make the change, OPERATION is ADD or REMOVE, and SELF/LIST is one of T (self), NIL (general member) or the name of an access list property.") (LET (GROUP INDIVIDUAL RESULT FULLNAME ORIGINAL) (if (AND (OR (EQ SELF/LIST T) (SETQ INDIVIDUAL (\NSMT.READFNAME " name:" *LASTNAME* NIL NIL (COND ((EQ OPERATION (QUOTE REMOVE)) (* ; "Want to be able to remove bogus names if they got on there somehow, so let's do the processing ourselves") NIL) (SELF/LIST (* ; "must be valid ns name") T) (T (* ; "use canonical name, but foreign names ok") :CONFIRM)) :ANY))) (PROGN (if (AND (EQ OPERATION (QUOTE REMOVE)) (NEQ SELF/LIST T)) then (* ; "Do name fixing ourselves so we can keep track of the original (below)") (if (NOT (SETQ FULLNAME (\NSMT.LOOKUP INDIVIDUAL))) then (PRINTOUT T " (non-existent name)") elseif (NOT (EQUAL.CH.NAMES FULLNAME INDIVIDUAL)) then (* ; "name is an alias. ") (SETQ ORIGINAL INDIVIDUAL) (printout T " = " (NSNAME.TO.STRING (SETQ INDIVIDUAL FULLNAME) T)))) (SETQ GROUP (\NSMT.READFNAME (SELECTQ OPERATION (ADD " to group:") (REMOVE " from group:") (SHOULDNT)) *LASTGROUP* NIL T)))) then (* ;; "Ok, here's a name and a group, try the desired operation") (SETQ RESULT (SELECTQ SELF/LIST (T (* ; "adding/removing self") (CL:FUNCALL CHACCESSFN GROUP (QUOTE MEMBERS))) (NIL (* ; "adding/removing member") (CL:FUNCALL CHACCESSFN GROUP (QUOTE MEMBERS) INDIVIDUAL T)) (PROGN (* ; "Adding/removing from access list") (CL:FUNCALL CHACCESSFN GROUP (QUOTE MEMBERS) SELF/LIST INDIVIDUAL T)))) (if (if (AND (LISTP RESULT) (EQ (CADDR RESULT) (QUOTE NoChange)) ORIGINAL (OR SELF/LIST (CH.ISMEMBER GROUP (QUOTE MEMBERS) NIL ORIGINAL)) (NLISTP (SETQ RESULT (CL:FUNCALL CHACCESSFN GROUP (QUOTE MEMBERS) (SETQ INDIVIDUAL ORIGINAL) T)))) then (* ;; "Command was to remove something. We first tried the full name, but CH said it didn't work. Then tried the original, after checking that the other name is in the group (for group hacking. For Remove Friend/Owner, where is InPropertyACL?") (PRINTOUT T " removed " (NSNAME.TO.STRING ORIGINAL T) T) T else (\NSMT.SHOW.RESULT (LISTP RESULT) NIL GROUP INDIVIDUAL)) then (* ; "Success") (SETQ *LASTGROUP* RESULT) (SETQ *LASTSTRING* *LASTGROUP*)) (SETQ *LASTNAME* INDIVIDUAL)))) ) (\NSMT.CHANGE.REMARK (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (PROG (PROPS GOODPROPS MAINPROP NAME REALNAME RESULT REMARK) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME* *LASTGROUP*)) (COND ((SETQ NAME (\NSMT.READFNAME " for object:" *LASTSTRING*)) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (COND ((EQ (SETQ REALNAME (CAR PROPS)) (QUOTE ERROR)) (* ; "Object does not exist, probably") (\NSMT.SHOW.RESULT PROPS)) ((NULL (SETQ GOODPROPS (\NSMT.DESCRIPTIVE.PROPS (CADR PROPS)))) (printout T T (SETQ *LASTSTRING* REALNAME) " has no remarkable properties." T)) (T (COND ((NULL (CDR GOODPROPS)) (* ; "only one, the normal case") (PRINTOUT T (CONCAT " (" (COND ((EQUAL.CH.NAMES REALNAME NAME) "") (T (CONCAT (NSNAME.TO.STRING REALNAME) " -- "))) "a " (CL:STRING-CAPITALIZE (STRING (SETQ MAINPROP (CAR GOODPROPS)))) ")"))) (T (PRINTOUT T T (NSNAME.TO.STRING REALNAME) " has the descriptive properties ") (\NSMT.PRINT.LIST GOODPROPS) (COND ((NULL (SETQ MAINPROP (CAR (TTYIN "Specify property to modify: " GOODPROPS T (QUOTE (FIX RAISE)))))) (RETURN))))) (TERPRI T) (COND ((SETQ REMARK (CADR (CH.RETRIEVE.ITEM REALNAME MAINPROP))) (* ; "Retrieve carefully in case the prop is null") (SETQ REMARK (COURIER.READ.REP REMARK NIL (QUOTE STRING))))) (COND ((SETQ REMARK (\NSMT.GET.REMARK REMARK)) (PRIN1 "..." T) (\NSMT.SHOW.RESULT (LISTP (CH.CHANGE.ITEM REALNAME MAINPROP REMARK (QUOTE STRING))))) (T (PRINTOUT T " xxx" T))) (SETQ *LASTSTRING* (COND ((EQ MAINPROP (QUOTE USERGROUP)) (SETQ *LASTGROUP* REALNAME)) (T (SETQ *LASTNAME* REALNAME)))))))))) ) (\NSMT.DESCRIPTIVE.PROPS (LAMBDA (PROPS) (* ; "Edited 18-Aug-89 14:28 by bvm") (* ;; "PROPS is a list of property numbers. Return the subset, translated to english, that are %"descriptive%" properties, i.e., whose value is a remark string.") (COND ((for P in PROPS collect (OR (CH.NUMBER.TO.PROPERTY P) P) when (MEMB P *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*))) ((MEMB (CONSTANT (CH.PROPERTY (QUOTE USERGROUP))) PROPS) (* ; "Treat USERGROUP specially, as it is the property conventionally holding a group remark, but we ignore it if object has other props (like USER).") (LIST (QUOTE USERGROUP))))) ) (\NSMT.REMOVE.ALIAS (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (ALIAS) (COND ((NULL (SETQ ALIAS (\NSMT.READFNAME " alias:" NIL NIL T)))) ((NLISTP (SETQ ALIAS (CH.DELETE.ALIAS ALIAS))) (* ; "Success, returned canonical name") (CL:FORMAT T "done, alias was removed from ~S~%%" (SETQ *LASTSTRING* ALIAS))) (T (\NSMT.SHOW.RESULT ALIAS))))) ) (\NSMT.REMOVE.OBJECT (LAMBDA (NAME) (* ; "Edited 18-Aug-89 17:12 by bvm") (COND ((AND (OR NAME (SETQ NAME (\NSMT.READFNAME ":" *LASTSTRING* NIL T))) (SETQ NAME (\NSMT.DESCRIBE.OBJECT NAME T)) (CL:Y-OR-N-P " Confirm deletion (y or n): ")) (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.OBJECT NAME)))))) ) (\NSMT.REMOVE.USER (LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (USER INFO) (COND ((NULL (SETQ USER (\NSMT.READFNAME ":" *LASTNAME* NIL T)))) ((NULL (SETQ INFO (CH.RETRIEVE.ITEM USER (QUOTE USER)))) (PRINTOUT T " not a user." T)) (T (PRINTOUT T T (NSNAME.TO.STRING (CAR INFO) T)) (COND ((CADR INFO) (CL:FORMAT T " (~A)" (COURIER.READ.REP (CADR INFO) NIL (QUOTE STRING))))) (COND ((CL:Y-OR-N-P " Confirm deletion (y or n): ") (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.OBJECT USER))))))))) ) ) (FILESLOAD (SYSLOAD) DES AUTHENTICATION) (RPAQQ *NSMAINTAIN-COMMANDS* (("?" "" RETURN (FUNCTION \NSMT.HELP)) ("Add Alias" "" RETURN (FUNCTION \NSMT.ADD.ALIAS)) ("Add Domain Administrator" "" RETURN '(\NSMT.CHANGE.ADMINISTRATORS CH.ADD.MEMBER.TO.DOMAIN.ACL ADD)) ("Add Friend" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.ADD.MEMBER.TO.PROPERTY.ACL ADD selfControllers)) ("Add Group" "" RETURN (FUNCTION \NSMT.ADD.GROUP)) ("Add Member" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.ADD.MEMBER ADD)) ("Add Owner" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.ADD.MEMBER.TO.PROPERTY.ACL ADD Administrators)) ("Add Self" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.ADD.SELF ADD T)) ("Add User" "" RETURN (FUNCTION \NSMT.ADD.USER)) ("Remove Alias" "" RETURN (FUNCTION \NSMT.REMOVE.ALIAS)) ("Remove Domain Administrator" "" RETURN '(\NSMT.CHANGE.ADMINISTRATORS CH.DELETE.MEMBER.FROM.DOMAIN.ACL REMOVE)) ("Remove Friend" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.DELETE.MEMBER.FROM.PROPERTY.ACL REMOVE selfControllers)) ("Remove Member" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.DELETE.MEMBER REMOVE)) ("Remove Owner" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.DELETE.MEMBER.FROM.PROPERTY.ACL REMOVE Administrators)) ("Remove Registered Object" "" RETURN (FUNCTION \NSMT.REMOVE.OBJECT)) ("Remove Self" "" RETURN '(\NSMT.CHANGE.GROUP.COMPONENT CH.DELETE.SELF REMOVE T)) ("Remove User" "" RETURN (FUNCTION \NSMT.REMOVE.USER)) ("Change Default Domain" "" RETURN (FUNCTION \NSMT.CHANGE.DOMAIN)) ("Change Forwarding" "" RETURN (FUNCTION \NSMT.CHANGE.FORWARDING)) ("Change Login" "" RETURN (FUNCTION \NSMT.LOGIN)) ("Change Password" "" RETURN (FUNCTION \NSMT.CHANGE.PASSWORD)) ("Change Remark" "" RETURN (FUNCTION \NSMT.CHANGE.REMARK)) ("Describe" "" RETURN (FUNCTION \NSMT.TYPE.ENTRY)) ("List Aliases" "" RETURN '(\NSMT.LIST.OBJECTS ALIAS)) ("List Administrators" "" RETURN (FUNCTION \NSMT.LIST.ADMINISTRATORS)) ("List Clearinghouses" "" RETURN (FUNCTION \NSMT.LIST.CLEARINGHOUSES)) ("List Domains" "" RETURN (FUNCTION \NSMT.LIST.DOMAINS)) ("List Groups" "" RETURN '(\NSMT.LIST.OBJECTS MEMBERS)) ("List Members" "" RETURN (FUNCTION \NSMT.TYPE.MEMBERS)) ("List Objects" "" RETURN (FUNCTION \NSMT.LIST.OBJECTS)) ("List Servers" "" RETURN (FUNCTION \NSMT.LIST.SERVERS)) ("List True Groups" "" RETURN '(\NSMT.LIST.OBJECTS MEMBERS \NSMT.GROUP.FILTER)) ("List Users" "" RETURN '(\NSMT.LIST.OBJECTS USER)) ("Show Details of previously listed names" "" RETURN (FUNCTION \NSMT.SHOW.DETAILS)) ("Type Entry" "" RETURN (FUNCTION \NSMT.TYPE.ENTRY) EXPLAINSTRING "Type Entry -- same as Describe") ("Type Members" "" RETURN (FUNCTION \NSMT.TYPE.MEMBERS) EXPLAINSTRING "Type Members -- same as List Members") ("Quit" " [confirm]" CONFIRMFLG T RETURN NIL))) (RPAQQ *NSMAINTAIN-ABORT-ITEM* ("" "" EXPLAINSTRING " - abort" RETURN NIL)) (ADDTOVAR CH.PROPERTIES (ALIAS 1)) (ADDTOVAR *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10023 10024) (ADDTOVAR *NSMAINTAIN-IGNORE-PROPERTIES* 6 7 10027 20003 20002 20101) (ADDTOVAR *NSMAINTAIN-PROPERTY-FORMATS* (4 CLEARINGHOUSE . NETWORK.ADDRESS.LIST) (8 RECORD (SIMPLE BOOLEAN) (STRONG BOOLEAN)) (30 . NSNAME) (31 CLEARINGHOUSE . MAILBOX.VALUES) (10000 . STRING) (10001 . STRING) (10002 . STRING) (10003 . STRING) (10004 . STRING) (10005 . STRING) (10006 . STRING) (10007 . STRING) (10008 . STRING) (10009 . STRING) (10010 . STRING) (10011 . STRING) (10012 . STRING) (10013 . STRING) (10014 . STRING) (10015 . STRING) (10016 . STRING) (10017 . STRING) (10018 . STRING) (10019 . STRING) (10020 . STRING) (10021 . STRING) (10022 . STRING) (10023 . STRING) (10024 . STRING) (10029 . STRING) (10030 . STRING) (10032 . STRING) (10034 . STRING) (10035 . STRING) (15002 . STRING) (20000 CLEARINGHOUSE . USERDATA.VALUE) (20001 GAP . RS232CData) (20006 SEQUENCE NSNAME) (20007 . NSNAME) (20102 GAP . RS232CBack) (29965 . STRING) (30005 . NSNAME)) (ADDTOVAR *NSMAINTAIN-MEMBER-PROPERTIES* 20006) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM* *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* *NSMAINTAIN-IGNORE-PROPERTIES* *NSMAINTAIN-PROPERTY-FORMATS* *NSMAINTAIN-MEMBER-PROPERTIES* CH.PROPERTIES) ) (CL:PROCLAIM '(CL:SPECIAL *USER* *LASTDOMAIN* *LASTNAME* *LASTGROUP* *LASTLIST* *LASTSTRING* *SERVERTYPES* *ALLTYPES* *DEFAULTDOMAIN* *REAL-NAME-CACHE*)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS NSMAINTAIN COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4822 15320 (NSMAINTAIN 4832 . 6374) (\NSMT.HELP 6376 . 8012) (\NSMT.READFNAME 8014 . 10438) (\NSMT.LOOKUP 10440 . 10879) (\NSMT.COLLECT.NAMES 10881 . 11195) (\NSMT.GET.REMARK 11197 . 11489) (\NSMT.GET.PASSWORD 11491 . 12072) (\NSMT.LOGIN 12074 . 12584) (\NSMT.CHANGE.DOMAIN 12586 . 13029) (\NSMT.PRINT.LIST 13031 . 13336) (\NSMT.PRINT.OBJECTS 13338 . 13813) (\NSMT.PROCESS.LIST 13815 . 14556) (\NSMT.SHOW.RESULT 14558 . 15318)) (15360 25860 (\NSMT.CHANGE.PASSWORD 15370 . 16182) ( \NSMT.DESCRIBE.GROUP 16184 . 16824) (\NSMT.DESCRIBE.OBJECT 16826 . 19002) (\NSMT.DESCRIBE.PROPERTY 19004 . 20236) (\NSMT.LIST.OBJECTS 20238 . 21042) (\NSMT.LIST.CLEARINGHOUSES 21044 . 22324) ( \NSMT.LIST.SERVERS 22326 . 23070) (\NSMT.SHOW.DETAILS 23072 . 23857) (\NSMT.GROUP.FILTER 23859 . 24360 ) (\NSMT.LIST.ADMINISTRATORS 24362 . 24623) (\NSMT.LIST.DOMAINS 24625 . 24871) (\NSMT.TYPE.ENTRY 24873 . 25062) (\NSMT.TYPE.MEMBERS 25064 . 25858)) (25900 40356 (\NSMT.ADD.ALIAS 25910 . 26424) ( \NSMT.ADD.GROUP 26426 . 28620) (\NSMT.ADD.USER 28622 . 29969) (\NSMT.CHANGE.ADMINISTRATORS 29971 . 30559) (\NSMT.CHANGE.FORWARDING 30561 . 34591) (\NSMT.CHANGE.GROUP.COMPONENT 34593 . 37018) ( \NSMT.CHANGE.REMARK 37020 . 38596) (\NSMT.DESCRIPTIVE.PROPS 38598 . 39199) (\NSMT.REMOVE.ALIAS 39201 . 39554) (\NSMT.REMOVE.OBJECT 39556 . 39854) (\NSMT.REMOVE.USER 39856 . 40354))))) STOP \ No newline at end of file diff --git a/library/PCTREE.~3~ b/library/PCTREE.~3~ deleted file mode 100644 index c7683134..00000000 --- a/library/PCTREE.~3~ +++ /dev/null @@ -1,251 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "29-Jan-99 17:33:18" {DSK}sybalsky>lispcore3.0>library>PCTREE.;2 28268 changes to%: (FNS \INSERTTREE \DELETETREE) previous date%: "21-Mar-95 15:30:14" {DSK}sybalsky>lispcore3.0>library>PCTREE.;1) (* ; " Copyright (c) 1990, 1991, 1993, 1994, 1995, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PCTREECOMS) (RPAQQ PCTREECOMS [ (* ;; "Balanced tree PIECE TABLE supporting functions") (FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "\WORDSINBTREEMAIN = # of words in the child-pointers & offsets section of the node -- everything before SPARE5 (the overflow place).") (* ;;  "\BTREEMAXCOUNT = number of children in a full node = maximum value for a node's COUNT field.") (* ;; "\BTREELASTREALOFFSET = offset of last real space for a child entry in the node ( = \WORDSINBTREEMAIN - 4)") (CONSTANTS (\BTREEMAXENTRIES 8) (\BTREEMAXCOUNT 8) (\BTREEWORDSPERENTRY 4) (\WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4)) (\BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES) 4)) (\BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1) 4))) (FILES (LOADCOMP) TEDITDECLS)) (FNS UPDATEPCNODES FINDPCNODE \FIRSTNODE \DELETETREE \INSERTTREE \LASTNODE \MATCHPCS \SPLITTREE \TEDIT.UPDATETREE \TEDIT.PIECE-CHNO \TEDIT.SET-TOTLEN) (FNS DISPTREE TREEGRAPHNODE) (RECORDS BTREENODE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Balanced tree PIECE TABLE supporting functions") (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \BTREEMAXENTRIES 8) (RPAQQ \BTREEMAXCOUNT 8) (RPAQQ \BTREEWORDSPERENTRY 4) (RPAQ \WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4)) (RPAQ \BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES) 4)) (RPAQ \BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1) 4)) (CONSTANTS (\BTREEMAXENTRIES 8) (\BTREEMAXCOUNT 8) (\BTREEWORDSPERENTRY 4) (\WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4)) (\BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES) 4)) (\BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1) 4))) ) (FILESLOAD (LOADCOMP) TEDITDECLS) ) (DEFINEQ (UPDATEPCNODES - [LAMBDA (PC DELTA) (* ; "Edited 21-Apr-93 16:09 by jds") - - (* ;; "ADD DELTA TO CHNUM IN NEXTALL NODES OF TOPNODE.") - - (LET ((UPWARD (fetch (PIECE PTREENODE) of PC))) - (while UPWARD do (for I from 0 by 4 as ITEM from 1 - to (fetch (BTREENODE COUNT) of UPWARD) - when (EQ PC (\GETBASEPTR UPWARD I)) - do [\PUTBASEFIXP UPWARD (IPLUS I 2) - (IPLUS DELTA (\GETBASEFIXP UPWARD (IPLUS I 2] - (add (fetch (BTREENODE TOTLEN) of UPWARD) - DELTA) - (SETQ PC UPWARD) - (SETQ UPWARD (fetch (BTREENODE UPWARD) of PC)) - (RETURN) finally (HELP "Piece not in its TREENODE"]) (FINDPCNODE - [LAMBDA (PC PCTB) (* ; "Edited 13-Apr-93 15:00 by jds") - - (* ;; "Given a piece and the pctb it's in, return pcnode") - - (fetch (PIECE PTREENODE) of PC]) (\FIRSTNODE - [LAMBDA (TREE) (* ; "Edited 14-Apr-93 02:06 by jds") - (LET ((COUNT (fetch (BTREENODE COUNT) of TREE)) - CHILD) - (SETQ CHILD (\GETBASEPTR TREE 0)) - (COND - ((type? BTREENODE CHILD) - (\FIRSTNODE CHILD)) - (T TREE]) (\DELETETREE [LAMBDA (OLD PCNODE) (* ;  "Edited 21-Mar-95 15:29 by sybalsky:mv:envos") (* ;; "Removes OLD from PCNODE. OLD is either a piece or tree node.") (UNINTERRUPTABLY (LET* ((OLDLEN (ffetch (BTREENODE TOTLEN) of PCNODE)) NEWLEN INCHNO AFTERFLG NODE-COUNT ITEM# BB) (* ;; "NEW CODE") (SETQ NODE-COUNT (fetch (BTREENODE COUNT) of PCNODE)) (* ;; "Find OLD, .") (for old ITEM# from 0 to (LLSH (SUB1 NODE-COUNT) 2) by 4 when (EQ OLD (\GETBASEPTR PCNODE ITEM#)) do (RETURN) finally (HELP "Piece/node not in PCNODE")) (* ;; "Update the previous piece's length, if appropriate:") (SETQ BB (\ADDBASE PCNODE ITEM#)) (\RPLPTR BB 0 NIL) [for I from 0 to (IDIFFERENCE \BTREELASTREALOFFSET ITEM#) by 4 do (\PUTBASEPTR BB I (\GETBASEPTR BB (IPLUS I 4))) (\PUTBASEFIXP BB (IPLUS I 2) (\GETBASEFIXP BB (IPLUS I 6] (\PUTBASEPTR PCNODE \BTREELASTREALOFFSET NIL) (* ;  "Because it's been copied, clear the old value before the refcnt-er gets to it.") (* ;; " If adding this piece EMPTIES the tree node, DELETE it.") (* ;; "FIXMI -- This should coalesce adjacent nodes that are too empty!") [COND ((IEQP NODE-COUNT 1) (\DELETETREE PCNODE (fetch (BTREENODE UPWARD) of PCNODE))) (T (* ;  "No split, so update upper nodes with delta-length.") [SETQ NEWLEN (replace (BTREENODE TOTLEN) of PCNODE with (for I from 2 to NODE-COUNT as ITEM# from 2 by 4 sum (\GETBASEFIXP PCNODE ITEM#] (replace (BTREENODE COUNT) of PCNODE with (SUB1 NODE-COUNT)) (\TEDIT.UPDATETREE PCNODE (IDIFFERENCE NEWLEN OLDLEN] (* ;; "END NEW CODE") 1))]) (\INSERTTREE [LAMBDA (NEW OLD PCNODE NEW-PREVLEN NEW-OLDLEN PREV) (* ;  "Edited 21-Mar-95 15:29 by sybalsky:mv:envos") (* ;; "inserts NEW in front of OLD in PCNODE. NEW/OLD are either pieces or tree nodes.") (* ;; "If NEWE-PREVLEN is non-NIL, it's a DELTA for updating parents of THE PIECE BEFORE OLD. This is used by \SPLITPIECE to pass down the new shortened length for the original piece.") (UNINTERRUPTABLY (LET* ((OLDLEN (ffetch (BTREENODE TOTLEN) of PCNODE)) NEWLEN INCHNO AFTERFLG NODE-COUNT ITEM# BB) (* ;; "NEW CODE") (SETQ NODE-COUNT (fetch (BTREENODE COUNT) of PCNODE)) (* ;; "Find OLD, and insert the NEW piece (and length) in front of it.") (for old ITEM# from 0 to (LLSH (SUB1 NODE-COUNT) 2) by 4 when (EQ OLD (\GETBASEPTR PCNODE ITEM#)) do (RETURN) FINALLY (HELP "Old piece not in this PCNODE.")) (OR NEW (HELP "Inserting empty item")) (* ;; "Update the previous piece's length, if appropriate:") [AND NEW-PREVLEN (COND ((ZEROP ITEM#) (* ;; "The hard way -- the previous piece is in a prior btree node, so we have to go there to update it.") (LET* ((NODE (fetch (PIECE PTREENODE) of PREV))) (UPDATEPCNODES PREV NEW-PREVLEN))) (T (* ;; "Easy way -- it's in this node. Update it in place.") (\PUTBASEFIXP PCNODE (IDIFFERENCE ITEM# 2) (IPLUS NEW-PREVLEN (\GETBASEFIXP PCNODE (IDIFFERENCE ITEM# 2] (COND (NEW-OLDLEN (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2) NEW-OLDLEN))) (SETQ BB (\ADDBASE PCNODE ITEM#)) (\RPLPTR PCNODE \WORDSINBTREEMAIN NIL) (* ;  "Clean out the slot that's about to be copied over.") (\BLT (\ADDBASE BB 4) BB (IDIFFERENCE \WORDSINBTREEMAIN ITEM#)) (\PUTBASEPTR PCNODE ITEM# NIL) (* ;  "Because it's been copied, clear the old value before the refcnt-er gets to it.") (\RPLPTR PCNODE ITEM# NEW) (COND ((type? PIECE NEW) (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2) (fetch (PIECE PLEN) of NEW)) (replace (PIECE PTREENODE) of NEW with PCNODE)) ((type? BTREENODE NEW) (* ; "Inserting a NODE") (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2) (fetch (BTREENODE TOTLEN) of NEW)) (replace (BTREENODE UPWARD) of NEW with PCNODE)) (T (\ILLEGAL.ARG NEW))) [SETQ NEWLEN (replace (BTREENODE TOTLEN) of PCNODE with (for I from 0 to NODE-COUNT as ITEM# from 2 by 4 sum (\GETBASEFIXP PCNODE ITEM#] (* ;; " If adding this piece overflows the tree node, split it.") [COND ((IEQP NODE-COUNT \BTREEMAXCOUNT) (* ;  "Tree node is full, so have to split.") (\SPLITTREE PCNODE OLD NEW)) (T (* ;  "No split, so update upper nodes with delta-length.") (replace (BTREENODE COUNT) of PCNODE with (ADD1 NODE-COUNT)) (\TEDIT.UPDATETREE PCNODE (IDIFFERENCE NEWLEN OLDLEN] (* ;; "END NEW CODE") 1))]) (\LASTNODE - [LAMBDA (TREE) (* ; "Edited 14-Apr-93 16:29 by jds") - (LET ((COUNT (fetch (BTREENODE COUNT) of TREE)) - CHILD) - (for ITEM# from (LLSH (IDIFFERENCE COUNT 1) - 2) to 0 by -4 when (SETQ CHILD (\GETBASEPTR TREE - ITEM#)) - do (RETURN (COND - ((type? BTREENODE CHILD) - (\LASTNODE CHILD)) - (T TREE]) (\MATCHPCS - [LAMBDA (PCNODE) (* ; "Edited 5-May-93 17:57 by jds") - - (* ;; "Make sure that any pieces pointed to this node point back to this node.") - - (bind PC for OFFSET from 0 to \WORDSINBTREEMAIN by 4 as I from 1 - to (fetch (BTREENODE COUNT) of PCNODE) do (SETQ PC (\GETBASEPTR PCNODE OFFSET) - ) - (COND - ((type? PIECE PC) - (replace (PIECE PTREENODE) - of PC with PCNODE)) - ((type? BTREENODE PC) - (replace (BTREENODE UPWARD) - of PC with PCNODE]) (\SPLITTREE - [LAMBDA (PCNODE) (* ; - "Edited 21-Mar-95 15:26 by sybalsky:mv:envos") - - (* ;; "We're adding piece NEW in front of OLD. OLD is represented in the B-tree node PCNODE, which is full.") - - (* ;; "Split PCNODE in two and propogate any changes upward.") - - (UNINTERRUPTABLY - [LET ((UPWARD (fetch (BTREENODE UPWARD) of PCNODE)) - COUNT ITEM# NEW1 NEW2) - (COND - (UPWARD - - (* ;; - "Easy case: This is not the root node, so split the node and propogate up.") - - (SETQ NEW1 (create BTREENODE using PCNODE)) - - (* ;; "Clean out upper 3 child entries, leaving only the lower 2. Have to tell GC about actual child slots being set to NIL (hence \RPLPTRs):") - - (for OFST from \BTREETOPHALFOFFSET to \WORDSINBTREEMAIN - by 4 do (\RPLPTR NEW1 OFST NIL) - (\PUTBASEFIXP NEW1 (IPLUS OFST 2) - 0)) - (replace (BTREENODE COUNT) of NEW1 with (LRSH \BTREEMAXENTRIES 1)) - (\TEDIT.SET-TOTLEN NEW1) - (\MATCHPCS NEW1) - - (* ;; - "Now clean up the old piece, to contain only the upper 3 original children:") - - (for OFST from 0 to (SUB1 \BTREETOPHALFOFFSET) by 4 - do (* ; - "For GC, have to tell it we've dropped pointers to first N/2 pieces") - (\RPLPTR PCNODE OFST NIL)) - - (* ;; "Move upper N/2+1 down") - - [for OFST from 0 to \BTREETOPHALFOFFSET by 4 as UPPEROFST - from \BTREETOPHALFOFFSET by 4 - do (\PUTBASEPTR PCNODE OFST (\GETBASEPTR PCNODE UPPEROFST)) - (\PUTBASEFIXP PCNODE (IPLUS 2 OFST) - (\GETBASEFIXP PCNODE (IPLUS 2 UPPEROFST] - - (* ;; "And clean out upper 2 slots, without the GC seeing it:") - - (for OFST from (IPLUS \BTREEWORDSPERENTRY \BTREETOPHALFOFFSET) - to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY - do (\PUTBASEPTR PCNODE OFST NIL) - (\PUTBASEFIXP PCNODE (IPLUS OFST 2) - 0)) - (replace (BTREENODE COUNT) of PCNODE with (ADD1 (LRSH - \BTREEMAXENTRIES - 1))) - (\TEDIT.SET-TOTLEN PCNODE) - (SETQ COUNT (fetch (BTREENODE COUNT) of UPWARD)) - (\INSERTTREE NEW1 PCNODE UPWARD NIL (fetch (BTREENODE TOTLEN) - of PCNODE))) - (T - (* ;; "Hard case: This is the root node. We need to create 2 new nodes, put the split parts there, and re-use this node as the root.") - - (SETQ NEW1 (create BTREENODE using PCNODE)) - (for OFST from \BTREETOPHALFOFFSET to \WORDSINBTREEMAIN by 4 - do (\RPLPTR NEW1 OFST NIL) - (\PUTBASEFIXP NEW1 (IPLUS OFST 2) - 0)) - (replace (BTREENODE UPWARD) of NEW1 with PCNODE) - (replace (BTREENODE COUNT) of NEW1 with (LRSH \BTREEMAXENTRIES 1)) - (\TEDIT.SET-TOTLEN NEW1) - (\MATCHPCS NEW1) - - (* ;; "--") - - (SETQ NEW2 (create BTREENODE using PCNODE)) - (for OFST from 0 to (SUB1 \BTREETOPHALFOFFSET) by 4 - do (* ; - "For GC, have to tell it we've dropped pointers to first N/2 pieces") - (\RPLPTR NEW2 OFST NIL)) - [for OFST from 0 to \BTREETOPHALFOFFSET by 4 as UPPEROFST - from \BTREETOPHALFOFFSET by 4 - do (\PUTBASEPTR NEW2 OFST (\GETBASEPTR NEW2 UPPEROFST)) - (\PUTBASEFIXP NEW2 (IPLUS 2 OFST) - (\GETBASEFIXP NEW2 (IPLUS 2 UPPEROFST] - (for OFST from (IPLUS \BTREEWORDSPERENTRY \BTREETOPHALFOFFSET) - to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY - do (\PUTBASEPTR NEW2 OFST NIL) - (\PUTBASEFIXP NEW2 (IPLUS OFST 2) - 0)) - (replace (BTREENODE UPWARD) of NEW2 with PCNODE) - (replace (BTREENODE COUNT) of NEW2 with (ADD1 (LRSH \BTREEMAXENTRIES 1 - ))) - (\TEDIT.SET-TOTLEN NEW2) - (\MATCHPCS NEW2) - - (* ;; "Now clean out the top-level node, and fill it in with its new children.") - - (for OFST from 0 to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY - do - - (* ;; "Clean out the entries in the node, so we don't over-write them by mistake, thus losing refcount sync.") - - (\RPLPTR PCNODE OFST NIL) - (\PUTBASEFIXP PCNODE (IPLUS 2 OFST) - 0)) - (\RPLPTR PCNODE 0 NEW1) (* ; "Add first new node") - (\PUTBASEFIXP PCNODE 2 (ffetch (BTREENODE TOTLEN) of NEW1)) - (\RPLPTR PCNODE 4 NEW2) (* ; "And the second....") - (\PUTBASEFIXP PCNODE 6 (ffetch (BTREENODE TOTLEN) of NEW2)) - (freplace (BTREENODE COUNT) of PCNODE with 2) - (freplace (BTREENODE TOTLEN) of PCNODE with (IPLUS (ffetch - (BTREENODE TOTLEN) - of NEW1) - (ffetch - (BTREENODE TOTLEN) - of NEW2])]) (\TEDIT.UPDATETREE - [LAMBDA (PCNODE DELTA) (* ; - "Edited 21-Mar-95 14:40 by sybalsky:mv:envos") - - (* ;; "The size of the text represented by PCNODE has grown by DELTA. Update all of PCNODE's parents to reflect the change in length.") - - (LET ((UPWARD (fetch (BTREENODE UPWARD) of PCNODE))) - (while UPWARD do - - (* ;; "Keep going up in the tree til we hit the top.") - - (for old ITEM# from 0 by 4 as I from 1 - to (ffetch (BTREENODE COUNT) of UPWARD) - when (EQ (\GETBASEPTR UPWARD ITEM#) - PCNODE) - do (\PUTBASEFIXP UPWARD (IPLUS ITEM# 2) - (IPLUS (\GETBASEFIXP UPWARD (IPLUS ITEM# 2)) - DELTA)) - (add (fetch (BTREENODE TOTLEN) of UPWARD) - DELTA) - (RETURN) FINALLY (HELP "PCNODE not in upward node.")) - (SETQ PCNODE UPWARD) - (SETQ UPWARD (fetch (BTREENODE UPWARD) of PCNODE]) (\TEDIT.PIECE-CHNO - [LAMBDA (PC) - (LET ((PCNODE (fetch (PIECE PTREENODE) of PC)) - (CHARCOUNT 0)) - (while PCNODE do [add CHARCOUNT (for OFST from 0 by 4 - while (NEQ PC (\GETBASEPTR PCNODE OFST)) - sum (\GETBASEFIXP PCNODE (IPLUS OFST 2] - (SETQ PC PCNODE) - (SETQ PCNODE (fetch (BTREENODE UPWARD) of PCNODE))) - (ADD1 CHARCOUNT]) (\TEDIT.SET-TOTLEN - [LAMBDA (PCNODE) (* ; "Edited 9-May-93 15:40 by jds") - - (* ;; "Fix the TOTLEN field of a node to match the sum of its childrens' lengths") - - (replace (BTREENODE TOTLEN) of PCNODE with (for I from 1 - to (fetch (BTREENODE COUNT) - of PCNODE) as ITEM# - from 2 by 4 - sum (\GETBASEFIXP PCNODE ITEM#]) ) (DEFINEQ (DISPTREE - [LAMBDA (TREE DEPTH) (* ; "Edited 13-Apr-90 15:00 by ON") - (LET [(G (TREEGRAPHNODE TREE NIL (OR (NUMBERP DEPTH) - T] - (SHOWGRAPH (LAYOUTGRAPH (CADR G) - (LIST (CAR G)) - '(VERTICAL)) - NIL - #'(LAMBDA (X) - (INSPECT (fetch NODEID of X]) (TREEGRAPHNODE - [LAMBDA (TREE PARENT DEPTH) (* ; "Edited 12-Jun-90 10:33 by mitani") - (LET (THISNODE NEWDEPTH NODEID LONODES HINODES BFNODE BFNODEID RANKNODE RANKNODEID) - (COND - ((ATOM TREE) - (LIST [fetch NODEID of (SETQ THISNODE (NODECREATE (CONS) - TREE NIL NIL (LIST PARENT] - (LIST THISNODE))) - ((OR (EQ DEPTH T) - (AND (NUMBERP DEPTH) - (>= DEPTH 0))) - (SETQ NEWDEPTH (COND - ((NUMBERP DEPTH) - (SUB1 DEPTH)) - (T DEPTH))) - (SETQ NODEID (fetch (PCTNODE PCE) of TREE)) - (SETQ LONODES (TREEGRAPHNODE (fetch (PCTNODE LO) of TREE) - NODEID NEWDEPTH)) - (SETQ HINODES (TREEGRAPHNODE (fetch (PCTNODE HI) of TREE) - NODEID NEWDEPTH)) - (SETQ BFNODE (NODECREATE (SETQ BFNODEID (CONS)) - (fetch (PCTNODE BF) of TREE) - NIL NIL (LIST NODEID))) - (SETQ RANKNODE (NODECREATE (SETQ RANKNODEID (CONS)) - (fetch (PCTNODE RANK) of TREE) - NIL NIL (LIST NODEID))) - [SETQ THISNODE (NODECREATE NODEID (fetch (PCTNODE CHNUM) of TREE) - NIL - (LIST (CAR LONODES) - BFNODEID RANKNODEID (CAR HINODES)) - (AND PARENT (LIST PARENT] - (LIST (fetch NODEID of THISNODE) - (APPEND (LIST THISNODE BFNODE RANKNODE) - (CADR LONODES) - (CADR HINODES]) ) (DECLARE%: EVAL@COMPILE (DATATYPE BTREENODE ( (* ;; "An order-4 BTREE node for representing the piece table for TEdit.") DOWN1 (DLEN1 FIXP) DOWN2 (DLEN2 FIXP) DOWN3 (DLEN3 FIXP) DOWN4 (DLEN4 FIXP) DOWN5 (DLEN5 FIXP) DOWN6 (DLEN6 FIXP) DOWN7 (DLEN7 FIXP) DOWN8 (DLEN8 FIXP) SPARE5 (* ;  "Used only to hold the extra piece when we're overflowing") (SPARELEN FIXP) (* ; "So the code is easy and fast.") (COUNT BITS 4) (* ; "# of children of this node") (UPWARD XPOINTER) (* ; "Parent of this node, if any.") (TOTLEN FIXP) (* ;  "Total length of this tree and subtrees") )) ) (/DECLAREDATATYPE 'BTREENODE '(POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP (BITS 4) XPOINTER FIXP) '((BTREENODE 0 POINTER) (BTREENODE 2 FIXP) (BTREENODE 4 POINTER) (BTREENODE 6 FIXP) (BTREENODE 8 POINTER) (BTREENODE 10 FIXP) (BTREENODE 12 POINTER) (BTREENODE 14 FIXP) (BTREENODE 16 POINTER) (BTREENODE 18 FIXP) (BTREENODE 20 POINTER) (BTREENODE 22 FIXP) (BTREENODE 24 POINTER) (BTREENODE 26 FIXP) (BTREENODE 28 POINTER) (BTREENODE 30 FIXP) (BTREENODE 32 POINTER) (BTREENODE 34 FIXP) (BTREENODE 32 (BITS . 3)) (BTREENODE 36 XPOINTER) (BTREENODE 38 FIXP)) '40) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PCTREE COPYRIGHT ("Venue & Xerox Corporation" 1990 1991 1993 1994 1995 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3028 23323 (UPDATEPCNODES 3038 . 4125) (FINDPCNODE 4127 . 4359) (\FIRSTNODE 4361 . 4718 ) (\DELETETREE 4720 . 7201) (\INSERTTREE 7203 . 11632) (\LASTNODE 11634 . 12277) (\MATCHPCS 12279 . 13403) (\SPLITTREE 13405 . 20581) (\TEDIT.UPDATETREE 20583 . 22060) (\TEDIT.PIECE-CHNO 22062 . 22641) (\TEDIT.SET-TOTLEN 22643 . 23321)) (23324 25764 (DISPTREE 23334 . 23790) (TREEGRAPHNODE 23792 . 25762) )))) STOP \ No newline at end of file diff --git a/library/POSTSCRIPTSTREAM.~1~ b/library/POSTSCRIPTSTREAM.~1~ deleted file mode 100644 index a086e3ba..00000000 --- a/library/POSTSCRIPTSTREAM.~1~ +++ /dev/null @@ -1,3729 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") -(FILECREATED "15-Mar-95 14:50:16" {DSK}library>POSTSCRIPTSTREAM.;9 252259 - - changes to%: (VARS *POSTSCRIPT-NS-TRANSLATIONS*) - - previous date%: " 4-Jan-95 11:17:13" {DSK}library>POSTSCRIPTSTREAM.;8) - - -(* ; " -Copyright (c) 1989, 1990, 1991, 1992, 1993, 1994, 1995 by Venue This program or documentation contains confidential information and trade secrets of Venue. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Venue. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved. -") - -(PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS) - -(RPAQQ POSTSCRIPTSTREAMCOMS - [ - (* ;; "PostScript printer support for Medley") - - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FONTID PSCFONT \POSTSCRIPTDATA POSTSCRIPTXFORM)) - (INITRECORDS \POSTSCRIPTDATA) - (FNS POSTSCRIPT.INIT) - (ADDVARS (DEFAULTFILETYPELIST (PS . TEXT) - (PSC . TEXT) - (PSF . BINARY) - (PSCFONT . BINARY) - (POSTSCRIPT . TEXT)) - (*DISPLAY-FONT-NAME-MAP* (AVANTGARDE-BOOK . AB) - (AVANTGARDE-DEMI . AD) - (BECKMAN . BM) - (BOOKMAN-LIGHT . BL) - (BOOKMAN-DEMI . BD) - (COURIER . CO) - (HELVETICA-NARROW . HN) - (NEWCENTURYSCHLBK . NC) - (PALATINO . PA) - (TIMES . TS) - (ZAPFCHANCERY-MEDIUM . ZM) - (ZAPFCHANCERY . ZC) - (ZAPFDINGBATS . ZD))) - - (* ;; "Font-reading code") - - (FNS PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.COERCEFILE PSCFONTFROMCACHE.SPELLFILE - PSCFONTFROMCACHE.COERCEFILE PSCFONT.WRITEFONT READ-AFM-FILE CONVERT-AFM-FILES - POSTSCRIPT.GETFONTID POSTSCRIPT.FONTCREATE \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS - POSTSCRIPT.FONTSAVAILABLE) - (COMS - (* ;; "Until macro in FONT is exported") - - (MACROS \FSETCHARWIDTH)) - (FNS OPENPOSTSCRIPTSTREAM CLOSEPOSTSCRIPTSTREAM) - (INITVARS (*POSTSCRIPT-FILE-TYPE* 'BINARY)) - (FNS POSTSCRIPT.HARDCOPYW POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP MAKEEPSFILE) - (FNS POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.ENDPAGE POSTSCRIPT.OUTSTR - POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SET-FAKE-LANDSCAPE - POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK - \PS.SCALEREGION \SCALEDBITBLT.PSC \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC - \SWITCHFONTS.PSC \TERPRI.PSC) - - (* ;; "DIG operations: ") - - (FNS \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \CREATECHARSET.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC - \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC - \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPCOLOR.PSC \DSPFONT.PSC - \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPPUSHSTATE.PSC \DSPPOPSTATE.PSC \DSPRESET.PSC - \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC \DSPSCALE.PSC \DSPSCALE2.PSC \DSPSPACEFACTOR.PSC - \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC - \FILLPOLYGON.PSC \FIXLINELENGTH.PSC \MOVETO.PSC \NEWPAGE.PSC) - (COMS - (* ;; "Character-output, plus special-cases:") - - (FNS \POSTSCRIPT.CHANGECHARSET \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PRINTSLUG - \POSTSCRIPT.SPECIALOUTCHARFN \UPDATE.PSC \POSTSCRIPT.ACCENTFN - \POSTSCRIPT.ACCENTPAIR) - - (* ;; - "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions") - - (FNS \PSC.SPACEDISP \PSC.SPACEWID \PSC.SYMBOLS) - - (* ;; - "The mapping of NS characters to Postscript renderings, both as an AList and as a hashtable") - - (FNS \POSTSCRIPT.NSHASH) - (VARS (*POSTSCRIPT-UNACCENTED-FONTS* '(Dancer ZapfDingbats "Dancer" "ZapfDingbats")) - *POSTSCRIPT-NS-TRANSLATIONS*) - (GLOBALVARS *POSTSCRIPT-NS-HASH*)) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \POSTSCRIPT.FRACTION)) - (VARS (\POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T - "Print this file/document/image in Landscape Orientation" - ) - ("Portrait" 'NIL - "Print this file/document/image in Portrait Orientation" - )) - TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _ - (create POSITION XCOORD _ -1 YCOORD _ 0) - CHANGEOFFSETFLG _ 'Y)) - (\POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS _ '(("Ask" 'ASK - "Always ask whether to print in Landscape or Portrait Orientation" - ) - ("Landscape" T - "Default printing to Landscape Orientation" - ) - ("Portrait" 'NIL - "Default printing to Portrait Orientation" - )) - TITLE _ "Default Orientation" CENTERFLG _ - T)) - PS.BITMAPARRAY \POSTSCRIPT.JOB.SETUP SlopeMenuItems WeightMenuItems) - [ADDVARS (BackgroundMenuCommands ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE - (MENU - \POSTSCRIPT.ORIENTATION.OPTIONS.MENU - )) - - "Select the default Orientation for PostScript output" - (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE - 'ASK) - - "Always ask whether to print in Landscape or Portrait Orientation" - ) - ("Landscape" '(SETQ - POSTSCRIPT.PREFER.LANDSCAPE - T) - - "Default printing to Landscape Orientation" - ) - ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE - NIL) - - "Default printing to Portrait Orientation" - ] - (VARS (BackgroundMenu NIL)) - (CONSTANTS (GOLDEN.RATIO 1.618034) - (\PS.SCALE0 100) - (\PS.TEMPARRAYLEN 20)) - (INITVARS (POSTSCRIPT.BITMAP.SCALE 1) - (POSTSCRIPT.EOL 'CR) - (POSTSCRIPT.IMAGESIZEFACTOR 1) - (POSTSCRIPT.PREFER.LANDSCAPE NIL) - (POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) - (POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800)) - (POSTSCRIPT.TEXTURE.SCALE 4) - [POSTSCRIPTFONTDIRECTORIES (LIST (COND ((EQ (MACHINETYPE) - 'MAIKO) - "{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/") - (T "{DSK}POSTSCRIPT>"] - (\POSTSCRIPT.MAX.WILD.FONTSIZE 72)) - [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) - (HELVETICAD . HELVETICA) - (TIMESROMAN . TIMES) - (TIMESROMAND . TIMES) - (COURIER . COURIER) - (GACHA . COURIER) - (CLASSIC . NEWCENTURYSCHLBK) - (MODERN . HELVETICA) - (CREAM . HELVETICA) - (TERMINAL . COURIER) - (LOGO . HELVETICA) - (OPTIMA . PALATINO) - (TITAN . COURIER)) - [PRINTERTYPES ((POSTSCRIPT) - (CANPRINT (POSTSCRIPT)) - (STATUS TRUE) - (PROPERTIES NILL) - (SEND UnixPrint) - (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) - (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION - ROTATION TITLE] - [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) - (EXTENSION (PS PSC PSF)) - (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT] - (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) - (FONTCREATE POSTSCRIPT.FONTCREATE) - (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) - (CREATECHARSET \CREATECHARSET.PSC] - (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER)) - [APPENDVARS (POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) - (-0.1 -0.1 8.7 11.2)) - (LEGAL (0 0 8.5 14) - (-0.1 -0.1 8.7 14.2)) - (NOTE (0 0 8.5 11) - (-0.1 -0.1 8.7 11.2] - (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST - POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE - POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE - \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE - POSTSCRIPT.PAGEREGIONS) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (POSTSCRIPT.INIT))) - (PROP (FILETYPE MAKEFILE-ENVIRONMENT) - POSTSCRIPTSTREAM) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA - POSTSCRIPT.PUTCOMMAND - ]) - - - -(* ;; "PostScript printer support for Medley") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR)) - -(RECORD PSCFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS)) - -(DATATYPE \POSTSCRIPTDATA - ((POSTSCRIPTACCENTED FLAG) (* ; - "T if we're to do NS-to-PS translations on characters in the current font.") - POSTSCRIPTFONT (* ; - "The fontdescriptor of the current font") - POSTSCRIPTX (* ; "The current X") - POSTSCRIPTY (* ; "... and Y") - POSTSCRIPTLEFTMARGIN (* ; "The margins") - POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLINESPACING - (* ; "Line to line spacing") - POSTSCRIPTCOLOR (* ; - "Color (or grey shade) in effect; 0.0=black, 1.0=white.") - POSTSCRIPTSCALE (* ; "Scale of the stream") - POSTSCRIPTOPERATION (* ; - "Default operation (PAINT, REPLACE, ...)") - POSTSCRIPTCLIPPINGREGION (* ; - "The current region available to be written into") - POSTSCRIPTPAGENUM (* ; "Current page number") - POSTSCRIPTHEADING (* ; "The heading") - POSTSCRIPTHEADINGFONT (* ; "Font for the heading") - POSTSCRIPTSPACEFACTOR (* ; - "Expansion factor for spaces (see DSPSPACEFACTOR)") - POSTSCRIPTSPACEWIDTH (* ; - "The width of a space in the current font") - POSTSCRIPTLANDSCAPE (* ; - "non-NIL for paper in 'landscape' mode") - POSTSCRIPTCHARSTOSHOW (* ; - "non-NIL if the string (PostScript-type string) of chars has already been started") - POSTSCRIPTFONTCHANGEDFLG (* ; "Font has changed") - POSTSCRIPTMOVEFLG (* ; "Need to move") - POSTSCRIPTWIDTHS (* ; - "The widths vector of the current font") - POSTSCRIPTTRANSX (* ; "Translation in X") - POSTSCRIPTTRANSY (* ; "... and Y") - POSTSCRIPTPENDINGXFORM (* ; - "A userspace to devicespace transform is pending") - POSTSCRIPTPAGEREGION (* ; "The whole page") - POSTSCRIPTPAGEBLANK (* ; "This page is blank flag") - POSTSCRIPTSCALEHACK (* ; - "For \PS.SCALEHACK since DSPSCALE doesn't change the scale of the stream") - POSTSCRIPTTEMPARRAY (* ; - "For converting FIXP to string of digit chars") - POSTSCRIPTXFORMSTACK (* ; "The stack of transformations. DSPPUSHSTATE pushes one onto this, DSPPOPSTATE uses it to reset values.") - POSTSCRIPTROTATION (* ; - "Rotation value currently in effect.") - POSTSCRIPTPENDINGROTATION (* ; - "Rotation to take effect at next SETXFORM.") - POSTSCRIPTFONTSUSED (* ; "List of FONTIDs of the fonts that've been used before. This is used to control the re-encoding of fonts for accented-character rendering.") - (POSTSCRIPTNSCHARSET BYTE) (* ; - "Current NSCHARSET--widths are in POSTSCRIPTWIDTHS") - (POSTSCRIPTNATURALSPACEWIDTH WORD) (* ; - "Width of the space in the current font, used to compute the scaled space width.") - ) - POSTSCRIPTX _ 0 POSTSCRIPTY _ 0 POSTSCRIPTTRANSX _ 0 POSTSCRIPTTRANSY _ 0 - POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0 POSTSCRIPTSCALEHACK _ 1 POSTSCRIPTTEMPARRAY - _ (ARRAY \PS.TEMPARRAYLEN 'BYTE 0 0) - POSTSCRIPTROTATION _ 0 POSTSCRIPTCOLOR _ 0.0) - -(RECORD POSTSCRIPTXFORM ( - (* ;; "Holds the transformation state as saved by DSPPUSHSTATE. Used by DSPPOPSTATE to restore the tranformation state.") - - PSXCLIP (* ; "Clipping region") - PSXPAGE (* ; "Page region") - PSXX (* ; "X position?") - PSXY (* ; "Y position?") - PSXLEFT (* ; "Left margin") - PSXRIGHT (* ; "Right margin") - PSXTOP (* ; "Top margin") - PSXBOTTOM (* ; "Bottom Margin") - PSXTRANX (* ; "X-translation in effect") - PSXTRANY (* ; "Y-translation in effect") - PSXLAND (* ; "Landscape?") - PSXXFORMPEND (* ; "Are there transforms pending? ") - )) -) - -(/DECLAREDATATYPE '\POSTSCRIPTDATA - '(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 - BYTE WORD) - '((\POSTSCRIPTDATA 0 (FLAGBITS . 0)) - (\POSTSCRIPTDATA 0 POINTER) - (\POSTSCRIPTDATA 2 POINTER) - (\POSTSCRIPTDATA 4 POINTER) - (\POSTSCRIPTDATA 6 POINTER) - (\POSTSCRIPTDATA 8 POINTER) - (\POSTSCRIPTDATA 10 POINTER) - (\POSTSCRIPTDATA 12 POINTER) - (\POSTSCRIPTDATA 14 POINTER) - (\POSTSCRIPTDATA 16 POINTER) - (\POSTSCRIPTDATA 18 POINTER) - (\POSTSCRIPTDATA 20 POINTER) - (\POSTSCRIPTDATA 22 POINTER) - (\POSTSCRIPTDATA 24 POINTER) - (\POSTSCRIPTDATA 26 POINTER) - (\POSTSCRIPTDATA 28 POINTER) - (\POSTSCRIPTDATA 30 POINTER) - (\POSTSCRIPTDATA 32 POINTER) - (\POSTSCRIPTDATA 34 POINTER) - (\POSTSCRIPTDATA 36 POINTER) - (\POSTSCRIPTDATA 38 POINTER) - (\POSTSCRIPTDATA 40 POINTER) - (\POSTSCRIPTDATA 42 POINTER) - (\POSTSCRIPTDATA 44 POINTER) - (\POSTSCRIPTDATA 46 POINTER) - (\POSTSCRIPTDATA 48 POINTER) - (\POSTSCRIPTDATA 50 POINTER) - (\POSTSCRIPTDATA 52 POINTER) - (\POSTSCRIPTDATA 54 POINTER) - (\POSTSCRIPTDATA 56 POINTER) - (\POSTSCRIPTDATA 58 POINTER) - (\POSTSCRIPTDATA 60 POINTER) - (\POSTSCRIPTDATA 62 POINTER) - (\POSTSCRIPTDATA 64 POINTER) - (\POSTSCRIPTDATA 66 (BITS . 7)) - (\POSTSCRIPTDATA 67 (BITS . 15))) - '68) -) - -(/DECLAREDATATYPE '\POSTSCRIPTDATA - '(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 - BYTE WORD) - '((\POSTSCRIPTDATA 0 (FLAGBITS . 0)) - (\POSTSCRIPTDATA 0 POINTER) - (\POSTSCRIPTDATA 2 POINTER) - (\POSTSCRIPTDATA 4 POINTER) - (\POSTSCRIPTDATA 6 POINTER) - (\POSTSCRIPTDATA 8 POINTER) - (\POSTSCRIPTDATA 10 POINTER) - (\POSTSCRIPTDATA 12 POINTER) - (\POSTSCRIPTDATA 14 POINTER) - (\POSTSCRIPTDATA 16 POINTER) - (\POSTSCRIPTDATA 18 POINTER) - (\POSTSCRIPTDATA 20 POINTER) - (\POSTSCRIPTDATA 22 POINTER) - (\POSTSCRIPTDATA 24 POINTER) - (\POSTSCRIPTDATA 26 POINTER) - (\POSTSCRIPTDATA 28 POINTER) - (\POSTSCRIPTDATA 30 POINTER) - (\POSTSCRIPTDATA 32 POINTER) - (\POSTSCRIPTDATA 34 POINTER) - (\POSTSCRIPTDATA 36 POINTER) - (\POSTSCRIPTDATA 38 POINTER) - (\POSTSCRIPTDATA 40 POINTER) - (\POSTSCRIPTDATA 42 POINTER) - (\POSTSCRIPTDATA 44 POINTER) - (\POSTSCRIPTDATA 46 POINTER) - (\POSTSCRIPTDATA 48 POINTER) - (\POSTSCRIPTDATA 50 POINTER) - (\POSTSCRIPTDATA 52 POINTER) - (\POSTSCRIPTDATA 54 POINTER) - (\POSTSCRIPTDATA 56 POINTER) - (\POSTSCRIPTDATA 58 POINTER) - (\POSTSCRIPTDATA 60 POINTER) - (\POSTSCRIPTDATA 62 POINTER) - (\POSTSCRIPTDATA 64 POINTER) - (\POSTSCRIPTDATA 66 (BITS . 7)) - (\POSTSCRIPTDATA 67 (BITS . 15))) - '68) -(DEFINEQ - -(POSTSCRIPT.INIT -(LAMBDA NIL (* ; "Edited 4-Jan-95 10:46 by jds") (* ; "Edited 4-Feb-93 21:08 by jds") (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE)) (* ;; "Add POSTSCRIPT font descriptions to the active font profile.") (MAPC (CL:REMOVE-DUPLICATES (NCONC (for FD in FONTDEFS join (for FP in (CDR (ASSOC (QUOTE FONTPROFILE) (CDR FD))) collect (CAR FP))) (QUOTE (FONT7 FONT6 FONT5 FONT4 FONT3 FONT2 FONT1 BOLDFONT LITTLEFONT BIGFONT PRETTYCOMFONT COMMENTFONT USERFONT SYSTEMFONT CLISPFONT LAMBDAFONT CHANGEFONT DEFAULTFONT)))) (FUNCTION (LAMBDA (CLASS) (LET (COPYFD OLDPSCFD) (if (BOUNDP CLASS) then (SETQ CLASS (EVALV CLASS)) (if (TYPEP CLASS (QUOTE FONTCLASS)) then (SETQ COPYFD (OR (fetch (FONTCLASS INTERPRESSFD) of CLASS) (fetch (FONTCLASS PRESSFD) of CLASS) (fetch (FONTCLASS DISPLAYFD) of CLASS))) (if (SETQ OLDPSCFD (ASSOC (QUOTE POSTSCRIPT) (fetch (FONTCLASS OTHERFDS) of CLASS))) then (if (NOT (CDR OLDPSCFD)) then (RPLACD OLDPSCFD (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD)))) else (push (fetch (FONTCLASS OTHERFDS) of CLASS) (CONS (QUOTE POSTSCRIPT) (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD))))))))))) (FOR FD IN FONTDEFS DO (FOR FP IN (CDR (ASSOC (QUOTE FONTPROFILE) (CDR FD))) DO (COND ((ASSOC (QUOTE POSTSCRIPT) (CL:NTHCDR 5 FP)) (* ;; "There's already a postscript spec, so leave it be.")) (T (NCONC1 FP (BQUOTE (POSTSCRIPT (\, (OR (CL:FIFTH FP) (CL:FOURTH FP) (CL:THIRD FP)))))))))) (* ;; "Eliminate any existing postscript fonts, to start with a clean slate if reinitializing.") (FOR FD IN (FONTSAVAILABLE (QUOTE *) (QUOTE *) (QUOTE *) (QUOTE *) (QUOTE POSTSCRIPT)) DO (APPLY (FUNCTION SETFONTDESCRIPTOR) FD)) (SETQ POSTSCRIPTFONTCACHE NIL) (SETQ \POSTSCRIPT.CHARTYPE (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT T)) (* ;; "\POSTSCRIPT.OUTCHARFN uses this array to quickly determine whether a character needs any special processing -- T means yes") (for x from (CHARCODE SP) to 126 unless (FMEMB x (CHARCODE (%( %) \))) do (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE x) NIL)) (SETQ \POSTSCRIPTIMAGEOPS (create IMAGEOPS IMAGETYPE _ (QUOTE POSTSCRIPT) IMCLOSEFN _ (FUNCTION CLOSEPOSTSCRIPTSTREAM) IMXPOSITION _ (FUNCTION \DSPXPOSITION.PSC) IMYPOSITION _ (FUNCTION \DSPYPOSITION.PSC) IMMOVETO _ (FUNCTION \MOVETO.PSC) IMFONT _ (FUNCTION \DSPFONT.PSC) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.PSC) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.PSC) IMLINEFEED _ (FUNCTION \DSPLINEFEED.PSC) IMDRAWLINE _ (FUNCTION \DRAWLINE.PSC) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.PSC) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.PSC) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.PSC) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.PSC) IMBLTSHADE _ (FUNCTION \BLTSHADE.PSC) IMBITBLT _ (FUNCTION \BITBLT.PSC) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.PSC) IMNEWPAGE _ (FUNCTION \NEWPAGE.PSC) IMSCALE _ (FUNCTION \DSPSCALE.PSC) IMSCALE2 _ (FUNCTION \DSPSCALE2.PSC) IMCOLOR _ (FUNCTION \DSPCOLOR.PSC) IMTERPRI _ (FUNCTION \TERPRI.PSC) IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PSC) IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PSC) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PSC) IMFONTCREATE _ (QUOTE POSTSCRIPT) IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.PSC) IMRESET _ (FUNCTION \DSPRESET.PSC) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.PSC) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.PSC) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.PSC) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.PSC) IMDRAWARC _ (FUNCTION \DRAWARC.PSC) IMROTATE _ (FUNCTION \DSPROTATE.PSC) IMTRANSLATE _ (FUNCTION \DSPTRANSLATE.PSC) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.PSC) IMPUSHSTATE _ (FUNCTION \DSPPUSHSTATE.PSC) IMPOPSTATE _ (FUNCTION \DSPPOPSTATE.PSC))) (SETQ *POSTSCRIPT-NS-HASH* (HARRAY 255)) (\POSTSCRIPT.NSHASH *POSTSCRIPT-NS-TRANSLATIONS*)) -) -) - -(ADDTOVAR DEFAULTFILETYPELIST (PS . TEXT) - (PSC . TEXT) - (PSF . BINARY) - (PSCFONT . BINARY) - (POSTSCRIPT . TEXT)) - -(ADDTOVAR *DISPLAY-FONT-NAME-MAP* (AVANTGARDE-BOOK . AB) - (AVANTGARDE-DEMI . AD) - (BECKMAN . BM) - (BOOKMAN-LIGHT . BL) - (BOOKMAN-DEMI . BD) - (COURIER . CO) - (HELVETICA-NARROW . HN) - (NEWCENTURYSCHLBK . NC) - (PALATINO . PA) - (TIMES . TS) - (ZAPFCHANCERY-MEDIUM . ZM) - (ZAPFCHANCERY . ZC) - (ZAPFDINGBATS . ZD)) - - - -(* ;; "Font-reading code") - -(DEFINEQ - -(PSCFONT.READFONT [LAMBDA (FONTFILENAME) (* ; "Edited 5-Oct-93 17:19 by rmk:") (* ; "Edited 1-Sep-89 10:55 by jds") (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics. First check to see if incore cache as information indexed under the file's name.") (LET (FID W [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T] (PF (create PSCFONT))) [replace (PSCFONT FID) of PF with (SETQ FID (READ S (FIND-READTABLE "INTERLISP"] (* ;; "Read until we hit a 255 byte, marking the end of the font-id section.") (CL:DO NIL ((EQ (BIN S) 255)) (* ;; "Body of the loop is empty, the test does all of the work") ) (replace (PSCFONT IL-FONTID) of PF with (CAR FID)) (replace (PSCFONT FIRSTCHAR) of PF with (\WIN S)) (replace (PSCFONT LASTCHAR) of PF with (\WIN S)) (replace (PSCFONT ASCENT) of PF with (\WIN S)) (replace (PSCFONT DESCENT) of PF with (\WIN S)) (replace (PSCFONT WIDTHS) of PF with (SETQ W (ARRAY 256 'SMALLPOSP 0 0))) (for C from 0 to 255 do (SETA W C (\WIN S))) (CLOSEF S) (* ;;  "PATCH JDS 9/1/89: The afm font reader made fonts too tall. This should fix things pro tem.") (replace (PSCFONT ASCENT) of PF with (- 1000 (fetch (PSCFONT DESCENT) OF PF))) (PUSH POSTSCRIPTFONTCACHE (CONS (L-CASE (FILENAMEFIELD FONTFILENAME 'NAME)) (CREATE PSCFONT USING PF))) PF]) - -(PSCFONT.SPELLFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 22:15 by rmk:") (* ; "Edited 5-Oct-92 15:23 by jds") (* ;;  "Find the font file for a postscript font. Does the display-name conversion as well, for DOS.") (CL:WHEN POSTSCRIPTFONTDIRECTORIES (\FINDFONTFILE (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST)) FAMILY) SIZE FACE 0 DEVICE 0 POSTSCRIPTFONTDIRECTORIES '(PSCFONT PF PSC)))]) - -(PSCFONT.COERCEFILE [LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE) (* ; "Edited 5-Oct-93 16:28 by rmk:") (* ;; "This coerces the WEIGHT and SLOPE incrementally back to REGULAR in order to find a matching file.") (COND ((AND (NEQ EXPANSION 'REGULAR) (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) ROTATION DEVICE))) ((AND (EQ SLOPE 'ITALIC) (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) ROTATION DEVICE))) ((AND (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (EQ SLOPE 'ITALIC) (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) ROTATION DEVICE]) - -(PSCFONTFROMCACHE.SPELLFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 17:54 by rmk:") (* ; "Edited 5-Oct-92 15:23 by jds") (* ;; "Tries to find postscript font information in the cache, indexed by the name-field of the fontfile. ") (LET [(CACHE (CDR (ASSOC (L-CASE (FILENAMEFIELD (\FONTFILENAME (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST )) FAMILY) SIZE FACE 'PSCFONT 0) 'NAME)) POSTSCRIPTFONTCACHE] (IF CACHE THEN (CREATE PSCFONT USING CACHE]) - -(PSCFONTFROMCACHE.COERCEFILE [LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE) (* ; "Edited 5-Oct-93 17:00 by rmk:") (* ;; "This coerces the WEIGHT and SLOPE incrementally back to REGULAR in order to find a matching font in the cache.") (COND ((AND (NEQ EXPANSION 'REGULAR) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) ROTATION DEVICE))) ((AND (EQ SLOPE 'ITALIC) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) ROTATION DEVICE))) ((AND (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (EQ SLOPE 'ITALIC) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) ROTATION DEVICE))) ((AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) ROTATION DEVICE]) - -(PSCFONT.WRITEFONT - [LAMBDA (FONTFILENAME PF) (* ; - "Edited 5-Aug-93 16:28 by sybalskY:MV:ENVOS") - - (* ;; "Given a PSCFONT data structure, write it out as a properly-named xxx.PSCFONT file, for later reading.") - - NIL - (LET ([S (OPENSTREAM FONTFILENAME 'OUTPUT NIL '((TYPE BINARY) - (SEQUENTIAL T] - (W (fetch (PSCFONT WIDTHS) of PF)) - (*READTABLE* (FIND-READTABLE "INTERLISP"))) - (PRIN3 (fetch (PSCFONT FID) of PF) - S) - (BOUT S 0) - (BOUT S 255) - (\WOUT S (fetch (PSCFONT FIRSTCHAR) of PF)) - (\WOUT S (fetch (PSCFONT LASTCHAR) of PF)) - (\WOUT S (fetch (PSCFONT ASCENT) of PF)) - (\WOUT S (fetch (PSCFONT DESCENT) of PF)) - (for C from 0 to 255 do (\WOUT S (ELT W C))) - (CLOSEF S) - FONTFILENAME]) - -(READ-AFM-FILE - [LAMBDA (FILE BOLDNESS ITALICNESS) (* ; - "Edited 5-Aug-93 16:37 by sybalskY:MV:ENVOS") - - (* ;; - "Read an Adobe-version-3 AFM file, and extract the metrics from it for making a PSCFONT file.") - - (LET ((IFILE (OPENSTREAM FILE 'INPUT)) - (PSCFONT (create PSCFONT)) - (FCHAR 1000) - (LCHAR 0) - (W (ARRAY 256 'SMALLPOSP 0 0)) - TOKEN WEIGHT SLOPE HEIGHT CMCOUNT FBBOX) - (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE)) - do (READCCODE IFILE)) - (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE))) - do (READCCODE IFILE)) - [COND - ((NOT (AND (BOUNDP 'WeightMenu) - (type? MENU WeightMenu))) - (SETQ WeightMenu (create MENU - ITEMS _ WeightMenuItems - MENUFONT _ (FONTCREATE 'HELVETICA 12] - [COND - ((NOT (AND (BOUNDP 'SlopeMenu) - (type? MENU SlopeMenu))) - (SETQ SlopeMenu (create MENU - ITEMS _ SlopeMenuItems - MENUFONT _ (FONTCREATE 'HELVETICA 12] - (OR (SETQ WEIGHT BOLDNESS) - (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu)) - T)) - (OR (SETQ SLOPE ITALICNESS) - (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu)) - T)) - (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR)) - [SETQ IL-FONTID (COND - ((AND (EQ SLOPE 'REGULAR) - (EQ WEIGHT 'MEDIUM)) - TOKEN) - (T (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR] - [repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN) - do (SETQ TOKEN (RSTRING IFILE)) - (COND - [(STRING-EQUAL "FontBBox" TOKEN) - (SETQ FBBOX (LIST (READ IFILE) - (READ IFILE) - (READ IFILE) - (READ IFILE))) - - (* ;; "The Ascender and Descender properties from the AFM file are currently ignored, and the values from the FontBBox are used, SCALED to the height of the font.") - - (SETQ DESCENT (IABS (CADR FBBOX))) - (SETQ ASCENT (CADDDR FBBOX)) - (SETQ HEIGHT (IPLUS ASCENT DESCENT)) - [SETQ DESCENT (FIXR (FTIMES DESCENT (/ 1000 HEIGHT] - (SETQ ASCENT (FIXR (FTIMES ASCENT (/ 1000 HEIGHT] - (T (READCCODE IFILE] - (SETQ CMCOUNT (RATOM IFILE)) - (repeatuntil (EQ (CHARCODE EOL) - (READCCODE IFILE)) do) - (SETQ WIDTHS W) - (for CC from 1 to CMCOUNT - do (LET (CCODE) - (repeatuntil (EQ 'C (RATOM IFILE)) do) - (SETQ CCODE (READ IFILE)) - (RATOMS 'WX IFILE) - (SETQ CWIDTH (READ IFILE)) - [COND - ((CL:PLUSP CCODE) (* ; - "This character appears in the standard encoding, so just use the charcode.") - (COND - ((ILESSP CCODE FCHAR) - (SETQ FCHAR CCODE))) - (COND - ((IGREATERP CCODE LCHAR) - (SETQ LCHAR CCODE))) - (SETA W CCODE CWIDTH)) - (T (* ; "A character not in the standard encoding; look it up to see if it's one we need (eth & thorn are brought into the CS-0 codespace for UToronto's work).") - (repeatuntil (EQ 'N (RATOM IFILE)) do - - (* ;; - "Skip to the N entry, which gives the Adobe-standard name.") -) - (SETQ CNAME (RATOM IFILE)) - (* ; "GET THE NAME") - (SETQ CCODE (LISTGET *POSTSCRIPT-EXTRA-CHARACTERS* CNAME)) - (COND - (CCODE (COND - ((ILESSP CCODE FCHAR) - (SETQ FCHAR CCODE))) - (COND - ((IGREATERP CCODE LCHAR) - (SETQ LCHAR CCODE))) - (SETA W CCODE CWIDTH] - (repeatuntil (EQ (CHARCODE EOL) - (READCCODE IFILE)) do))) - (SETQ FIRSTCHAR FCHAR) - (SETQ LASTCHAR LCHAR)) - (CLOSEF IFILE) - PSCFONT]) - -(CONVERT-AFM-FILES - [LAMBDA (FILE-LIST) (* ; - "Edited 5-Aug-93 16:47 by sybalskY:MV:ENVOS") - (for FL in FILE-LIST do (LET ((FNAME (pop FL)) - FONT FILENAME) - (for AFM-FILE in FL as WEIGHT - in '(MEDIUM MEDIUM BOLD BOLD) as SLOPE - in '(REGULAR ITALIC REGULAR ITALIC) - do (SETQ FONT (READ-AFM-FILE AFM-FILE WEIGHT - SLOPE)) - (SETQ FILENAME (\FONTFILENAME - FNAME 1 (LIST WEIGHT SLOPE - 'REGULAR) - 'PSCFONT 0)) - (PSCFONT.WRITEFONT FILENAME FONT]) - -(POSTSCRIPT.GETFONTID - [LAMBDA (FID WEIGHT SLOPE EXPANSION) (* ; - "Edited 20-Nov-92 15:04 by sybalsky:mv:envos") - (LET (FONTID) - (SETQ FONTID (create FONTID - FONTIDNAME _ (CAR FID) - FONTXFACTOR _ 1.0 - FONTOBLIQUEFACTOR _ 0.0)) - [if (AND (NEQ (CADDR FID) - SLOPE) - (EQ SLOPE 'ITALIC)) - then (replace (FONTID FONTOBLIQUEFACTOR) of FONTID - with (CONSTANT (TAN 7.0] - (if (AND (NEQ (CADR FID) - WEIGHT) - (EQ WEIGHT 'BOLD)) - then (* ; "Fake bold by slight expansion.") - (replace (FONTID FONTXFACTOR) of FONTID with 1.1)) - [if (NEQ EXPANSION 'REGULAR) - then (replace (FONTID FONTXFACTOR) of FONTID - with (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) - (if (EQ EXPANSION 'COMPRESSED) - then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO)) - else GOLDEN.RATIO] - FONTID]) - -(POSTSCRIPT.FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 29-Oct-93 16:39 by rmk:") (* ; "Edited 3-Feb-93 17:22 by jds") (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS PSCWIDTHSBLOCK WIDTHSBLOCK FD FACECHANGED (WEIGHT (CAR FACE)) (SLOPE (CADR FACE)) (EXPANSION (CADDR FACE))) (* ;;  "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.") [COND [(EQ SIZE 1) (* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info") (COND ((SETQ PSCFD (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) (* ;; "Check in-core cache for exact match first") (SETQ FACECHANGED NIL)) ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) (* ;; "Check file for exact match next") (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ FACECHANGED NIL)) ((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE)) (* ;; "Then check cache for coerced match") (SETQ FACECHANGED T)) ((SETQ FULLNAME (PSCFONT.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE)) (* ;; "Check file for coerced match") (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ FACECHANGED T))) (COND (PSCFD (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD) 0.1))) (SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD) 0.1))) (COND (FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD with (POSTSCRIPT.GETFONTID (fetch (PSCFONT FID) of PSCFD) WEIGHT SLOPE EXPANSION] ((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T)) (SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT) 'PSCFONT)) (* ;; "Scale the ASCENT and DESCENT") (SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD) 0.1))) (SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD) 0.1))) (SETQ SCALEFONTP T)) (T (* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.") (COND ([SETQ PSCFD (COND ((PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) (PSCFONT.READFONT FULLNAME] (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD)) (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD)) (SETQ SCALEFONTP NIL] (COND (PSCFD (* ;; "Set up the Charset descriptions and Widths vectors for character set 0:") (SETQ FD (create FONTDESCRIPTOR OTHERDEVICEFONTPROPS _ (LIST 'PSCFONT PSCFD) FONTSCALE _ 100 FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE ROTATION _ 0 \SFHeight _ (IPLUS ASCENT DESCENT) \SFAscent _ ASCENT \SFDescent _ DESCENT)) (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 FD))) (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD)) [COND [SCALEFONTP (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE (ELT FIXPWIDTHS CH) 0.1] (T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (ELT FIXPWIDTHS CH] (SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT)) (* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.") (for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH (\FGETWIDTH WIDTHSBLOCK CH))) [LET [(TMP (COND (FULLNAME (\FONTINFOFROMFILENAME FULLNAME DEVICE)) (UNITFONT (fetch FONTDEVICESPEC of UNITFONT] (* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got") (COND ((AND TMP (NEQ FAMILY (CAR TMP))) (replace FONTDEVICESPEC of FD with (LIST (CAR TMP) SIZE (COPY FACE) 0 DEVICE] [LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION DEVICE)) (DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD ROTATION DEVICE))) (* ;;  "Now run thru the mapping table, filling in the new font from whatever source is specified:") [MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE) (DESTRUCTURING-BIND (KIND CODE2 BASECHAR) MAPPING (* ;;  "Depending on what kind of item it is, process it:") (SELECTQ KIND (NIL (* ;;  "Translating an NS character to a PSC char in CS 0.") (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK (\CHAR8CODE CODE2)))) (SYMBOL [AND SYMWIDTHS (\FSETCHARWIDTH FD CODE (ELT SYMWIDTHS (\CHAR8CODE CODE2]) (DINGBAT [AND DINGWIDTHS (\FSETCHARWIDTH FD CODE (ELT DINGWIDTHS (\CHAR8CODE CODE2]) (FUNCTION (* ;;  "This is fake and only works for the fractions. Need a better case.") [\FSETCHARWIDTH FD CODE (IPLUS (\FGETWIDTH PSCWIDTHSBLOCK 164) (FIXR (FTIMES 1.3 (\FGETWIDTH PSCWIDTHSBLOCK (CHARCODE 1]) (ACCENT (* ;  "CODE2 is the rendering character but width comes from width of basechar") (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK BASECHAR))) (ACCENTPAIR (* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent") (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK CODE2))) (PROGN (* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other NS characters are available. Also skip anything else") NIL] (* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)") (MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE) (CL:WHEN (EQ (CAR MAPPING) 'APPLY*) (\FSETCHARWIDTH FD CODE (APPLY* (CADDDR MAPPING ) FD (CADR MAPPING)) ))] FD) (T NIL]) - -(\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS [LAMBDA (TYPE FD ROTATION DEVICE) (* ; "Edited 5-Oct-93 18:21 by rmk:") (* ;; "Returns the scaled widths for a unit font of type TYPE (SYMBOL or ZAPFDINGBATS) compatible with FD. A separate function so that the unit widths can be easily cached.") (LET [TYPEFONT WIDTHS NEWWIDTHS (SIZE (FETCH FONTSIZE OF FD)) (FONTFILE (OR (PSCFONT.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR FONTFACE) OF FD) ROTATION DEVICE) (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) ROTATION DEVICE] [SETQ TYPEFONT (COND ((PSCFONTFROMCACHE.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR FONTFACE) OF FD) ROTATION DEVICE)) ((SETQ FONTFILE (PSCFONT.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR FONTFACE) OF FD) ROTATION DEVICE)) (PSCFONT.READFONT FONTFILE)) ((PSCFONTFROMCACHE.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) ROTATION DEVICE)) ((SETQ FONTFILE (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) ROTATION DEVICE)) (PSCFONT.READFONT FONTFILE] (CL:WHEN (AND TYPEFONT (SETQ WIDTHS (FETCH (PSCFONT WIDTHS) OF TYPEFONT))) (SETQ NEWWIDTHS (ARRAY 256 'SMALLPOSP 0 0)) (* ;; "Have to copy because of scaling") [FOR CH FROM 0 TO 255 DO (SETA NEWWIDTHS CH (FIXR (TIMES SIZE (ELT WIDTHS CH) 0.1] NEWWIDTHS)]) - -(POSTSCRIPT.FONTSAVAILABLE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 12-Jan-88 13:04 by Matt Heffron") - - (* ;; "the filtering code was borrowed from Richard Burton's \SEARCHINTERPRESSFONTS. Note that without it [HELVETICA * (MEDIUM REGULAR REGULAR)] would pick up [HELVETICA-NARROW * (MEDIUM REGULAR REGULAR)] as well.") - - (LET - ((PATTERN (\FONTFILENAME (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST)) - FAMILY) - SIZE FACE 'PSCFONT)) - [INVERSE.ALIST (for PAIR in POSTSCRIPT.FONT.ALIST collect (CONS (CDR PAIR) - (CAR PAIR] - FONTSAVAILABLE) - (SETQ FONTSAVAILABLE - (for FD in [for DIRECTORY in POSTSCRIPTFONTDIRECTORIES - join (for FILE in (DIRECTORY (CONCAT DIRECTORY PATTERN)) - collect (LET* ((RAWFD (\FONTINFOFROMFILENAME FILE DEVICE) - ) - (RAWNAME (CAR RAWFD))) - (RPLACA RAWFD - (OR (CDR (ASSOC RAWNAME - INVERSE.ALIST)) - RAWNAME] - when (AND (OR (EQ FAMILY '*) - (EQ FAMILY (CAR FD))) - (OR (EQ SIZE '*) - (EQ SIZE (CADR FD)) - (EQ (CADR FD) - 1)) - (OR (EQ FACE '*) - (EQUAL FACE (CADDR FD)) - (EQUAL [CDR (ASSOC FACE '((MRR MEDIUM REGULAR REGULAR) - (STANDARD MEDIUM REGULAR REGULAR) - (MIR MEDIUM ITALIC REGULAR) - (ITALIC MEDIUM ITALIC REGULAR) - (BRR BOLD REGULAR REGULAR) - (BOLD BOLD REGULAR REGULAR) - (BIR BOLD ITALIC REGULAR) - (BOLDITALIC BOLD ITALIC REGULAR] - (CADDR FD))) - (NOT (MEMBER FD $$VAL))) collect FD)) - (if (EQ SIZE '*) - then - -(* ;;; "If SIZE was wildcarded, then provide list of pointsizes for Postscript scaled fonts (those with a 1 point descriptor file)") - - (for FD in FONTSAVAILABLE - join (if (EQ 1 (CADR FD)) - then (CONS FD (for NF - in (for S from 2 to - \POSTSCRIPT.MAX.WILD.FONTSIZE - collect (LET ((NFD (COPY FD))) - (RPLACA (CDR NFD) - S) - NFD)) - unless (MEMBER NF FONTSAVAILABLE) collect - NF)) - else (LIST FD))) - else FONTSAVAILABLE]) -) - - - -(* ;; "Until macro in FONT is exported") - -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) - (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) - of (\GETCHARSETINFO (\CHARSET - CHARCODE) - FONTDESC)) - (\CHAR8CODE CHARCODE) - WIDTH))) -) -(DEFINEQ - -(OPENPOSTSCRIPTSTREAM [LAMBDA (FILE OPTIONS) (* ; "Edited 3-Apr-94 15:47 by rmk:") (* ;  "Edited 31-May-93 12:42 by sybalsky:mv:envos") (* ; "Edited 23-Dec-92 01:17 by jds") (LET [[FP (OPENSTREAM FILE 'OUTPUT NIL `((TYPE ,*POSTSCRIPT-FILE-TYPE*) (SEQUENTIAL T] (IMAGEDATA (create \POSTSCRIPTDATA)) PAPER IMAGESIZEFACTOR CLIP REG (BBOX (LISTGET OPTIONS 'BOUNDINGBOX] (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN) (replace (STREAM IMAGEDATA) of FP with IMAGEDATA) (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS) (* ;; "Bounding box is for encapsulated postscript. The bounding box is in Medley's postscript-coordinate system, so we have to scale it back to default postscript since it will be interpreted outside of the operators specified below. CEIL and FLOOR to make sure that we don't leave anything out. We may also want to change the header to have the EPSF qualifier") (printout FP "%%!PS-Adobe-2.0" T %# (CL:WHEN BBOX (PRINTOUT FP "%%%%BoundingBox: " (CL:FLOOR (CAR BBOX) \PS.SCALE0) " " (CL:FLOOR (CADR BBOX) \PS.SCALE0) " " (CL:CEILING (CADDR BBOX) \PS.SCALE0) " " (CL:CEILING (CADDDR BBOX) \PS.SCALE0) T)) "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 'DOCUMENT.NAME) FILE)) T "%%%%Creator: PostScript Driver Copyright (C) 1988-1992 Venue and others" T "%%%%CreationDate: " (DATE) T %# (COND ((EQ 'LPT (FILENAMEFIELD FP 'HOST)) (* ;; "Put current user's name on break page only if going to LPT for immediate printing. Presumably the print-spooler itself should know what the user's system login-name is, but that may not be the case for all printers in all environments.") (PRINTOUT NIL "%%%%For: " (MKSTRING USERNAME) T))) "%%%%EndComments" T) (for X in \POSTSCRIPT.JOB.SETUP do (POSTSCRIPT.OUTSTR FP X) (\FILEOUTCHARFN FP (CHARCODE EOL))) (SETQ PAPER (OR (CDR (CL:ASSOC (SETQ PAPER (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) POSTSCRIPT.PAGEREGIONS :TEST #'STRING-EQUAL)) (ERROR "Unknown PostScript page type" PAPER))) (* ;; "Set the paper size:") (PRINTOUT FP (L-CASE (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) T) (COND ((NOT (AND [SETQ IMAGESIZEFACTOR (NUMBERP (LISTGET OPTIONS 'IMAGESIZEFACTOR] (CL:PLUSP IMAGESIZEFACTOR))) (SETQ IMAGESIZEFACTOR 1))) [COND ((AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR) (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR)) (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR] (printout FP "/imagesizefactor " IMAGESIZEFACTOR " def" T) (printout FP "%%%%EndSetup" T) (replace (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA with \PS.SCALE0) (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN) (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA with (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (CAR PAPER))) [replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with (SETQ CLIP (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (CADR PAPER] (* ;; "If a REGION parameter was supplied, it establishes the initial margins.") (SETQ REG (OR (AND (SETQ REG (LISTGET OPTIONS 'REGION)) (INTERSECTREGIONS REG CLIP)) (CREATEREGION 3600 3600 54000 72000))) (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA with (fetch (REGION LEFT) of REG)) (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA with (fetch (REGION BOTTOM) of REG)) (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA with (PLUS (fetch (REGION BOTTOM) of REG) (fetch (REGION HEIGHT) of REG) -1)) (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA with (PLUS (fetch (REGION LEFT) of REG) (fetch (REGION WIDTH) of REG) -1)) (\DSPFONT.PSC FP (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS] DEFAULTFONT) NIL NIL NIL FP)) (\SWITCHFONTS.PSC FP IMAGEDATA) [COND ((replace (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA with (LISTGET OPTIONS 'HEADING)) (replace (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of IMAGEDATA with (COND ((LISTGET OPTIONS 'HEADINGFONT) (FONTCREATE (LISTGET OPTIONS 'HEADINGFONT) NIL NIL NIL FP)) (T (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA] (* ;; "Decide if it's landscape: if (LANDSCAPE T) appears in OPTIONS, it is. IF ROTATION isn't DEFAULT, it is.") (COND ([COND ((CL:GETF OPTIONS 'LANDSCAPE NIL)) ((EQL (CL:GETF OPTIONS 'ROTATION 'DEFAULT) 'DEFAULT) (COND ((EQL POSTSCRIPT.PREFER.LANDSCAPE 'ASK) (MENU \POSTSCRIPT.ORIENTATION.MENU)) (T POSTSCRIPT.PREFER.LANDSCAPE))) (T (CL:GETF OPTIONS 'ROTATION] (POSTSCRIPT.SET-FAKE-LANDSCAPE FP 90))) (POSTSCRIPT.STARTPAGE FP) FP]) - -(CLOSEPOSTSCRIPTSTREAM - [LAMBDA (STREAM) (* ; "Edited 8-Mar-93 10:31 by jds") - (POSTSCRIPT.ENDPAGE STREAM) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Trailer" :EOL) - (* BOUT STREAM (CHARCODE ^D)) - ]) -) - -(RPAQ? *POSTSCRIPT-FILE-TYPE* 'BINARY) -(DEFINEQ - -(POSTSCRIPT.HARDCOPYW - [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE) - (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (ALLOW.BUTTON.EVENTS) - (LET* ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape? - 'IMAGESIZEFACTOR SCALEFACTOR))) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (SCLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA)) - SCALE) - [COND - [REGION (SETQ REGION (COPY REGION)) (* ; "In case we need to change it.") - [COND - ((< (fetch BITMAPWIDTH of BITMAP) - (+ (fetch (REGION LEFT) of REGION) - (fetch (REGION WIDTH) of REGION))) - (replace (REGION WIDTH) of REGION with (- (fetch BITMAPWIDTH - of BITMAP) - (fetch (REGION - LEFT) - of REGION] - (COND - ((< (fetch BITMAPHEIGHT of BITMAP) - (+ (fetch (REGION BOTTOM) of REGION) - (fetch (REGION HEIGHT) of REGION))) - (replace (REGION HEIGHT) of REGION - with (- (fetch BITMAPHEIGHT of BITMAP) - (fetch (REGION BOTTOM) of REGION] - (T (SETQ REGION (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch BITMAPWIDTH of BITMAP) - HEIGHT _ (fetch BITMAPHEIGHT of BITMAP] - (SETQ SCALE (TIMES POSTSCRIPT.BITMAP.SCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) - of IMAGEDATA))) - (BITBLT BITMAP (fetch (REGION LEFT) of REGION) - (fetch (REGION BOTTOM) of REGION) - STREAM - (PLUS (fetch (REGION LEFT) of SCLIP) - (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of SCLIP) - (TIMES SCALE (fetch (REGION WIDTH) of REGION))) - 2)) - (PLUS (fetch (REGION BOTTOM) of SCLIP) - (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of SCLIP) - (TIMES SCALE (fetch (REGION HEIGHT) of REGION))) - 2)) - (fetch (REGION WIDTH) of REGION) - (fetch (REGION HEIGHT) of REGION) - 'INPUT - 'REPLACE) - (CLOSEF STREAM) - (FULLNAME STREAM]) - -(POSTSCRIPT.TEDIT - [LAMBDA (FILE PFILE) (* ; "Edited 18-Sep-91 18:16 by jds") - - (* ;; "Make a PS file from a TEdit document. If FILE is a string, make it into a symbol for the file-name. If it's a STREAM, use that stream.") - - [COND - ((STRINGP FILE) - (SETQ FILE (MKATOM FILE] - (SETQ FILE (OPENTEXTSTREAM FILE)) - (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'POSTSCRIPT) - (CLOSEF? FILE) - PFILE]) - -(POSTSCRIPT.TEXT - [LAMBDA (FILE PSCFILE FONTS HEADING TABS) (* ; "Edited 23-Apr-89 11:31 by TAL") - (TEXTTOIMAGEFILE FILE PSCFILE 'POSTSCRIPT FONTS HEADING TABS - `(REGION ,POSTSCRIPT.DEFAULT.PAGEREGION ROTATION ,(NOT (NOT POSTSCRIPT.TEXTFILE.LANDSCAPE]) - -(POSTSCRIPTFILEP - [LAMBDA (FILE) (* ; "Edited 5-Mar-93 21:40 by rmk:") - (* ; "Edited 14-Jan-93 10:56 by jds") - (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION) - '("PS" "PSC" "PSF") - :TEST - (FUNCTION STRING-EQUAL)) - (PROGN (SETFILEPTR FILE 0) - (PROG1 (AND (EQ (BIN FILE) - (CHARCODE %%)) - (EQ (BIN FILE) - (CHARCODE !))) - (SETFILEPTR FILE 0]) - -(MAKEEPSFILE [LAMBDA (IMAGEOBJ FILENAME) (* ; "Edited 7-Apr-94 14:48 by rmk:") (* ;; "Puts IMAGEOBJ on a 1-page encapsulated postscript file. The lower-left corner of the image box will be at 0,0 on the page.") (LET* [(STREAM (OPENIMAGESTREAM `{NODIRCORE}SCRATCH 'POSTSCRIPT)) (IMAGEBOX (APPLY* (IMAGEOBJPROP IMAGEOBJ 'IMAGEBOXFN) IMAGEOBJ STREAM)) (BOUNDINGBOX (LIST 0 0 (FETCH XSIZE OF IMAGEBOX) (FETCH YSIZE OF IMAGEBOX] [SETQ STREAM (OPENIMAGESTREAM FILENAME 'POSTSCRIPT `(BOUNDINGBOX (0 0 ,(FETCH XSIZE OF IMAGEBOX) ,(FETCH YSIZE OF IMAGEBOX] (MOVETO (FETCH XKERN OF IMAGEBOX) (FETCH YDESC OF IMAGEBOX) STREAM) (APPLY* (IMAGEOBJPROP IMAGEOBJ 'DISPLAYFN) IMAGEOBJ STREAM) (CLOSEF STREAM]) -) -(DEFINEQ - -(POSTSCRIPT.BITMAPSCALE - [LAMBDA (WIDTH HEIGHT) (* ; - "Edited 20-Nov-92 14:52 by sybalsky:mv:envos") - (LET* ([PAGEREGION (\PS.SCALEREGION (/ 72 POSTSCRIPT.BITMAP.SCALE) - (CADDR (FASSOC POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS] - (LONGEDGE (MAX (fetch (REGION WIDTH) of PAGEREGION) - (fetch (REGION HEIGHT) of PAGEREGION))) - (SHORTEDGE (MIN (fetch (REGION WIDTH) of PAGEREGION) - (fetch (REGION HEIGHT) of PAGEREGION))) - [MINDIMP (MIN (FQUOTIENT LONGEDGE (SETQ HEIGHT (TIMES HEIGHT POSTSCRIPT.BITMAP.SCALE))) - (FQUOTIENT SHORTEDGE (SETQ WIDTH (TIMES WIDTH POSTSCRIPT.BITMAP.SCALE] - (MINDIML (MIN (FQUOTIENT SHORTEDGE HEIGHT) - (FQUOTIENT LONGEDGE WIDTH))) - (PPL (if (EQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) - then (MENU \POSTSCRIPT.ORIENTATION.MENU) - else POSTSCRIPT.PREFER.LANDSCAPE)) - MINDIM OTHERDIM SF1 SF2) - (if PPL - then (SETQ MINDIM MINDIML) - (SETQ OTHERDIM MINDIMP) - else (SETQ MINDIM MINDIMP) - (SETQ OTHERDIM MINDIML)) - (SETQ SF1 (if (GREATERP MINDIM 1) - then 1 - elseif (GREATERP MINDIM 0.75) - then 0.75 - elseif (GREATERP MINDIM 0.5) - then 0.5 - elseif (GREATERP MINDIM 0.25) - then 0.25 - else MINDIM)) - (SETQ SF2 (if (GREATERP OTHERDIM 1) - then 1 - elseif (GREATERP OTHERDIM 0.75) - then 0.75 - elseif (GREATERP OTHERDIM 0.5) - then 0.5 - elseif (GREATERP OTHERDIM 0.25) - then 0.25 - else OTHERDIM)) - (if (AND (LESSP SF1 1) - (LESSP SF1 SF2)) - then (CONS SF2 (NOT PPL)) - else (CONS SF1 PPL]) - -(POSTSCRIPT.CLOSESTRING - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (COND - ((fetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (POSTSCRIPT.OUTSTR STREAM ") ") - (replace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with NIL) - T) - (T NIL]) - -(POSTSCRIPT.ENDPAGE - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) - (COND - ((NOT (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA) - (POSTSCRIPT.PUTCOMMAND STREAM "grestore savepage restore "))) - (POSTSCRIPT.PUTCOMMAND STREAM "showpage" :EOL))) - - (* ;; -"Force re-encoding of fonts, because the restore wipes out any you encoded while writing this page.") - - (replace (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of IMAGEDATA with NIL]) - -(POSTSCRIPT.OUTSTR - [LAMBDA (STREAM X) (* ; "Edited 14-Jul-89 14:05 by Matt Heffron") - (DECLARE (LOCALVARS . T)) - (COND - ((FIXP X) (* ; "Common case, speed helps") - (\PS.BOUTFIXP STREAM X)) - [(STRINGP X) (* ; "Other common case") - (COND - [(ffetch (STRINGP FATSTRINGP) of X) - (for c infatstring X do (BOUT STREAM (\CHAR8CODE c] - (T (\BOUTS STREAM (ffetch (STRINGP BASE) of X) - (ffetch (STRINGP OFFST) of X) - (ffetch (STRINGP LENGTH) of X] - [(LITATOM X) - (for c inatom X do (BOUT STREAM (\CHAR8CODE c] - ((ZEROP X) - (BOUT STREAM (CHARCODE 0))) - (T [COND - ((TYPEP X 'RATIO) - (SETQ X (FLOAT X] - (for c in (CHCON X) do (BOUT STREAM (\CHAR8CODE c]) - -(POSTSCRIPT.PUTBITMAPBYTES - [LAMBDA (STREAM BITMAP DELIMFLG) - (DECLARE (GLOBALVARS PS.BITMAPARRAY) - (LOCALVARS . T)) (* ; "Edited 30-Mar-90 20:15 by Matt Heffron") - (LET* - ((WIDTH (fetch BITMAPWIDTH of BITMAP)) - (HEIGHT (fetch BITMAPHEIGHT of BITMAP)) - (BMBASE (fetch BITMAPBASE of BITMAP)) - (BYTESPERROW (LRSH (IPLUS WIDTH 7) - 3)) - (BYTEOFFSETPERROW (LSH (fetch BITMAPRASTERWIDTH of BITMAP) - 1)) - (PS.BITMAPARRAYBASE (fetch (ARRAYP BASE) of PS.BITMAPARRAY))) - (COND - [DELIMFLG (LET ((POS 0) - BYTE) - (\FILEOUTCHARFN STREAM (CHARCODE SPACE)) - (\FILEOUTCHARFN STREAM (CHARCODE <)) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (for R from (SUB1 HEIGHT) to 0 by -1 as ROWOFFSET - from (ITIMES (SUB1 HEIGHT) - BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW) - do (for B from 1 to BYTESPERROW as BYTEOFFSET - from ROWOFFSET by 1 - do (COND - ((IGEQ POS 254) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) - [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH BYTE 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 BYTE))) - (SETQ POS (IPLUS POS 2))) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0)) - (\FILEOUTCHARFN STREAM (CHARCODE SPACE)) - (\FILEOUTCHARFN STREAM (CHARCODE >)) - (\FILEOUTCHARFN STREAM (CHARCODE EOL] - (T - (LET* - ((PRVBM (BITMAPCREATE WIDTH 1)) - (PRVBASE (fetch BITMAPBASE of PRVBM))) - (for R from 0 to (SUB1 HEIGHT) as ROWOFFSET - from (ITIMES (SUB1 HEIGHT) - BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW) - do - (LET ((POS 0) - (BYTEOFFSET ROWOFFSET) - (B 1) - (PRVO 0) - BYTE REPC) - [while (ILEQ B BYTESPERROW) - do (SETQ REPC - (for BB from B to BYTESPERROW as BO from BYTEOFFSET - by 1 as PO from PRVO by 1 - while (EQ (\GETBASEBYTE BMBASE BO) - (\GETBASEBYTE PRVBASE PO)) count T)) - (COND - [(IGEQ REPC 3) - (SETQ B (IPLUS B REPC)) - (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) - (SETQ PRVO (IPLUS PRVO REPC)) - (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) - do (COND - ((IGEQ POS 251) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - (BOUT STREAM (CHARCODE B)) - (BOUT STREAM (CHARCODE 3)) - [COND - ((IGEQ REPC 256) - (BOUT STREAM (CHARCODE F)) - (BOUT STREAM (CHARCODE F))) - (T [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH REPC 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 REPC] - (SETQ REPC (IDIFFERENCE REPC 256)) - (SETQ POS (IPLUS POS 4] - (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) - (SETQ REPC - (for BB from B to BYTESPERROW as BO from - BYTEOFFSET - by 1 while (EQ (\GETBASEBYTE BMBASE BO) - BYTE) count T)) - (COND - [(IGEQ REPC 3) - (SETQ B (IPLUS B REPC)) - (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) - (SETQ PRVO (IPLUS PRVO REPC)) - (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) - do (COND - ((IGEQ POS 249) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - (BOUT STREAM (CHARCODE B)) - (BOUT STREAM (CHARCODE 2)) - [COND - ((IGEQ REPC 256) - (BOUT STREAM (CHARCODE F)) - (BOUT STREAM (CHARCODE F))) - (T [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH REPC 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 REPC] - [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH BYTE 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 BYTE))) - (SETQ REPC (IDIFFERENCE REPC 256)) - (SETQ POS (IPLUS POS 4] - (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) - (COND - ((IGEQ POS 251) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - [COND - ((FMEMB BYTE '(178 179 180)) - - (* ;; "BYTE is B2, B3, or B4; quote it") - - (BOUT STREAM (CHARCODE B)) - (BOUT STREAM (CHARCODE 4)) - (SETQ POS (IPLUS POS 2] - [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH BYTE 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE) - )) - (SETQ B (IPLUS B 1)) - (SETQ BYTEOFFSET (IPLUS BYTEOFFSET 1)) - (SETQ PRVO (IPLUS PRVO 1)) - (SETQ POS (IPLUS POS 2] - (\FILEOUTCHARFN STREAM (CHARCODE EOL))) - (\MOVEBYTES BMBASE ROWOFFSET PRVBASE 0 BYTESPERROW]) - -(POSTSCRIPT.PUTCOMMAND - [LAMBDA S.STRS (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET* ((STREAM (ARG S.STRS 1)) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - S#S) - (freplace (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA with NIL) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (POSTSCRIPT.SHOWACCUM STREAM))) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA) - (\SETXFORM.PSC STREAM IMAGEDATA))) - (for STR# from 2 to S.STRS do (COND - ((EQ (SETQ S#S (ARG S.STRS STR#)) - :EOL) - (\FILEOUTCHARFN STREAM (CHARCODE EOL))) - (T (POSTSCRIPT.OUTSTR STREAM S#S]) - -(POSTSCRIPT.SET-FAKE-LANDSCAPE - [LAMBDA (STREAM ROTATION) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - - (* ;; "Set up for (or disable) fake landscaping") - - (* ;; - "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLAND (COND - ((fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) - 90) - (T 0))) - LAND C0 P0 C P ML MB MR MT) - (COND - ((AND ROTATION (NEQ (SETQ LAND (NOT (ZEROP ROTATION))) - (fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\DSPTRANSLATE.PSC STREAM 0 0) - (SETQ C0 (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA)) - (SETQ P0 (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA)) - (SETQ C (create REGION - WIDTH _ (fetch (REGION HEIGHT) of C0) - HEIGHT _ (fetch (REGION WIDTH) of C0))) - (SETQ P (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch (REGION HEIGHT) of P0) - HEIGHT _ (fetch (REGION WIDTH) of P0))) - [COND - (LAND (replace (REGION LEFT) of C with (fetch (REGION BOTTOM) - of C0)) - [replace (REGION BOTTOM) of C with - (- (fetch (REGION WIDTH) - of P0) - (+ (fetch (REGION LEFT) - of C0) - (fetch (REGION WIDTH) - of C0] - (SETQ ML (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - ) - (SETQ MB (- (fetch (REGION WIDTH) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of - IMAGEDATA - ) - 1)) - (SETQ MR (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA)) - (SETQ MT (- (fetch (REGION WIDTH) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA - ) - 1))) - (T [replace (REGION LEFT) of C with (- (fetch (REGION HEIGHT) - of P0) - (+ (fetch (REGION BOTTOM) - of C0) - (fetch (REGION HEIGHT) - of C0] - (replace (REGION BOTTOM) of C with (fetch (REGION LEFT) - of C0)) - (SETQ ML (- (fetch (REGION HEIGHT) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - 1)) - (SETQ MB (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA)) - (SETQ MR (- (fetch (REGION HEIGHT) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - 1)) - (SETQ MT (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA] - (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with - C) - (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA with P) - (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA with ML) - (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA with MB) - (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA with MR) - (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA with MT) - (replace (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA with LAND) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) - (\DSPRESET.PSC STREAM))) - OLAND]) - -(POSTSCRIPT.SHOWACCUM - [LAMBDA (STREAM) (* ; "Edited 23-May-93 11:52 by rmk:") - - (* ;; - "Send commands to SHOW the accumulated characters. Uses S (= SHOW) for regular characters.") - - (* ;; "Uses WIDTHSHOW if the space-factor isn't 1") - - (* ;; "Uses ASHOW if a KERN value is on STREAM's properties") - - (* ;; "USES AWIDTHSHOW if both space-factor != 1 and there's a KERN value.") - - (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM)) - KERN) - (COND - ((fetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (SETQ KERN (STREAMPROP STREAM 'KERN)) - [COND - [(EQP (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA) - 1) - (COND - (KERN (POSTSCRIPT.OUTSTR STREAM (CONCAT ") " KERN " 0 3 -1 roll ashow"))) - (T (POSTSCRIPT.OUTSTR STREAM ") S"] - (T (POSTSCRIPT.OUTSTR STREAM ") ") - (POSTSCRIPT.OUTSTR STREAM (DIFFERENCE (ffetch (\POSTSCRIPTDATA - POSTSCRIPTSPACEWIDTH) - of IMAGEDATA) - (ffetch (\POSTSCRIPTDATA - POSTSCRIPTNATURALSPACEWIDTH - ) of IMAGEDATA))) - (COND - (KERN (POSTSCRIPT.OUTSTR STREAM (CONCAT " 0 " (CHARCODE SPACE) - " " KERN " 0 " - " 6 -1 roll awidthshow"))) - (T (POSTSCRIPT.OUTSTR STREAM (CONSTANT (CONCAT " 0 " (CHARCODE SPACE) - " 4 -1 roll widthshow"] - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with NIL]) - -(POSTSCRIPT.STARTPAGE -(LAMBDA (STREAM) (* ; "Edited 28-Dec-94 17:41 by jds") (* ;; "Start up a new page in a Postscript document.") (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) NEW-PAGE) (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) (* ; "shouldnt need this") (SETQ NEW-PAGE (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGENUM) of IMAGEDATA))) (* ; "Page number goes up by 1") (* ;; "Print the %"Document structuring%" info for the page, then the initial page setup") (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Page: " NEW-PAGE " " NEW-PAGE :EOL "%%%%BeginPageSetup" :EOL "/savepage save def" :EOL (FQUOTIENT 1 \PS.SCALE0) " imagesizefactor mul dup scale" :EOL "%%%%EndPageSetup" :EOL) (\SETXFORM.PSC STREAM IMAGEDATA T) (* ;; "Lisp depends on the current font being carried over from page to page, but in postscript there is no current font at the beginning of a page, so force a setfont.") (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with T) (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA with T) (* ; "nothing printed yet...") (COND ((fetch (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA) (* ;; "Here we handle headings.") (LET ((FONT (\DSPFONT.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of IMAGEDATA)))) (\DSPRESET.PSC STREAM) (PRIN3 (fetch (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA) STREAM) (RELMOVETO (CONSTANT (TIMES 72 \PS.SCALE0)) 0 STREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " STREAM) (PRIN3 NEW-PAGE STREAM) (\TERPRI.PSC STREAM) (* ; "Skip 2 lines") (\TERPRI.PSC STREAM) (\DSPFONT.PSC STREAM FONT))) (T (\DSPRESET.PSC STREAM))))) -) - -(\POSTSCRIPTTAB - [LAMBDA (POSTSCRIPTDATA) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET [(TABSPACE (TIMES 8 (ffetch FONTAVGCHARWIDTH of (ffetch (\POSTSCRIPTDATA - POSTSCRIPTFONT) - of POSTSCRIPTDATA] - (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of POSTSCRIPTDATA) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) - of POSTSCRIPTDATA)) - TABSPACE]) - -(\PS.BOUTFIXP - [LAMBDA (STREAM N) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - - (* ;; "BOUT the decimal representation of N to STREAM using temp storage from the imagedata. Done this way for speed.") - - (DECLARE (LOCALVARS . T)) - [COND - ((MINUSP N) - (BOUT STREAM (CHARCODE -)) - (SETQ N (IMINUS N] - (COND - [(LESSP N 10) - (BOUT STREAM (IPLUS N (CHARCODE 0] - [(LESSP N 1000000000) - (LET ([BASE (fetch (ARRAYP BASE) of (fetch (\POSTSCRIPTDATA POSTSCRIPTTEMPARRAY) - of (fetch (STREAM IMAGEDATA) - of STREAM] - (i (SUB1 \PS.TEMPARRAYLEN))) - [for old i by -1 do (\PUTBASEBYTE BASE i (IPLUS (IREMAINDER N 10) - (CHARCODE 0))) - repeatwhile (NEQ 0 (SETQ N (IQUOTIENT N 10] - (\BOUTS STREAM BASE i (IDIFFERENCE \PS.TEMPARRAYLEN i] - (T (* ; "Just in case we get a bignum") - (for c in (CHCON N) do (BOUT STREAM (\CHAR8CODE c]) - -(\PS.SCALEHACK - [LAMBDA (STREAM SCALEFACTOR) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA)) - FACTOR) - (COND - ((AND (NUMBERP SCALEFACTOR) - (NOT (EQP OLDSCALE SCALEFACTOR))) - (POSTSCRIPT.SHOWACCUM STREAM) - (SETQ FACTOR (/ OLDSCALE SCALEFACTOR)) - [for REG in (LIST (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA) - (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) - of IMAGEDATA)) - do (change (fetch (REGION LEFT) of REG) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (REGION BOTTOM) of REG) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (REGION WIDTH) of REG) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (REGION HEIGHT) of REG) - (FIXR (CL:* DATUM FACTOR] - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (replace (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA with - SCALEFACTOR) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T))) - OLDSCALE]) - -(\PS.SCALEREGION - [LAMBDA (SCALE REGION) (* ; "Edited 5-Apr-89 16:15 by TAL") - (* ; "Scales a region") - (create REGION - LEFT _ (FIXR (TIMES SCALE (fetch (REGION LEFT) of REGION))) - BOTTOM _ (FIXR (TIMES SCALE (fetch (REGION BOTTOM) of REGION))) - WIDTH _ (FIXR (TIMES SCALE (fetch (REGION WIDTH) of REGION))) - HEIGHT _ (FIXR (TIMES SCALE (fetch (REGION HEIGHT) of REGION]) - -(\SCALEDBITBLT.PSC - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM - SCALE) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - - (* ;; "Postscript can only handle OPERATION REPLACE and PAINT. SOURCETYPE = TEXTURE is converted to BLTSHADE before getting here (so the TEXTURE argument can be ignored). If the destination region lies completely outside the clipping region we do nothing, otherwise we output the whole thing and let the printer clip. Could be more clever.") - - (OR (NUMBERP SCALE) - (SETQ SCALE 1)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (SCALE1 (TIMES SCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA))) - (SCALE2 (TIMES SCALE1 (OR (NUMBERP POSTSCRIPT.BITMAP.SCALE) - 1))) - DESTREGION - (BITMAPWIDTH (fetch BITMAPWIDTH of SOURCEBITMAP)) - (BITMAPHEIGHT (fetch BITMAPHEIGHT of SOURCEBITMAP)) - TEMPBM) - [COND - ((NULL DESTINATIONLEFT) - (SETQ DESTINATIONLEFT (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA] - [COND - ((NULL DESTINATIONBOTTOM) - (SETQ DESTINATIONBOTTOM (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA] - (COND - ((OR (NULL WIDTH) - (NULL HEIGHT)) - (SETQ WIDTH BITMAPWIDTH) - (SETQ HEIGHT BITMAPHEIGHT))) - (COND - ((GREATERP WIDTH BITMAPWIDTH) - (SETQ WIDTH BITMAPWIDTH))) - (COND - ((GREATERP HEIGHT BITMAPHEIGHT) - (SETQ HEIGHT BITMAPHEIGHT))) - [SETQ DESTREGION (INTERSECTREGIONS (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA) - (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES SCALE1 WIDTH - ) - (TIMES SCALE1 HEIGHT] - (COND - ((AND DESTREGION (OR (NULL CLIPPINGREGION) - (REGIONSINTERSECTP DESTREGION CLIPPINGREGION))) - [COND - ((AND (EQ SOURCELEFT 0) - (EQ SOURCEBOTTOM 0) - (EQP WIDTH BITMAPWIDTH) - (EQP HEIGHT BITMAPHEIGHT)) (* ; - "Avoid copy if sending entire bitmap") - (SETQ TEMPBM SOURCEBITMAP)) - (T (SETQ TEMPBM (BITMAPCREATE WIDTH HEIGHT 1)) - (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM TEMPBM 0 0 WIDTH HEIGHT SOURCETYPE - 'REPLACE] - (POSTSCRIPT.PUTCOMMAND STREAM "/bitbltsave save def " DESTINATIONLEFT " " - DESTINATIONBOTTOM " translate " (TIMES SCALE2 WIDTH) - " " - (TIMES SCALE2 HEIGHT) - " scale " WIDTH " " HEIGHT (COND - ((EQ OPERATION 'PAINT) - " true") - (T " false")) - " thebitimage" :EOL) - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "bitbltsave restore" :EOL) - (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) - T) - (T NIL]) - -(\SETPOS.PSC - [LAMBDA (STREAM IMAGEDATA) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - " " - (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - " M ") - (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with NIL]) - -(\SETXFORM.PSC -(LAMBDA (STREAM IMAGEDATA NORESTORE) (* ; "Edited 28-Dec-94 17:59 by jds") (* ;; "Write transforms into the PS file to make what it prints match what we think it should print.") (LET ((CLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA))) (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) (COND ((NOT NORESTORE) (POSTSCRIPT.OUTSTR STREAM "grestore "))) (POSTSCRIPT.PUTCOMMAND STREAM "gsave" :EOL) (* ;; "Scaling") (COND ((NOT (EQP (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA) 1)) (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA) " dup scale" :EOL))) (* ;; "Landscape mode (as in POSTSCRIPT.PREFER.LANDSCAPE, not as in TEdit doing landscaping)") (COND ((fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) (POSTSCRIPT.OUTSTR STREAM " 90 rotate 0 -61200 imagesizefactor div translate "))) (* ;; "Any rotation that is in effect.") (POSTSCRIPT.PUTCOMMAND STREAM " " (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA) " rotate " :EOL) (* ;; "Any translations that are in effect.") (COND ((NOT (AND (ZEROP (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA)) (ZEROP (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA)))) (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) " " (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) " translate" :EOL))) (* ;; "Clipping region:") (POSTSCRIPT.PUTCOMMAND STREAM " " (fetch (REGION HEIGHT) of CLIP) " " (fetch (REGION WIDTH) of CLIP) " " (fetch (REGION LEFT) of CLIP) " " (fetch (REGION BOTTOM) of CLIP) " CLP" :EOL) (* ;; "And force recaching of location and font.") (replace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with T) (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with T))) -) - -(\STRINGWIDTH.PSC - [LAMBDA (STREAM STR RDTBL) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) - (\STRINGWIDTH.GENERIC STR (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA) - RDTBL - (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA]) - -(\SWITCHFONTS.PSC - [LAMBDA (STREAM POSTSCRIPTDATA) (* ; "Edited 23-May-93 12:04 by rmk:") - (* ; "Edited 11-May-93 02:11 by jds") - - (* ;; "Actually emit the PS commands to change the font. If the new font hasn't been used (on this page) before, re-encode it to support accented characters.") - - (LET* [(FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of POSTSCRIPTDATA)) - (FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR - OTHERDEVICEFONTPROPS - ) of FONT) - 'PSCFONT] - [COND - [(LISTP FONTID) - [COND - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of POSTSCRIPTDATA))) - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - *POSTSCRIPT-UNACCENTED-FONTS*)) - (T - (* ;; - "This font hasn't been used on this page yet. Re-encode it to include accented characters.") - - (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch (FONTID FONTIDNAME) of - FONTID) - " /" - (CONCAT (fetch (FONTID FONTIDNAME) of FONTID) - "-Acnt") - " encodefont" :EOL) - (CL:PUSH (fetch (FONTID FONTIDNAME) of FONTID) - (FFETCH (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) OF POSTSCRIPTDATA] - (COND - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - *POSTSCRIPT-UNACCENTED-FONTS*) - (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF POSTSCRIPTDATA - WITH NIL) - (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch (FONTID FONTIDNAME) of FONTID) - " findfont [" - (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 " - (TIMES (fetch (FONTID FONTOBLIQUEFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " " - (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 0] makefont setfont" :EOL)) - (T (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF POSTSCRIPTDATA - WITH T) - (POSTSCRIPT.PUTCOMMAND STREAM "/" (CONCAT (fetch (FONTID FONTIDNAME) - of FONTID) - "-Acnt") - " findfont [" - (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 " - (TIMES (fetch (FONTID FONTOBLIQUEFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " " - (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 0] makefont setfont" :EOL] - (T [COND - ((MEMB FONTID (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of - POSTSCRIPTDATA - ))) - ((MEMB FONTID *POSTSCRIPT-UNACCENTED-FONTS*)) - (T - (* ;; - "This font hasn't been used on this page yet. Re-encode it to include accented characters.") - - (POSTSCRIPT.PUTCOMMAND STREAM "/" FONTID " /" (CONCAT FONTID "-Acnt") - " encodefont" :EOL) - (CL:PUSH FONTID (FFETCH (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) OF - POSTSCRIPTDATA - ] - (COND - ((MEMB FONTID *POSTSCRIPT-UNACCENTED-FONTS*) - (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of POSTSCRIPTDATA - with NIL) - (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) - of FONT) - 100) - " /" FONTID " F" :EOL)) - (T (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of POSTSCRIPTDATA - with T) - (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) - of FONT) - 100) - " /" - (CONCAT FONTID "-Acnt") - " F" :EOL] - (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of POSTSCRIPTDATA with - NIL]) - -(\TERPRI.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (NEWY (PLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of IMAGEDATA] - (COND - ([LESSP NEWY (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of - IMAGEDATA - ) - (fetch (FONTDESCRIPTOR \SFDescent) of (ffetch - (\POSTSCRIPTDATA - POSTSCRIPTFONT) - of IMAGEDATA] - (DSPNEWPAGE STREAM)) - (T (replace (STREAM CHARPOSITION) of STREAM with 0) - (\MOVETO.PSC STREAM (ffetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) - of IMAGEDATA) - NEWY))) - NIL]) -) - - - -(* ;; "DIG operations: ") - -(DEFINEQ - -(\BITBLT.PSC - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) - (* ; "Edited 7-Apr-89 19:53 by TAL") - (\SCALEDBITBLT.PSC SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT - DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION - CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM 1]) - -(\BLTSHADE.PSC - [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - - (* ;; "Maybe we should do something with OPERATION") - - (LET ((RGN (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT)) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - TEXTUREBM TEXTUREWIDTH LEFT BOTTOM WIDTH HEIGHT) - [COND - [CLIPPINGREGION (SETQ RGN (INTERSECTREGIONS RGN CLIPPINGREGION (fetch ( - \POSTSCRIPTDATA - - POSTSCRIPTCLIPPINGREGION - ) of - IMAGEDATA] - (T (SETQ RGN (INTERSECTREGIONS RGN (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA] - (COND - (RGN (SETQ LEFT (fetch (REGION LEFT) of RGN)) - (SETQ BOTTOM (fetch (REGION BOTTOM) of RGN)) - (SETQ WIDTH (CL:1- (fetch (REGION WIDTH) of RGN))) - (SETQ HEIGHT (CL:1- (fetch (REGION HEIGHT) of RGN))) - [COND - ((FIXP TEXTURE) - (SETQ TEXTURE (SELECT TEXTURE ((BLACKSHADE -1) - 0.0) - (WHITESHADE 1.0) - TEXTURE] - [COND - ((AND (FLOATP TEXTURE) - (<= 0.0 TEXTURE 1.0)) - (POSTSCRIPT.PUTCOMMAND STREAM HEIGHT " " WIDTH " " LEFT " " BOTTOM " " - TEXTURE " R" :EOL)) - ((OR (TEXTUREP TEXTURE) - (NULL TEXTURE)) - (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) - (SETQ TEXTUREWIDTH 16) - (BLTSHADE TEXTURE TEXTUREBM)) - ((BITMAPP TEXTURE) - (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) - (fetch BITMAPHEIGHT of TEXTUREBM))) - (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) - (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE] - (COND - (TEXTUREBM (POSTSCRIPT.PUTCOMMAND STREAM "gsave newpath ") - (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale " (QUOTIENT LEFT 100.0) - " " - (QUOTIENT BOTTOM 100.0) - " M " - (SETQ WIDTH (QUOTIENT WIDTH 100.0)) - " 0 rlineto 0 " - (QUOTIENT HEIGHT 100.0) - " rlineto " - (MINUS WIDTH) - " 0 rlineto closepath" :EOL) - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) - (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " - (LSH (fetch BITMAPRASTERWIDTH of TEXTUREBM) - 1) - " 0 " - (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) - 100.0)) - " findresolution " TEXTUREWIDTH " div div ceiling " - POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" - :EOL))) - (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) - T) - (T NIL]) - -(\CHARWIDTH.PSC - [LAMBDA (STREAM CHARCODE) (* ; "Edited 8-May-93 11:19 by rmk:") - (COND - ((EQ CHARCODE (CHARCODE SPACE)) - (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of (ffetch (STREAM IMAGEDATA) - of STREAM))) - ((\FGETCHARWIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of (ffetch (STREAM - IMAGEDATA - ) - of STREAM)) - CHARCODE]) - -(\CREATECHARSET.PSC - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 8-May-93 22:55 by rmk:") - (LET* ((CSINFO (CREATE CHARSETINFO - OFFSETS _ NIL)) - (WIDTHS (FETCH (CHARSETINFO WIDTHS) OF CSINFO))) - (REPLACE (CHARSETINFO IMAGEWIDTHS) OF CSINFO WITH WIDTHS) - - (* ;; "Make imagewidths point to widths. Shouldn't matter to anyone, since imagewidths really has to do with bitmaps etc. But...") - - (CL:UNLESS (EQ CHARSET 0) - - (* ;; "For all charsets other than 0, initialize widths with width of black box=average char width. We know that the AVGCHARWIDTH field of the FONTDESC will eventually be the width of A, but that might not be filled in when this is executed inside POSTSCRIPT.FONTCREATE--it's only after the return to FONTCREATE itself that this gets filled in. However, we do know that charset 0 is all set up before any other characters are dealt with.") - - (FOR I (AVGCHARWIDTH _ (CHARWIDTH (CHARCODE A) - FONTDESC)) FROM 0 TO 255 - FIRST (CL:WHEN (EQ 0 AVGCHARWIDTH) - - (* ;; - "This is what \AVGCHARWIDTH in FONT does, but we don't have it here. Just to be extremely safe.") - - [SETQ AVGCHARWIDTH (MAX 1 (FIXR (FTIMES 0.6 (FONTPROP FONTDESC - 'HEIGHT]) - DO (\FSETWIDTH WIDTHS I AVGCHARWIDTH))) - CSINFO]) - -(\DRAWARC.PSC - [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH)) - ((LISTP BRUSH) - (COND - ((NEQ (fetch BRUSHSHAPE of BRUSH) - 'ROUND) - (printout T T - "[In \DRAWARC.PSC: Non-ROUND BRUSH not supported.] -[Using ROUND BRUSH]" T))) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T (* ; - "If FUNCTIONAL BRUSH big trouble!") - (printout T T - "[In \DRAWARC.PSC: Functional BRUSH not supported.] -[Using ROUND 1 point BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - (* ; - "COLOR is specified in POSTSCRIPT setgray notation.") - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ")) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL) - (* ; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") - )) - (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " - CENTERX " " CENTERY " " RADIUS " " STARTANGLE " " (+ STARTANGLE NDEGREES) - " arc stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM CENTERX CENTERY]) - -(\DRAWCIRCLE.PSC - [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH)) - ((LISTP BRUSH) - (COND - ((NEQ (fetch BRUSHSHAPE of BRUSH) - 'ROUND) - (printout T T - "[In \DRAWCIRCLE.PSC: Non-ROUND BRUSH not supported.] -[Using ROUND BRUSH]" T))) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T (* ; - "If FUNCTIONAL BRUSH big trouble!") - (printout T T - "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - (* ; - "COLOR is specified in POSTSCRIPT setgray notation.") - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ")) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL) - (* ; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") - )) - (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " - CENTERX " " CENTERY " " RADIUS " 0 360 arc stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM CENTERX CENTERY]) - -(\DRAWCURVE.PSC - [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH) - (SETQ SHAPE 'ROUND)) - ((LISTP BRUSH) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T - (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") - - (printout T T - "[In \DRAWCURVE.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - (SETQ SHAPE 'ROUND] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - - (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") - - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ") - - (* ;; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") -) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL))) - (SETQ PSPLINE (PARAMETRICSPLINE KNOTS CLOSED NIL)) - (SETQ N (pop PSPLINE)) - (SETQ XA (pop PSPLINE)) - (SETQ YA (pop PSPLINE)) - (SETQ DXA (pop PSPLINE)) - (SETQ DYA (pop PSPLINE)) - (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE - (ROUND " 1 setlinecap 1 setlinejoin ") - (SQUARE " 2 setlinecap 0 setlinejoin ") - " 0 setlinecap 0 setlinejoin ") - WIDTH " setlinewidth " (SETQ PREVX (ELT XA 1)) - " " - (SETQ PREVY (ELT YA 1)) - " M" :EOL) - (SETQ PREV-DX3 (FQUOTIENT (ELT DXA 1) - 3.0)) - (SETQ PREV-DY3 (FQUOTIENT (ELT DYA 1) - 3.0)) - (for C from 2 to N do (POSTSCRIPT.PUTCOMMAND - STREAM - (FPLUS PREVX PREV-DX3) - " " - (FPLUS PREVY PREV-DY3) - " " - (FDIFFERENCE (SETQ PREVX (ELT XA C)) - (SETQ PREV-DX3 (FQUOTIENT (ELT DXA C) - 3.0))) - " " - (FDIFFERENCE (SETQ PREVY (ELT YA C)) - (SETQ PREV-DY3 (FQUOTIENT (ELT DYA C) - 3.0))) - " " PREVX " " PREVY " curveto" :EOL)) - (POSTSCRIPT.PUTCOMMAND STREAM "stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM PREVX PREVY)) - NIL]) - -(\DRAWELLIPSE.PSC - [LAMBDA (STREAM CENTERX CENTERY MINORRADIUS MAJORRADIUS ORIENTATION BRUSH DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH)) - ((LISTP BRUSH) - (COND - ((NEQ (fetch BRUSHSHAPE of BRUSH) - 'ROUND) - (printout T T - "[In \DRAWELLIPSE.PSC: Non-ROUND BRUSH not supported.] -[Using ROUND BRUSH]" T))) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T (* ; - "If FUNCTIONAL BRUSH, big trouble!") - (printout T T - "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - (* ; - "COLOR is specified in POSTSCRIPT setgray notation.") - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ") - - (* ;; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") -) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL))) - (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " - CENTERX " " CENTERY " " MAJORRADIUS " " MINORRADIUS " " ORIENTATION - " 0 360 ellipse stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM CENTERX CENTERY]) - -(\DRAWLINE.PSC - [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - - (* ;; "DRAWLINE method for postscript streams.") - - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - [COND - ((NOT (NUMBERP WIDTH)) - - (* ;; "The WIDTH = NIL should have been handled before here, but just in case!") - - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - [COND - ((NOT (ZEROP WIDTH)) - (COND - ((LESSP X2 X1) - - (* ;; "For Syntelligence, make all lines move from left to right, to defeat a bug in SPARCPrinter PS decoder.") - - (\DRAWLINE.PSC STREAM X2 Y2 X1 Y1 WIDTH OPERATION COLOR DASHING)) - ((NOT (OR (FLOATP COLOR) - (LISTP DASHING))) (* ; "Simple case, no dash or gray") - (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " L" :EOL)) - (T (* ; - "COLOR is interpreted as gray factor") - (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " " - (OR (FLOATP COLOR) - "0") - " [") - (for D in (LISTP DASHING) do - - (* ;; - "Interlisp DASHING is in terms of BRUSH units, so multiply by the brush size.") - - (POSTSCRIPT.PUTCOMMAND STREAM - (TIMES D WIDTH) - " ")) - (POSTSCRIPT.PUTCOMMAND STREAM "] L1" :EOL] - (replace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with X2) - (freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA with Y2) - (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with NIL]) - -(\DRAWPOINT.PSC - [LAMBDA (STREAM X Y BRUSH OPERATION) (* ; "Edited 30-Mar-90 17:53 by Matt Heffron") - - (* ;; "draw a point on the stream ") - - (if (BITMAPP BRUSH) - then (LET ((WIDTH (fetch BITMAPWIDTH of BRUSH)) - (HEIGHT (fetch BITMAPHEIGHT of BRUSH))) - (BITBLT BRUSH 0 0 STREAM (- X (IQUOTIENT WIDTH 2)) - (- Y (IQUOTIENT HEIGHT 2)) - WIDTH HEIGHT OPERATION)) - else (\DRAWLINE.PSC STREAM X Y X Y BRUSH OPERATION]) - -(\DRAWPOLYGON.PSC - [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING)(* ; - "Edited 20-Nov-92 15:17 by sybalsky:mv:envos") - (LET ((LASTPOINT (CAR (LAST POINTS))) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH SHAPE COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH) - (SETQ SHAPE 'ROUND)) - ((LISTP BRUSH) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T - (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") - - (printout T T - "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - (SETQ SHAPE 'ROUND] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - - (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") - - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ") - - (* ;; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") -) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL))) - (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE - (ROUND " 1 setlinecap 1 setlinejoin ") - (SQUARE " 2 setlinecap 0 setlinejoin ") - " 0 setlinecap 0 setlinejoin ") - WIDTH " setlinewidth " (fetch (POSITION XCOORD) of (CAR POINTS)) - " " - (fetch (POSITION YCOORD) of (CAR POINTS)) - " M" :EOL) - (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM - (fetch (POSITION XCOORD) of P) - " " - (fetch (POSITION YCOORD) of P) - " lineto" :EOL)) - (COND - (CLOSED (POSTSCRIPT.PUTCOMMAND STREAM " closepath"))) - (POSTSCRIPT.PUTCOMMAND STREAM " stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM (fetch (POSITION XCOORD) of LASTPOINT) - (fetch (POSITION YCOORD) of LASTPOINT]) - -(\DSPBOTTOMMARGIN.PSC - [LAMBDA (STREAM YPOSITION) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of (fetch (STREAM IMAGEDATA) - of STREAM)) - (COND - (YPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) - of (fetch (STREAM IMAGEDATA) of STREAM) with YPOSITION))))]) - -(\DSPCLIPPINGREGION.PSC - [LAMBDA (STREAM REGION) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDCLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA))) - (COND - ([AND REGION (NOT (AND (EQP (fetch (REGION LEFT) of OLDCLIP) - (fetch (REGION LEFT) of REGION)) - (EQP (fetch (REGION BOTTOM) of OLDCLIP) - (fetch (REGION BOTTOM) of REGION)) - (EQP (fetch (REGION WIDTH) of OLDCLIP) - (fetch (REGION WIDTH) of REGION)) - (EQP (fetch (REGION HEIGHT) of OLDCLIP) - (fetch (REGION HEIGHT) of REGION] - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with - REGION) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) - (\FIXLINELENGTH.PSC STREAM IMAGEDATA))) - OLDCLIP]) - -(\DSPCOLOR.PSC - [LAMBDA (STREAM COLOR) (* ; "Edited 14-Jan-93 17:14 by jds") - - (* ;; - "Postscript %"color%" setter -- really sets gray shade for now. 0.0 = black, 1.0 = white.") - - (POSTSCRIPT.SHOWACCUM STREAM) - (PROG1 (FETCH (\POSTSCRIPTDATA POSTSCRIPTCOLOR) OF (FETCH (STREAM IMAGEDATA) - OF STREAM)) - (COND - ((AND (NUMBERP COLOR) - (<= 0 COLOR 1)) - (REPLACE (\POSTSCRIPTDATA POSTSCRIPTCOLOR) OF (FETCH (STREAM IMAGEDATA) - OF STREAM) WITH COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL COLOR " setgray ")) - (COLOR (\ILLEGAL.ARG COLOR))))]) - -(\DSPFONT.PSC - [LAMBDA (STREAM FONT) (* ; - "Edited 26-May-93 01:06 by sybalsky:mv:envos") - (* ; "Edited 11-May-93 02:11 by jds") - (* ; "Edited 19-Jan-93 17:17 by jds") - - (* ;; "Change fonts on the PostScript stream STREAM to be FONT.") - - (* ;; "Doesn't actually write the font-change command to the stream (it saves doing that until the font is actually needed, so that multiple font changes don't yield larger PS files).") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFONT (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) - NEWFONT FONTID) - (COND - ((AND FONT (SETQ NEWFONT (OR (\COERCEFONTDESC FONT STREAM) - (FONTCOPY OLDFONT FONT))) - (type? FONTDESCRIPTOR NEWFONT) - (NEQ NEWFONT OLDFONT)) - - (* ;; "OK, it's a good font.") - - (POSTSCRIPT.SHOWACCUM STREAM) (* ; - " Write out any accumulated characters.") - - (* ;; "Change the font in the Lisp stream:") - - (replace (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA with NEWFONT) - - (* ;; "and now update all font-dependent fields in the imagedata, EXCEPT POSTSCRIPTSPACEWIDTH and POSTSCRIPTNATURALSPACEWIDTH. These latter 2 must stay as-is up thru the actual writing of characters by SHOWACCUM, so") - - (\POSTSCRIPT.CHANGECHARSET IMAGEDATA 0) - (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of - NEWFONT))) - [replace (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA - with (FIXR (TIMES (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) - of IMAGEDATA) - (replace (\POSTSCRIPTDATA POSTSCRIPTNATURALSPACEWIDTH) - of IMAGEDATA with (\FGETWIDTH (fetch - (\POSTSCRIPTDATA - POSTSCRIPTWIDTHS) - of IMAGEDATA) - (CHARCODE SPACE] - (\FIXLINELENGTH.PSC STREAM IMAGEDATA) - [SETQ FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR - - OTHERDEVICEFONTPROPS - ) of - NEWFONT - ) - 'PSCFONT] - (COND - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - *POSTSCRIPT-UNACCENTED-FONTS*) - (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF IMAGEDATA WITH NIL)) - (T (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of IMAGEDATA with - T))) - - (* ;; "Remember to actually write a change command") - - (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with - T))) - OLDFONT]) - -(\DSPLEFTMARGIN.PSC - [LAMBDA (STREAM XPOSITION) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - (COND - (XPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA - with XPOSITION) - (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) - -(\DSPLINEFEED.PSC - [LAMBDA (STREAM LINELEADING) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of (fetch (STREAM IMAGEDATA) - of STREAM)) - (COND - (LINELEADING (replace (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) - of (fetch (STREAM IMAGEDATA) of STREAM) with LINELEADING)) - ))]) - -(\DSPPUSHSTATE.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (push (fetch (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of IMAGEDATA) - (create POSTSCRIPTXFORM - PSXCLIP _ (COPY (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA)) - PSXPAGE _ (COPY (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of - IMAGEDATA)) - PSXLEFT _ (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - PSXRIGHT _ (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA - ) - PSXTOP _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - PSXBOTTOM _ (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of - IMAGEDATA - ) - PSXTRANX _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) - PSXTRANY _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) - PSXLAND _ (fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) - PSXXFORMPEND _ (fetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) - of IMAGEDATA]) - -(\DSPPOPSTATE.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:15 by sybalsky:mv:envos") - (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (XFORM (pop (fetch (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of IMAGEDATA] - (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXCLIP) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXPAGE) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXBOTTOM) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXTOP) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXLEFT) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXRIGHT) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXLAND) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXXFORMPEND) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA with - (fetch ( - POSTSCRIPTXFORM - PSXTRANX) - of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA with - (fetch ( - POSTSCRIPTXFORM - PSXTRANY) - of XFORM]) - -(\DSPRESET.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (replace (STREAM CHARPOSITION) of STREAM with 0) - (\MOVETO.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - (FONTPROP (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA) - 'ASCENT]) - -(\DSPRIGHTMARGIN.PSC - [LAMBDA (STREAM XPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) - (COND - (XPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA - with XPOSITION) - (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) - -(\DSPROTATE.PSC - [LAMBDA (STREAM ROTATION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "rotate the postscript stream by ROTATION") - - (* ;; - "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OROT (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA)) - LAND C0 P0 C P ML MB MR MT) - (COND - ((AND ROTATION (NEQ ROTATION (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) - of IMAGEDATA))) - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA with ROTATION) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) - (\DSPRESET.PSC STREAM))) - OROT]) - -(\DSPSCALE.PSC - [LAMBDA (STREAM SCALE) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - NSCALE) - (COND - ((AND NIL - - (* ;; "Changing SCALE is not implemented. According to IRM.") - - (NUMBERP SCALE) - (CL:PLUSP SCALE)) - (SETQ NSCALE (QUOTIENT SCALE OSCALE)) - - (* ;; - "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.") - - (POSTSCRIPT.PUTCOMMAND STREAM " " NSCALE " " NSCALE " scale" :EOL) - (replace (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA with SCALE))) - OSCALE]) - -(\DSPSCALE2.PSC - [LAMBDA (STREAM X-SCALE Y-SCALE) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "SETS X AND Y SCALE ") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - NSCALE) - (COND - ((AND X-SCALE (NUMBERP X-SCALE) - (CL:PLUSP X-SCALE)) - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - - (* ;; - "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.") - - (POSTSCRIPT.PUTCOMMAND STREAM " " X-SCALE " " Y-SCALE " scale" :EOL))) - T]) - -(\DSPSPACEFACTOR.PSC - [LAMBDA (STREAM FACTOR) (* ; - "Edited 26-May-93 01:18 by sybalsky:mv:envos") - (DECLARE (LOCALVARS . T)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFACTOR (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA))) - [COND - ((AND (NUMBERP FACTOR) - (NOT (EQUAL FACTOR OLDFACTOR))) - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA with FACTOR) - (replace (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA - with (FIXR (TIMES FACTOR (ffetch (\POSTSCRIPTDATA - POSTSCRIPTNATURALSPACEWIDTH) - of IMAGEDATA] - OLDFACTOR]) - -(\DSPTOPMARGIN.PSC - [LAMBDA (STREAM YPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of (fetch (STREAM IMAGEDATA) - of STREAM)) - (COND - (YPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of (fetch - (STREAM IMAGEDATA) - of STREAM) - with YPOSITION))))]) - -(\DSPTRANSLATE.PSC - [LAMBDA (STREAM TX TY) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (MDX (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) - TX)) - (MDY (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) - TY))) - (COND - ((NOT (AND (ZEROP MDX) - (ZEROP MDY))) - (POSTSCRIPT.SHOWACCUM STREAM) - (for REG in (LIST (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA) - (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) - of IMAGEDATA)) do (CL:INCF (fetch (REGION - LEFT) - of REG) - MDX) - (CL:INCF (fetch (REGION - BOTTOM) - of REG) - MDY)) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - MDX) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - MDY) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - MDX) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) - MDX) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - MDY) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - MDY) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA with TX) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA with TY) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T]) - -(\DSPXPOSITION.PSC - [LAMBDA (STREAM XPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - OLDX) - (PROG1 (SETQ OLDX (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) - [COND - ((AND XPOSITION (NOT (EQUAL XPOSITION OLDX))) - (\MOVETO.PSC STREAM XPOSITION (fetch (\POSTSCRIPTDATA POSTSCRIPTY) - of IMAGEDATA])]) - -(\DSPYPOSITION.PSC - [LAMBDA (STREAM YPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - OLDY) - (PROG1 (SETQ OLDY (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA)) - (COND - ((AND YPOSITION (NOT (EQUAL YPOSITION OLDY))) - (\MOVETO.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - YPOSITION))))]) - -(\FILLCIRCLE.PSC - [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 30-Mar-90 17:59 by Matt Heffron") - (LET (TEXTUREBM TEXTUREWIDTH) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (if (FIXP TEXTURE) - then (if (ZEROP TEXTURE) - then (SETQ TEXTURE 1.0) (* ; "The setgray version of white") - elseif (OR (EQL TEXTURE 65535) - (EQL TEXTURE -1)) - then (SETQ TEXTURE 0.0) (* ; "The setgray version of black") - )) - (if (FLOATP TEXTURE) - then - - (* ;; - "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.") - - (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ") - elseif (OR (TEXTUREP TEXTURE) - (NULL TEXTURE)) - then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) - (SETQ TEXTUREWIDTH 16) - (BLTSHADE TEXTURE TEXTUREBM) - elseif (BITMAPP TEXTURE) - then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) - (fetch BITMAPHEIGHT of TEXTUREBM))) - (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) - (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) - (POSTSCRIPT.PUTCOMMAND STREAM " " CENTERX " " CENTERY " " RADIUS " 0 360 arc" :EOL) - (if TEXTUREBM - then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ") - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) - (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch - BITMAPRASTERWIDTH - of TEXTUREBM) - 1) - " 0 " - (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) - 100.0)) - " findresolution " TEXTUREWIDTH " div div ceiling " - POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" :EOL) - else (POSTSCRIPT.PUTCOMMAND STREAM " eofill" :EOL "grestore" :EOL)) - (\MOVETO.PSC STREAM CENTERX CENTERY]) - -(\FILLPOLYGON.PSC - [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER) - (* ; - "Edited 20-Nov-92 15:17 by sybalsky:mv:envos") - (DECLARE (SPECVARS FILL.WRULE)) - - (* ;; "OPERATION is ignored here") - - (LET ((LASTPOINT (CAR (LAST KNOTS))) - TEXTUREBM TEXTUREWIDTH) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (if (NOT (OR (ZEROP WINDNUMBER) - (EQL WINDNUMBER 1))) - then (SETQ WINDNUMBER FILL.WRULE)) - (if (FIXP TEXTURE) - then (if (ZEROP TEXTURE) - then (SETQ TEXTURE 1.0) (* ; "The setgray version of white") - elseif (OR (EQL TEXTURE 65535) - (EQL TEXTURE -1)) - then (SETQ TEXTURE 0.0) (* ; "The setgray version of black") - )) - (if (FLOATP TEXTURE) - then - - (* ;; - "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.") - - (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ") - elseif (OR (TEXTUREP TEXTURE) - (NULL TEXTURE)) - then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) - (SETQ TEXTUREWIDTH 16) - (BLTSHADE TEXTURE TEXTUREBM) - elseif (BITMAPP TEXTURE) - then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) - (fetch BITMAPHEIGHT of TEXTUREBM))) - (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) - (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) - (POSTSCRIPT.PUTCOMMAND STREAM (fetch (POSITION XCOORD) of (CAR KNOTS)) - " " - (fetch (POSITION YCOORD) of (CAR KNOTS)) - " M" :EOL) - (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch - (POSITION XCOORD) - of K) - " " - (fetch (POSITION YCOORD) of K) - " lineto" :EOL)) - (POSTSCRIPT.PUTCOMMAND STREAM " closepath" :EOL) - (if TEXTUREBM - then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ") - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) - (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch - BITMAPRASTERWIDTH - of TEXTUREBM) - 1) - " 0 " - (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) - 100.0)) - " findresolution " TEXTUREWIDTH " div div ceiling " - POSTSCRIPT.TEXTURE.SCALE " mul setpattern")) - (POSTSCRIPT.PUTCOMMAND STREAM (if (ZEROP WINDNUMBER) - then " fill" - else " eofill") - :EOL "grestore" :EOL) - (\MOVETO.PSC STREAM (fetch (POSITION XCOORD) of LASTPOINT) - (fetch (POSITION YCOORD) of LASTPOINT]) - -(\FIXLINELENGTH.PSC - [LAMBDA (STREAM IMAGEDATA) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "Called by margin, font or rotation change to update the LINELENGTH field in the stream.") - - (LET [(TMP (MIN MAX.SMALLP (FIX (QUOTIENT (DIFFERENCE (fetch (\POSTSCRIPTDATA - POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA) - (ffetch (\POSTSCRIPTDATA - POSTSCRIPTLEFTMARGIN) - of IMAGEDATA)) - (fetch FONTAVGCHARWIDTH of (ffetch - (\POSTSCRIPTDATA - POSTSCRIPTFONT) - of IMAGEDATA] - (replace (STREAM LINELENGTH) of STREAM with (COND - ((GREATERP TMP 1) - TMP) - (T 10]) - -(\MOVETO.PSC - [LAMBDA (STREAM X Y) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) - (COND - ([NOT (AND (EQP X (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) - (EQP Y (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA] - (POSTSCRIPT.SHOWACCUM STREAM) - (freplace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with X) - (freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA with Y) - (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with T]) - -(\NEWPAGE.PSC - [LAMBDA (STREAM) (* ; "Edited 5-Apr-89 17:31 by TAL") - (POSTSCRIPT.ENDPAGE STREAM) - (POSTSCRIPT.STARTPAGE STREAM]) -) - - - -(* ;; "Character-output, plus special-cases:") - -(DEFINEQ - -(\POSTSCRIPT.CHANGECHARSET - [LAMBDA (PSDATA CHARSET) (* ; "Edited 29-Apr-93 13:51 by rmk:") - - (* ;; -"Called when the character set information cached in a display stream doesn't correspond to CHARSET") - - (PROG* ((FONT (ffetch POSTSCRIPTFONT of PSDATA)) - (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 POSTSCRIPTWIDTHS of PSDATA with (ffetch (CHARSETINFO WIDTHS) - of CSINFO)) - (freplace POSTSCRIPTNSCHARSET of PSDATA with CHARSET))]) - -(\POSTSCRIPT.OUTCHARFN - [LAMBDA (STREAM CHAR) (* ; "Edited 23-May-93 12:00 by rmk:") - (* ; "Edited 4-May-93 02:20 by jds") - (* ; "Edited 3-Feb-93 00:45 by jds") - -(* ;;; "Output a character to be printed.") - -(* ;;; "Change font if necessary, do newline if at right margin, check for special chars and do appropriate thing, quote char and/or start postscript string if necessary.") - -(* ;;; "This is called a lot, so the code is unrolled for efficiency.") - - (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE) - (LOCALVARS . T)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (XPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) - (FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) - CHARWID NEWXPOS MAPPING) - (CL:UNLESS (EQ (\CHARSET CHAR) - (ffetch POSTSCRIPTNSCHARSET of IMAGEDATA)) - - (* ;; "Switch character set so that we get the right char width.") - - (\POSTSCRIPT.CHANGECHARSET IMAGEDATA (\CHARSET CHAR))) - [SETQ CHARWID (SELCHARQ CHAR - (SPACE (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of - IMAGEDATA - )) - (\FGETWIDTH (ffetch (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) of - IMAGEDATA - ) - (\CHAR8CODE CHAR] - - (* ;; "POSTSCRIPTACCENTED true if font has accented rendering characters in it; otherwise, a c-set 0 special font (SYMBOL, ZAPFDINGBATS...)") - - [COND - [[OR (NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of IMAGEDATA)) - (AND (ILEQ CHAR 254) - (NOT (CL:AREF \POSTSCRIPT.CHARTYPE CHAR] - - (* ;; "OR is NIL if char is special in any way: Either font isn't supposed to be treated as an NS font (e.g. ZapfDingbats, which uses all the legal char positions for its own), or char itself is in cset 0 and ordinary") - - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - CHARWID] - (CL:UNLESS (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with - T)) - (COND - [(ILESSP CHAR (CHARCODE " ")) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - [(IGEQ CHAR 127) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - (T (SELCHARQ CHAR - ((%( %) \) - (BOUT STREAM (CHARCODE \)) - (BOUT STREAM CHAR)) - (BOUT STREAM CHAR] - [(SETQ MAPPING (GETHASH CHAR *POSTSCRIPT-NS-HASH*)) - (* ; - "Special character that's taken care of by the NS mapping.") - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - CHARWID] - (SELECTQ (CAR MAPPING) - (NIL - (* ;; "just a remap within the lower 256. But the code in (CDR MAPPING) is in charset 2 to prevent recursion") - - (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING))) - (SYMBOL - (* ;; "Its in the SYMBOL font. Symbol is specified as %"2,xxx%" rather than %"0,xxx%" to defeat translations to symbol that go to matching character codes.") - - (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING) - 'SYMBOL)) - (ACCENT (* ; "Special accent mapping we did") - (\POSTSCRIPT.ACCENTFN STREAM (CADR MAPPING))) - (ACCENTPAIR (* ; - "Given base char & accent, overlap them.") - (\POSTSCRIPT.ACCENTPAIR STREAM (CADR MAPPING) - (CADDR MAPPING) - (CADDDR MAPPING))) - (DINGBAT (* ; "A Zapf dingbat") - (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING) - 'ZAPFDINGBATS)) - (APPLY* (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - - (* ;; "User function can call any stream operations it wants. At the end, we guarantee that baseline hasn't changed and that xpos is where the widthset it would be.") - - [freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA - with (PROG1 (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) OF - IMAGEDATA - ) - (APPLY* (CADDR MAPPING) - STREAM - (CADR MAPPING)))]) - (FUNCTION (* ; "Done as special PS code.") - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - (POSTSCRIPT.OUTSTR STREAM (CADR MAPPING))) - (\ILLEGAL.ARG (CAR MAPPING] - (T (* ; "Special char") - (SELCHARQ CHAR - ((EOL LF) - (\TERPRI.PSC STREAM) - - (* ;; - "Set NEWXPOS to current value here and in FF to preserve value after external resetting.") - - (SETQ NEWXPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))) - (FF (DSPNEWPAGE STREAM) - (SETQ NEWXPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))) - (TAB (SETQ NEWXPOS (IPLUS XPOS (\POSTSCRIPTTAB IMAGEDATA))) - [COND - ((IGREATERP NEWXPOS (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of IMAGEDATA) - (\POSTSCRIPTTAB IMAGEDATA] - (\MOVETO.PSC STREAM NEWXPOS (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) - of IMAGEDATA))) - ("357,140" (* ; " Ballot box, checked") - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of IMAGEDATA) - CHARWID] - (LET ((OLDFONT (\DSPFONT.PSC STREAM))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\DSPFONT.PSC STREAM (LIST 'ZAPFDINGBATS (fetch - (FONTDESCRIPTOR - FONTSIZE) - of OLDFONT) - (fetch (FONTDESCRIPTOR - FONTFACE) - of OLDFONT))) - (\UPDATE.PSC STREAM IMAGEDATA) - (POSTSCRIPT.OUTSTR STREAM " bboxchk ") - (\DSPFONT.PSC STREAM OLDFONT))) - (PROGN [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of IMAGEDATA) - CHARWID] - (COND - ((IGEQ CHAR 255) - - (* ;; "If it's 255 or above and we don't know anything about it, print the black box. Width vector will determine width of box, to maintain consistency.") - - (\POSTSCRIPT.PRINTSLUG STREAM CHAR)) - (T (SETQ CHAR (\CHAR8CODE CHAR)) - (COND - ((NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) - of IMAGEDATA)) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) - of IMAGEDATA with T))) - (BOUT STREAM (CHARCODE \)) - (SELCHARQ CHAR - ((%( %) \) - (BOUT STREAM CHAR)) - (PROGN [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - (freplace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with NEWXPOS) - CHAR]) - -(\POSTSCRIPT.PRINTSLUG - [LAMBDA (STREAM CHAR) (* ; "Edited 9-May-93 21:55 by rmk:") - (* ; "Edited 4-May-93 02:20 by jds") - (* ; "Edited 3-Feb-93 00:45 by jds") - -(* ;;; "Internal function to display a black box for a missing character. Width is taken from widths vector, so that box and charwidth are always consistent. Caller (\POSTSCRIPT.OUTCHARFN) is responsible for guaranteeing proper caching of widths vector and for measurement and position updating, although \DRAWLINE.PSC also updates position.") - - (DECLARE (LOCALVARS . T)) - (LET ((IMAGEDATA (FETCH (STREAM IMAGEDATA) OF STREAM))) - (\BLTSHADE.PSC BLACKSHADE STREAM (FETCH (\POSTSCRIPTDATA POSTSCRIPTX) OF - IMAGEDATA - ) - (FETCH (\POSTSCRIPTDATA POSTSCRIPTY) OF IMAGEDATA) - (\FGETWIDTH (FFETCH (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) OF IMAGEDATA) - (\CHAR8CODE CHAR)) - (FETCH (FONTDESCRIPTOR \SFAscent) OF (FETCH (\POSTSCRIPTDATA - POSTSCRIPTFONT) - OF IMAGEDATA)) - 'PAINT) - (\MOVETO.PSC STREAM (IPLUS (FETCH (\POSTSCRIPTDATA POSTSCRIPTX) OF IMAGEDATA) - (\FGETWIDTH (FFETCH (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) - OF IMAGEDATA) - (\CHAR8CODE CHAR))) - (FETCH (\POSTSCRIPTDATA POSTSCRIPTY) OF IMAGEDATA]) - -(\POSTSCRIPT.SPECIALOUTCHARFN - [LAMBDA (STREAM CHAR FAMILY) (* ; "Edited 23-May-93 13:31 by rmk:") - (* ; "Edited 4-May-93 02:20 by jds") - (* ; "Edited 3-Feb-93 00:45 by jds") - -(* ;;; "Internal function to output a special character to be printed, changing font if necessary. Width processing is carried out at higher level. If FAMILY is given, switches to that font (SYMBOL, ZAPFDINGBATS) before printing, then switches back.") - - (DECLARE (LOCALVARS . T)) - (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFONT (AND FAMILY (\DSPFONT.PSC STREAM] - (CL:WHEN OLDFONT - (\DSPFONT.PSC STREAM (LIST FAMILY (fetch (FONTDESCRIPTOR FONTSIZE) of - OLDFONT) - (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT)))) - (CL:UNLESS (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with T)) - [COND - [(ILESSP CHAR (CHARCODE " ")) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - [(IGEQ CHAR 127) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - (T (SELCHARQ CHAR - ((%( %) \) - (BOUT STREAM (CHARCODE \)) - (BOUT STREAM CHAR)) - (BOUT STREAM CHAR] - (CL:WHEN OLDFONT (\DSPFONT.PSC STREAM OLDFONT)) - CHAR]) - -(\UPDATE.PSC - [LAMBDA (STREAM IMAGEDATA) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "Make any outstanding font, scale, location updates, prepatory to something that might depend heavily on it. (e.g. before starting to output characters, or making a scale change)") - (* ; - "This code was originally in \POSTSCRIPT.OUTCHAR &c, and is here for commonality.") - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA) - (\SETXFORM.PSC STREAM IMAGEDATA))) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA) - (* ; - "If font was changed then switch before printing") - (\SWITCHFONTS.PSC STREAM IMAGEDATA))) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA) - (* ; "likewise for position") - (\SETPOS.PSC STREAM IMAGEDATA]) - -(\POSTSCRIPT.ACCENTFN - [LAMBDA (STREAM CHAR) (* ; "Edited 28-Apr-93 16:35 by rmk:") - (* ; "Edited 3-Feb-93 01:05 by jds") - -(* ;;; "Output an accented character to be printed. .") - -(* ;;;; "Need to inc CHARPOSITION of STREAM") - - (DECLARE (LOCALVARS . T)) - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (COND - ((NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA)) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with T))) - (BOUT STREAM (CHARCODE "\")) - (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING CHAR)) - -3) do (BOUT STREAM CH)) - CHAR]) - -(\POSTSCRIPT.ACCENTPAIR - [LAMBDA (STREAM CHAR ACCENTS UNDER-ACCENTS) (* ; - "Edited 17-Aug-93 17:02 by sybalskY:MV:ENVOS") - (* ; "Edited 3-Feb-93 01:29 by jds") - -(* ;;; "Output an accented character to be printed. .") - -(* ;;;; "Prints the character as \xxx, with 3 octal digits, to avoid tripping up on EOLs and other postscript-special characters.") - - (DECLARE (LOCALVARS . T)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (BOUT STREAM (CHARCODE "\")) - (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING CHAR)) - -3) do (BOUT STREAM CH)) - (BOUT STREAM (CHARCODE %))) - (BOUT STREAM (CHARCODE %()) - (for ACCENT inside ACCENTS do (BOUT STREAM (CHARCODE "\")) - (for CH - instring (SUBSTRING (CONCAT "000" - (OCTALSTRING - ACCENT)) - -3) - do (BOUT STREAM CH))) - (POSTSCRIPT.PUTCOMMAND STREAM ") (") - (for ACCENT inside UNDER-ACCENTS - do (BOUT STREAM (CHARCODE "\")) - (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING ACCENT)) - -3) do (BOUT STREAM CH))) - (BOUT STREAM (CHARCODE %))) - (COND - (NIL (OR (IEQP ACCENT (CHARCODE "0,313")) - (IEQP ACCENT (CHARCODE "0,316"))) (* ; - "Cedilla and ogonek are under-accents, so don't raise them for capital letters.") - (POSTSCRIPT.PUTCOMMAND STREAM " 0 ")) - ((ILESSP CHAR (CHARCODE a)) (* ; - "upper case, so adjust offset for accent") - (POSTSCRIPT.PUTCOMMAND STREAM " " (/ (fetch \SFAscent of FONT) - 3.0) - " ")) - (T (POSTSCRIPT.PUTCOMMAND STREAM " 0 "))) - (POSTSCRIPT.PUTCOMMAND STREAM " " (FONTPROP FONT 'SIZE) - " ") - (POSTSCRIPT.PUTCOMMAND STREAM " accentor ") - CHAR]) -) - - - -(* ;; "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions") - -(DEFINEQ - -(\PSC.SPACEDISP - [LAMBDA (STREAM WIDTH) (* ; "Edited 28-Sep-93 13:50 by jds") - (POSTSCRIPT.PUTCOMMAND STREAM (\PSC.SPACEWID (DSPFONT NIL STREAM) - WIDTH) - " 0 rmoveto "]) - -(\PSC.SPACEWID - [LAMBDA (FONTDESC CHAR) (* ; "Edited 28-Sep-93 13:41 by jds") - - (* ;; "Spacing character with a special width (e.g. M space, thin (1/5-M) space...") - - (* ;; "If CHAR is a list, it's (CHARCODE FACTOR), and we return a width of FACTOR * (CHARWIDTH CHARCODE). Otherwise, we just return the width of CHARCODE.") - - (COND - [(LISTP CHAR) - (FIXR (FTIMES (CADR CHAR) - (CHARWIDTH (CHARCODE.DECODE (CAR CHAR)) - FONTDESC] - (T (CHARWIDTH (CHARCODE.DECODE CHAR) - FONTDESC]) - -(\PSC.SYMBOLS - [LAMBDA (STREAM CHAR) (* ; "Edited 2-Nov-94 17:01 by jds") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFONT (\DSPFONT.PSC STREAM))) - (\DSPFONT.PSC STREAM (LIST 'ZAPFDINGBATS (fetch (FONTDESCRIPTOR FONTSIZE) - of OLDFONT) - (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - (COND - ((EQUAL CHAR "0,161") - (POSTSCRIPT.OUTSTR STREAM " bboxchk "))) - (\DSPFONT.PSC STREAM OLDFONT]) -) - - - -(* ;; "The mapping of NS characters to Postscript renderings, both as an AList and as a hashtable") - -(DEFINEQ - -(\POSTSCRIPT.NSHASH - [LAMBDA (MAPPING-LIST) (* ; - "Edited 30-Jul-93 14:46 by sybalskY:MV:ENVOS") - (* ; "Edited 4-May-93 02:21 by jds") - (* ; "Edited 3-Feb-93 00:33 by jds") - (for MAPPING in MAPPING-LIST unless (EQ (CAR MAPPING) - '*) - do (* ; - "Skip comments in the mapping list.") - (LET [(CHARCODE (CHARCODE.DECODE (CAR MAPPING] - - (* ;; "Fill in the translation entry for this character:") - - (PUTHASH CHARCODE - [DESTRUCTURING-BIND - (KIND CODE2 BASECHAR UNDERACCENTS) - (SETQ MAPPING (CDR MAPPING)) - (CONS KIND (SELECTQ KIND - ((SYMBOL NIL DINGBAT) - (CONS (CHARCODE.DECODE CODE2))) - (FUNCTION (CONS CODE2)) - ((ACCENT ACCENTPAIR) - (LIST (CHARCODE.DECODE CODE2) - (CHARCODE.DECODE BASECHAR) - (AND UNDERACCENTS (CHARCODE.DECODE UNDERACCENTS)) - )) - (APPLY* (* ; - "Apply setup function to coerce argument data") - - (* ;; "MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN SETUPFN) PRINTFN gets applied to stream and result of applying SETUPFN to DATA. WIDTHFN gets applied to coerced data and fontdescriptor") - - (LIST (APPLY* (OR (CAR (CDDDDR MAPPING)) - (FUNCTION CL:IDENTITY)) - (CADR MAPPING)) - (CADDR MAPPING) - (CADDDR MAPPING))) - (ERROR "UNRECOGNIZED POSTSCRIPT CHARACTER TYPE" MAPPING] - *POSTSCRIPT-NS-HASH*) - - (* ;; "If this character is in the lower 127, we need to mark it for special handling in \POSTSCRIPT.CHARTYPE, by putting a T in the array at the charcode's position:") - - (CL:WHEN (<= CHARCODE 254) - (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE CHARCODE) - T))]) -) - -(RPAQQ *POSTSCRIPT-UNACCENTED-FONTS* (Dancer ZapfDingbats "Dancer" "ZapfDingbats")) - -(RPAQQ *POSTSCRIPT-NS-TRANSLATIONS* - ( - (* ;; "Mapping of NS characters to Postscript renderings.") - - - (* ;; "First few are for control-codes in old Press fonts (Timesroman, etc.); not strictly NS, but undefined therein so should be OK.") - - ("^S" NIL "2,320") - (* ; "pressfont em dash") - ("^V" NIL "2,261") - (* ; "pressfont en dash") - ("^G" NIL "0,140") - ("0,244" NIL "2,250") - (* ; "generic currency symbol") - ("0,251" NIL "2,140") - (* ; "left single quote") - ("0,254" SYMBOL "2,254") - (* ; "left arrow") - ("0,255" SYMBOL "2,255") - (* ; "uparrow") - ("0,256" SYMBOL "2,256") - (* ; "right arrow") - ("0,257" SYMBOL "2,257") - (* ; "down arrow") - ("0,260" SYMBOL "2,260") - (* ; "degree") - ("0,261" SYMBOL "2,261") - (* ; "+/-") - ("0,264" SYMBOL "2,264") - (* ; "times") - ("0,267" NIL "2,264") - (* ; "Center-dot") - ("0,270" SYMBOL "2,270") - (* ; "divide") - ("0,271" NIL "2,047") - (* ; "right single quote") - ("0,274" FUNCTION " f14 ") - (* ; "1/4") - ("0,275" FUNCTION " f12 ") - (* ; "1/2") - ("0,276" FUNCTION " f34 ") - (* ; "3/4") - ("0,322" SYMBOL "2,342") - (* ; "registered") - ("0,323" SYMBOL "2,343") - (* ; "copyright") - ("0,324" SYMBOL "2,344") - (* ; "tm") - ("0,334" FUNCTION " f18 ") - (* ; "1/8") - ("0,335" FUNCTION " f38 ") - (* ; "3/8") - ("0,336" FUNCTION " f58 ") - (* ; "5/8") - ("0,337" FUNCTION " f78 ") - (* ; "7/8") - ("0,342" NIL "2,235") - (* ; "Eth (slashed D?)") - ("0,354" NIL "2,237") - (* ; "Thorn") - ("0,363" NIL "2,236") - (* ; "eth") - ("0,374" NIL "2,240") - (* ; "thorn") - ("41,172" DINGBAT "0,110") - (* ; "filled star") - ("42,42" DINGBAT "0,161") - (* ; "ballot-box") - ("42,61" APPLY* "0,161" \PSC.SYMBOLS \PSC.SPACEWID NIL) - (* ; "Checked ballot-box") - ("357,44" NIL "2,261") - (* ; "n dash") - ("357,45" NIL "2,320") - (* ; "m dash") - ("357,55" APPLY* "M" \PSC.SPACEDISP \PSC.SPACEWID NIL) - (* ; "M quad") - ("357,54" APPLY* "N" \PSC.SPACEDISP \PSC.SPACEWID NIL) - (* ; "N quad") - ("357,56" APPLY* "1" \PSC.SPACEDISP \PSC.SPACEWID NIL) - (* ; "FIGURE quad") - ("357,57" APPLY* ("M" 0.2) - \PSC.SPACEDISP \PSC.SPACEWID NIL) - (* ; "This space (1/5M)") - ("357,60" NIL "2,262") - (* ; "dagger") - ("357,61" NIL "2,263") - (* ; "double dagger") - ("357,062" SYMBOL "2,361") - (* ; "angleright") - ("357,063" SYMBOL "2,341") - (* ; "angleleft") - ("357,70" SYMBOL "2,315") - (* ; "perpendicular") - ("357,101" NIL "2,275") - (* ; "per mil o/oo") - ("357,104" ACCENTPAIR "<" NIL "/") - (* ; "not less than") - ("357,105" ACCENTPAIR ">" "/") - (* ; "not greater than") - ("357,110" SYMBOL "2,312") - (* ; "parallel") - ("357,111" SYMBOL "2,315") - (* ; "not parallel") - ("357,112" SYMBOL "2,316") - (* ; "element") - ("357,113" SYMBOL "2,317") - (* ; "notelement") - ("357,114" SYMBOL "2,047") - (* ; "suchthat") - ("357,115" SYMBOL "2,334") - (* ; "implied by, double arrow left") - ("357,116" SYMBOL "2,333") - (* ; "iff, double arrow") - ("357,117" SYMBOL "2,336") - (* ; "implies, double arrow right") - ("357,120" SYMBOL "2,253") - (* ; "double arrow") - ("357,121" SYMBOL "2,333") - (* ; "double arrow") - ("357,122" SYMBOL "2,333") - (* ; "l/r arrow") - ("357,126" SYMBOL "2,307") - (* ; "intersection") - ("357,127" SYMBOL "2,310") - (* ; "union") - ("357,130" SYMBOL "2,312") - (* ; "reflexsuperset") - ("357,131" SYMBOL "2,315") - (* ; "reflexsubset") - ("357,132" SYMBOL "2,311") - (* ; "propersuperset") - ("357,133" SYMBOL "2,314") - (* ; "propersubset") - ("357,137" SYMBOL "2,313") - (* ; "notsubset") - ("357,141" SYMBOL "2,306") - (* ; "emptyset") - ("357,142" SYMBOL "2,305") - (* ; "circleplus") - ("357,144" SYMBOL "2,304") - (* ; "circlemultiply") - ("357,146" NIL "2,267") - (* ; "bullet") - ("357,147" SYMBOL "2,260") - (* ; - "center circle (composition), lowered degree") - ("357,152" SYMBOL "2,330") - (* ; "logicalnot") - ("357,154" SYMBOL "2,320") - (* ; "angle") - ("357,160" SYMBOL "2,136") - (* ; "perpendicular") - ("357,161" SYMBOL "2,265") - (* ; "proportional") - ("357,162" SYMBOL "2,272") - (* ; "equivalence") - ("357,165" SYMBOL "2,362") - (* ; "integral") - ("357,167" SYMBOL "2,273") - (* ; "approxequal") - ("357,170" SYMBOL "2,100") - (* ; "congruent") - ("357,172" SYMBOL "2,345") - (* ; "summation") - ("357,173" SYMBOL "2,325") - (* ; "product") - ("357,174" SYMBOL "2,326") - (* ; "radical") - ("357,242" SYMBOL "2,246") - (* ; "florin") - ("357,260" SYMBOL "2,351") - (* ; "Ceiling, left ") - ("357,261" SYMBOL "2,371") - (* ; "Ceiling, right") - ("357,262" SYMBOL "2,353") - (* ; "Floor, left ") - ("357,263" SYMBOL "2,373") - (* ; "Floor, right") - ("357,264" SYMBOL "2,44") - (* ; "exists") - ("357,265" SYMBOL "2,42") - (* ; "forall") - ("357,266" SYMBOL "2,331") - (* ; "logicaland") - ("357,267" SYMBOL "2,332") - (* ; "logicalor") - ("357,271" SYMBOL "2,321") - (* ; "gradient") - ("357,272" SYMBOL "2,266") - (* ; "partialdiff") - ("357,313" SYMBOL "2,252") - (* ; "spade") - ("357,317" DINGBAT "0,63") - (* ; "check") - ("357,375" FUNCTION " f13 ") - (* ; "1/3") - ("357,376" FUNCTION " f23 ") - (* ; "2/3") - ("361,041" ACCENT "0,4" A) - ("361,042" ACCENT "0,1" A) - ("361,043" ACCENT "0,2" A) - ("361,044" ACCENT "0,6" A) - ("361,045" ACCENTPAIR A "0,305") - (* ; "A-macron") - ("361,046" ACCENTPAIR A "0,306") - (* ; "A-breve") - ("361,047" ACCENT "0,3" A) - ("361,050" ACCENT "0,5" A) - ("361,055" ACCENT "0,7" C) - ("361,060" ACCENT "0,13" E) - ("361,061" ACCENT "0,10" E) - ("361,062" ACCENT "0,11" E) - ("361,063" ACCENTPAIR E "0,305") - (* ; "E-macron") - ("361,065" ACCENT "0,12" E) - ("361,066" ACCENTPAIR E NIL "0,316") - (* ; "E-ogonek") - ("361,076" ACCENT "0,17" I) - ("361,077" ACCENT "0,14" I) - ("361,100" ACCENT "0,15" I) - ("361,102" ACCENTPAIR I "0,305") - (* ; "I-macron") - ("361,104" ACCENT "0,16" I) - ("361,114" ACCENT "0,20" N) - ("361,117" ACCENT "0,24" O) - ("361,120" ACCENT "0,21" O) - ("361,121" ACCENT "0,22" O) - ("361,122" ACCENT "0,25" O) - ("361,123" ACCENTPAIR O "0,305") - (* ; "O-macron") - ("361,124" ACCENT "0,23" O) - ("361,134" ACCENT "0,26" S) - ("361,137" ACCENT "0,32" U) - ("361,140" ACCENT "0,27" U) - ("361,141" ACCENT "0,30" U) - ("361,143" ACCENTPAIR U "0,305") - (* ; "U-macron") - ("361,145" ACCENT "0,31" U) - ("361,155" ACCENT "0,33" Y) - ("361,160" ACCENT "0,34" Z) - ("361,165" ACCENTPAIR Y "0,305") - (* ; "Y-macron") - ("361,166" ACCENTPAIR "0,341" "0,305") - (* ; "AE-macron") - ("361,167" ACCENTPAIR "0,352" "0,305") - (* ; "OE-macron") - ("361,241" ACCENT "0,204" a) - ("361,242" ACCENT "0,201" a) - ("361,243" ACCENT "0,202" a) - ("361,244" ACCENT "0,206" a) - ("361,245" ACCENTPAIR a "0,305") - (* ; "a-macron") - ("361,246" ACCENTPAIR a "0,306") - (* ; "a-breve") - ("361,247" ACCENT "0,203" a) - ("361,250" ACCENT "0,205" a) - ("361,255" ACCENT "0,207" c) - ("361,260" ACCENT "0,213" e) - ("361,261" ACCENT "0,210" e) - ("361,262" ACCENT "0,211" e) - ("361,263" ACCENTPAIR e "0,305") - (* ; "e-macron") - ("361,265" ACCENT "0,212" e) - ("361,266" ACCENTPAIR e NIL "0,316") - (* ; "e-ogonek") - ("361,267" ACCENTPAIR e "0,317") - (* ; "e-caron") - ("361,276" ACCENT "0,217" i) - ("361,277" ACCENT "0,214" i) - ("361,300" ACCENT "0,215" i) - ("361,302" ACCENTPAIR "0,365" "0,305") - (* ; "i-macron") - ("361,304" ACCENT "0,216" i) - ("361,314" ACCENT "0,220" n) - ("361,317" ACCENT "0,224" o) - ("361,320" ACCENT "0,221" o) - ("361,321" ACCENT "0,222" o) - ("361,322" ACCENT "0,225" o) - ("361,323" ACCENTPAIR o "0,305") - (* ; "o-macron") - ("361,324" ACCENT "0,223" o) - ("361,334" ACCENT "0,226" s) - ("361,337" ACCENT "0,232" u) - ("361,340" ACCENT "0,227" u) - ("361,341" ACCENT "0,230" u) - ("361,343" ACCENTPAIR u "0,305") - (* ; "u-macron") - ("361,344" ACCENTPAIR u "0,306") - (* ; "u-breve") - ("361,345" ACCENT "0,231" u) - ("361,355" ACCENT "0,233" y) - ("361,360" ACCENT "0,234" z) - ("361,365" ACCENTPAIR y "0,305") - (* ; "y-macron") - ("361,366" ACCENTPAIR "0,361" "0,305") - (* ; "ae-macron") - ("361,367" ACCENTPAIR "0,372" "0,305") - (* ; "oe-macron") - ("361,371" ACCENTPAIR a "0,317") - (* ; "a-caron") - ("361,375" ACCENTPAIR g "0,317") - (* ; "g-caron") - - (* ;; "Special code assignments for Dictionary of Old English, UToronto:") - - ("361,370" ACCENTPAIR a ("0,305" "0,306")) - (* ; "a - breve-macron") - ("361,372" ACCENTPAIR e "0,306") - (* ; "e-breve") - ("361,373" ACCENTPAIR e "0,305" "0,56") - (* ; "e macron underdot") - ("361,374" ACCENTPAIR e ("0,305" "0,306")) - (* ; "e - breve-macron") - ("361,376" ACCENTPAIR "0,365" "0,306") - (* ; "i-breve") - ("362,242" ACCENTPAIR "0,365" "0,317") - (* ; "i-caron") - ("362,241" ACCENTPAIR "0,365" ("0,305" "0,306")) - (* ; " i - breve-macron") - ("362,243" ACCENTPAIR n "0,305") - (* ; "n-macron") - ("362,244" ACCENTPAIR m "0,305") - (* ; "m-macron") - ("362,245" ACCENTPAIR o "0,317") - (* ; "o-caron") - ("362,246" ACCENTPAIR o "0,306") - (* ; "o-breve") - ("362,247" ACCENTPAIR o ("0,305" "0,306")) - (* ; "o - breve-macron") - ("362,250" ACCENTPAIR o "0,305" "0,56") - (* ; "o-macron underdot") - ("362,251" ACCENTPAIR o "0,316") - (* ; "o-ogonek") - ("362,252" ACCENTPAIR u "0,317") - (* ; "u-caron") - ("362,253" ACCENTPAIR u ("0,305" "0,306")) - (* ; "u - breve-macron") - ("362,254" ACCENTPAIR y "0,306") - (* ; "y-breve") - ("362,256" ACCENTPAIR y "0,317") - (* ; "y-caron") - ("362,255" ACCENTPAIR y ("0,305" "0,306")) - (* ; "y - breve-macron") - (* ; "235 = Eth") - (* ; "236 = eth") - (* ; "237 = Thorn") - (* ; "240 = thorn") - - (* ;; "NS Greek characters") - - ("46,101" SYMBOL "2,101") - (* ; "Alpha") - ("46,102" SYMBOL "2,102") - (* ; "Beta") - ("46,103" SYMBOL 0) - (* ; "--empty--") - ("46,104" SYMBOL "2,107") - (* ; "Gamma") - ("46,105" SYMBOL "2,104") - (* ; "Delta") - ("46,106" SYMBOL "2,105") - (* ; "Epsilon") - ("46,107" SYMBOL 0) - (* ; "Stigma") - ("46,110" SYMBOL 0) - (* ; "Digamma") - ("46,111" SYMBOL "2,132") - (* ; "Zeta") - ("46,112" SYMBOL "2,110") - (* ; "Eta") - ("46,113" SYMBOL "2,121") - (* ; "Theta") - ("46,114" SYMBOL "2,111") - (* ; "Iota") - ("46,115" SYMBOL "2,113") - (* ; "Kappa") - ("46,116" SYMBOL "2,114") - (* ; "Lambda") - ("46,117" SYMBOL "2,115") - (* ; "Mu") - ("46,120" SYMBOL "2,116") - (* ; "Nu") - ("46,121" SYMBOL "2,130") - (* ; "Xi") - ("46,122" SYMBOL "2,117") - (* ; "Omicron") - ("46,123" SYMBOL "2,120") - (* ; "Pi") - ("46,124" SYMBOL 0) - (* ; "Koppa") - ("46,125" SYMBOL "2,122") - (* ; "Rho") - ("46,126" SYMBOL "2,123") - (* ; "Sigma") - ("46,127" SYMBOL 0) - (* ; "--empty--") - ("46,130" SYMBOL "2,124") - (* ; "Tau") - ("46,131" SYMBOL "2,125") - (* ; "Upsilon") - ("46,132" SYMBOL "2,106") - (* ; "Phi") - ("46,133" SYMBOL "2,103") - (* ; "Chi") - ("46,134" SYMBOL "2,131") - (* ; "Psi") - ("46,135" SYMBOL "2,132") - (* ; "Omega") - ("46,141" SYMBOL "2,141") - (* ; "alpha") - ("46,142" SYMBOL "2,142") - (* ; "beta") - ("46,143" SYMBOL 0) - (* ; "(md beta)") - ("46,144" SYMBOL "2,147") - (* ; "gamma") - ("46,145" SYMBOL "2,144") - (* ; "delta") - ("46,146" SYMBOL "2,145") - (* ; "epsilon") - ("46,147" SYMBOL "2,126") - (* ; "stigma") - ("46,150" SYMBOL 0) - (* ; "digamma") - ("46,151" SYMBOL "2,172") - (* ; "zeta") - ("46,152" SYMBOL "2,150") - (* ; "eta") - ("46,153" SYMBOL "2,161") - (* ; "theta") - ("46,154" SYMBOL "2,151") - (* ; "iota") - ("46,155" SYMBOL "2,153") - (* ; "kappa") - ("46,156" SYMBOL "2,154") - (* ; "lambda") - ("46,157" SYMBOL "2,155") - (* ; "mu") - ("46,160" SYMBOL "2,156") - (* ; "nu") - ("46,161" SYMBOL "2,170") - (* ; "xi") - ("46,162" SYMBOL "2,157") - (* ; "omicron") - ("46,163" SYMBOL "2,160") - (* ; "pi") - ("46,164" SYMBOL 0) - (* ; "(koppa)") - ("46,165" SYMBOL "2,162") - (* ; "rho") - ("46,166" SYMBOL "2,163") - (* ; "sigma") - ("46,167" SYMBOL "2,126") - (* ; "(fl sigma)") - ("46,170" SYMBOL "2,164") - (* ; "tau") - ("46,171" SYMBOL "2.165") - (* ; "upsilon") - ("46,172" SYMBOL "2,146") - (* ; "phi") - ("46,173" SYMBOL "2,143") - (* ; "chi") - ("46,174" SYMBOL "2,171") - (* ; "psi") - ("46,175" SYMBOL "2,167") - (* ; "omega") - - (* ;; "NS Miscellaneous symbols") - - ("041,142" SYMBOL "2,271") - (* ; "notequal") - ("041,145" SYMBOL "2,243") - (* ; "lessequal") - ("041,146" SYMBOL "2,263") - (* ; "greaterequal") - ("041,147" SYMBOL "2,245") - (* ; "infinity") - ("041,150" SYMBOL "2,134") - (* ; "therefore") - ("041,155" SYMBOL "2,262") - (* ; "second") - ("356,055" SYMBOL "2,055") - (* ; "minus") - ("356,106" SYMBOL "2,340") - (* ; "lozenge") - ("356,163" SYMBOL "2,351") - (* ; "topleftbracket") - ("356,164" SYMBOL "2,353") - (* ; "bottomleftbracket") - ("356,165" SYMBOL "2,352") - (* ; "centerbracket") - ("356,166" SYMBOL "2,371") - (* ; "toprightbracket") - ("356,167" SYMBOL "2,373") - (* ; "bottomrightbracket") - ("356,176" SYMBOL "2,176") - (* ; "similar") - ("356,314" SYMBOL "2,251") - (* ; "heart") - ("356,340" SYMBOL "2,374") - (* ; "toprightbracce") - ("356,341" SYMBOL "2,357") - (* ; "braceextend") - ("356,342" SYMBOL "2,375") - (* ; "centerrightbracce") - ("356,343" SYMBOL "2,376") - (* ; "bottomrightbracce") - ("356,344" SYMBOL "2,354") - (* ; "topleftbracce") - ("356,345" SYMBOL "2,356") - (* ; "bottomleftbracce") - ("356,346" SYMBOL "2,355") - (* ; "centerleftbracce") - ("356,355" SYMBOL "2,363") - (* ; "integraltop") - ("356,356" SYMBOL "2,365") - (* ; "integralbottom") - ("356,357" SYMBOL "2,364") - (* ; "integralcenter"))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *POSTSCRIPT-NS-HASH*) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \POSTSCRIPT.FRACTION MACRO ((STREAM STRING) - - (* ;; "Handle printing of a fraction, given a string that's the name of the PS function (defined in \POSTSCRIPT.JOB.SETUP) that prints it. You must put spaces around the name.") - - (POSTSCRIPT.SHOWACCUM STREAM) - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch POSTSCRIPTRIGHTMARGIN - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch POSTSCRIPTX - of IMAGEDATA) - CHARWID] - [COND - ((NOT (ffetch POSTSCRIPTCHARSTOSHOW of - IMAGEDATA)) - (COND - ((ffetch POSTSCRIPTPENDINGXFORM of - IMAGEDATA) - (\SETXFORM.PSC STREAM IMAGEDATA))) - (COND - ((ffetch POSTSCRIPTFONTCHANGEDFLG - of IMAGEDATA) - (* ; - "If font was changed then switch before printing") - (\SWITCHFONTS.PSC STREAM IMAGEDATA))) - (COND - ((ffetch POSTSCRIPTMOVEFLG of IMAGEDATA) - (* ; "likewise for position") - (\SETPOS.PSC STREAM IMAGEDATA] - (POSTSCRIPT.OUTSTR STREAM STRING))) -) -) - -(RPAQ \POSTSCRIPT.ORIENTATION.MENU - (create MENU ITEMS _ '(("Landscape" T "Print this file/document/image in Landscape Orientation" - ) - ("Portrait" 'NIL - "Print this file/document/image in Portrait Orientation")) - TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _ - (create POSITION XCOORD _ -1 YCOORD _ 0) - CHANGEOFFSETFLG _ 'Y)) - -(RPAQ \POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS _ '(("Ask" 'ASK - "Always ask whether to print in Landscape or Portrait Orientation" - ) - ("Landscape" T - "Default printing to Landscape Orientation" - ) - ("Portrait" 'NIL - "Default printing to Portrait Orientation" - )) - TITLE _ "Default Orientation" CENTERFLG _ T)) - -(RPAQ PS.BITMAPARRAY (READARRAY-FROM-LIST 16 (QUOTE BYTE) 0 (QUOTE (48 49 50 51 52 53 54 55 56 57 65 -66 67 68 69 70 NIL)))) - - -(RPAQQ \POSTSCRIPT.JOB.SETUP - ("/bdef {bind def} bind def" "/ldef {load def} bdef" "/S /show ldef" "/M /moveto ldef" - "/DR {transform round exch round exch itransform} bdef" - "/L {gsave newpath setlinewidth 0 setlinecap" - " M lineto currentpoint stroke grestore M} bdef" - "/L1 {gsave newpath 0 setdash setgray setlinewidth 0 setlinecap" - " M lineto currentpoint stroke grestore M} bdef" - "/F {findfont exch scalefont setfont} bdef" - "/CLP {newpath M dup 0 rlineto exch 0 exch rlineto" - " neg 0 rlineto closepath clip newpath} bdef" - "/R {gsave setgray newpath M dup 0 rlineto exch 0 exch" - " rlineto neg 0 rlineto closepath eofill grestore} bdef" "/ellipsedict 9 dict def" - "ellipsedict /mtrx matrix put" "/ellipse" " { ellipsedict begin" " /endangle exch def" - " /startangle exch def" " /orientation exch def" " /minorrad exch def" - " /majorrad exch def" " /y exch def" " /x exch def" - " /savematrix mtrx currentmatrix def" " x y translate" " orientation rotate" - " majorrad minorrad scale" " 0 0 1 startangle endangle arc" " savematrix setmatrix" - " end } bdef" "/concatprocs" " {/proc2 exch cvlit def" " /proc1 exch cvlit def" - " /newproc proc1 length proc2 length add array def" " newproc 0 proc1 putinterval" - " newproc proc1 length proc2 putinterval" " newproc cvx" " } bdef" - "/resmatrix matrix def" "/findresolution" " {72 0 resmatrix defaultmatrix dtransform" - " /yres exch def /xres exch def" " xres dup mul yres dup mul add sqrt" " } bdef" - "/thebitimage" " {/maskp exch def" " /bihgt exch def" " /biwid exch def" - " /byte 1 string def" " /strbufl biwid 8 div ceiling cvi def" - " /strbuf strbufl string def" - " maskp not{{1 exch sub} currenttransfer concatprocs settransfer} if" " biwid bihgt" - " maskp { true } { 1 } ifelse" " [biwid 0 0 bihgt 0 0]" " {/col 0 def" - " {currentfile byte readhexstring pop 0 get" " dup 16#B2 eq {pop" - " currentfile byte readhexstring pop 0 get 1 add" - " currentfile byte readhexstring pop pop /nbyte byte 0 get def" - " { strbuf col nbyte put /col col 1 add def} repeat}" - " {dup 16#B3 eq {pop /col col" " currentfile byte readhexstring pop" - " 0 get add 1 add def}" " {16#B4 eq {currentfile byte readhexstring pop pop} if" - " strbuf col byte 0 get put /col col 1 add def} ifelse" " } ifelse" - " col strbufl ge { exit } if } loop" " strbuf }" - " maskp { imagemask } { image } ifelse" " } bdef" "/setuserscreendict 22 dict def" - "setuserscreendict begin" " /tempctm matrix def" " /temprot matrix def" - " /tempscale matrix def" "end" "/setuserscreen" " {setuserscreendict begin" - " /spotfunction exch def" " /screenangle exch def" " /cellsize exch def" - " /m tempctm currentmatrix def" " /rm screenangle temprot rotate def" - " /sm cellsize dup tempscale scale def" - " sm rm m m concatmatrix m concatmatrix pop" - " 1 0 m dtransform /y1 exch def /x1 exch def" - " /veclength x1 dup mul y1 dup mul add sqrt def" - " /frequency findresolution veclength div def" " /newscreenangle y1 x1 atan def" - " m 2 get m 1 get mul m 0 get m 3 get mul sub" - " 0 gt { { neg } /spotfunction load concatprocs" - " /spotfunction exch def } if" - " frequency newscreenangle /spotfunction load setscreen" " end" " } bdef" - "/setpatterndict 18 dict def" "setpatterndict begin" " /bitison" - " {/ybit exch def /xbit exch def" - " /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def" - " /mask 1 7 xbit 8 mod sub bitshift def" " bytevalue mask and 0 ne" " } bdef" - "end" "/bitpatternspotfunction" " {setpatterndict begin" " /y exch def /x exch def" - " /xindex x 1 add 2 div bpside mul 1 sub cvi def" - " /yindex y 1 add 2 div bpside mul 1 sub cvi def" " xindex yindex bitison" - " {/onbits onbits 1 add def 1}" " {/offbits offbits 1 add def 0} ifelse" " end" - " } bdef" "/setpattern" " {setpatterndict begin" " /cellsz exch def" - " /angle exch def" " /bwidth exch def" " /bpside exch def" " /bstring exch def" - " /onbits 0 def /offbits 0 def" - " cellsz angle /bitpatternspotfunction load setuserscreen" " {} settransfer" - " offbits offbits onbits add div setgray" " end" " } bdef" - "%% - - - - - Fraction-setting code, to support NS fonts better - - - - -" - "/fractiondict 20 dict def" "/fractionshow " "{ fractiondict begin" "/denom exch def " - "/num exch def " "/regfont currentfont def" - "/fractfont currentfont [.65 0 0 .6 0 0] makefont def " "gsave newpath 0 0 moveto " - "(1) true charpath flattenpath pathbbox " "/height exch def pop pop pop" " grestore" - "0 .4 height mul rmoveto" "fractfont setfont num show" - "0 .4 height mul neg rmoveto regfont setfont (\244) show" - "fractfont setfont denom show regfont setfont end } bdef" - "/f14 { (1) (4) fractionshow } bdef" "/f12 { (1) (2) fractionshow } bdef" - "/f34 { (3) (4) fractionshow } bdef" "/f18 { (1) (8) fractionshow } bdef" - "/f38 { (3) (8) fractionshow } bdef" "/f58 { (5) (8) fractionshow } bdef" - "/f78 { (7) (8) fractionshow } bdef" "/f13 { (1) (3) fractionshow } bdef" - "/f23 { (2) (3) fractionshow } bdef" "/bboxdict 20 dict def" - "/bboxchk { bboxdict begin" "/regfont currentfont def" - "/chkfont currentfont [1.25 0 0 1.25 0 0] makefont def " "gsave newpath 0 0 moveto " - "(\161) true charpath flattenpath pathbbox " "/height exch def pop pop pop " - " grestore " " currentpoint " " .2 height mul .3 height mul rmoveto" - "chkfont setfont (\063) show" " moveto" " regfont setfont" "(\161) show end } bdef" - "/rencdict 15 dict def" "/encodefont { rencdict begin" "/newname exch def" - "/oldfont exch def" "/newcodes [" "8#001 /Aacute" "8#002 /Acircumflex" - "8#003 /Adieresis" "8#004 /Agrave" "8#005 /Aring" "8#006 /Atilde" "8#007 /Ccedilla" - "8#010 /Eacute" "8#011 /Ecircumflex" "8#012 /Edieresis" "8#013 /Egrave" "8#014 /Iacute" - "8#015 /Icircumflex" "8#016 /Idieresis" "8#017 /Igrave" "8#020 /Ntilde" "8#021 /Oacute" - "8#022 /Ocircumflex" "8#023 /Odieresis" "8#024 /Ograve" "8#025 /Otilde" "8#026 /Scaron" - "8#027 /Uacute" "8#030 /Ucircumflex" "8#031 /Udieresis" "8#032 /Ugrave" - "8#033 /Ydieresis" "8#034 /Zcaron" "8#177 /periodinferior" "8#201 /aacute" - "8#202 /acircumflex" "8#203 /adieresis" "8#204 /agrave" "8#205 /aring" "8#206 /atilde" - "8#207 /ccedilla" "8#210 /eacute" "8#211 /ecircumflex" "8#212 /edieresis" - "8#213 /egrave" "8#214 /iacute" "8#215 /icircumflex" "8#216 /idieresis" "8#217 /igrave" - "8#220 /ntilde" "8#221 /oacute" "8#222 /ocircumflex" "8#223 /odieresis" "8#224 /ograve" - "8#225 /otilde" "8#226 /scaron" "8#227 /uacute" "8#230 /ucircumflex" "8#231 /udieresis" - "8#232 /ugrave" "8#233 /ydieresis" "8#234 /zcaron" "8#235 /Eth" "8#236 /eth" - "8#237 /Thorn" "8#240 /thorn" " ] def" - "/olddict oldfont findfont def /newfont olddict maxlength dict def" - "olddict { exch dup /FID ne { dup /Encoding eq" - "{ exch dup length array copy newfont 3 1 roll put }" - "{ exch newfont 3 1 roll put } ifelse }" " { pop pop } ifelse } forall" - "newfont /FontName newname put" "newcodes aload pop" - "newcodes length 2 idiv { newfont /Encoding get 3 1 roll put } repeat " - "newname newfont definefont pop end } def" " /accentdict 10 dict def " - " /accentor { accentdict begin /scaler exch def /delta exch def " - "/unders exch def /accents exch def /mainch exch def /scrt (X) def" - " /w1 mainch stringwidth pop def " " currentpoint mainch show currentpoint 4 2 roll " - "accents { /ch exch def 2 copy moveto " " scrt 0 ch put " - " /w2 scrt stringwidth pop def " - " w1 w2 sub 2 div delta rmoveto scrt show " - " /delta delta 150 scaler mul 9 div add def" " } forall " - "unders { /ch exch def 2 copy moveto " " scrt 0 ch put " - " /w2 scrt stringwidth pop def " - " ch 46 eq { w1 w2 sub 2 div -175 scaler mul 9 div rmoveto scrt show 0 175 rmoveto }" - " { w1 w2 sub 2 div 0 rmoveto scrt show } ifelse " " } forall " - " pop pop moveto end } def " "%%%%EndProlog" "%%%%BeginSetup")) - -(RPAQQ SlopeMenuItems ((Italic 'ITALIC "This is an Italic Slope font") - (Regular 'REGULAR "This is a Regular Slope font"))) - -(RPAQQ WeightMenuItems ((Bold 'BOLD "This is a Bold Weight font") - (Medium 'MEDIUM "This is a Medium Weight font") - (Light 'LIGHT "This is a Light Weight font"))) - -(ADDTOVAR BackgroundMenuCommands - ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE (MENU - \POSTSCRIPT.ORIENTATION.OPTIONS.MENU - )) - "Select the default Orientation for PostScript output" - (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) - "Always ask whether to print in Landscape or Portrait Orientation") - ("Landscape" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE T) - "Default printing to Landscape Orientation") - ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE NIL) - "Default printing to Portrait Orientation")))) - -(RPAQQ BackgroundMenu NIL) -(DECLARE%: EVAL@COMPILE - -(RPAQQ GOLDEN.RATIO 1.618034) - -(RPAQQ \PS.SCALE0 100) - -(RPAQQ \PS.TEMPARRAYLEN 20) - - -(CONSTANTS (GOLDEN.RATIO 1.618034) - (\PS.SCALE0 100) - (\PS.TEMPARRAYLEN 20)) -) - -(RPAQ? POSTSCRIPT.BITMAP.SCALE 1) - -(RPAQ? POSTSCRIPT.EOL 'CR) - -(RPAQ? POSTSCRIPT.IMAGESIZEFACTOR 1) - -(RPAQ? POSTSCRIPT.PREFER.LANDSCAPE NIL) - -(RPAQ? POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) - -(RPAQ? POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800)) - -(RPAQ? POSTSCRIPT.TEXTURE.SCALE 4) - -(RPAQ? POSTSCRIPTFONTDIRECTORIES (LIST (COND ((EQ (MACHINETYPE) - 'MAIKO) - "{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/") - (T "{DSK}POSTSCRIPT>")))) - -(RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72) - -(ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) - (HELVETICAD . HELVETICA) - (TIMESROMAN . TIMES) - (TIMESROMAND . TIMES) - (COURIER . COURIER) - (GACHA . COURIER) - (CLASSIC . NEWCENTURYSCHLBK) - (MODERN . HELVETICA) - (CREAM . HELVETICA) - (TERMINAL . COURIER) - (LOGO . HELVETICA) - (OPTIMA . PALATINO) - (TITAN . COURIER)) - -(ADDTOVAR PRINTERTYPES ((POSTSCRIPT) - (CANPRINT (POSTSCRIPT)) - (STATUS TRUE) - (PROPERTIES NILL) - (SEND UnixPrint) - (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) - (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION - TITLE)))) - -(ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) - (EXTENSION (PS PSC PSF)) - (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT)))) - -(ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) - (FONTCREATE POSTSCRIPT.FONTCREATE) - (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) - (CREATECHARSET \CREATECHARSET.PSC))) - -(RPAQ? POSTSCRIPT.PAGETYPE 'LETTER) - -(APPENDTOVAR POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) - (-0.1 -0.1 8.7 11.2)) - (LEGAL (0 0 8.5 14) - (-0.1 -0.1 8.7 14.2)) - (NOTE (0 0 8.5 11) - (-0.1 -0.1 8.7 11.2))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST - POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE - POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE - \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(POSTSCRIPT.INIT) -) - -(PUTPROPS POSTSCRIPTSTREAM FILETYPE :TCOMPL) - -(PUTPROPS POSTSCRIPTSTREAM MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND) -) -(PUTPROPS POSTSCRIPTSTREAM COPYRIGHT ( -"Venue This program or documentation contains confidential information and trade secrets of Venue. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Venue. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets" - 1989 1990 1991 1992 1993 1994 1995)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (22277 25973 (POSTSCRIPT.INIT 22287 . 25971)) (27017 61801 (PSCFONT.READFONT 27027 . -28935) (PSCFONT.SPELLFILE 28937 . 29515) (PSCFONT.COERCEFILE 29517 . 31089) ( -PSCFONTFROMCACHE.SPELLFILE 31091 . 32076) (PSCFONTFROMCACHE.COERCEFILE 32078 . 33730) ( -PSCFONT.WRITEFONT 33732 . 34747) (READ-AFM-FILE 34749 . 40620) (CONVERT-AFM-FILES 40622 . 41834) ( -POSTSCRIPT.GETFONTID 41836 . 43231) (POSTSCRIPT.FONTCREATE 43233 . 55632) ( -\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 55634 . 58031) (POSTSCRIPT.FONTSAVAILABLE 58033 . 61799)) (62468 -70447 (OPENPOSTSCRIPTSTREAM 62478 . 70113) (CLOSEPOSTSCRIPTSTREAM 70115 . 70445)) (70492 76313 ( -POSTSCRIPT.HARDCOPYW 70502 . 73851) (POSTSCRIPT.TEDIT 73853 . 74333) (POSTSCRIPT.TEXT 74335 . 74626) ( -POSTSCRIPTFILEP 74628 . 75264) (MAKEEPSFILE 75266 . 76311)) (76314 120000 (POSTSCRIPT.BITMAPSCALE -76324 . 78660) (POSTSCRIPT.CLOSESTRING 78662 . 79196) (POSTSCRIPT.ENDPAGE 79198 . 80069) ( -POSTSCRIPT.OUTSTR 80071 . 81092) (POSTSCRIPT.PUTBITMAPBYTES 81094 . 89770) (POSTSCRIPT.PUTCOMMAND -89772 . 90896) (POSTSCRIPT.SET-FAKE-LANDSCAPE 90898 . 96346) (POSTSCRIPT.SHOWACCUM 96348 . 98606) ( -POSTSCRIPT.STARTPAGE 98608 . 100263) (\POSTSCRIPTTAB 100265 . 101136) (\PS.BOUTFIXP 101138 . 102488) ( -\PS.SCALEHACK 102490 . 105319) (\PS.SCALEREGION 105321 . 105881) (\SCALEDBITBLT.PSC 105883 . 109727) ( -\SETPOS.PSC 109729 . 110191) (\SETXFORM.PSC 110193 . 112012) (\STRINGWIDTH.PSC 112014 . 112468) ( -\SWITCHFONTS.PSC 112470 . 118627) (\TERPRI.PSC 118629 . 119998)) (120035 175755 (\BITBLT.PSC 120045 . -120598) (\BLTSHADE.PSC 120600 . 124882) (\CHARWIDTH.PSC 124884 . 125651) (\CREATECHARSET.PSC 125653 . -127351) (\DRAWARC.PSC 127353 . 129833) (\DRAWCIRCLE.PSC 129835 . 132244) (\DRAWCURVE.PSC 132246 . -136267) (\DRAWELLIPSE.PSC 136269 . 138746) (\DRAWLINE.PSC 138748 . 141098) (\DRAWPOINT.PSC 141100 . -141688) (\DRAWPOLYGON.PSC 141690 . 144804) (\DSPBOTTOMMARGIN.PSC 144806 . 145371) ( -\DSPCLIPPINGREGION.PSC 145373 . 146816) (\DSPCOLOR.PSC 146818 . 147659) (\DSPFONT.PSC 147661 . 151871) - (\DSPLEFTMARGIN.PSC 151873 . 152442) (\DSPLINEFEED.PSC 152444 . 153020) (\DSPPUSHSTATE.PSC 153022 . -154785) (\DSPPOPSTATE.PSC 154787 . 157296) (\DSPRESET.PSC 157298 . 157944) (\DSPRIGHTMARGIN.PSC 157946 - . 158518) (\DSPROTATE.PSC 158520 . 159543) (\DSPSCALE.PSC 159545 . 160476) (\DSPSCALE2.PSC 160478 . -161297) (\DSPSPACEFACTOR.PSC 161299 . 162271) (\DSPTOPMARGIN.PSC 162273 . 162990) (\DSPTRANSLATE.PSC -162992 . 165566) (\DSPXPOSITION.PSC 165568 . 166167) (\DSPYPOSITION.PSC 166169 . 166741) ( -\FILLCIRCLE.PSC 166743 . 169389) (\FILLPOLYGON.PSC 169391 . 173307) (\FIXLINELENGTH.PSC 173309 . -174803) (\MOVETO.PSC 174805 . 175556) (\NEWPAGE.PSC 175558 . 175753)) (175811 198963 ( -\POSTSCRIPT.CHANGECHARSET 175821 . 176625) (\POSTSCRIPT.OUTCHARFN 176627 . 189484) ( -\POSTSCRIPT.PRINTSLUG 189486 . 191453) (\POSTSCRIPT.SPECIALOUTCHARFN 191455 . 193887) (\UPDATE.PSC -193889 . 195112) (\POSTSCRIPT.ACCENTFN 195114 . 196056) (\POSTSCRIPT.ACCENTPAIR 196058 . 198961)) ( -199061 200706 (\PSC.SPACEDISP 199071 . 199350) (\PSC.SPACEWID 199352 . 199971) (\PSC.SYMBOLS 199973 . -200704)) (200815 203806 (\POSTSCRIPT.NSHASH 200825 . 203804))))) -STOP diff --git a/library/POSTSCRIPTSTREAM.~2~ b/library/POSTSCRIPTSTREAM.~2~ deleted file mode 100644 index 53bc04a7..00000000 --- a/library/POSTSCRIPTSTREAM.~2~ +++ /dev/null @@ -1,2591 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "29-Apr-98 08:47:55" {DSK}medley2.0>library>POSTSCRIPTSTREAM.;80 252396 changes to%: (FNS POSTSCRIPT.BITMAPSCALE) previous date%: "17-Jun-97 21:19:53" {DSK}medley2.0>library>POSTSCRIPTSTREAM.;79) (* ; " Copyright (c) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998 by Venue This program or documentation contains confidential information and trade secrets of Venue. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Venue. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved. ") (PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS) (RPAQQ POSTSCRIPTSTREAMCOMS [ (* ;; "PostScript printer support for Medley") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FONTID PSCFONT \POSTSCRIPTDATA POSTSCRIPTXFORM)) (INITRECORDS \POSTSCRIPTDATA) (FNS POSTSCRIPT.INIT) (ADDVARS (DEFAULTFILETYPELIST (PS . TEXT) (PSC . TEXT) (PSF . BINARY) (PSCFONT . BINARY) (POSTSCRIPT . TEXT)) (*DISPLAY-FONT-NAME-MAP* (AVANTGARDE-BOOK . AB) (AVANTGARDE-DEMI . AD) (BECKMAN . BM) (BOOKMAN-LIGHT . BL) (BOOKMAN-DEMI . BD) (COURIER . CO) (HELVETICA-NARROW . HN) (NEWCENTURYSCHLBK . NC) (PALATINO . PA) (TIMES . TS) (ZAPFCHANCERY-MEDIUM . ZM) (ZAPFCHANCERY . ZC) (ZAPFDINGBATS . ZD))) (* ;; "Font-reading code") (FNS PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.COERCEFILE PSCFONTFROMCACHE.SPELLFILE PSCFONTFROMCACHE.COERCEFILE PSCFONT.WRITEFONT READ-AFM-FILE CONVERT-AFM-FILES POSTSCRIPT.GETFONTID POSTSCRIPT.FONTCREATE \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS POSTSCRIPT.FONTSAVAILABLE) (COMS (* ;; "Until macro in FONT is exported") (MACROS \FSETCHARWIDTH)) (FNS OPENPOSTSCRIPTSTREAM CLOSEPOSTSCRIPTSTREAM) (INITVARS (*POSTSCRIPT-FILE-TYPE* 'BINARY)) (FNS POSTSCRIPT.HARDCOPYW POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP MAKEEPSFILE) (FNS POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.ENDPAGE POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SET-FAKE-LANDSCAPE POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK \PS.SCALEREGION \SCALEDBITBLT.PSC \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC \SWITCHFONTS.PSC \TERPRI.PSC) (* ;; "DIG operations: ") (FNS \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \CREATECHARSET.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPCOLOR.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPPUSHSTATE.PSC \DSPPOPSTATE.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC \DSPSCALE.PSC \DSPSCALE2.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \FIXLINELENGTH.PSC \MOVETO.PSC \NEWPAGE.PSC) (COMS (* ;; "Character-output, plus special-cases:") (FNS \POSTSCRIPT.CHANGECHARSET \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PRINTSLUG \POSTSCRIPT.SPECIALOUTCHARFN \UPDATE.PSC \POSTSCRIPT.ACCENTFN \POSTSCRIPT.ACCENTPAIR) (* ;;  "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions") (FNS \PSC.SPACEDISP \PSC.SPACEWID \PSC.SYMBOLS) (* ;;  "The mapping of NS characters to Postscript renderings, both as an AList and as a hashtable") (FNS \POSTSCRIPT.NSHASH) (VARS (*POSTSCRIPT-UNACCENTED-FONTS* '(Dancer ZapfDingbats "Dancer" "ZapfDingbats")) *POSTSCRIPT-NS-TRANSLATIONS*) (GLOBALVARS *POSTSCRIPT-NS-HASH*)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \POSTSCRIPT.FRACTION)) (VARS (\POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T "Print this file/document/image in Landscape Orientation" ) ("Portrait" 'NIL "Print this file/document/image in Portrait Orientation" )) TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) CHANGEOFFSETFLG _ 'Y)) (\POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS _ '(("Ask" 'ASK "Always ask whether to print in Landscape or Portrait Orientation" ) ("Landscape" T "Default printing to Landscape Orientation" ) ("Portrait" 'NIL "Default printing to Portrait Orientation" )) TITLE _ "Default Orientation" CENTERFLG _ T)) PS.BITMAPARRAY \POSTSCRIPT.JOB.SETUP SlopeMenuItems WeightMenuItems) [ADDVARS (BackgroundMenuCommands ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE (MENU \POSTSCRIPT.ORIENTATION.OPTIONS.MENU )) "Select the default Orientation for PostScript output" (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) "Always ask whether to print in Landscape or Portrait Orientation" ) ("Landscape" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE T) "Default printing to Landscape Orientation" ) ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE NIL) "Default printing to Portrait Orientation" ] (VARS (BackgroundMenu NIL)) (CONSTANTS (GOLDEN.RATIO 1.618034) (\PS.SCALE0 100) (\PS.TEMPARRAYLEN 20)) (INITVARS (POSTSCRIPT.BITMAP.SCALE 1) (POSTSCRIPT.EOL 'CR) (POSTSCRIPT.IMAGESIZEFACTOR 1) (POSTSCRIPT.PREFER.LANDSCAPE NIL) (POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) (POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800)) (POSTSCRIPT.TEXTURE.SCALE 4) [POSTSCRIPTFONTDIRECTORIES (LIST (COND ((EQ (MACHINETYPE) 'MAIKO) "{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/") (T "{DSK}POSTSCRIPT>"] (\POSTSCRIPT.MAX.WILD.FONTSIZE 72)) [COMS (FNS POSTSCRIPTSEND) (ADDVARS (PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPTSEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (HELVETICAD . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . NEWCENTURYSCHLBK) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (OPTIMA . PALATINO) (TITAN . COURIER)) [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC PSF)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT] (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET \CREATECHARSET.PSC] (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER)) (* ;; "NIL means initial clipping is same as paper size. Don't know why the other regions were specified--rmk") [APPENDVARS (POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2)) (LEGAL (0 0 8.5 14) NIL (-0.1 -0.1 8.7 14.2)) (NOTE (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2] (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (POSTSCRIPT.INIT))) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) POSTSCRIPTSTREAM) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA POSTSCRIPT.PUTCOMMAND ]) (* ;; "PostScript printer support for Medley") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR)) (RECORD PSCFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS)) (DATATYPE \POSTSCRIPTDATA ((POSTSCRIPTACCENTED FLAG) (* ;  "T if we're to do NS-to-PS translations on characters in the current font.") POSTSCRIPTFONT (* ;  "The fontdescriptor of the current font") POSTSCRIPTX (* ; "The current X") POSTSCRIPTY (* ; "... and Y") POSTSCRIPTLEFTMARGIN (* ; "The margins") POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLINESPACING (* ; "Line to line spacing") POSTSCRIPTCOLOR (* ;  "Color (or grey shade) in effect; 0.0=black, 1.0=white.") POSTSCRIPTSCALE (* ; "Scale of the stream") POSTSCRIPTOPERATION (* ;  "Default operation (PAINT, REPLACE, ...)") POSTSCRIPTCLIPPINGREGION (* ;  "The current region available to be written into") POSTSCRIPTPAGENUM (* ; "Current page number") POSTSCRIPTHEADING (* ; "The heading") POSTSCRIPTHEADINGFONT (* ; "Font for the heading") POSTSCRIPTSPACEFACTOR (* ;  "Expansion factor for spaces (see DSPSPACEFACTOR)") POSTSCRIPTSPACEWIDTH (* ;  "The width of a space in the current font") POSTSCRIPTLANDSCAPE (* ;  "non-NIL for paper in 'landscape' mode") POSTSCRIPTCHARSTOSHOW (* ;  "non-NIL if the string (PostScript-type string) of chars has already been started") POSTSCRIPTFONTCHANGEDFLG (* ; "Font has changed") POSTSCRIPTMOVEFLG (* ; "Need to move") POSTSCRIPTWIDTHS (* ;  "The widths vector of the current font") POSTSCRIPTTRANSX (* ; "Translation in X") POSTSCRIPTTRANSY (* ; "... and Y") POSTSCRIPTPENDINGXFORM (* ;  "A userspace to devicespace transform is pending") POSTSCRIPTPAGEREGION (* ; "The whole page") POSTSCRIPTPAGEBLANK (* ; "This page is blank flag") POSTSCRIPTSCALEHACK (* ;  "For \PS.SCALEHACK since DSPSCALE doesn't change the scale of the stream") POSTSCRIPTTEMPARRAY (* ;  "For converting FIXP to string of digit chars") POSTSCRIPTXFORMSTACK (* ; "The stack of transformations. DSPPUSHSTATE pushes one onto this, DSPPOPSTATE uses it to reset values.") POSTSCRIPTROTATION (* ;  "Rotation value currently in effect.") POSTSCRIPTPENDINGROTATION (* ;  "Rotation to take effect at next SETXFORM.") POSTSCRIPTFONTSUSED (* ; "List of FONTIDs of the fonts that've been used before. This is used to control the re-encoding of fonts for accented-character rendering.") (POSTSCRIPTNSCHARSET BYTE) (* ;  "Current NSCHARSET--widths are in POSTSCRIPTWIDTHS") (POSTSCRIPTNATURALSPACEWIDTH WORD) (* ;  "Width of the space in the current font, used to compute the scaled space width.") ) POSTSCRIPTX _ 0 POSTSCRIPTY _ 0 POSTSCRIPTTRANSX _ 0 POSTSCRIPTTRANSY _ 0 POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0 POSTSCRIPTSCALEHACK _ 1 POSTSCRIPTTEMPARRAY _ (ARRAY \PS.TEMPARRAYLEN 'BYTE 0 0) POSTSCRIPTROTATION _ 0 POSTSCRIPTCOLOR _ 0.0) (RECORD POSTSCRIPTXFORM ( (* ;; "Holds the transformation state as saved by DSPPUSHSTATE. Used by DSPPOPSTATE to restore the tranformation state.") PSXCLIP (* ; "Clipping region") PSXPAGE (* ; "Page region") PSXX (* ; "X position?") PSXY (* ; "Y position?") PSXLEFT (* ; "Left margin") PSXRIGHT (* ; "Right margin") PSXTOP (* ; "Top margin") PSXBOTTOM (* ; "Bottom Margin") PSXTRANX (* ; "X-translation in effect") PSXTRANY (* ; "Y-translation in effect") PSXLAND (* ; "Landscape?") PSXXFORMPEND (* ; "Are there transforms pending? ") )) ) (/DECLAREDATATYPE '\POSTSCRIPTDATA '(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 BYTE WORD) '((\POSTSCRIPTDATA 0 (FLAGBITS . 0)) (\POSTSCRIPTDATA 0 POINTER) (\POSTSCRIPTDATA 2 POINTER) (\POSTSCRIPTDATA 4 POINTER) (\POSTSCRIPTDATA 6 POINTER) (\POSTSCRIPTDATA 8 POINTER) (\POSTSCRIPTDATA 10 POINTER) (\POSTSCRIPTDATA 12 POINTER) (\POSTSCRIPTDATA 14 POINTER) (\POSTSCRIPTDATA 16 POINTER) (\POSTSCRIPTDATA 18 POINTER) (\POSTSCRIPTDATA 20 POINTER) (\POSTSCRIPTDATA 22 POINTER) (\POSTSCRIPTDATA 24 POINTER) (\POSTSCRIPTDATA 26 POINTER) (\POSTSCRIPTDATA 28 POINTER) (\POSTSCRIPTDATA 30 POINTER) (\POSTSCRIPTDATA 32 POINTER) (\POSTSCRIPTDATA 34 POINTER) (\POSTSCRIPTDATA 36 POINTER) (\POSTSCRIPTDATA 38 POINTER) (\POSTSCRIPTDATA 40 POINTER) (\POSTSCRIPTDATA 42 POINTER) (\POSTSCRIPTDATA 44 POINTER) (\POSTSCRIPTDATA 46 POINTER) (\POSTSCRIPTDATA 48 POINTER) (\POSTSCRIPTDATA 50 POINTER) (\POSTSCRIPTDATA 52 POINTER) (\POSTSCRIPTDATA 54 POINTER) (\POSTSCRIPTDATA 56 POINTER) (\POSTSCRIPTDATA 58 POINTER) (\POSTSCRIPTDATA 60 POINTER) (\POSTSCRIPTDATA 62 POINTER) (\POSTSCRIPTDATA 64 POINTER) (\POSTSCRIPTDATA 64 (BITS . 7)) (\POSTSCRIPTDATA 66 (BITS . 15))) '68) ) (/DECLAREDATATYPE '\POSTSCRIPTDATA '(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 BYTE WORD) '((\POSTSCRIPTDATA 0 (FLAGBITS . 0)) (\POSTSCRIPTDATA 0 POINTER) (\POSTSCRIPTDATA 2 POINTER) (\POSTSCRIPTDATA 4 POINTER) (\POSTSCRIPTDATA 6 POINTER) (\POSTSCRIPTDATA 8 POINTER) (\POSTSCRIPTDATA 10 POINTER) (\POSTSCRIPTDATA 12 POINTER) (\POSTSCRIPTDATA 14 POINTER) (\POSTSCRIPTDATA 16 POINTER) (\POSTSCRIPTDATA 18 POINTER) (\POSTSCRIPTDATA 20 POINTER) (\POSTSCRIPTDATA 22 POINTER) (\POSTSCRIPTDATA 24 POINTER) (\POSTSCRIPTDATA 26 POINTER) (\POSTSCRIPTDATA 28 POINTER) (\POSTSCRIPTDATA 30 POINTER) (\POSTSCRIPTDATA 32 POINTER) (\POSTSCRIPTDATA 34 POINTER) (\POSTSCRIPTDATA 36 POINTER) (\POSTSCRIPTDATA 38 POINTER) (\POSTSCRIPTDATA 40 POINTER) (\POSTSCRIPTDATA 42 POINTER) (\POSTSCRIPTDATA 44 POINTER) (\POSTSCRIPTDATA 46 POINTER) (\POSTSCRIPTDATA 48 POINTER) (\POSTSCRIPTDATA 50 POINTER) (\POSTSCRIPTDATA 52 POINTER) (\POSTSCRIPTDATA 54 POINTER) (\POSTSCRIPTDATA 56 POINTER) (\POSTSCRIPTDATA 58 POINTER) (\POSTSCRIPTDATA 60 POINTER) (\POSTSCRIPTDATA 62 POINTER) (\POSTSCRIPTDATA 64 POINTER) (\POSTSCRIPTDATA 64 (BITS . 7)) (\POSTSCRIPTDATA 66 (BITS . 15))) '68) (DEFINEQ (POSTSCRIPT.INIT -(LAMBDA NIL (* ; "Edited 4-Jan-95 10:46 by jds") (* ; "Edited 4-Feb-93 21:08 by jds") (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE)) (* ;; "Add POSTSCRIPT font descriptions to the active font profile.") (MAPC (CL:REMOVE-DUPLICATES (NCONC (for FD in FONTDEFS join (for FP in (CDR (ASSOC (QUOTE FONTPROFILE) (CDR FD))) collect (CAR FP))) (QUOTE (FONT7 FONT6 FONT5 FONT4 FONT3 FONT2 FONT1 BOLDFONT LITTLEFONT BIGFONT PRETTYCOMFONT COMMENTFONT USERFONT SYSTEMFONT CLISPFONT LAMBDAFONT CHANGEFONT DEFAULTFONT)))) (FUNCTION (LAMBDA (CLASS) (LET (COPYFD OLDPSCFD) (if (BOUNDP CLASS) then (SETQ CLASS (EVALV CLASS)) (if (TYPEP CLASS (QUOTE FONTCLASS)) then (SETQ COPYFD (OR (fetch (FONTCLASS INTERPRESSFD) of CLASS) (fetch (FONTCLASS PRESSFD) of CLASS) (fetch (FONTCLASS DISPLAYFD) of CLASS))) (if (SETQ OLDPSCFD (ASSOC (QUOTE POSTSCRIPT) (fetch (FONTCLASS OTHERFDS) of CLASS))) then (if (NOT (CDR OLDPSCFD)) then (RPLACD OLDPSCFD (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD)))) else (push (fetch (FONTCLASS OTHERFDS) of CLASS) (CONS (QUOTE POSTSCRIPT) (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD))))))))))) (FOR FD IN FONTDEFS DO (FOR FP IN (CDR (ASSOC (QUOTE FONTPROFILE) (CDR FD))) DO (COND ((ASSOC (QUOTE POSTSCRIPT) (CL:NTHCDR 5 FP)) (* ;; "There's already a postscript spec, so leave it be.")) (T (NCONC1 FP (BQUOTE (POSTSCRIPT (\, (OR (CL:FIFTH FP) (CL:FOURTH FP) (CL:THIRD FP)))))))))) (* ;; "Eliminate any existing postscript fonts, to start with a clean slate if reinitializing.") (FOR FD IN (FONTSAVAILABLE (QUOTE *) (QUOTE *) (QUOTE *) (QUOTE *) (QUOTE POSTSCRIPT)) DO (APPLY (FUNCTION SETFONTDESCRIPTOR) FD)) (SETQ POSTSCRIPTFONTCACHE NIL) (SETQ \POSTSCRIPT.CHARTYPE (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT T)) (* ;; "\POSTSCRIPT.OUTCHARFN uses this array to quickly determine whether a character needs any special processing -- T means yes") (for x from (CHARCODE SP) to 126 unless (FMEMB x (CHARCODE (%( %) \))) do (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE x) NIL)) (SETQ \POSTSCRIPTIMAGEOPS (create IMAGEOPS IMAGETYPE _ (QUOTE POSTSCRIPT) IMCLOSEFN _ (FUNCTION CLOSEPOSTSCRIPTSTREAM) IMXPOSITION _ (FUNCTION \DSPXPOSITION.PSC) IMYPOSITION _ (FUNCTION \DSPYPOSITION.PSC) IMMOVETO _ (FUNCTION \MOVETO.PSC) IMFONT _ (FUNCTION \DSPFONT.PSC) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.PSC) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.PSC) IMLINEFEED _ (FUNCTION \DSPLINEFEED.PSC) IMDRAWLINE _ (FUNCTION \DRAWLINE.PSC) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.PSC) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.PSC) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.PSC) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.PSC) IMBLTSHADE _ (FUNCTION \BLTSHADE.PSC) IMBITBLT _ (FUNCTION \BITBLT.PSC) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.PSC) IMNEWPAGE _ (FUNCTION \NEWPAGE.PSC) IMSCALE _ (FUNCTION \DSPSCALE.PSC) IMSCALE2 _ (FUNCTION \DSPSCALE2.PSC) IMCOLOR _ (FUNCTION \DSPCOLOR.PSC) IMTERPRI _ (FUNCTION \TERPRI.PSC) IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PSC) IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PSC) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PSC) IMFONTCREATE _ (QUOTE POSTSCRIPT) IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.PSC) IMRESET _ (FUNCTION \DSPRESET.PSC) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.PSC) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.PSC) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.PSC) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.PSC) IMDRAWARC _ (FUNCTION \DRAWARC.PSC) IMROTATE _ (FUNCTION \DSPROTATE.PSC) IMTRANSLATE _ (FUNCTION \DSPTRANSLATE.PSC) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.PSC) IMPUSHSTATE _ (FUNCTION \DSPPUSHSTATE.PSC) IMPOPSTATE _ (FUNCTION \DSPPOPSTATE.PSC))) (SETQ *POSTSCRIPT-NS-HASH* (HARRAY 255)) (\POSTSCRIPT.NSHASH *POSTSCRIPT-NS-TRANSLATIONS*)) -) ) (ADDTOVAR DEFAULTFILETYPELIST (PS . TEXT) (PSC . TEXT) (PSF . BINARY) (PSCFONT . BINARY) (POSTSCRIPT . TEXT)) (ADDTOVAR *DISPLAY-FONT-NAME-MAP* (AVANTGARDE-BOOK . AB) (AVANTGARDE-DEMI . AD) (BECKMAN . BM) (BOOKMAN-LIGHT . BL) (BOOKMAN-DEMI . BD) (COURIER . CO) (HELVETICA-NARROW . HN) (NEWCENTURYSCHLBK . NC) (PALATINO . PA) (TIMES . TS) (ZAPFCHANCERY-MEDIUM . ZM) (ZAPFCHANCERY . ZC) (ZAPFDINGBATS . ZD)) (* ;; "Font-reading code") (DEFINEQ (PSCFONT.READFONT - [LAMBDA (FONTFILENAME) (* ; "Edited 5-Oct-93 17:19 by rmk:") - (* ; "Edited 1-Sep-89 10:55 by jds") - - (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics. First check to see if incore cache as information indexed under the file's name.") - - (LET (FID W [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T] - (PF (create PSCFONT))) - [replace (PSCFONT FID) of PF with (SETQ FID (READ S (FIND-READTABLE "INTERLISP"] - - (* ;; "Read until we hit a 255 byte, marking the end of the font-id section.") - - (CL:DO NIL - ((EQ (BIN S) - 255)) - - (* ;; "Body of the loop is empty, the test does all of the work") - - ) - (replace (PSCFONT IL-FONTID) of PF with (CAR FID)) - (replace (PSCFONT FIRSTCHAR) of PF with (\WIN S)) - (replace (PSCFONT LASTCHAR) of PF with (\WIN S)) - (replace (PSCFONT ASCENT) of PF with (\WIN S)) - (replace (PSCFONT DESCENT) of PF with (\WIN S)) - (replace (PSCFONT WIDTHS) of PF with (SETQ W (ARRAY 256 'SMALLPOSP 0 0))) - (for C from 0 to 255 do (SETA W C (\WIN S))) - (CLOSEF S) - - (* ;; - "PATCH JDS 9/1/89: The afm font reader made fonts too tall. This should fix things pro tem.") - - (replace (PSCFONT ASCENT) of PF with (- 1000 (fetch (PSCFONT DESCENT) - OF PF))) - (PUSH POSTSCRIPTFONTCACHE (CONS (L-CASE (FILENAMEFIELD FONTFILENAME 'NAME)) - (CREATE PSCFONT USING PF))) - PF]) (PSCFONT.SPELLFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 22:15 by rmk:") - (* ; "Edited 5-Oct-92 15:23 by jds") - - (* ;; - "Find the font file for a postscript font. Does the display-name conversion as well, for DOS.") - - (CL:WHEN POSTSCRIPTFONTDIRECTORIES - (\FINDFONTFILE (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST)) - FAMILY) - SIZE FACE 0 DEVICE 0 POSTSCRIPTFONTDIRECTORIES '(PSCFONT PF PSC)))]) (PSCFONT.COERCEFILE - [LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE) - (* ; "Edited 5-Oct-93 16:28 by rmk:") - - (* ;; -"This coerces the WEIGHT and SLOPE incrementally back to REGULAR in order to find a matching file.") - - (COND - ((AND (NEQ EXPANSION 'REGULAR) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) - ROTATION DEVICE))) - ((AND (EQ SLOPE 'ITALIC) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) - ROTATION DEVICE))) - ((AND (NEQ EXPANSION 'REGULAR) - (EQ SLOPE 'ITALIC) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (NEQ EXPANSION 'REGULAR) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (EQ SLOPE 'ITALIC) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (NEQ EXPANSION 'REGULAR) - (EQ SLOPE 'ITALIC) - (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) - ROTATION DEVICE]) (PSCFONTFROMCACHE.SPELLFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 17:54 by rmk:") - (* ; "Edited 5-Oct-92 15:23 by jds") - - (* ;; "Tries to find postscript font information in the cache, indexed by the name-field of the fontfile. ") - - (LET [(CACHE (CDR (ASSOC (L-CASE (FILENAMEFIELD (\FONTFILENAME (OR (CDR (FASSOC FAMILY - POSTSCRIPT.FONT.ALIST - )) - FAMILY) - SIZE FACE 'PSCFONT 0) - 'NAME)) - POSTSCRIPTFONTCACHE] - (IF CACHE - THEN (CREATE PSCFONT USING CACHE]) (PSCFONTFROMCACHE.COERCEFILE - [LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE) - (* ; "Edited 5-Oct-93 17:00 by rmk:") - - (* ;; "This coerces the WEIGHT and SLOPE incrementally back to REGULAR in order to find a matching font in the cache.") - - (COND - ((AND (NEQ EXPANSION 'REGULAR) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) - ROTATION DEVICE))) - ((AND (EQ SLOPE 'ITALIC) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) - ROTATION DEVICE))) - ((AND (NEQ EXPANSION 'REGULAR) - (EQ SLOPE 'ITALIC) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (NEQ EXPANSION 'REGULAR) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (EQ SLOPE 'ITALIC) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) - ROTATION DEVICE))) - ((AND (NEQ WEIGHT 'MEDIUM) - (NEQ EXPANSION 'REGULAR) - (EQ SLOPE 'ITALIC) - (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) - ROTATION DEVICE]) (PSCFONT.WRITEFONT - [LAMBDA (FONTFILENAME PF) (* ; - "Edited 5-Aug-93 16:28 by sybalskY:MV:ENVOS") - - (* ;; "Given a PSCFONT data structure, write it out as a properly-named xxx.PSCFONT file, for later reading.") - - NIL - (LET ([S (OPENSTREAM FONTFILENAME 'OUTPUT NIL '((TYPE BINARY) - (SEQUENTIAL T] - (W (fetch (PSCFONT WIDTHS) of PF)) - (*READTABLE* (FIND-READTABLE "INTERLISP"))) - (PRIN3 (fetch (PSCFONT FID) of PF) - S) - (BOUT S 0) - (BOUT S 255) - (\WOUT S (fetch (PSCFONT FIRSTCHAR) of PF)) - (\WOUT S (fetch (PSCFONT LASTCHAR) of PF)) - (\WOUT S (fetch (PSCFONT ASCENT) of PF)) - (\WOUT S (fetch (PSCFONT DESCENT) of PF)) - (for C from 0 to 255 do (\WOUT S (ELT W C))) - (CLOSEF S) - FONTFILENAME]) (READ-AFM-FILE - [LAMBDA (FILE BOLDNESS ITALICNESS) (* ; - "Edited 5-Aug-93 16:37 by sybalskY:MV:ENVOS") - - (* ;; - "Read an Adobe-version-3 AFM file, and extract the metrics from it for making a PSCFONT file.") - - (LET ((IFILE (OPENSTREAM FILE 'INPUT)) - (PSCFONT (create PSCFONT)) - (FCHAR 1000) - (LCHAR 0) - (W (ARRAY 256 'SMALLPOSP 0 0)) - TOKEN WEIGHT SLOPE HEIGHT CMCOUNT FBBOX) - (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE)) - do (READCCODE IFILE)) - (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE))) - do (READCCODE IFILE)) - [COND - ((NOT (AND (BOUNDP 'WeightMenu) - (type? MENU WeightMenu))) - (SETQ WeightMenu (create MENU - ITEMS _ WeightMenuItems - MENUFONT _ (FONTCREATE 'HELVETICA 12] - [COND - ((NOT (AND (BOUNDP 'SlopeMenu) - (type? MENU SlopeMenu))) - (SETQ SlopeMenu (create MENU - ITEMS _ SlopeMenuItems - MENUFONT _ (FONTCREATE 'HELVETICA 12] - (OR (SETQ WEIGHT BOLDNESS) - (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu)) - T)) - (OR (SETQ SLOPE ITALICNESS) - (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu)) - T)) - (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR)) - [SETQ IL-FONTID (COND - ((AND (EQ SLOPE 'REGULAR) - (EQ WEIGHT 'MEDIUM)) - TOKEN) - (T (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR] - [repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN) - do (SETQ TOKEN (RSTRING IFILE)) - (COND - [(STRING-EQUAL "FontBBox" TOKEN) - (SETQ FBBOX (LIST (READ IFILE) - (READ IFILE) - (READ IFILE) - (READ IFILE))) - - (* ;; "The Ascender and Descender properties from the AFM file are currently ignored, and the values from the FontBBox are used, SCALED to the height of the font.") - - (SETQ DESCENT (IABS (CADR FBBOX))) - (SETQ ASCENT (CADDDR FBBOX)) - (SETQ HEIGHT (IPLUS ASCENT DESCENT)) - [SETQ DESCENT (FIXR (FTIMES DESCENT (/ 1000 HEIGHT] - (SETQ ASCENT (FIXR (FTIMES ASCENT (/ 1000 HEIGHT] - (T (READCCODE IFILE] - (SETQ CMCOUNT (RATOM IFILE)) - (repeatuntil (EQ (CHARCODE EOL) - (READCCODE IFILE)) do) - (SETQ WIDTHS W) - (for CC from 1 to CMCOUNT - do (LET (CCODE) - (repeatuntil (EQ 'C (RATOM IFILE)) do) - (SETQ CCODE (READ IFILE)) - (RATOMS 'WX IFILE) - (SETQ CWIDTH (READ IFILE)) - [COND - ((CL:PLUSP CCODE) (* ; - "This character appears in the standard encoding, so just use the charcode.") - (COND - ((ILESSP CCODE FCHAR) - (SETQ FCHAR CCODE))) - (COND - ((IGREATERP CCODE LCHAR) - (SETQ LCHAR CCODE))) - (SETA W CCODE CWIDTH)) - (T (* ; "A character not in the standard encoding; look it up to see if it's one we need (eth & thorn are brought into the CS-0 codespace for UToronto's work).") - (repeatuntil (EQ 'N (RATOM IFILE)) do - - (* ;; - "Skip to the N entry, which gives the Adobe-standard name.") -) - (SETQ CNAME (RATOM IFILE)) - (* ; "GET THE NAME") - (SETQ CCODE (LISTGET *POSTSCRIPT-EXTRA-CHARACTERS* CNAME)) - (COND - (CCODE (COND - ((ILESSP CCODE FCHAR) - (SETQ FCHAR CCODE))) - (COND - ((IGREATERP CCODE LCHAR) - (SETQ LCHAR CCODE))) - (SETA W CCODE CWIDTH] - (repeatuntil (EQ (CHARCODE EOL) - (READCCODE IFILE)) do))) - (SETQ FIRSTCHAR FCHAR) - (SETQ LASTCHAR LCHAR)) - (CLOSEF IFILE) - PSCFONT]) (CONVERT-AFM-FILES - [LAMBDA (FILE-LIST) (* ; - "Edited 5-Aug-93 16:47 by sybalskY:MV:ENVOS") - (for FL in FILE-LIST do (LET ((FNAME (pop FL)) - FONT FILENAME) - (for AFM-FILE in FL as WEIGHT - in '(MEDIUM MEDIUM BOLD BOLD) as SLOPE - in '(REGULAR ITALIC REGULAR ITALIC) - do (SETQ FONT (READ-AFM-FILE AFM-FILE WEIGHT - SLOPE)) - (SETQ FILENAME (\FONTFILENAME - FNAME 1 (LIST WEIGHT SLOPE - 'REGULAR) - 'PSCFONT 0)) - (PSCFONT.WRITEFONT FILENAME FONT]) (POSTSCRIPT.GETFONTID - [LAMBDA (FID WEIGHT SLOPE EXPANSION) (* ; - "Edited 20-Nov-92 15:04 by sybalsky:mv:envos") - (LET (FONTID) - (SETQ FONTID (create FONTID - FONTIDNAME _ (CAR FID) - FONTXFACTOR _ 1.0 - FONTOBLIQUEFACTOR _ 0.0)) - [if (AND (NEQ (CADDR FID) - SLOPE) - (EQ SLOPE 'ITALIC)) - then (replace (FONTID FONTOBLIQUEFACTOR) of FONTID - with (CONSTANT (TAN 7.0] - (if (AND (NEQ (CADR FID) - WEIGHT) - (EQ WEIGHT 'BOLD)) - then (* ; "Fake bold by slight expansion.") - (replace (FONTID FONTXFACTOR) of FONTID with 1.1)) - [if (NEQ EXPANSION 'REGULAR) - then (replace (FONTID FONTXFACTOR) of FONTID - with (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) - (if (EQ EXPANSION 'COMPRESSED) - then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO)) - else GOLDEN.RATIO] - FONTID]) (POSTSCRIPT.FONTCREATE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 29-Oct-93 16:39 by rmk:") - (* ; "Edited 3-Feb-93 17:22 by jds") - (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS PSCWIDTHSBLOCK WIDTHSBLOCK FD - FACECHANGED (WEIGHT (CAR FACE)) - (SLOPE (CADR FACE)) - (EXPANSION (CADDR FACE))) - - (* ;; - "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.") - - [COND - [(EQ SIZE 1) - - (* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info") - - (COND - ((SETQ PSCFD (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) - - (* ;; "Check in-core cache for exact match first") - - (SETQ FACECHANGED NIL)) - ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) - - (* ;; "Check file for exact match next") - - (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) - (SETQ FACECHANGED NIL)) - ((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION - ROTATION DEVICE)) - - (* ;; "Then check cache for coerced match") - - (SETQ FACECHANGED T)) - ((SETQ FULLNAME (PSCFONT.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION - DEVICE)) - - (* ;; "Check file for coerced match") - - (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) - (SETQ FACECHANGED T))) - (COND - (PSCFD (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD) - 0.1))) - (SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD) - 0.1))) - (COND - (FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD - with (POSTSCRIPT.GETFONTID (fetch (PSCFONT - FID) - of PSCFD) - WEIGHT SLOPE EXPANSION] - ((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T)) - (SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT) - 'PSCFONT)) - - (* ;; "Scale the ASCENT and DESCENT") - - (SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD) - 0.1))) - (SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD) - 0.1))) - (SETQ SCALEFONTP T)) - (T - (* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.") - - (COND - ([SETQ PSCFD (COND - ((PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) - ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION - DEVICE)) - (PSCFONT.READFONT FULLNAME] - (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD)) - (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD)) - (SETQ SCALEFONTP NIL] - (COND - (PSCFD - (* ;; "Set up the Charset descriptions and Widths vectors for character set 0:") - - (SETQ FD - (create FONTDESCRIPTOR - OTHERDEVICEFONTPROPS _ (LIST 'PSCFONT PSCFD) - FONTSCALE _ 100 - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - ROTATION _ 0 - \SFHeight _ (IPLUS ASCENT DESCENT) - \SFAscent _ ASCENT - \SFDescent _ DESCENT)) - (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 FD))) - (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD)) - [COND - [SCALEFONTP (for CH from 0 to 255 - do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE - (ELT FIXPWIDTHS - CH) - 0.1] - (T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH - (ELT FIXPWIDTHS CH] - (SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT)) - - (* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.") - - (for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH - (\FGETWIDTH WIDTHSBLOCK CH))) - [LET [(TMP (COND - (FULLNAME (\FONTINFOFROMFILENAME FULLNAME DEVICE)) - (UNITFONT (fetch FONTDEVICESPEC of UNITFONT] - - (* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got") - - (COND - ((AND TMP (NEQ FAMILY (CAR TMP))) - (replace FONTDEVICESPEC of FD with (LIST (CAR TMP) - SIZE - (COPY FACE) - 0 DEVICE] - [LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION - DEVICE)) - (DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD - ROTATION DEVICE))) - - (* ;; - "Now run thru the mapping table, filling in the new font from whatever source is specified:") - - [MAPHASH *POSTSCRIPT-NS-HASH* - (FUNCTION (LAMBDA (MAPPING CODE) - (DESTRUCTURING-BIND - (KIND CODE2 BASECHAR) - MAPPING - - (* ;; - "Depending on what kind of item it is, process it:") - - (SELECTQ KIND - (NIL - (* ;; - "Translating an NS character to a PSC char in CS 0.") - - (\FSETCHARWIDTH FD CODE (\FGETWIDTH - PSCWIDTHSBLOCK - (\CHAR8CODE - CODE2)))) - (SYMBOL [AND SYMWIDTHS (\FSETCHARWIDTH - FD CODE (ELT SYMWIDTHS - (\CHAR8CODE - CODE2]) - (DINGBAT [AND DINGWIDTHS (\FSETCHARWIDTH - FD CODE (ELT DINGWIDTHS - (\CHAR8CODE - CODE2]) - (FUNCTION - (* ;; - "This is fake and only works for the fractions. Need a better case.") - - [\FSETCHARWIDTH - FD CODE - (IPLUS (\FGETWIDTH PSCWIDTHSBLOCK 164) - (FIXR (FTIMES 1.3 - (\FGETWIDTH - PSCWIDTHSBLOCK - (CHARCODE 1]) - (ACCENT (* ; - "CODE2 is the rendering character but width comes from width of basechar") - (\FSETCHARWIDTH FD CODE (\FGETWIDTH - PSCWIDTHSBLOCK - BASECHAR))) - (ACCENTPAIR - - (* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent") - - (\FSETCHARWIDTH FD CODE (\FGETWIDTH - PSCWIDTHSBLOCK - CODE2))) - (PROGN - - (* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other NS characters are available. Also skip anything else") - - NIL] - - (* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)") - - (MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE) - (CL:WHEN (EQ (CAR MAPPING) - 'APPLY*) - (\FSETCHARWIDTH - FD CODE (APPLY* (CADDDR - MAPPING - ) - FD - (CADR MAPPING)) - ))] - FD) - (T NIL]) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS - [LAMBDA (TYPE FD ROTATION DEVICE) (* ; "Edited 5-Oct-93 18:21 by rmk:") - - (* ;; "Returns the scaled widths for a unit font of type TYPE (SYMBOL or ZAPFDINGBATS) compatible with FD. A separate function so that the unit widths can be easily cached.") - - (LET [TYPEFONT WIDTHS NEWWIDTHS (SIZE (FETCH FONTSIZE OF FD)) - (FONTFILE (OR (PSCFONT.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR FONTFACE) - OF FD) - ROTATION DEVICE) - (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) - ROTATION DEVICE] - [SETQ TYPEFONT (COND - ((PSCFONTFROMCACHE.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR - FONTFACE) - OF FD) - ROTATION DEVICE)) - ((SETQ FONTFILE (PSCFONT.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR - FONTFACE) - OF FD) - ROTATION DEVICE)) - (PSCFONT.READFONT FONTFILE)) - ((PSCFONTFROMCACHE.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) - ROTATION DEVICE)) - ((SETQ FONTFILE (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) - ROTATION DEVICE)) - (PSCFONT.READFONT FONTFILE] - (CL:WHEN (AND TYPEFONT (SETQ WIDTHS (FETCH (PSCFONT WIDTHS) OF TYPEFONT))) - (SETQ NEWWIDTHS (ARRAY 256 'SMALLPOSP 0 0)) - - (* ;; "Have to copy because of scaling") - - [FOR CH FROM 0 TO 255 DO (SETA NEWWIDTHS CH - (FIXR (TIMES SIZE (ELT WIDTHS CH) - 0.1] - NEWWIDTHS)]) (POSTSCRIPT.FONTSAVAILABLE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 12-Jan-88 13:04 by Matt Heffron") - - (* ;; "the filtering code was borrowed from Richard Burton's \SEARCHINTERPRESSFONTS. Note that without it [HELVETICA * (MEDIUM REGULAR REGULAR)] would pick up [HELVETICA-NARROW * (MEDIUM REGULAR REGULAR)] as well.") - - (LET - ((PATTERN (\FONTFILENAME (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST)) - FAMILY) - SIZE FACE 'PSCFONT)) - [INVERSE.ALIST (for PAIR in POSTSCRIPT.FONT.ALIST collect (CONS (CDR PAIR) - (CAR PAIR] - FONTSAVAILABLE) - (SETQ FONTSAVAILABLE - (for FD in [for DIRECTORY in POSTSCRIPTFONTDIRECTORIES - join (for FILE in (DIRECTORY (CONCAT DIRECTORY PATTERN)) - collect (LET* ((RAWFD (\FONTINFOFROMFILENAME FILE DEVICE) - ) - (RAWNAME (CAR RAWFD))) - (RPLACA RAWFD - (OR (CDR (ASSOC RAWNAME - INVERSE.ALIST)) - RAWNAME] - when (AND (OR (EQ FAMILY '*) - (EQ FAMILY (CAR FD))) - (OR (EQ SIZE '*) - (EQ SIZE (CADR FD)) - (EQ (CADR FD) - 1)) - (OR (EQ FACE '*) - (EQUAL FACE (CADDR FD)) - (EQUAL [CDR (ASSOC FACE '((MRR MEDIUM REGULAR REGULAR) - (STANDARD MEDIUM REGULAR REGULAR) - (MIR MEDIUM ITALIC REGULAR) - (ITALIC MEDIUM ITALIC REGULAR) - (BRR BOLD REGULAR REGULAR) - (BOLD BOLD REGULAR REGULAR) - (BIR BOLD ITALIC REGULAR) - (BOLDITALIC BOLD ITALIC REGULAR] - (CADDR FD))) - (NOT (MEMBER FD $$VAL))) collect FD)) - (if (EQ SIZE '*) - then - -(* ;;; "If SIZE was wildcarded, then provide list of pointsizes for Postscript scaled fonts (those with a 1 point descriptor file)") - - (for FD in FONTSAVAILABLE - join (if (EQ 1 (CADR FD)) - then (CONS FD (for NF - in (for S from 2 to - \POSTSCRIPT.MAX.WILD.FONTSIZE - collect (LET ((NFD (COPY FD))) - (RPLACA (CDR NFD) - S) - NFD)) - unless (MEMBER NF FONTSAVAILABLE) collect - NF)) - else (LIST FD))) - else FONTSAVAILABLE]) ) (* ;; "Until macro in FONT is exported") (DECLARE%: EVAL@COMPILE (PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (\CHAR8CODE CHARCODE) WIDTH))) ) (DEFINEQ (OPENPOSTSCRIPTSTREAM [LAMBDA (FILE OPTIONS) (* ; "Edited 17-Jun-97 21:15 by rmk:") (* ;  "Edited 31-May-93 12:42 by sybalsky:mv:envos") (* ; "Edited 23-Dec-92 01:17 by jds") (LET [[FP (OPENSTREAM FILE 'OUTPUT NIL `((TYPE ,*POSTSCRIPT-FILE-TYPE*) (SEQUENTIAL T] (IMAGEDATA (create \POSTSCRIPTDATA)) PAPER IMAGESIZEFACTOR CLIP REG (BBOX (LISTGET OPTIONS 'BOUNDINGBOX] (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN) (replace (STREAM IMAGEDATA) of FP with IMAGEDATA) (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS) (* ;; "Bounding box is for encapsulated postscript. The bounding box is in Medley's postscript-coordinate system, so we have to scale it back to default postscript since it will be interpreted outside of the operators specified below. CEIL and FLOOR to make sure that we don't leave anything out. We may also want to change the header to have the EPSF qualifier") (printout FP "%%!PS-Adobe-2.0" T %# (CL:WHEN BBOX (PRINTOUT FP "%%%%BoundingBox: " (CL:FLOOR (CAR BBOX) \PS.SCALE0) " " (CL:FLOOR (CADR BBOX) \PS.SCALE0) " " (CL:CEILING (CADDR BBOX) \PS.SCALE0) " " (CL:CEILING (CADDDR BBOX) \PS.SCALE0) T)) "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 'DOCUMENT.NAME) FILE)) T "%%%%Creator: PostScript Driver Copyright (C) 1988-1992 Venue and others" T "%%%%CreationDate: " (DATE) T %# (COND ((EQ 'LPT (FILENAMEFIELD FP 'HOST)) (* ;; "Put current user's name on break page only if going to LPT for immediate printing. Presumably the print-spooler itself should know what the user's system login-name is, but that may not be the case for all printers in all environments.") (PRINTOUT NIL "%%%%For: " (MKSTRING USERNAME) T))) "%%%%EndComments" T) (for X in \POSTSCRIPT.JOB.SETUP do (POSTSCRIPT.OUTSTR FP X) (\FILEOUTCHARFN FP (CHARCODE EOL))) (SETQ PAPER (OR (CDR (CL:ASSOC (SETQ PAPER (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) POSTSCRIPT.PAGEREGIONS :TEST #'STRING-EQUAL)) (ERROR "Unknown PostScript page type" PAPER))) (* ;; "Set the paper size:") (PRINTOUT FP (L-CASE (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) T) (COND ((NOT (AND [SETQ IMAGESIZEFACTOR (NUMBERP (LISTGET OPTIONS 'IMAGESIZEFACTOR] (CL:PLUSP IMAGESIZEFACTOR))) (SETQ IMAGESIZEFACTOR 1))) [COND ((AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR) (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR)) (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR] (printout FP "/imagesizefactor " IMAGESIZEFACTOR " def" T) (printout FP "%%%%EndSetup" T) (replace (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA with \PS.SCALE0) (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN) (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA with (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (CAR PAPER))) (* ;;  "Initial clipping region can be specified separately from the page size, default is to page size.") [replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with (SETQ CLIP (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (OR (CADR PAPER) (CAR PAPER] (* ;; "If a REGION parameter was supplied, it establishes the initial margins.") (SETQ REG (OR (AND (SETQ REG (LISTGET OPTIONS 'REGION)) (INTERSECTREGIONS REG CLIP)) (CREATEREGION 3600 3600 54000 72000))) (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA with (fetch (REGION LEFT) of REG)) (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA with (fetch (REGION BOTTOM) of REG)) (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA with (PLUS (fetch (REGION BOTTOM) of REG) (fetch (REGION HEIGHT) of REG) -1)) (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA with (PLUS (fetch (REGION LEFT) of REG) (fetch (REGION WIDTH) of REG) -1)) (\DSPFONT.PSC FP (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS] DEFAULTFONT) NIL NIL NIL FP)) (\SWITCHFONTS.PSC FP IMAGEDATA) [COND ((replace (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA with (LISTGET OPTIONS 'HEADING)) (replace (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of IMAGEDATA with (COND ((LISTGET OPTIONS 'HEADINGFONT) (FONTCREATE (LISTGET OPTIONS 'HEADINGFONT) NIL NIL NIL FP)) (T (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA] (* ;; "Decide if it's landscape: if (LANDSCAPE T) appears in OPTIONS, it is. IF ROTATION isn't DEFAULT, it is.") (COND ([COND ((CL:GETF OPTIONS 'LANDSCAPE NIL)) ((EQL (CL:GETF OPTIONS 'ROTATION 'DEFAULT) 'DEFAULT) (COND ((EQL POSTSCRIPT.PREFER.LANDSCAPE 'ASK) (MENU \POSTSCRIPT.ORIENTATION.MENU)) (T POSTSCRIPT.PREFER.LANDSCAPE))) (T (CL:GETF OPTIONS 'ROTATION] (POSTSCRIPT.SET-FAKE-LANDSCAPE FP 90))) (POSTSCRIPT.STARTPAGE FP) FP]) (CLOSEPOSTSCRIPTSTREAM - [LAMBDA (STREAM) (* ; "Edited 8-Mar-93 10:31 by jds") - (POSTSCRIPT.ENDPAGE STREAM) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Trailer" :EOL) - (* BOUT STREAM (CHARCODE ^D)) - ]) ) (RPAQ? *POSTSCRIPT-FILE-TYPE* 'BINARY) (DEFINEQ (POSTSCRIPT.HARDCOPYW - [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE) - (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (ALLOW.BUTTON.EVENTS) - (LET* ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape? - 'IMAGESIZEFACTOR SCALEFACTOR))) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (SCLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA)) - SCALE) - [COND - [REGION (SETQ REGION (COPY REGION)) (* ; "In case we need to change it.") - [COND - ((< (fetch BITMAPWIDTH of BITMAP) - (+ (fetch (REGION LEFT) of REGION) - (fetch (REGION WIDTH) of REGION))) - (replace (REGION WIDTH) of REGION with (- (fetch BITMAPWIDTH - of BITMAP) - (fetch (REGION - LEFT) - of REGION] - (COND - ((< (fetch BITMAPHEIGHT of BITMAP) - (+ (fetch (REGION BOTTOM) of REGION) - (fetch (REGION HEIGHT) of REGION))) - (replace (REGION HEIGHT) of REGION - with (- (fetch BITMAPHEIGHT of BITMAP) - (fetch (REGION BOTTOM) of REGION] - (T (SETQ REGION (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch BITMAPWIDTH of BITMAP) - HEIGHT _ (fetch BITMAPHEIGHT of BITMAP] - (SETQ SCALE (TIMES POSTSCRIPT.BITMAP.SCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) - of IMAGEDATA))) - (BITBLT BITMAP (fetch (REGION LEFT) of REGION) - (fetch (REGION BOTTOM) of REGION) - STREAM - (PLUS (fetch (REGION LEFT) of SCLIP) - (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of SCLIP) - (TIMES SCALE (fetch (REGION WIDTH) of REGION))) - 2)) - (PLUS (fetch (REGION BOTTOM) of SCLIP) - (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of SCLIP) - (TIMES SCALE (fetch (REGION HEIGHT) of REGION))) - 2)) - (fetch (REGION WIDTH) of REGION) - (fetch (REGION HEIGHT) of REGION) - 'INPUT - 'REPLACE) - (CLOSEF STREAM) - (FULLNAME STREAM]) (POSTSCRIPT.TEDIT - [LAMBDA (FILE PFILE) (* ; "Edited 18-Sep-91 18:16 by jds") - - (* ;; "Make a PS file from a TEdit document. If FILE is a string, make it into a symbol for the file-name. If it's a STREAM, use that stream.") - - [COND - ((STRINGP FILE) - (SETQ FILE (MKATOM FILE] - (SETQ FILE (OPENTEXTSTREAM FILE)) - (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'POSTSCRIPT) - (CLOSEF? FILE) - PFILE]) (POSTSCRIPT.TEXT - [LAMBDA (FILE PSCFILE FONTS HEADING TABS) (* ; "Edited 23-Apr-89 11:31 by TAL") - (TEXTTOIMAGEFILE FILE PSCFILE 'POSTSCRIPT FONTS HEADING TABS - `(REGION ,POSTSCRIPT.DEFAULT.PAGEREGION ROTATION ,(NOT (NOT POSTSCRIPT.TEXTFILE.LANDSCAPE]) (POSTSCRIPTFILEP - [LAMBDA (FILE) (* ; "Edited 5-Mar-93 21:40 by rmk:") - (* ; "Edited 14-Jan-93 10:56 by jds") - (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION) - '("PS" "PSC" "PSF") - :TEST - (FUNCTION STRING-EQUAL)) - (PROGN (SETFILEPTR FILE 0) - (PROG1 (AND (EQ (BIN FILE) - (CHARCODE %%)) - (EQ (BIN FILE) - (CHARCODE !))) - (SETFILEPTR FILE 0]) (MAKEEPSFILE - [LAMBDA (IMAGEOBJ FILENAME) (* ; "Edited 7-Apr-94 14:48 by rmk:") - - (* ;; "Puts IMAGEOBJ on a 1-page encapsulated postscript file. The lower-left corner of the image box will be at 0,0 on the page.") - - (LET* [(STREAM (OPENIMAGESTREAM `{NODIRCORE}SCRATCH 'POSTSCRIPT)) - (IMAGEBOX (APPLY* (IMAGEOBJPROP IMAGEOBJ 'IMAGEBOXFN) - IMAGEOBJ STREAM)) - (BOUNDINGBOX (LIST 0 0 (FETCH XSIZE OF IMAGEBOX) - (FETCH YSIZE OF IMAGEBOX] - [SETQ STREAM (OPENIMAGESTREAM FILENAME 'POSTSCRIPT - `(BOUNDINGBOX (0 0 ,(FETCH XSIZE OF IMAGEBOX) - ,(FETCH YSIZE OF IMAGEBOX] - (MOVETO (FETCH XKERN OF IMAGEBOX) - (FETCH YDESC OF IMAGEBOX) - STREAM) - (APPLY* (IMAGEOBJPROP IMAGEOBJ 'DISPLAYFN) - IMAGEOBJ STREAM) - (CLOSEF STREAM]) ) (DEFINEQ (POSTSCRIPT.BITMAPSCALE [LAMBDA (WIDTH HEIGHT) (* ; "Edited 29-Apr-98 08:46 by rmk:") (* ;  "Edited 20-Nov-92 14:52 by sybalsky:mv:envos") (LET* ([PAGEREGION (\PS.SCALEREGION (/ 72 POSTSCRIPT.BITMAP.SCALE) (CADR (FASSOC POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS] (LONGEDGE (MAX (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION HEIGHT) of PAGEREGION))) (SHORTEDGE (MIN (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION HEIGHT) of PAGEREGION))) [MINDIMP (MIN (FQUOTIENT LONGEDGE (SETQ HEIGHT (TIMES HEIGHT POSTSCRIPT.BITMAP.SCALE))) (FQUOTIENT SHORTEDGE (SETQ WIDTH (TIMES WIDTH POSTSCRIPT.BITMAP.SCALE] (MINDIML (MIN (FQUOTIENT SHORTEDGE HEIGHT) (FQUOTIENT LONGEDGE WIDTH))) (PPL (if (EQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) then (MENU \POSTSCRIPT.ORIENTATION.MENU) else POSTSCRIPT.PREFER.LANDSCAPE)) MINDIM OTHERDIM SF1 SF2) (if PPL then (SETQ MINDIM MINDIML) (SETQ OTHERDIM MINDIMP) else (SETQ MINDIM MINDIMP) (SETQ OTHERDIM MINDIML)) (SETQ SF1 (if (GREATERP MINDIM 1) then 1 elseif (GREATERP MINDIM 0.75) then 0.75 elseif (GREATERP MINDIM 0.5) then 0.5 elseif (GREATERP MINDIM 0.25) then 0.25 else MINDIM)) (SETQ SF2 (if (GREATERP OTHERDIM 1) then 1 elseif (GREATERP OTHERDIM 0.75) then 0.75 elseif (GREATERP OTHERDIM 0.5) then 0.5 elseif (GREATERP OTHERDIM 0.25) then 0.25 else OTHERDIM)) (if (AND (LESSP SF1 1) (LESSP SF1 SF2)) then (CONS SF2 (NOT PPL)) else (CONS SF1 PPL]) (POSTSCRIPT.CLOSESTRING - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (COND - ((fetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (POSTSCRIPT.OUTSTR STREAM ") ") - (replace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with NIL) - T) - (T NIL]) (POSTSCRIPT.ENDPAGE - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) - (COND - ((NOT (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA) - (POSTSCRIPT.PUTCOMMAND STREAM "grestore savepage restore "))) - (POSTSCRIPT.PUTCOMMAND STREAM "showpage" :EOL))) - - (* ;; -"Force re-encoding of fonts, because the restore wipes out any you encoded while writing this page.") - - (replace (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of IMAGEDATA with NIL]) (POSTSCRIPT.OUTSTR - [LAMBDA (STREAM X) (* ; "Edited 14-Jul-89 14:05 by Matt Heffron") - (DECLARE (LOCALVARS . T)) - (COND - ((FIXP X) (* ; "Common case, speed helps") - (\PS.BOUTFIXP STREAM X)) - [(STRINGP X) (* ; "Other common case") - (COND - [(ffetch (STRINGP FATSTRINGP) of X) - (for c infatstring X do (BOUT STREAM (\CHAR8CODE c] - (T (\BOUTS STREAM (ffetch (STRINGP BASE) of X) - (ffetch (STRINGP OFFST) of X) - (ffetch (STRINGP LENGTH) of X] - [(LITATOM X) - (for c inatom X do (BOUT STREAM (\CHAR8CODE c] - ((ZEROP X) - (BOUT STREAM (CHARCODE 0))) - (T [COND - ((TYPEP X 'RATIO) - (SETQ X (FLOAT X] - (for c in (CHCON X) do (BOUT STREAM (\CHAR8CODE c]) (POSTSCRIPT.PUTBITMAPBYTES - [LAMBDA (STREAM BITMAP DELIMFLG) - (DECLARE (GLOBALVARS PS.BITMAPARRAY) - (LOCALVARS . T)) (* ; "Edited 30-Mar-90 20:15 by Matt Heffron") - (LET* - ((WIDTH (fetch BITMAPWIDTH of BITMAP)) - (HEIGHT (fetch BITMAPHEIGHT of BITMAP)) - (BMBASE (fetch BITMAPBASE of BITMAP)) - (BYTESPERROW (LRSH (IPLUS WIDTH 7) - 3)) - (BYTEOFFSETPERROW (LSH (fetch BITMAPRASTERWIDTH of BITMAP) - 1)) - (PS.BITMAPARRAYBASE (fetch (ARRAYP BASE) of PS.BITMAPARRAY))) - (COND - [DELIMFLG (LET ((POS 0) - BYTE) - (\FILEOUTCHARFN STREAM (CHARCODE SPACE)) - (\FILEOUTCHARFN STREAM (CHARCODE <)) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (for R from (SUB1 HEIGHT) to 0 by -1 as ROWOFFSET - from (ITIMES (SUB1 HEIGHT) - BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW) - do (for B from 1 to BYTESPERROW as BYTEOFFSET - from ROWOFFSET by 1 - do (COND - ((IGEQ POS 254) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) - [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH BYTE 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 BYTE))) - (SETQ POS (IPLUS POS 2))) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0)) - (\FILEOUTCHARFN STREAM (CHARCODE SPACE)) - (\FILEOUTCHARFN STREAM (CHARCODE >)) - (\FILEOUTCHARFN STREAM (CHARCODE EOL] - (T - (LET* - ((PRVBM (BITMAPCREATE WIDTH 1)) - (PRVBASE (fetch BITMAPBASE of PRVBM))) - (for R from 0 to (SUB1 HEIGHT) as ROWOFFSET - from (ITIMES (SUB1 HEIGHT) - BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW) - do - (LET ((POS 0) - (BYTEOFFSET ROWOFFSET) - (B 1) - (PRVO 0) - BYTE REPC) - [while (ILEQ B BYTESPERROW) - do (SETQ REPC - (for BB from B to BYTESPERROW as BO from BYTEOFFSET - by 1 as PO from PRVO by 1 - while (EQ (\GETBASEBYTE BMBASE BO) - (\GETBASEBYTE PRVBASE PO)) count T)) - (COND - [(IGEQ REPC 3) - (SETQ B (IPLUS B REPC)) - (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) - (SETQ PRVO (IPLUS PRVO REPC)) - (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) - do (COND - ((IGEQ POS 251) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - (BOUT STREAM (CHARCODE B)) - (BOUT STREAM (CHARCODE 3)) - [COND - ((IGEQ REPC 256) - (BOUT STREAM (CHARCODE F)) - (BOUT STREAM (CHARCODE F))) - (T [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH REPC 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 REPC] - (SETQ REPC (IDIFFERENCE REPC 256)) - (SETQ POS (IPLUS POS 4] - (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) - (SETQ REPC - (for BB from B to BYTESPERROW as BO from - BYTEOFFSET - by 1 while (EQ (\GETBASEBYTE BMBASE BO) - BYTE) count T)) - (COND - [(IGEQ REPC 3) - (SETQ B (IPLUS B REPC)) - (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) - (SETQ PRVO (IPLUS PRVO REPC)) - (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) - do (COND - ((IGEQ POS 249) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - (BOUT STREAM (CHARCODE B)) - (BOUT STREAM (CHARCODE 2)) - [COND - ((IGEQ REPC 256) - (BOUT STREAM (CHARCODE F)) - (BOUT STREAM (CHARCODE F))) - (T [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH REPC 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 REPC] - [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH BYTE 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 BYTE))) - (SETQ REPC (IDIFFERENCE REPC 256)) - (SETQ POS (IPLUS POS 4] - (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) - (COND - ((IGEQ POS 251) - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (SETQ POS 0))) - [COND - ((FMEMB BYTE '(178 179 180)) - - (* ;; "BYTE is B2, B3, or B4; quote it") - - (BOUT STREAM (CHARCODE B)) - (BOUT STREAM (CHARCODE 4)) - (SETQ POS (IPLUS POS 2] - [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE - (LOGAND 15 (LRSH BYTE 4] - (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE) - )) - (SETQ B (IPLUS B 1)) - (SETQ BYTEOFFSET (IPLUS BYTEOFFSET 1)) - (SETQ PRVO (IPLUS PRVO 1)) - (SETQ POS (IPLUS POS 2] - (\FILEOUTCHARFN STREAM (CHARCODE EOL))) - (\MOVEBYTES BMBASE ROWOFFSET PRVBASE 0 BYTESPERROW]) (POSTSCRIPT.PUTCOMMAND - [LAMBDA S.STRS (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET* ((STREAM (ARG S.STRS 1)) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - S#S) - (freplace (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA with NIL) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (POSTSCRIPT.SHOWACCUM STREAM))) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA) - (\SETXFORM.PSC STREAM IMAGEDATA))) - (for STR# from 2 to S.STRS do (COND - ((EQ (SETQ S#S (ARG S.STRS STR#)) - :EOL) - (\FILEOUTCHARFN STREAM (CHARCODE EOL))) - (T (POSTSCRIPT.OUTSTR STREAM S#S]) (POSTSCRIPT.SET-FAKE-LANDSCAPE - [LAMBDA (STREAM ROTATION) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - - (* ;; "Set up for (or disable) fake landscaping") - - (* ;; - "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLAND (COND - ((fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) - 90) - (T 0))) - LAND C0 P0 C P ML MB MR MT) - (COND - ((AND ROTATION (NEQ (SETQ LAND (NOT (ZEROP ROTATION))) - (fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\DSPTRANSLATE.PSC STREAM 0 0) - (SETQ C0 (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA)) - (SETQ P0 (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA)) - (SETQ C (create REGION - WIDTH _ (fetch (REGION HEIGHT) of C0) - HEIGHT _ (fetch (REGION WIDTH) of C0))) - (SETQ P (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch (REGION HEIGHT) of P0) - HEIGHT _ (fetch (REGION WIDTH) of P0))) - [COND - (LAND (replace (REGION LEFT) of C with (fetch (REGION BOTTOM) - of C0)) - [replace (REGION BOTTOM) of C with - (- (fetch (REGION WIDTH) - of P0) - (+ (fetch (REGION LEFT) - of C0) - (fetch (REGION WIDTH) - of C0] - (SETQ ML (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - ) - (SETQ MB (- (fetch (REGION WIDTH) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of - IMAGEDATA - ) - 1)) - (SETQ MR (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA)) - (SETQ MT (- (fetch (REGION WIDTH) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA - ) - 1))) - (T [replace (REGION LEFT) of C with (- (fetch (REGION HEIGHT) - of P0) - (+ (fetch (REGION BOTTOM) - of C0) - (fetch (REGION HEIGHT) - of C0] - (replace (REGION BOTTOM) of C with (fetch (REGION LEFT) - of C0)) - (SETQ ML (- (fetch (REGION HEIGHT) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - 1)) - (SETQ MB (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA)) - (SETQ MR (- (fetch (REGION HEIGHT) of P0) - (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - 1)) - (SETQ MT (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA] - (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with - C) - (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA with P) - (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA with ML) - (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA with MB) - (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA with MR) - (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA with MT) - (replace (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA with LAND) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) - (\DSPRESET.PSC STREAM))) - OLAND]) (POSTSCRIPT.SHOWACCUM - [LAMBDA (STREAM) (* ; "Edited 23-May-93 11:52 by rmk:") - - (* ;; - "Send commands to SHOW the accumulated characters. Uses S (= SHOW) for regular characters.") - - (* ;; "Uses WIDTHSHOW if the space-factor isn't 1") - - (* ;; "Uses ASHOW if a KERN value is on STREAM's properties") - - (* ;; "USES AWIDTHSHOW if both space-factor != 1 and there's a KERN value.") - - (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM)) - KERN) - (COND - ((fetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (SETQ KERN (STREAMPROP STREAM 'KERN)) - [COND - [(EQP (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA) - 1) - (COND - (KERN (POSTSCRIPT.OUTSTR STREAM (CONCAT ") " KERN " 0 3 -1 roll ashow"))) - (T (POSTSCRIPT.OUTSTR STREAM ") S"] - (T (POSTSCRIPT.OUTSTR STREAM ") ") - (POSTSCRIPT.OUTSTR STREAM (DIFFERENCE (ffetch (\POSTSCRIPTDATA - POSTSCRIPTSPACEWIDTH) - of IMAGEDATA) - (ffetch (\POSTSCRIPTDATA - POSTSCRIPTNATURALSPACEWIDTH - ) of IMAGEDATA))) - (COND - (KERN (POSTSCRIPT.OUTSTR STREAM (CONCAT " 0 " (CHARCODE SPACE) - " " KERN " 0 " - " 6 -1 roll awidthshow"))) - (T (POSTSCRIPT.OUTSTR STREAM (CONSTANT (CONCAT " 0 " (CHARCODE SPACE) - " 4 -1 roll widthshow"] - (\FILEOUTCHARFN STREAM (CHARCODE EOL)) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with NIL]) (POSTSCRIPT.STARTPAGE -(LAMBDA (STREAM) (* ; "Edited 28-Dec-94 17:41 by jds") (* ;; "Start up a new page in a Postscript document.") (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) NEW-PAGE) (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) (* ; "shouldnt need this") (SETQ NEW-PAGE (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGENUM) of IMAGEDATA))) (* ; "Page number goes up by 1") (* ;; "Print the %"Document structuring%" info for the page, then the initial page setup") (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Page: " NEW-PAGE " " NEW-PAGE :EOL "%%%%BeginPageSetup" :EOL "/savepage save def" :EOL (FQUOTIENT 1 \PS.SCALE0) " imagesizefactor mul dup scale" :EOL "%%%%EndPageSetup" :EOL) (\SETXFORM.PSC STREAM IMAGEDATA T) (* ;; "Lisp depends on the current font being carried over from page to page, but in postscript there is no current font at the beginning of a page, so force a setfont.") (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with T) (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA with T) (* ; "nothing printed yet...") (COND ((fetch (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA) (* ;; "Here we handle headings.") (LET ((FONT (\DSPFONT.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of IMAGEDATA)))) (\DSPRESET.PSC STREAM) (PRIN3 (fetch (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA) STREAM) (RELMOVETO (CONSTANT (TIMES 72 \PS.SCALE0)) 0 STREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " STREAM) (PRIN3 NEW-PAGE STREAM) (\TERPRI.PSC STREAM) (* ; "Skip 2 lines") (\TERPRI.PSC STREAM) (\DSPFONT.PSC STREAM FONT))) (T (\DSPRESET.PSC STREAM))))) -) (\POSTSCRIPTTAB - [LAMBDA (POSTSCRIPTDATA) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET [(TABSPACE (TIMES 8 (ffetch FONTAVGCHARWIDTH of (ffetch (\POSTSCRIPTDATA - POSTSCRIPTFONT) - of POSTSCRIPTDATA] - (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of POSTSCRIPTDATA) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) - of POSTSCRIPTDATA)) - TABSPACE]) (\PS.BOUTFIXP - [LAMBDA (STREAM N) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - - (* ;; "BOUT the decimal representation of N to STREAM using temp storage from the imagedata. Done this way for speed.") - - (DECLARE (LOCALVARS . T)) - [COND - ((MINUSP N) - (BOUT STREAM (CHARCODE -)) - (SETQ N (IMINUS N] - (COND - [(LESSP N 10) - (BOUT STREAM (IPLUS N (CHARCODE 0] - [(LESSP N 1000000000) - (LET ([BASE (fetch (ARRAYP BASE) of (fetch (\POSTSCRIPTDATA POSTSCRIPTTEMPARRAY) - of (fetch (STREAM IMAGEDATA) - of STREAM] - (i (SUB1 \PS.TEMPARRAYLEN))) - [for old i by -1 do (\PUTBASEBYTE BASE i (IPLUS (IREMAINDER N 10) - (CHARCODE 0))) - repeatwhile (NEQ 0 (SETQ N (IQUOTIENT N 10] - (\BOUTS STREAM BASE i (IDIFFERENCE \PS.TEMPARRAYLEN i] - (T (* ; "Just in case we get a bignum") - (for c in (CHCON N) do (BOUT STREAM (\CHAR8CODE c]) (\PS.SCALEHACK - [LAMBDA (STREAM SCALEFACTOR) (* ; - "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA)) - FACTOR) - (COND - ((AND (NUMBERP SCALEFACTOR) - (NOT (EQP OLDSCALE SCALEFACTOR))) - (POSTSCRIPT.SHOWACCUM STREAM) - (SETQ FACTOR (/ OLDSCALE SCALEFACTOR)) - [for REG in (LIST (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA) - (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) - of IMAGEDATA)) - do (change (fetch (REGION LEFT) of REG) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (REGION BOTTOM) of REG) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (REGION WIDTH) of REG) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (REGION HEIGHT) of REG) - (FIXR (CL:* DATUM FACTOR] - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) - (FIXR (CL:* DATUM FACTOR))) - (replace (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA with - SCALEFACTOR) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T))) - OLDSCALE]) (\PS.SCALEREGION - [LAMBDA (SCALE REGION) (* ; "Edited 5-Apr-89 16:15 by TAL") - (* ; "Scales a region") - (create REGION - LEFT _ (FIXR (TIMES SCALE (fetch (REGION LEFT) of REGION))) - BOTTOM _ (FIXR (TIMES SCALE (fetch (REGION BOTTOM) of REGION))) - WIDTH _ (FIXR (TIMES SCALE (fetch (REGION WIDTH) of REGION))) - HEIGHT _ (FIXR (TIMES SCALE (fetch (REGION HEIGHT) of REGION]) (\SCALEDBITBLT.PSC - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM - SCALE) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - - (* ;; "Postscript can only handle OPERATION REPLACE and PAINT. SOURCETYPE = TEXTURE is converted to BLTSHADE before getting here (so the TEXTURE argument can be ignored). If the destination region lies completely outside the clipping region we do nothing, otherwise we output the whole thing and let the printer clip. Could be more clever.") - - (OR (NUMBERP SCALE) - (SETQ SCALE 1)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (SCALE1 (TIMES SCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA))) - (SCALE2 (TIMES SCALE1 (OR (NUMBERP POSTSCRIPT.BITMAP.SCALE) - 1))) - DESTREGION - (BITMAPWIDTH (fetch BITMAPWIDTH of SOURCEBITMAP)) - (BITMAPHEIGHT (fetch BITMAPHEIGHT of SOURCEBITMAP)) - TEMPBM) - [COND - ((NULL DESTINATIONLEFT) - (SETQ DESTINATIONLEFT (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA] - [COND - ((NULL DESTINATIONBOTTOM) - (SETQ DESTINATIONBOTTOM (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA] - (COND - ((OR (NULL WIDTH) - (NULL HEIGHT)) - (SETQ WIDTH BITMAPWIDTH) - (SETQ HEIGHT BITMAPHEIGHT))) - (COND - ((GREATERP WIDTH BITMAPWIDTH) - (SETQ WIDTH BITMAPWIDTH))) - (COND - ((GREATERP HEIGHT BITMAPHEIGHT) - (SETQ HEIGHT BITMAPHEIGHT))) - [SETQ DESTREGION (INTERSECTREGIONS (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA) - (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES SCALE1 WIDTH - ) - (TIMES SCALE1 HEIGHT] - (COND - ((AND DESTREGION (OR (NULL CLIPPINGREGION) - (REGIONSINTERSECTP DESTREGION CLIPPINGREGION))) - [COND - ((AND (EQ SOURCELEFT 0) - (EQ SOURCEBOTTOM 0) - (EQP WIDTH BITMAPWIDTH) - (EQP HEIGHT BITMAPHEIGHT)) (* ; - "Avoid copy if sending entire bitmap") - (SETQ TEMPBM SOURCEBITMAP)) - (T (SETQ TEMPBM (BITMAPCREATE WIDTH HEIGHT 1)) - (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM TEMPBM 0 0 WIDTH HEIGHT SOURCETYPE - 'REPLACE] - (POSTSCRIPT.PUTCOMMAND STREAM "/bitbltsave save def " DESTINATIONLEFT " " - DESTINATIONBOTTOM " translate " (TIMES SCALE2 WIDTH) - " " - (TIMES SCALE2 HEIGHT) - " scale " WIDTH " " HEIGHT (COND - ((EQ OPERATION 'PAINT) - " true") - (T " false")) - " thebitimage" :EOL) - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "bitbltsave restore" :EOL) - (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) - T) - (T NIL]) (\SETPOS.PSC - [LAMBDA (STREAM IMAGEDATA) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - " " - (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - " M ") - (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with NIL]) (\SETXFORM.PSC -(LAMBDA (STREAM IMAGEDATA NORESTORE) (* ; "Edited 28-Dec-94 17:59 by jds") (* ;; "Write transforms into the PS file to make what it prints match what we think it should print.") (LET ((CLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA))) (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) (COND ((NOT NORESTORE) (POSTSCRIPT.OUTSTR STREAM "grestore "))) (POSTSCRIPT.PUTCOMMAND STREAM "gsave" :EOL) (* ;; "Scaling") (COND ((NOT (EQP (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA) 1)) (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA) " dup scale" :EOL))) (* ;; "Landscape mode (as in POSTSCRIPT.PREFER.LANDSCAPE, not as in TEdit doing landscaping)") (COND ((fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) (POSTSCRIPT.OUTSTR STREAM " 90 rotate 0 -61200 imagesizefactor div translate "))) (* ;; "Any rotation that is in effect.") (POSTSCRIPT.PUTCOMMAND STREAM " " (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA) " rotate " :EOL) (* ;; "Any translations that are in effect.") (COND ((NOT (AND (ZEROP (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA)) (ZEROP (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA)))) (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) " " (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) " translate" :EOL))) (* ;; "Clipping region:") (POSTSCRIPT.PUTCOMMAND STREAM " " (fetch (REGION HEIGHT) of CLIP) " " (fetch (REGION WIDTH) of CLIP) " " (fetch (REGION LEFT) of CLIP) " " (fetch (REGION BOTTOM) of CLIP) " CLP" :EOL) (* ;; "And force recaching of location and font.") (replace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with T) (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with T))) -) (\STRINGWIDTH.PSC - [LAMBDA (STREAM STR RDTBL) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) - (\STRINGWIDTH.GENERIC STR (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA) - RDTBL - (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA]) (\SWITCHFONTS.PSC - [LAMBDA (STREAM POSTSCRIPTDATA) (* ; "Edited 23-May-93 12:04 by rmk:") - (* ; "Edited 11-May-93 02:11 by jds") - - (* ;; "Actually emit the PS commands to change the font. If the new font hasn't been used (on this page) before, re-encode it to support accented characters.") - - (LET* [(FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of POSTSCRIPTDATA)) - (FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR - OTHERDEVICEFONTPROPS - ) of FONT) - 'PSCFONT] - [COND - [(LISTP FONTID) - [COND - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of POSTSCRIPTDATA))) - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - *POSTSCRIPT-UNACCENTED-FONTS*)) - (T - (* ;; - "This font hasn't been used on this page yet. Re-encode it to include accented characters.") - - (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch (FONTID FONTIDNAME) of - FONTID) - " /" - (CONCAT (fetch (FONTID FONTIDNAME) of FONTID) - "-Acnt") - " encodefont" :EOL) - (CL:PUSH (fetch (FONTID FONTIDNAME) of FONTID) - (FFETCH (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) OF POSTSCRIPTDATA] - (COND - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - *POSTSCRIPT-UNACCENTED-FONTS*) - (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF POSTSCRIPTDATA - WITH NIL) - (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch (FONTID FONTIDNAME) of FONTID) - " findfont [" - (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 " - (TIMES (fetch (FONTID FONTOBLIQUEFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " " - (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 0] makefont setfont" :EOL)) - (T (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF POSTSCRIPTDATA - WITH T) - (POSTSCRIPT.PUTCOMMAND STREAM "/" (CONCAT (fetch (FONTID FONTIDNAME) - of FONTID) - "-Acnt") - " findfont [" - (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 " - (TIMES (fetch (FONTID FONTOBLIQUEFACTOR) of FONTID) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " " - (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - 100) - " 0 0] makefont setfont" :EOL] - (T [COND - ((MEMB FONTID (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of - POSTSCRIPTDATA - ))) - ((MEMB FONTID *POSTSCRIPT-UNACCENTED-FONTS*)) - (T - (* ;; - "This font hasn't been used on this page yet. Re-encode it to include accented characters.") - - (POSTSCRIPT.PUTCOMMAND STREAM "/" FONTID " /" (CONCAT FONTID "-Acnt") - " encodefont" :EOL) - (CL:PUSH FONTID (FFETCH (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) OF - POSTSCRIPTDATA - ] - (COND - ((MEMB FONTID *POSTSCRIPT-UNACCENTED-FONTS*) - (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of POSTSCRIPTDATA - with NIL) - (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) - of FONT) - 100) - " /" FONTID " F" :EOL)) - (T (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of POSTSCRIPTDATA - with T) - (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) - of FONT) - 100) - " /" - (CONCAT FONTID "-Acnt") - " F" :EOL] - (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of POSTSCRIPTDATA with - NIL]) (\TERPRI.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (NEWY (PLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of IMAGEDATA] - (COND - ([LESSP NEWY (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of - IMAGEDATA - ) - (fetch (FONTDESCRIPTOR \SFDescent) of (ffetch - (\POSTSCRIPTDATA - POSTSCRIPTFONT) - of IMAGEDATA] - (DSPNEWPAGE STREAM)) - (T (replace (STREAM CHARPOSITION) of STREAM with 0) - (\MOVETO.PSC STREAM (ffetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) - of IMAGEDATA) - NEWY))) - NIL]) ) (* ;; "DIG operations: ") (DEFINEQ (\BITBLT.PSC - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) - (* ; "Edited 7-Apr-89 19:53 by TAL") - (\SCALEDBITBLT.PSC SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT - DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION - CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM 1]) (\BLTSHADE.PSC - [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - - (* ;; "Maybe we should do something with OPERATION") - - (LET ((RGN (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT)) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - TEXTUREBM TEXTUREWIDTH LEFT BOTTOM WIDTH HEIGHT) - [COND - [CLIPPINGREGION (SETQ RGN (INTERSECTREGIONS RGN CLIPPINGREGION (fetch ( - \POSTSCRIPTDATA - - POSTSCRIPTCLIPPINGREGION - ) of - IMAGEDATA] - (T (SETQ RGN (INTERSECTREGIONS RGN (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA] - (COND - (RGN (SETQ LEFT (fetch (REGION LEFT) of RGN)) - (SETQ BOTTOM (fetch (REGION BOTTOM) of RGN)) - (SETQ WIDTH (CL:1- (fetch (REGION WIDTH) of RGN))) - (SETQ HEIGHT (CL:1- (fetch (REGION HEIGHT) of RGN))) - [COND - ((FIXP TEXTURE) - (SETQ TEXTURE (SELECT TEXTURE ((BLACKSHADE -1) - 0.0) - (WHITESHADE 1.0) - TEXTURE] - [COND - ((AND (FLOATP TEXTURE) - (<= 0.0 TEXTURE 1.0)) - (POSTSCRIPT.PUTCOMMAND STREAM HEIGHT " " WIDTH " " LEFT " " BOTTOM " " - TEXTURE " R" :EOL)) - ((OR (TEXTUREP TEXTURE) - (NULL TEXTURE)) - (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) - (SETQ TEXTUREWIDTH 16) - (BLTSHADE TEXTURE TEXTUREBM)) - ((BITMAPP TEXTURE) - (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) - (fetch BITMAPHEIGHT of TEXTUREBM))) - (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) - (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE] - (COND - (TEXTUREBM (POSTSCRIPT.PUTCOMMAND STREAM "gsave newpath ") - (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale " (QUOTIENT LEFT 100.0) - " " - (QUOTIENT BOTTOM 100.0) - " M " - (SETQ WIDTH (QUOTIENT WIDTH 100.0)) - " 0 rlineto 0 " - (QUOTIENT HEIGHT 100.0) - " rlineto " - (MINUS WIDTH) - " 0 rlineto closepath" :EOL) - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) - (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " - (LSH (fetch BITMAPRASTERWIDTH of TEXTUREBM) - 1) - " 0 " - (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) - 100.0)) - " findresolution " TEXTUREWIDTH " div div ceiling " - POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" - :EOL))) - (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) - T) - (T NIL]) (\CHARWIDTH.PSC - [LAMBDA (STREAM CHARCODE) (* ; "Edited 8-May-93 11:19 by rmk:") - (COND - ((EQ CHARCODE (CHARCODE SPACE)) - (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of (ffetch (STREAM IMAGEDATA) - of STREAM))) - ((\FGETCHARWIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of (ffetch (STREAM - IMAGEDATA - ) - of STREAM)) - CHARCODE]) (\CREATECHARSET.PSC - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 8-May-93 22:55 by rmk:") - (LET* ((CSINFO (CREATE CHARSETINFO - OFFSETS _ NIL)) - (WIDTHS (FETCH (CHARSETINFO WIDTHS) OF CSINFO))) - (REPLACE (CHARSETINFO IMAGEWIDTHS) OF CSINFO WITH WIDTHS) - - (* ;; "Make imagewidths point to widths. Shouldn't matter to anyone, since imagewidths really has to do with bitmaps etc. But...") - - (CL:UNLESS (EQ CHARSET 0) - - (* ;; "For all charsets other than 0, initialize widths with width of black box=average char width. We know that the AVGCHARWIDTH field of the FONTDESC will eventually be the width of A, but that might not be filled in when this is executed inside POSTSCRIPT.FONTCREATE--it's only after the return to FONTCREATE itself that this gets filled in. However, we do know that charset 0 is all set up before any other characters are dealt with.") - - (FOR I (AVGCHARWIDTH _ (CHARWIDTH (CHARCODE A) - FONTDESC)) FROM 0 TO 255 - FIRST (CL:WHEN (EQ 0 AVGCHARWIDTH) - - (* ;; - "This is what \AVGCHARWIDTH in FONT does, but we don't have it here. Just to be extremely safe.") - - [SETQ AVGCHARWIDTH (MAX 1 (FIXR (FTIMES 0.6 (FONTPROP FONTDESC - 'HEIGHT]) - DO (\FSETWIDTH WIDTHS I AVGCHARWIDTH))) - CSINFO]) (\DRAWARC.PSC - [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH)) - ((LISTP BRUSH) - (COND - ((NEQ (fetch BRUSHSHAPE of BRUSH) - 'ROUND) - (printout T T - "[In \DRAWARC.PSC: Non-ROUND BRUSH not supported.] -[Using ROUND BRUSH]" T))) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T (* ; - "If FUNCTIONAL BRUSH big trouble!") - (printout T T - "[In \DRAWARC.PSC: Functional BRUSH not supported.] -[Using ROUND 1 point BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - (* ; - "COLOR is specified in POSTSCRIPT setgray notation.") - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ")) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL) - (* ; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") - )) - (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " - CENTERX " " CENTERY " " RADIUS " " STARTANGLE " " (+ STARTANGLE NDEGREES) - " arc stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWCIRCLE.PSC - [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH)) - ((LISTP BRUSH) - (COND - ((NEQ (fetch BRUSHSHAPE of BRUSH) - 'ROUND) - (printout T T - "[In \DRAWCIRCLE.PSC: Non-ROUND BRUSH not supported.] -[Using ROUND BRUSH]" T))) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T (* ; - "If FUNCTIONAL BRUSH big trouble!") - (printout T T - "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - (* ; - "COLOR is specified in POSTSCRIPT setgray notation.") - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ")) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL) - (* ; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") - )) - (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " - CENTERX " " CENTERY " " RADIUS " 0 360 arc stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWCURVE.PSC - [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH) - (SETQ SHAPE 'ROUND)) - ((LISTP BRUSH) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T - (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") - - (printout T T - "[In \DRAWCURVE.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - (SETQ SHAPE 'ROUND] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - - (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") - - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ") - - (* ;; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") -) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL))) - (SETQ PSPLINE (PARAMETRICSPLINE KNOTS CLOSED NIL)) - (SETQ N (pop PSPLINE)) - (SETQ XA (pop PSPLINE)) - (SETQ YA (pop PSPLINE)) - (SETQ DXA (pop PSPLINE)) - (SETQ DYA (pop PSPLINE)) - (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE - (ROUND " 1 setlinecap 1 setlinejoin ") - (SQUARE " 2 setlinecap 0 setlinejoin ") - " 0 setlinecap 0 setlinejoin ") - WIDTH " setlinewidth " (SETQ PREVX (ELT XA 1)) - " " - (SETQ PREVY (ELT YA 1)) - " M" :EOL) - (SETQ PREV-DX3 (FQUOTIENT (ELT DXA 1) - 3.0)) - (SETQ PREV-DY3 (FQUOTIENT (ELT DYA 1) - 3.0)) - (for C from 2 to N do (POSTSCRIPT.PUTCOMMAND - STREAM - (FPLUS PREVX PREV-DX3) - " " - (FPLUS PREVY PREV-DY3) - " " - (FDIFFERENCE (SETQ PREVX (ELT XA C)) - (SETQ PREV-DX3 (FQUOTIENT (ELT DXA C) - 3.0))) - " " - (FDIFFERENCE (SETQ PREVY (ELT YA C)) - (SETQ PREV-DY3 (FQUOTIENT (ELT DYA C) - 3.0))) - " " PREVX " " PREVY " curveto" :EOL)) - (POSTSCRIPT.PUTCOMMAND STREAM "stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM PREVX PREVY)) - NIL]) (\DRAWELLIPSE.PSC - [LAMBDA (STREAM CENTERX CENTERY MINORRADIUS MAJORRADIUS ORIENTATION BRUSH DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH)) - ((LISTP BRUSH) - (COND - ((NEQ (fetch BRUSHSHAPE of BRUSH) - 'ROUND) - (printout T T - "[In \DRAWELLIPSE.PSC: Non-ROUND BRUSH not supported.] -[Using ROUND BRUSH]" T))) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T (* ; - "If FUNCTIONAL BRUSH, big trouble!") - (printout T T - "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - (* ; - "COLOR is specified in POSTSCRIPT setgray notation.") - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ") - - (* ;; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") -) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL))) - (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " - CENTERX " " CENTERY " " MAJORRADIUS " " MINORRADIUS " " ORIENTATION - " 0 360 ellipse stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWLINE.PSC - [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - - (* ;; "DRAWLINE method for postscript streams.") - - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - [COND - ((NOT (NUMBERP WIDTH)) - - (* ;; "The WIDTH = NIL should have been handled before here, but just in case!") - - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] - [COND - ((NOT (ZEROP WIDTH)) - (COND - ((LESSP X2 X1) - - (* ;; "For Syntelligence, make all lines move from left to right, to defeat a bug in SPARCPrinter PS decoder.") - - (\DRAWLINE.PSC STREAM X2 Y2 X1 Y1 WIDTH OPERATION COLOR DASHING)) - ((NOT (OR (FLOATP COLOR) - (LISTP DASHING))) (* ; "Simple case, no dash or gray") - (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " L" :EOL)) - (T (* ; - "COLOR is interpreted as gray factor") - (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " " - (OR (FLOATP COLOR) - "0") - " [") - (for D in (LISTP DASHING) do - - (* ;; - "Interlisp DASHING is in terms of BRUSH units, so multiply by the brush size.") - - (POSTSCRIPT.PUTCOMMAND STREAM - (TIMES D WIDTH) - " ")) - (POSTSCRIPT.PUTCOMMAND STREAM "] L1" :EOL] - (replace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with X2) - (freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA with Y2) - (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with NIL]) (\DRAWPOINT.PSC - [LAMBDA (STREAM X Y BRUSH OPERATION) (* ; "Edited 30-Mar-90 17:53 by Matt Heffron") - - (* ;; "draw a point on the stream ") - - (if (BITMAPP BRUSH) - then (LET ((WIDTH (fetch BITMAPWIDTH of BRUSH)) - (HEIGHT (fetch BITMAPHEIGHT of BRUSH))) - (BITBLT BRUSH 0 0 STREAM (- X (IQUOTIENT WIDTH 2)) - (- Y (IQUOTIENT HEIGHT 2)) - WIDTH HEIGHT OPERATION)) - else (\DRAWLINE.PSC STREAM X Y X Y BRUSH OPERATION]) (\DRAWPOLYGON.PSC - [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING)(* ; - "Edited 20-Nov-92 15:17 by sybalsky:mv:envos") - (LET ((LASTPOINT (CAR (LAST POINTS))) - (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - WIDTH SHAPE COLOR) - [COND - ((NUMBERP BRUSH) - (SETQ WIDTH BRUSH) - (SETQ SHAPE 'ROUND)) - ((LISTP BRUSH) - (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) - (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) - (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) - (T - (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") - - (printout T T - "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.] -[Using (ROUND 1) BRUSH]" T) - (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - (SETQ SHAPE 'ROUND] - (COND - ((NOT (ZEROP WIDTH)) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (COND - ((FLOATP COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") - - (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") - - )) - (COND - ((LISTP DASHING) - (POSTSCRIPT.OUTSTR STREAM " [") - (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) - " ") - - (* ;; - "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") -) - (POSTSCRIPT.PUTCOMMAND STREAM "] 0 setdash" :EOL))) - (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE - (ROUND " 1 setlinecap 1 setlinejoin ") - (SQUARE " 2 setlinecap 0 setlinejoin ") - " 0 setlinecap 0 setlinejoin ") - WIDTH " setlinewidth " (fetch (POSITION XCOORD) of (CAR POINTS)) - " " - (fetch (POSITION YCOORD) of (CAR POINTS)) - " M" :EOL) - (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM - (fetch (POSITION XCOORD) of P) - " " - (fetch (POSITION YCOORD) of P) - " lineto" :EOL)) - (COND - (CLOSED (POSTSCRIPT.PUTCOMMAND STREAM " closepath"))) - (POSTSCRIPT.PUTCOMMAND STREAM " stroke" :EOL "grestore" :EOL))) - (\MOVETO.PSC STREAM (fetch (POSITION XCOORD) of LASTPOINT) - (fetch (POSITION YCOORD) of LASTPOINT]) (\DSPBOTTOMMARGIN.PSC - [LAMBDA (STREAM YPOSITION) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of (fetch (STREAM IMAGEDATA) - of STREAM)) - (COND - (YPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) - of (fetch (STREAM IMAGEDATA) of STREAM) with YPOSITION))))]) (\DSPCLIPPINGREGION.PSC - [LAMBDA (STREAM REGION) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDCLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA))) - (COND - ([AND REGION (NOT (AND (EQP (fetch (REGION LEFT) of OLDCLIP) - (fetch (REGION LEFT) of REGION)) - (EQP (fetch (REGION BOTTOM) of OLDCLIP) - (fetch (REGION BOTTOM) of REGION)) - (EQP (fetch (REGION WIDTH) of OLDCLIP) - (fetch (REGION WIDTH) of REGION)) - (EQP (fetch (REGION HEIGHT) of OLDCLIP) - (fetch (REGION HEIGHT) of REGION] - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with - REGION) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) - (\FIXLINELENGTH.PSC STREAM IMAGEDATA))) - OLDCLIP]) (\DSPCOLOR.PSC - [LAMBDA (STREAM COLOR) (* ; "Edited 14-Jan-93 17:14 by jds") - - (* ;; - "Postscript %"color%" setter -- really sets gray shade for now. 0.0 = black, 1.0 = white.") - - (POSTSCRIPT.SHOWACCUM STREAM) - (PROG1 (FETCH (\POSTSCRIPTDATA POSTSCRIPTCOLOR) OF (FETCH (STREAM IMAGEDATA) - OF STREAM)) - (COND - ((AND (NUMBERP COLOR) - (<= 0 COLOR 1)) - (REPLACE (\POSTSCRIPTDATA POSTSCRIPTCOLOR) OF (FETCH (STREAM IMAGEDATA) - OF STREAM) WITH COLOR) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL COLOR " setgray ")) - (COLOR (\ILLEGAL.ARG COLOR))))]) (\DSPFONT.PSC - [LAMBDA (STREAM FONT) (* ; - "Edited 26-May-93 01:06 by sybalsky:mv:envos") - (* ; "Edited 11-May-93 02:11 by jds") - (* ; "Edited 19-Jan-93 17:17 by jds") - - (* ;; "Change fonts on the PostScript stream STREAM to be FONT.") - - (* ;; "Doesn't actually write the font-change command to the stream (it saves doing that until the font is actually needed, so that multiple font changes don't yield larger PS files).") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFONT (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) - NEWFONT FONTID) - (COND - ((AND FONT (SETQ NEWFONT (OR (\COERCEFONTDESC FONT STREAM) - (FONTCOPY OLDFONT FONT))) - (type? FONTDESCRIPTOR NEWFONT) - (NEQ NEWFONT OLDFONT)) - - (* ;; "OK, it's a good font.") - - (POSTSCRIPT.SHOWACCUM STREAM) (* ; - " Write out any accumulated characters.") - - (* ;; "Change the font in the Lisp stream:") - - (replace (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA with NEWFONT) - - (* ;; "and now update all font-dependent fields in the imagedata, EXCEPT POSTSCRIPTSPACEWIDTH and POSTSCRIPTNATURALSPACEWIDTH. These latter 2 must stay as-is up thru the actual writing of characters by SHOWACCUM, so") - - (\POSTSCRIPT.CHANGECHARSET IMAGEDATA 0) - (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of - NEWFONT))) - [replace (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA - with (FIXR (TIMES (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) - of IMAGEDATA) - (replace (\POSTSCRIPTDATA POSTSCRIPTNATURALSPACEWIDTH) - of IMAGEDATA with (\FGETWIDTH (fetch - (\POSTSCRIPTDATA - POSTSCRIPTWIDTHS) - of IMAGEDATA) - (CHARCODE SPACE] - (\FIXLINELENGTH.PSC STREAM IMAGEDATA) - [SETQ FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR - - OTHERDEVICEFONTPROPS - ) of - NEWFONT - ) - 'PSCFONT] - (COND - ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) - *POSTSCRIPT-UNACCENTED-FONTS*) - (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF IMAGEDATA WITH NIL)) - (T (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of IMAGEDATA with - T))) - - (* ;; "Remember to actually write a change command") - - (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with - T))) - OLDFONT]) (\DSPLEFTMARGIN.PSC - [LAMBDA (STREAM XPOSITION) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - (COND - (XPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA - with XPOSITION) - (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) (\DSPLINEFEED.PSC - [LAMBDA (STREAM LINELEADING) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of (fetch (STREAM IMAGEDATA) - of STREAM)) - (COND - (LINELEADING (replace (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) - of (fetch (STREAM IMAGEDATA) of STREAM) with LINELEADING)) - ))]) (\DSPPUSHSTATE.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (push (fetch (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of IMAGEDATA) - (create POSTSCRIPTXFORM - PSXCLIP _ (COPY (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA)) - PSXPAGE _ (COPY (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of - IMAGEDATA)) - PSXLEFT _ (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - PSXRIGHT _ (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA - ) - PSXTOP _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - PSXBOTTOM _ (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of - IMAGEDATA - ) - PSXTRANX _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) - PSXTRANY _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) - PSXLAND _ (fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) - PSXXFORMPEND _ (fetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) - of IMAGEDATA]) (\DSPPOPSTATE.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:15 by sybalsky:mv:envos") - (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (XFORM (pop (fetch (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of IMAGEDATA] - (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXCLIP) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXPAGE) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXBOTTOM) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXTOP) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXLEFT) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXRIGHT) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXLAND) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA - with (fetch (POSTSCRIPTXFORM PSXXFORMPEND) of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA with - (fetch ( - POSTSCRIPTXFORM - PSXTRANX) - of XFORM)) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA with - (fetch ( - POSTSCRIPTXFORM - PSXTRANY) - of XFORM]) (\DSPRESET.PSC - [LAMBDA (STREAM) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (replace (STREAM CHARPOSITION) of STREAM with 0) - (\MOVETO.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - (FONTPROP (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA) - 'ASCENT]) (\DSPRIGHTMARGIN.PSC - [LAMBDA (STREAM XPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) - (COND - (XPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA - with XPOSITION) - (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) (\DSPROTATE.PSC - [LAMBDA (STREAM ROTATION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "rotate the postscript stream by ROTATION") - - (* ;; - "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OROT (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA)) - LAND C0 P0 C P ML MB MR MT) - (COND - ((AND ROTATION (NEQ ROTATION (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) - of IMAGEDATA))) - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA with ROTATION) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) - (\DSPRESET.PSC STREAM))) - OROT]) (\DSPSCALE.PSC - [LAMBDA (STREAM SCALE) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - NSCALE) - (COND - ((AND NIL - - (* ;; "Changing SCALE is not implemented. According to IRM.") - - (NUMBERP SCALE) - (CL:PLUSP SCALE)) - (SETQ NSCALE (QUOTIENT SCALE OSCALE)) - - (* ;; - "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.") - - (POSTSCRIPT.PUTCOMMAND STREAM " " NSCALE " " NSCALE " scale" :EOL) - (replace (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA with SCALE))) - OSCALE]) (\DSPSCALE2.PSC - [LAMBDA (STREAM X-SCALE Y-SCALE) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "SETS X AND Y SCALE ") - - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) - NSCALE) - (COND - ((AND X-SCALE (NUMBERP X-SCALE) - (CL:PLUSP X-SCALE)) - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - - (* ;; - "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.") - - (POSTSCRIPT.PUTCOMMAND STREAM " " X-SCALE " " Y-SCALE " scale" :EOL))) - T]) (\DSPSPACEFACTOR.PSC - [LAMBDA (STREAM FACTOR) (* ; - "Edited 26-May-93 01:18 by sybalsky:mv:envos") - (DECLARE (LOCALVARS . T)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFACTOR (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA))) - [COND - ((AND (NUMBERP FACTOR) - (NOT (EQUAL FACTOR OLDFACTOR))) - (POSTSCRIPT.SHOWACCUM STREAM) - (replace (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA with FACTOR) - (replace (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA - with (FIXR (TIMES FACTOR (ffetch (\POSTSCRIPTDATA - POSTSCRIPTNATURALSPACEWIDTH) - of IMAGEDATA] - OLDFACTOR]) (\DSPTOPMARGIN.PSC - [LAMBDA (STREAM YPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of (fetch (STREAM IMAGEDATA) - of STREAM)) - (COND - (YPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of (fetch - (STREAM IMAGEDATA) - of STREAM) - with YPOSITION))))]) (\DSPTRANSLATE.PSC - [LAMBDA (STREAM TX TY) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (MDX (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) - TX)) - (MDY (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) - TY))) - (COND - ((NOT (AND (ZEROP MDX) - (ZEROP MDY))) - (POSTSCRIPT.SHOWACCUM STREAM) - (for REG in (LIST (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) - of IMAGEDATA) - (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) - of IMAGEDATA)) do (CL:INCF (fetch (REGION - LEFT) - of REG) - MDX) - (CL:INCF (fetch (REGION - BOTTOM) - of REG) - MDY)) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - MDX) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) - MDY) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) - MDX) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) - MDX) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) - MDY) - (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) - MDY) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA with TX) - (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA with TY) - (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T]) (\DSPXPOSITION.PSC - [LAMBDA (STREAM XPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - OLDX) - (PROG1 (SETQ OLDX (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) - [COND - ((AND XPOSITION (NOT (EQUAL XPOSITION OLDX))) - (\MOVETO.PSC STREAM XPOSITION (fetch (\POSTSCRIPTDATA POSTSCRIPTY) - of IMAGEDATA])]) (\DSPYPOSITION.PSC - [LAMBDA (STREAM YPOSITION) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - OLDY) - (PROG1 (SETQ OLDY (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA)) - (COND - ((AND YPOSITION (NOT (EQUAL YPOSITION OLDY))) - (\MOVETO.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - YPOSITION))))]) (\FILLCIRCLE.PSC - [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 30-Mar-90 17:59 by Matt Heffron") - (LET (TEXTUREBM TEXTUREWIDTH) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (if (FIXP TEXTURE) - then (if (ZEROP TEXTURE) - then (SETQ TEXTURE 1.0) (* ; "The setgray version of white") - elseif (OR (EQL TEXTURE 65535) - (EQL TEXTURE -1)) - then (SETQ TEXTURE 0.0) (* ; "The setgray version of black") - )) - (if (FLOATP TEXTURE) - then - - (* ;; - "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.") - - (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ") - elseif (OR (TEXTUREP TEXTURE) - (NULL TEXTURE)) - then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) - (SETQ TEXTUREWIDTH 16) - (BLTSHADE TEXTURE TEXTUREBM) - elseif (BITMAPP TEXTURE) - then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) - (fetch BITMAPHEIGHT of TEXTUREBM))) - (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) - (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) - (POSTSCRIPT.PUTCOMMAND STREAM " " CENTERX " " CENTERY " " RADIUS " 0 360 arc" :EOL) - (if TEXTUREBM - then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ") - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) - (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch - BITMAPRASTERWIDTH - of TEXTUREBM) - 1) - " 0 " - (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) - 100.0)) - " findresolution " TEXTUREWIDTH " div div ceiling " - POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" :EOL) - else (POSTSCRIPT.PUTCOMMAND STREAM " eofill" :EOL "grestore" :EOL)) - (\MOVETO.PSC STREAM CENTERX CENTERY]) (\FILLPOLYGON.PSC - [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER) - (* ; - "Edited 20-Nov-92 15:17 by sybalsky:mv:envos") - (DECLARE (SPECVARS FILL.WRULE)) - - (* ;; "OPERATION is ignored here") - - (LET ((LASTPOINT (CAR (LAST KNOTS))) - TEXTUREBM TEXTUREWIDTH) - (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") - (if (NOT (OR (ZEROP WINDNUMBER) - (EQL WINDNUMBER 1))) - then (SETQ WINDNUMBER FILL.WRULE)) - (if (FIXP TEXTURE) - then (if (ZEROP TEXTURE) - then (SETQ TEXTURE 1.0) (* ; "The setgray version of white") - elseif (OR (EQL TEXTURE 65535) - (EQL TEXTURE -1)) - then (SETQ TEXTURE 0.0) (* ; "The setgray version of black") - )) - (if (FLOATP TEXTURE) - then - - (* ;; - "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.") - - (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ") - elseif (OR (TEXTUREP TEXTURE) - (NULL TEXTURE)) - then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) - (SETQ TEXTUREWIDTH 16) - (BLTSHADE TEXTURE TEXTUREBM) - elseif (BITMAPP TEXTURE) - then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM) - (fetch BITMAPHEIGHT of TEXTUREBM))) - (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1)) - (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE)) - (POSTSCRIPT.PUTCOMMAND STREAM (fetch (POSITION XCOORD) of (CAR KNOTS)) - " " - (fetch (POSITION YCOORD) of (CAR KNOTS)) - " M" :EOL) - (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch - (POSITION XCOORD) - of K) - " " - (fetch (POSITION YCOORD) of K) - " lineto" :EOL)) - (POSTSCRIPT.PUTCOMMAND STREAM " closepath" :EOL) - (if TEXTUREBM - then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ") - (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T) - (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch - BITMAPRASTERWIDTH - of TEXTUREBM) - 1) - " 0 " - (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM) - 100.0)) - " findresolution " TEXTUREWIDTH " div div ceiling " - POSTSCRIPT.TEXTURE.SCALE " mul setpattern")) - (POSTSCRIPT.PUTCOMMAND STREAM (if (ZEROP WINDNUMBER) - then " fill" - else " eofill") - :EOL "grestore" :EOL) - (\MOVETO.PSC STREAM (fetch (POSITION XCOORD) of LASTPOINT) - (fetch (POSITION YCOORD) of LASTPOINT]) (\FIXLINELENGTH.PSC - [LAMBDA (STREAM IMAGEDATA) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "Called by margin, font or rotation change to update the LINELENGTH field in the stream.") - - (LET [(TMP (MIN MAX.SMALLP (FIX (QUOTIENT (DIFFERENCE (fetch (\POSTSCRIPTDATA - POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA) - (ffetch (\POSTSCRIPTDATA - POSTSCRIPTLEFTMARGIN) - of IMAGEDATA)) - (fetch FONTAVGCHARWIDTH of (ffetch - (\POSTSCRIPTDATA - POSTSCRIPTFONT) - of IMAGEDATA] - (replace (STREAM LINELENGTH) of STREAM with (COND - ((GREATERP TMP 1) - TMP) - (T 10]) (\MOVETO.PSC - [LAMBDA (STREAM X Y) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) - (COND - ([NOT (AND (EQP X (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) - (EQP Y (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA] - (POSTSCRIPT.SHOWACCUM STREAM) - (freplace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with X) - (freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA with Y) - (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with T]) (\NEWPAGE.PSC - [LAMBDA (STREAM) (* ; "Edited 5-Apr-89 17:31 by TAL") - (POSTSCRIPT.ENDPAGE STREAM) - (POSTSCRIPT.STARTPAGE STREAM]) ) (* ;; "Character-output, plus special-cases:") (DEFINEQ (\POSTSCRIPT.CHANGECHARSET - [LAMBDA (PSDATA CHARSET) (* ; "Edited 29-Apr-93 13:51 by rmk:") - - (* ;; -"Called when the character set information cached in a display stream doesn't correspond to CHARSET") - - (PROG* ((FONT (ffetch POSTSCRIPTFONT of PSDATA)) - (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 POSTSCRIPTWIDTHS of PSDATA with (ffetch (CHARSETINFO WIDTHS) - of CSINFO)) - (freplace POSTSCRIPTNSCHARSET of PSDATA with CHARSET))]) (\POSTSCRIPT.OUTCHARFN - [LAMBDA (STREAM CHAR) (* ; "Edited 23-May-93 12:00 by rmk:") - (* ; "Edited 4-May-93 02:20 by jds") - (* ; "Edited 3-Feb-93 00:45 by jds") - -(* ;;; "Output a character to be printed.") - -(* ;;; "Change font if necessary, do newline if at right margin, check for special chars and do appropriate thing, quote char and/or start postscript string if necessary.") - -(* ;;; "This is called a lot, so the code is unrolled for efficiency.") - - (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE) - (LOCALVARS . T)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (XPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) - (FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) - CHARWID NEWXPOS MAPPING) - (CL:UNLESS (EQ (\CHARSET CHAR) - (ffetch POSTSCRIPTNSCHARSET of IMAGEDATA)) - - (* ;; "Switch character set so that we get the right char width.") - - (\POSTSCRIPT.CHANGECHARSET IMAGEDATA (\CHARSET CHAR))) - [SETQ CHARWID (SELCHARQ CHAR - (SPACE (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of - IMAGEDATA - )) - (\FGETWIDTH (ffetch (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) of - IMAGEDATA - ) - (\CHAR8CODE CHAR] - - (* ;; "POSTSCRIPTACCENTED true if font has accented rendering characters in it; otherwise, a c-set 0 special font (SYMBOL, ZAPFDINGBATS...)") - - [COND - [[OR (NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of IMAGEDATA)) - (AND (ILEQ CHAR 254) - (NOT (CL:AREF \POSTSCRIPT.CHARTYPE CHAR] - - (* ;; "OR is NIL if char is special in any way: Either font isn't supposed to be treated as an NS font (e.g. ZapfDingbats, which uses all the legal char positions for its own), or char itself is in cset 0 and ordinary") - - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - CHARWID] - (CL:UNLESS (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with - T)) - (COND - [(ILESSP CHAR (CHARCODE " ")) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - [(IGEQ CHAR 127) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - (T (SELCHARQ CHAR - ((%( %) \) - (BOUT STREAM (CHARCODE \)) - (BOUT STREAM CHAR)) - (BOUT STREAM CHAR] - [(SETQ MAPPING (GETHASH CHAR *POSTSCRIPT-NS-HASH*)) - (* ; - "Special character that's taken care of by the NS mapping.") - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) - CHARWID] - (SELECTQ (CAR MAPPING) - (NIL - (* ;; "just a remap within the lower 256. But the code in (CDR MAPPING) is in charset 2 to prevent recursion") - - (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING))) - (SYMBOL - (* ;; "Its in the SYMBOL font. Symbol is specified as %"2,xxx%" rather than %"0,xxx%" to defeat translations to symbol that go to matching character codes.") - - (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING) - 'SYMBOL)) - (ACCENT (* ; "Special accent mapping we did") - (\POSTSCRIPT.ACCENTFN STREAM (CADR MAPPING))) - (ACCENTPAIR (* ; - "Given base char & accent, overlap them.") - (\POSTSCRIPT.ACCENTPAIR STREAM (CADR MAPPING) - (CADDR MAPPING) - (CADDDR MAPPING))) - (DINGBAT (* ; "A Zapf dingbat") - (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING) - 'ZAPFDINGBATS)) - (APPLY* (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - - (* ;; "User function can call any stream operations it wants. At the end, we guarantee that baseline hasn't changed and that xpos is where the widthset it would be.") - - [freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA - with (PROG1 (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) OF - IMAGEDATA - ) - (APPLY* (CADDR MAPPING) - STREAM - (CADR MAPPING)))]) - (FUNCTION (* ; "Done as special PS code.") - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - (POSTSCRIPT.OUTSTR STREAM (CADR MAPPING))) - (\ILLEGAL.ARG (CAR MAPPING] - (T (* ; "Special char") - (SELCHARQ CHAR - ((EOL LF) - (\TERPRI.PSC STREAM) - - (* ;; - "Set NEWXPOS to current value here and in FF to preserve value after external resetting.") - - (SETQ NEWXPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))) - (FF (DSPNEWPAGE STREAM) - (SETQ NEWXPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))) - (TAB (SETQ NEWXPOS (IPLUS XPOS (\POSTSCRIPTTAB IMAGEDATA))) - [COND - ((IGREATERP NEWXPOS (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of IMAGEDATA) - (\POSTSCRIPTTAB IMAGEDATA] - (\MOVETO.PSC STREAM NEWXPOS (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) - of IMAGEDATA))) - ("357,140" (* ; " Ballot box, checked") - [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of IMAGEDATA) - CHARWID] - (LET ((OLDFONT (\DSPFONT.PSC STREAM))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\DSPFONT.PSC STREAM (LIST 'ZAPFDINGBATS (fetch - (FONTDESCRIPTOR - FONTSIZE) - of OLDFONT) - (fetch (FONTDESCRIPTOR - FONTFACE) - of OLDFONT))) - (\UPDATE.PSC STREAM IMAGEDATA) - (POSTSCRIPT.OUTSTR STREAM " bboxchk ") - (\DSPFONT.PSC STREAM OLDFONT))) - (PROGN [COND - ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) - (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) - of IMAGEDATA)) - (\TERPRI.PSC STREAM) - (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) - of IMAGEDATA) - CHARWID] - (COND - ((IGEQ CHAR 255) - - (* ;; "If it's 255 or above and we don't know anything about it, print the black box. Width vector will determine width of box, to maintain consistency.") - - (\POSTSCRIPT.PRINTSLUG STREAM CHAR)) - (T (SETQ CHAR (\CHAR8CODE CHAR)) - (COND - ((NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) - of IMAGEDATA)) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) - of IMAGEDATA with T))) - (BOUT STREAM (CHARCODE \)) - (SELCHARQ CHAR - ((%( %) \) - (BOUT STREAM CHAR)) - (PROGN [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - (freplace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with NEWXPOS) - CHAR]) (\POSTSCRIPT.PRINTSLUG - [LAMBDA (STREAM CHAR) (* ; "Edited 9-May-93 21:55 by rmk:") - (* ; "Edited 4-May-93 02:20 by jds") - (* ; "Edited 3-Feb-93 00:45 by jds") - -(* ;;; "Internal function to display a black box for a missing character. Width is taken from widths vector, so that box and charwidth are always consistent. Caller (\POSTSCRIPT.OUTCHARFN) is responsible for guaranteeing proper caching of widths vector and for measurement and position updating, although \DRAWLINE.PSC also updates position.") - - (DECLARE (LOCALVARS . T)) - (LET ((IMAGEDATA (FETCH (STREAM IMAGEDATA) OF STREAM))) - (\BLTSHADE.PSC BLACKSHADE STREAM (FETCH (\POSTSCRIPTDATA POSTSCRIPTX) OF - IMAGEDATA - ) - (FETCH (\POSTSCRIPTDATA POSTSCRIPTY) OF IMAGEDATA) - (\FGETWIDTH (FFETCH (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) OF IMAGEDATA) - (\CHAR8CODE CHAR)) - (FETCH (FONTDESCRIPTOR \SFAscent) OF (FETCH (\POSTSCRIPTDATA - POSTSCRIPTFONT) - OF IMAGEDATA)) - 'PAINT) - (\MOVETO.PSC STREAM (IPLUS (FETCH (\POSTSCRIPTDATA POSTSCRIPTX) OF IMAGEDATA) - (\FGETWIDTH (FFETCH (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) - OF IMAGEDATA) - (\CHAR8CODE CHAR))) - (FETCH (\POSTSCRIPTDATA POSTSCRIPTY) OF IMAGEDATA]) (\POSTSCRIPT.SPECIALOUTCHARFN - [LAMBDA (STREAM CHAR FAMILY) (* ; "Edited 23-May-93 13:31 by rmk:") - (* ; "Edited 4-May-93 02:20 by jds") - (* ; "Edited 3-Feb-93 00:45 by jds") - -(* ;;; "Internal function to output a special character to be printed, changing font if necessary. Width processing is carried out at higher level. If FAMILY is given, switches to that font (SYMBOL, ZAPFDINGBATS) before printing, then switches back.") - - (DECLARE (LOCALVARS . T)) - (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFONT (AND FAMILY (\DSPFONT.PSC STREAM] - (CL:WHEN OLDFONT - (\DSPFONT.PSC STREAM (LIST FAMILY (fetch (FONTDESCRIPTOR FONTSIZE) of - OLDFONT) - (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT)))) - (CL:UNLESS (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with T)) - [COND - [(ILESSP CHAR (CHARCODE " ")) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - [(IGEQ CHAR 127) - (BOUT STREAM (CHARCODE \)) - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 3 (LRSH CHAR 6] - [BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 (LRSH CHAR 3] - (BOUT STREAM (IPLUS (CHARCODE 0) - (LOGAND 7 CHAR] - (T (SELCHARQ CHAR - ((%( %) \) - (BOUT STREAM (CHARCODE \)) - (BOUT STREAM CHAR)) - (BOUT STREAM CHAR] - (CL:WHEN OLDFONT (\DSPFONT.PSC STREAM OLDFONT)) - CHAR]) (\UPDATE.PSC - [LAMBDA (STREAM IMAGEDATA) (* ; - "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") - - (* ;; "Make any outstanding font, scale, location updates, prepatory to something that might depend heavily on it. (e.g. before starting to output characters, or making a scale change)") - (* ; - "This code was originally in \POSTSCRIPT.OUTCHAR &c, and is here for commonality.") - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA) - (\SETXFORM.PSC STREAM IMAGEDATA))) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA) - (* ; - "If font was changed then switch before printing") - (\SWITCHFONTS.PSC STREAM IMAGEDATA))) - (COND - ((ffetch (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA) - (* ; "likewise for position") - (\SETPOS.PSC STREAM IMAGEDATA]) (\POSTSCRIPT.ACCENTFN - [LAMBDA (STREAM CHAR) (* ; "Edited 28-Apr-93 16:35 by rmk:") - (* ; "Edited 3-Feb-93 01:05 by jds") - -(* ;;; "Output an accented character to be printed. .") - -(* ;;;; "Need to inc CHARPOSITION of STREAM") - - (DECLARE (LOCALVARS . T)) - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) - (COND - ((NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA)) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with T))) - (BOUT STREAM (CHARCODE "\")) - (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING CHAR)) - -3) do (BOUT STREAM CH)) - CHAR]) (\POSTSCRIPT.ACCENTPAIR - [LAMBDA (STREAM CHAR ACCENTS UNDER-ACCENTS) (* ; - "Edited 17-Aug-93 17:02 by sybalskY:MV:ENVOS") - (* ; "Edited 3-Feb-93 01:29 by jds") - -(* ;;; "Output an accented character to be printed. .") - -(* ;;;; "Prints the character as \xxx, with 3 octal digits, to avoid tripping up on EOLs and other postscript-special characters.") - - (DECLARE (LOCALVARS . T)) - (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - (BOUT STREAM (CHARCODE %()) - (BOUT STREAM (CHARCODE "\")) - (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING CHAR)) - -3) do (BOUT STREAM CH)) - (BOUT STREAM (CHARCODE %))) - (BOUT STREAM (CHARCODE %()) - (for ACCENT inside ACCENTS do (BOUT STREAM (CHARCODE "\")) - (for CH - instring (SUBSTRING (CONCAT "000" - (OCTALSTRING - ACCENT)) - -3) - do (BOUT STREAM CH))) - (POSTSCRIPT.PUTCOMMAND STREAM ") (") - (for ACCENT inside UNDER-ACCENTS - do (BOUT STREAM (CHARCODE "\")) - (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING ACCENT)) - -3) do (BOUT STREAM CH))) - (BOUT STREAM (CHARCODE %))) - (COND - (NIL (OR (IEQP ACCENT (CHARCODE "0,313")) - (IEQP ACCENT (CHARCODE "0,316"))) (* ; - "Cedilla and ogonek are under-accents, so don't raise them for capital letters.") - (POSTSCRIPT.PUTCOMMAND STREAM " 0 ")) - ((ILESSP CHAR (CHARCODE a)) (* ; - "upper case, so adjust offset for accent") - (POSTSCRIPT.PUTCOMMAND STREAM " " (/ (fetch \SFAscent of FONT) - 3.0) - " ")) - (T (POSTSCRIPT.PUTCOMMAND STREAM " 0 "))) - (POSTSCRIPT.PUTCOMMAND STREAM " " (FONTPROP FONT 'SIZE) - " ") - (POSTSCRIPT.PUTCOMMAND STREAM " accentor ") - CHAR]) ) (* ;; "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions") (DEFINEQ (\PSC.SPACEDISP - [LAMBDA (STREAM WIDTH) (* ; "Edited 28-Sep-93 13:50 by jds") - (POSTSCRIPT.PUTCOMMAND STREAM (\PSC.SPACEWID (DSPFONT NIL STREAM) - WIDTH) - " 0 rmoveto "]) (\PSC.SPACEWID - [LAMBDA (FONTDESC CHAR) (* ; "Edited 28-Sep-93 13:41 by jds") - - (* ;; "Spacing character with a special width (e.g. M space, thin (1/5-M) space...") - - (* ;; "If CHAR is a list, it's (CHARCODE FACTOR), and we return a width of FACTOR * (CHARWIDTH CHARCODE). Otherwise, we just return the width of CHARCODE.") - - (COND - [(LISTP CHAR) - (FIXR (FTIMES (CADR CHAR) - (CHARWIDTH (CHARCODE.DECODE (CAR CHAR)) - FONTDESC] - (T (CHARWIDTH (CHARCODE.DECODE CHAR) - FONTDESC]) (\PSC.SYMBOLS - [LAMBDA (STREAM CHAR) (* ; "Edited 2-Nov-94 17:01 by jds") - (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) - (OLDFONT (\DSPFONT.PSC STREAM))) - (\DSPFONT.PSC STREAM (LIST 'ZAPFDINGBATS (fetch (FONTDESCRIPTOR FONTSIZE) - of OLDFONT) - (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))) - (POSTSCRIPT.SHOWACCUM STREAM) - (\UPDATE.PSC STREAM IMAGEDATA) - (COND - ((EQUAL CHAR "0,161") - (POSTSCRIPT.OUTSTR STREAM " bboxchk "))) - (\DSPFONT.PSC STREAM OLDFONT]) ) (* ;; "The mapping of NS characters to Postscript renderings, both as an AList and as a hashtable") (DEFINEQ (\POSTSCRIPT.NSHASH - [LAMBDA (MAPPING-LIST) (* ; - "Edited 30-Jul-93 14:46 by sybalskY:MV:ENVOS") - (* ; "Edited 4-May-93 02:21 by jds") - (* ; "Edited 3-Feb-93 00:33 by jds") - (for MAPPING in MAPPING-LIST unless (EQ (CAR MAPPING) - '*) - do (* ; - "Skip comments in the mapping list.") - (LET [(CHARCODE (CHARCODE.DECODE (CAR MAPPING] - - (* ;; "Fill in the translation entry for this character:") - - (PUTHASH CHARCODE - [DESTRUCTURING-BIND - (KIND CODE2 BASECHAR UNDERACCENTS) - (SETQ MAPPING (CDR MAPPING)) - (CONS KIND (SELECTQ KIND - ((SYMBOL NIL DINGBAT) - (CONS (CHARCODE.DECODE CODE2))) - (FUNCTION (CONS CODE2)) - ((ACCENT ACCENTPAIR) - (LIST (CHARCODE.DECODE CODE2) - (CHARCODE.DECODE BASECHAR) - (AND UNDERACCENTS (CHARCODE.DECODE UNDERACCENTS)) - )) - (APPLY* (* ; - "Apply setup function to coerce argument data") - - (* ;; "MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN SETUPFN) PRINTFN gets applied to stream and result of applying SETUPFN to DATA. WIDTHFN gets applied to coerced data and fontdescriptor") - - (LIST (APPLY* (OR (CAR (CDDDDR MAPPING)) - (FUNCTION CL:IDENTITY)) - (CADR MAPPING)) - (CADDR MAPPING) - (CADDDR MAPPING))) - (ERROR "UNRECOGNIZED POSTSCRIPT CHARACTER TYPE" MAPPING] - *POSTSCRIPT-NS-HASH*) - - (* ;; "If this character is in the lower 127, we need to mark it for special handling in \POSTSCRIPT.CHARTYPE, by putting a T in the array at the charcode's position:") - - (CL:WHEN (<= CHARCODE 254) - (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE CHARCODE) - T))]) ) (RPAQQ *POSTSCRIPT-UNACCENTED-FONTS* (Dancer ZapfDingbats "Dancer" "ZapfDingbats")) (RPAQQ *POSTSCRIPT-NS-TRANSLATIONS* ( (* ;; "Mapping of NS characters to Postscript renderings.") (* ;; "First few are for control-codes in old Press fonts (Timesroman, etc.); not strictly NS, but undefined therein so should be OK.") ("^S" NIL "2,320") (* ; "pressfont em dash") ("^V" NIL "2,261") (* ; "pressfont en dash") ("^G" NIL "0,140") ("0,244" NIL "2,250") (* ; "generic currency symbol") ("0,251" NIL "2,140") (* ; "left single quote") ("0,254" SYMBOL "2,254") (* ; "left arrow") ("0,255" SYMBOL "2,255") (* ; "uparrow") ("0,256" SYMBOL "2,256") (* ; "right arrow") ("0,257" SYMBOL "2,257") (* ; "down arrow") ("0,260" SYMBOL "2,260") (* ; "degree") ("0,261" SYMBOL "2,261") (* ; "+/-") ("0,264" SYMBOL "2,264") (* ; "times") ("0,267" NIL "2,264") (* ; "Center-dot") ("0,270" SYMBOL "2,270") (* ; "divide") ("0,271" NIL "2,047") (* ; "right single quote") ("0,274" FUNCTION " f14 ") (* ; "1/4") ("0,275" FUNCTION " f12 ") (* ; "1/2") ("0,276" FUNCTION " f34 ") (* ; "3/4") ("0,322" SYMBOL "2,342") (* ; "registered") ("0,323" SYMBOL "2,343") (* ; "copyright") ("0,324" SYMBOL "2,344") (* ; "tm") ("0,334" FUNCTION " f18 ") (* ; "1/8") ("0,335" FUNCTION " f38 ") (* ; "3/8") ("0,336" FUNCTION " f58 ") (* ; "5/8") ("0,337" FUNCTION " f78 ") (* ; "7/8") ("0,342" NIL "2,235") (* ; "Eth (slashed D?)") ("0,354" NIL "2,237") (* ; "Thorn") ("0,363" NIL "2,236") (* ; "eth") ("0,374" NIL "2,240") (* ; "thorn") ("41,172" DINGBAT "0,110") (* ; "filled star") ("42,42" DINGBAT "0,161") (* ; "ballot-box") ("42,61" APPLY* "0,161" \PSC.SYMBOLS \PSC.SPACEWID NIL) (* ; "Checked ballot-box") ("357,44" NIL "2,261") (* ; "n dash") ("357,45" NIL "2,320") (* ; "m dash") ("357,55" APPLY* "M" \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "M quad") ("357,54" APPLY* "N" \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "N quad") ("357,56" APPLY* "1" \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "FIGURE quad") ("357,57" APPLY* ("M" 0.2) \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "This space (1/5M)") ("357,60" NIL "2,262") (* ; "dagger") ("357,61" NIL "2,263") (* ; "double dagger") ("357,062" SYMBOL "2,361") (* ; "angleright") ("357,063" SYMBOL "2,341") (* ; "angleleft") ("357,70" SYMBOL "2,315") (* ; "perpendicular") ("357,101" NIL "2,275") (* ; "per mil o/oo") ("357,104" ACCENTPAIR "<" NIL "/") (* ; "not less than") ("357,105" ACCENTPAIR ">" "/") (* ; "not greater than") ("357,110" SYMBOL "2,312") (* ; "parallel") ("357,111" SYMBOL "2,315") (* ; "not parallel") ("357,112" SYMBOL "2,316") (* ; "element") ("357,113" SYMBOL "2,317") (* ; "notelement") ("357,114" SYMBOL "2,047") (* ; "suchthat") ("357,115" SYMBOL "2,334") (* ; "implied by, double arrow left") ("357,116" SYMBOL "2,333") (* ; "iff, double arrow") ("357,117" SYMBOL "2,336") (* ; "implies, double arrow right") ("357,120" SYMBOL "2,253") (* ; "double arrow") ("357,121" SYMBOL "2,333") (* ; "double arrow") ("357,122" SYMBOL "2,333") (* ; "l/r arrow") ("357,126" SYMBOL "2,307") (* ; "intersection") ("357,127" SYMBOL "2,310") (* ; "union") ("357,130" SYMBOL "2,312") (* ; "reflexsuperset") ("357,131" SYMBOL "2,315") (* ; "reflexsubset") ("357,132" SYMBOL "2,311") (* ; "propersuperset") ("357,133" SYMBOL "2,314") (* ; "propersubset") ("357,137" SYMBOL "2,313") (* ; "notsubset") ("357,141" SYMBOL "2,306") (* ; "emptyset") ("357,142" SYMBOL "2,305") (* ; "circleplus") ("357,144" SYMBOL "2,304") (* ; "circlemultiply") ("357,146" NIL "2,267") (* ; "bullet") ("357,147" SYMBOL "2,260") (* ;  "center circle (composition), lowered degree") ("357,152" SYMBOL "2,330") (* ; "logicalnot") ("357,154" SYMBOL "2,320") (* ; "angle") ("357,160" SYMBOL "2,136") (* ; "perpendicular") ("357,161" SYMBOL "2,265") (* ; "proportional") ("357,162" SYMBOL "2,272") (* ; "equivalence") ("357,165" SYMBOL "2,362") (* ; "integral") ("357,167" SYMBOL "2,273") (* ; "approxequal") ("357,170" SYMBOL "2,100") (* ; "congruent") ("357,172" SYMBOL "2,345") (* ; "summation") ("357,173" SYMBOL "2,325") (* ; "product") ("357,174" SYMBOL "2,326") (* ; "radical") ("357,242" SYMBOL "2,246") (* ; "florin") ("357,260" SYMBOL "2,351") (* ; "Ceiling, left ") ("357,261" SYMBOL "2,371") (* ; "Ceiling, right") ("357,262" SYMBOL "2,353") (* ; "Floor, left ") ("357,263" SYMBOL "2,373") (* ; "Floor, right") ("357,264" SYMBOL "2,44") (* ; "exists") ("357,265" SYMBOL "2,42") (* ; "forall") ("357,266" SYMBOL "2,331") (* ; "logicaland") ("357,267" SYMBOL "2,332") (* ; "logicalor") ("357,271" SYMBOL "2,321") (* ; "gradient") ("357,272" SYMBOL "2,266") (* ; "partialdiff") ("357,313" SYMBOL "2,252") (* ; "spade") ("357,317" DINGBAT "0,63") (* ; "check") ("357,375" FUNCTION " f13 ") (* ; "1/3") ("357,376" FUNCTION " f23 ") (* ; "2/3") ("361,041" ACCENT "0,4" A) ("361,042" ACCENT "0,1" A) ("361,043" ACCENT "0,2" A) ("361,044" ACCENT "0,6" A) ("361,045" ACCENTPAIR A "0,305") (* ; "A-macron") ("361,046" ACCENTPAIR A "0,306") (* ; "A-breve") ("361,047" ACCENT "0,3" A) ("361,050" ACCENT "0,5" A) ("361,055" ACCENT "0,7" C) ("361,060" ACCENT "0,13" E) ("361,061" ACCENT "0,10" E) ("361,062" ACCENT "0,11" E) ("361,063" ACCENTPAIR E "0,305") (* ; "E-macron") ("361,065" ACCENT "0,12" E) ("361,066" ACCENTPAIR E NIL "0,316") (* ; "E-ogonek") ("361,076" ACCENT "0,17" I) ("361,077" ACCENT "0,14" I) ("361,100" ACCENT "0,15" I) ("361,102" ACCENTPAIR I "0,305") (* ; "I-macron") ("361,104" ACCENT "0,16" I) ("361,114" ACCENT "0,20" N) ("361,117" ACCENT "0,24" O) ("361,120" ACCENT "0,21" O) ("361,121" ACCENT "0,22" O) ("361,122" ACCENT "0,25" O) ("361,123" ACCENTPAIR O "0,305") (* ; "O-macron") ("361,124" ACCENT "0,23" O) ("361,134" ACCENT "0,26" S) ("361,137" ACCENT "0,32" U) ("361,140" ACCENT "0,27" U) ("361,141" ACCENT "0,30" U) ("361,143" ACCENTPAIR U "0,305") (* ; "U-macron") ("361,145" ACCENT "0,31" U) ("361,155" ACCENT "0,33" Y) ("361,160" ACCENT "0,34" Z) ("361,165" ACCENTPAIR Y "0,305") (* ; "Y-macron") ("361,166" ACCENTPAIR "0,341" "0,305") (* ; "AE-macron") ("361,167" ACCENTPAIR "0,352" "0,305") (* ; "OE-macron") ("361,241" ACCENT "0,204" a) ("361,242" ACCENT "0,201" a) ("361,243" ACCENT "0,202" a) ("361,244" ACCENT "0,206" a) ("361,245" ACCENTPAIR a "0,305") (* ; "a-macron") ("361,246" ACCENTPAIR a "0,306") (* ; "a-breve") ("361,247" ACCENT "0,203" a) ("361,250" ACCENT "0,205" a) ("361,255" ACCENT "0,207" c) ("361,260" ACCENT "0,213" e) ("361,261" ACCENT "0,210" e) ("361,262" ACCENT "0,211" e) ("361,263" ACCENTPAIR e "0,305") (* ; "e-macron") ("361,265" ACCENT "0,212" e) ("361,266" ACCENTPAIR e NIL "0,316") (* ; "e-ogonek") ("361,267" ACCENTPAIR e "0,317") (* ; "e-caron") ("361,276" ACCENT "0,217" i) ("361,277" ACCENT "0,214" i) ("361,300" ACCENT "0,215" i) ("361,302" ACCENTPAIR "0,365" "0,305") (* ; "i-macron") ("361,304" ACCENT "0,216" i) ("361,314" ACCENT "0,220" n) ("361,317" ACCENT "0,224" o) ("361,320" ACCENT "0,221" o) ("361,321" ACCENT "0,222" o) ("361,322" ACCENT "0,225" o) ("361,323" ACCENTPAIR o "0,305") (* ; "o-macron") ("361,324" ACCENT "0,223" o) ("361,334" ACCENT "0,226" s) ("361,337" ACCENT "0,232" u) ("361,340" ACCENT "0,227" u) ("361,341" ACCENT "0,230" u) ("361,343" ACCENTPAIR u "0,305") (* ; "u-macron") ("361,344" ACCENTPAIR u "0,306") (* ; "u-breve") ("361,345" ACCENT "0,231" u) ("361,355" ACCENT "0,233" y) ("361,360" ACCENT "0,234" z) ("361,365" ACCENTPAIR y "0,305") (* ; "y-macron") ("361,366" ACCENTPAIR "0,361" "0,305") (* ; "ae-macron") ("361,367" ACCENTPAIR "0,372" "0,305") (* ; "oe-macron") ("361,371" ACCENTPAIR a "0,317") (* ; "a-caron") ("361,375" ACCENTPAIR g "0,317") (* ; "g-caron") (* ;; "Special code assignments for Dictionary of Old English, UToronto:") ("361,370" ACCENTPAIR a ("0,305" "0,306")) (* ; "a - breve-macron") ("361,372" ACCENTPAIR e "0,306") (* ; "e-breve") ("361,373" ACCENTPAIR e "0,305" "0,56") (* ; "e macron underdot") ("361,374" ACCENTPAIR e ("0,305" "0,306")) (* ; "e - breve-macron") ("361,376" ACCENTPAIR "0,365" "0,306") (* ; "i-breve") ("362,242" ACCENTPAIR "0,365" "0,317") (* ; "i-caron") ("362,241" ACCENTPAIR "0,365" ("0,305" "0,306")) (* ; " i - breve-macron") ("362,243" ACCENTPAIR n "0,305") (* ; "n-macron") ("362,244" ACCENTPAIR m "0,305") (* ; "m-macron") ("362,245" ACCENTPAIR o "0,317") (* ; "o-caron") ("362,246" ACCENTPAIR o "0,306") (* ; "o-breve") ("362,247" ACCENTPAIR o ("0,305" "0,306")) (* ; "o - breve-macron") ("362,250" ACCENTPAIR o "0,305" "0,56") (* ; "o-macron underdot") ("362,251" ACCENTPAIR o "0,316") (* ; "o-ogonek") ("362,252" ACCENTPAIR u "0,317") (* ; "u-caron") ("362,253" ACCENTPAIR u ("0,305" "0,306")) (* ; "u - breve-macron") ("362,254" ACCENTPAIR y "0,306") (* ; "y-breve") ("362,256" ACCENTPAIR y "0,317") (* ; "y-caron") ("362,255" ACCENTPAIR y ("0,305" "0,306")) (* ; "y - breve-macron") (* ; "235 = Eth") (* ; "236 = eth") (* ; "237 = Thorn") (* ; "240 = thorn") (* ;; "NS Greek characters") ("46,101" SYMBOL "2,101") (* ; "Alpha") ("46,102" SYMBOL "2,102") (* ; "Beta") ("46,103" SYMBOL 0) (* ; "--empty--") ("46,104" SYMBOL "2,107") (* ; "Gamma") ("46,105" SYMBOL "2,104") (* ; "Delta") ("46,106" SYMBOL "2,105") (* ; "Epsilon") ("46,107" SYMBOL 0) (* ; "Stigma") ("46,110" SYMBOL 0) (* ; "Digamma") ("46,111" SYMBOL "2,132") (* ; "Zeta") ("46,112" SYMBOL "2,110") (* ; "Eta") ("46,113" SYMBOL "2,121") (* ; "Theta") ("46,114" SYMBOL "2,111") (* ; "Iota") ("46,115" SYMBOL "2,113") (* ; "Kappa") ("46,116" SYMBOL "2,114") (* ; "Lambda") ("46,117" SYMBOL "2,115") (* ; "Mu") ("46,120" SYMBOL "2,116") (* ; "Nu") ("46,121" SYMBOL "2,130") (* ; "Xi") ("46,122" SYMBOL "2,117") (* ; "Omicron") ("46,123" SYMBOL "2,120") (* ; "Pi") ("46,124" SYMBOL 0) (* ; "Koppa") ("46,125" SYMBOL "2,122") (* ; "Rho") ("46,126" SYMBOL "2,123") (* ; "Sigma") ("46,127" SYMBOL 0) (* ; "--empty--") ("46,130" SYMBOL "2,124") (* ; "Tau") ("46,131" SYMBOL "2,125") (* ; "Upsilon") ("46,132" SYMBOL "2,106") (* ; "Phi") ("46,133" SYMBOL "2,103") (* ; "Chi") ("46,134" SYMBOL "2,131") (* ; "Psi") ("46,135" SYMBOL "2,132") (* ; "Omega") ("46,141" SYMBOL "2,141") (* ; "alpha") ("46,142" SYMBOL "2,142") (* ; "beta") ("46,143" SYMBOL 0) (* ; "(md beta)") ("46,144" SYMBOL "2,147") (* ; "gamma") ("46,145" SYMBOL "2,144") (* ; "delta") ("46,146" SYMBOL "2,145") (* ; "epsilon") ("46,147" SYMBOL "2,126") (* ; "stigma") ("46,150" SYMBOL 0) (* ; "digamma") ("46,151" SYMBOL "2,172") (* ; "zeta") ("46,152" SYMBOL "2,150") (* ; "eta") ("46,153" SYMBOL "2,161") (* ; "theta") ("46,154" SYMBOL "2,151") (* ; "iota") ("46,155" SYMBOL "2,153") (* ; "kappa") ("46,156" SYMBOL "2,154") (* ; "lambda") ("46,157" SYMBOL "2,155") (* ; "mu") ("46,160" SYMBOL "2,156") (* ; "nu") ("46,161" SYMBOL "2,170") (* ; "xi") ("46,162" SYMBOL "2,157") (* ; "omicron") ("46,163" SYMBOL "2,160") (* ; "pi") ("46,164" SYMBOL 0) (* ; "(koppa)") ("46,165" SYMBOL "2,162") (* ; "rho") ("46,166" SYMBOL "2,163") (* ; "sigma") ("46,167" SYMBOL "2,126") (* ; "(fl sigma)") ("46,170" SYMBOL "2,164") (* ; "tau") ("46,171" SYMBOL "2.165") (* ; "upsilon") ("46,172" SYMBOL "2,146") (* ; "phi") ("46,173" SYMBOL "2,143") (* ; "chi") ("46,174" SYMBOL "2,171") (* ; "psi") ("46,175" SYMBOL "2,167") (* ; "omega") (* ;; "NS Miscellaneous symbols") ("041,142" SYMBOL "2,271") (* ; "notequal") ("041,145" SYMBOL "2,243") (* ; "lessequal") ("041,146" SYMBOL "2,263") (* ; "greaterequal") ("041,147" SYMBOL "2,245") (* ; "infinity") ("041,150" SYMBOL "2,134") (* ; "therefore") ("041,155" SYMBOL "2,262") (* ; "second") ("356,055" SYMBOL "2,055") (* ; "minus") ("356,106" SYMBOL "2,340") (* ; "lozenge") ("356,163" SYMBOL "2,351") (* ; "topleftbracket") ("356,164" SYMBOL "2,353") (* ; "bottomleftbracket") ("356,165" SYMBOL "2,352") (* ; "centerbracket") ("356,166" SYMBOL "2,371") (* ; "toprightbracket") ("356,167" SYMBOL "2,373") (* ; "bottomrightbracket") ("356,176" SYMBOL "2,176") (* ; "similar") ("356,314" SYMBOL "2,251") (* ; "heart") ("356,340" SYMBOL "2,374") (* ; "toprightbracce") ("356,341" SYMBOL "2,357") (* ; "braceextend") ("356,342" SYMBOL "2,375") (* ; "centerrightbracce") ("356,343" SYMBOL "2,376") (* ; "bottomrightbracce") ("356,344" SYMBOL "2,354") (* ; "topleftbracce") ("356,345" SYMBOL "2,356") (* ; "bottomleftbracce") ("356,346" SYMBOL "2,355") (* ; "centerleftbracce") ("356,355" SYMBOL "2,363") (* ; "integraltop") ("356,356" SYMBOL "2,365") (* ; "integralbottom") ("356,357" SYMBOL "2,364") (* ; "integralcenter"))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *POSTSCRIPT-NS-HASH*) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \POSTSCRIPT.FRACTION MACRO ((STREAM STRING) (* ;; "Handle printing of a fraction, given a string that's the name of the PS function (defined in \POSTSCRIPT.JOB.SETUP) that prints it. You must put spaces around the name.") (POSTSCRIPT.SHOWACCUM STREAM) [COND ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) (ffetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)) (\TERPRI.PSC STREAM) (SETQ NEWXPOS (IPLUS (ffetch POSTSCRIPTX of IMAGEDATA) CHARWID] [COND ((NOT (ffetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)) (COND ((ffetch POSTSCRIPTPENDINGXFORM of IMAGEDATA) (\SETXFORM.PSC STREAM IMAGEDATA))) (COND ((ffetch POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA) (* ;  "If font was changed then switch before printing") (\SWITCHFONTS.PSC STREAM IMAGEDATA))) (COND ((ffetch POSTSCRIPTMOVEFLG of IMAGEDATA) (* ; "likewise for position") (\SETPOS.PSC STREAM IMAGEDATA] (POSTSCRIPT.OUTSTR STREAM STRING))) ) ) (RPAQ \POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T "Print this file/document/image in Landscape Orientation" ) ("Portrait" 'NIL "Print this file/document/image in Portrait Orientation")) TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) CHANGEOFFSETFLG _ 'Y)) (RPAQ \POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS _ '(("Ask" 'ASK "Always ask whether to print in Landscape or Portrait Orientation" ) ("Landscape" T "Default printing to Landscape Orientation" ) ("Portrait" 'NIL "Default printing to Portrait Orientation" )) TITLE _ "Default Orientation" CENTERFLG _ T)) (RPAQ PS.BITMAPARRAY (READARRAY-FROM-LIST 16 (QUOTE BYTE) 0 (QUOTE (48 49 50 51 52 53 54 55 56 57 65 66 67 68 69 70 NIL)))) (RPAQQ \POSTSCRIPT.JOB.SETUP ("/bdef {bind def} bind def" "/ldef {load def} bdef" "/S /show ldef" "/M /moveto ldef" "/DR {transform round exch round exch itransform} bdef" "/L {gsave newpath setlinewidth 0 setlinecap" " M lineto currentpoint stroke grestore M} bdef" "/L1 {gsave newpath 0 setdash setgray setlinewidth 0 setlinecap" " M lineto currentpoint stroke grestore M} bdef" "/F {findfont exch scalefont setfont} bdef" "/CLP {newpath M dup 0 rlineto exch 0 exch rlineto" " neg 0 rlineto closepath clip newpath} bdef" "/R {gsave setgray newpath M dup 0 rlineto exch 0 exch" " rlineto neg 0 rlineto closepath eofill grestore} bdef" "/ellipsedict 9 dict def" "ellipsedict /mtrx matrix put" "/ellipse" " { ellipsedict begin" " /endangle exch def" " /startangle exch def" " /orientation exch def" " /minorrad exch def" " /majorrad exch def" " /y exch def" " /x exch def" " /savematrix mtrx currentmatrix def" " x y translate" " orientation rotate" " majorrad minorrad scale" " 0 0 1 startangle endangle arc" " savematrix setmatrix" " end } bdef" "/concatprocs" " {/proc2 exch cvlit def" " /proc1 exch cvlit def" " /newproc proc1 length proc2 length add array def" " newproc 0 proc1 putinterval" " newproc proc1 length proc2 putinterval" " newproc cvx" " } bdef" "/resmatrix matrix def" "/findresolution" " {72 0 resmatrix defaultmatrix dtransform" " /yres exch def /xres exch def" " xres dup mul yres dup mul add sqrt" " } bdef" "/thebitimage" " {/maskp exch def" " /bihgt exch def" " /biwid exch def" " /byte 1 string def" " /strbufl biwid 8 div ceiling cvi def" " /strbuf strbufl string def" " maskp not{{1 exch sub} currenttransfer concatprocs settransfer} if" " biwid bihgt" " maskp { true } { 1 } ifelse" " [biwid 0 0 bihgt 0 0]" " {/col 0 def" " {currentfile byte readhexstring pop 0 get" " dup 16#B2 eq {pop" " currentfile byte readhexstring pop 0 get 1 add" " currentfile byte readhexstring pop pop /nbyte byte 0 get def" " { strbuf col nbyte put /col col 1 add def} repeat}" " {dup 16#B3 eq {pop /col col" " currentfile byte readhexstring pop" " 0 get add 1 add def}" " {16#B4 eq {currentfile byte readhexstring pop pop} if" " strbuf col byte 0 get put /col col 1 add def} ifelse" " } ifelse" " col strbufl ge { exit } if } loop" " strbuf }" " maskp { imagemask } { image } ifelse" " } bdef" "/setuserscreendict 22 dict def" "setuserscreendict begin" " /tempctm matrix def" " /temprot matrix def" " /tempscale matrix def" "end" "/setuserscreen" " {setuserscreendict begin" " /spotfunction exch def" " /screenangle exch def" " /cellsize exch def" " /m tempctm currentmatrix def" " /rm screenangle temprot rotate def" " /sm cellsize dup tempscale scale def" " sm rm m m concatmatrix m concatmatrix pop" " 1 0 m dtransform /y1 exch def /x1 exch def" " /veclength x1 dup mul y1 dup mul add sqrt def" " /frequency findresolution veclength div def" " /newscreenangle y1 x1 atan def" " m 2 get m 1 get mul m 0 get m 3 get mul sub" " 0 gt { { neg } /spotfunction load concatprocs" " /spotfunction exch def } if" " frequency newscreenangle /spotfunction load setscreen" " end" " } bdef" "/setpatterndict 18 dict def" "setpatterndict begin" " /bitison" " {/ybit exch def /xbit exch def" " /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def" " /mask 1 7 xbit 8 mod sub bitshift def" " bytevalue mask and 0 ne" " } bdef" "end" "/bitpatternspotfunction" " {setpatterndict begin" " /y exch def /x exch def" " /xindex x 1 add 2 div bpside mul 1 sub cvi def" " /yindex y 1 add 2 div bpside mul 1 sub cvi def" " xindex yindex bitison" " {/onbits onbits 1 add def 1}" " {/offbits offbits 1 add def 0} ifelse" " end" " } bdef" "/setpattern" " {setpatterndict begin" " /cellsz exch def" " /angle exch def" " /bwidth exch def" " /bpside exch def" " /bstring exch def" " /onbits 0 def /offbits 0 def" " cellsz angle /bitpatternspotfunction load setuserscreen" " {} settransfer" " offbits offbits onbits add div setgray" " end" " } bdef" "%% - - - - - Fraction-setting code, to support NS fonts better - - - - -" "/fractiondict 20 dict def" "/fractionshow " "{ fractiondict begin" "/denom exch def " "/num exch def " "/regfont currentfont def" "/fractfont currentfont [.65 0 0 .6 0 0] makefont def " "gsave newpath 0 0 moveto " "(1) true charpath flattenpath pathbbox " "/height exch def pop pop pop" " grestore" "0 .4 height mul rmoveto" "fractfont setfont num show" "0 .4 height mul neg rmoveto regfont setfont (\244) show" "fractfont setfont denom show regfont setfont end } bdef" "/f14 { (1) (4) fractionshow } bdef" "/f12 { (1) (2) fractionshow } bdef" "/f34 { (3) (4) fractionshow } bdef" "/f18 { (1) (8) fractionshow } bdef" "/f38 { (3) (8) fractionshow } bdef" "/f58 { (5) (8) fractionshow } bdef" "/f78 { (7) (8) fractionshow } bdef" "/f13 { (1) (3) fractionshow } bdef" "/f23 { (2) (3) fractionshow } bdef" "/bboxdict 20 dict def" "/bboxchk { bboxdict begin" "/regfont currentfont def" "/chkfont currentfont [1.25 0 0 1.25 0 0] makefont def " "gsave newpath 0 0 moveto " "(\161) true charpath flattenpath pathbbox " "/height exch def pop pop pop " " grestore " " currentpoint " " .2 height mul .3 height mul rmoveto" "chkfont setfont (\063) show" " moveto" " regfont setfont" "(\161) show end } bdef" "/rencdict 15 dict def" "/encodefont { rencdict begin" "/newname exch def" "/oldfont exch def" "/newcodes [" "8#001 /Aacute" "8#002 /Acircumflex" "8#003 /Adieresis" "8#004 /Agrave" "8#005 /Aring" "8#006 /Atilde" "8#007 /Ccedilla" "8#010 /Eacute" "8#011 /Ecircumflex" "8#012 /Edieresis" "8#013 /Egrave" "8#014 /Iacute" "8#015 /Icircumflex" "8#016 /Idieresis" "8#017 /Igrave" "8#020 /Ntilde" "8#021 /Oacute" "8#022 /Ocircumflex" "8#023 /Odieresis" "8#024 /Ograve" "8#025 /Otilde" "8#026 /Scaron" "8#027 /Uacute" "8#030 /Ucircumflex" "8#031 /Udieresis" "8#032 /Ugrave" "8#033 /Ydieresis" "8#034 /Zcaron" "8#177 /periodinferior" "8#201 /aacute" "8#202 /acircumflex" "8#203 /adieresis" "8#204 /agrave" "8#205 /aring" "8#206 /atilde" "8#207 /ccedilla" "8#210 /eacute" "8#211 /ecircumflex" "8#212 /edieresis" "8#213 /egrave" "8#214 /iacute" "8#215 /icircumflex" "8#216 /idieresis" "8#217 /igrave" "8#220 /ntilde" "8#221 /oacute" "8#222 /ocircumflex" "8#223 /odieresis" "8#224 /ograve" "8#225 /otilde" "8#226 /scaron" "8#227 /uacute" "8#230 /ucircumflex" "8#231 /udieresis" "8#232 /ugrave" "8#233 /ydieresis" "8#234 /zcaron" "8#235 /Eth" "8#236 /eth" "8#237 /Thorn" "8#240 /thorn" " ] def" "/olddict oldfont findfont def /newfont olddict maxlength dict def" "olddict { exch dup /FID ne { dup /Encoding eq" "{ exch dup length array copy newfont 3 1 roll put }" "{ exch newfont 3 1 roll put } ifelse }" " { pop pop } ifelse } forall" "newfont /FontName newname put" "newcodes aload pop" "newcodes length 2 idiv { newfont /Encoding get 3 1 roll put } repeat " "newname newfont definefont pop end } def" " /accentdict 10 dict def " " /accentor { accentdict begin /scaler exch def /delta exch def " "/unders exch def /accents exch def /mainch exch def /scrt (X) def" " /w1 mainch stringwidth pop def " " currentpoint mainch show currentpoint 4 2 roll " "accents { /ch exch def 2 copy moveto " " scrt 0 ch put " " /w2 scrt stringwidth pop def " " w1 w2 sub 2 div delta rmoveto scrt show " " /delta delta 150 scaler mul 9 div add def" " } forall " "unders { /ch exch def 2 copy moveto " " scrt 0 ch put " " /w2 scrt stringwidth pop def " " ch 46 eq { w1 w2 sub 2 div -175 scaler mul 9 div rmoveto scrt show 0 175 rmoveto }" " { w1 w2 sub 2 div 0 rmoveto scrt show } ifelse " " } forall " " pop pop moveto end } def " "%%%%EndProlog" "%%%%BeginSetup")) (RPAQQ SlopeMenuItems ((Italic 'ITALIC "This is an Italic Slope font") (Regular 'REGULAR "This is a Regular Slope font"))) (RPAQQ WeightMenuItems ((Bold 'BOLD "This is a Bold Weight font") (Medium 'MEDIUM "This is a Medium Weight font") (Light 'LIGHT "This is a Light Weight font"))) (ADDTOVAR BackgroundMenuCommands ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE (MENU \POSTSCRIPT.ORIENTATION.OPTIONS.MENU )) "Select the default Orientation for PostScript output" (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) "Always ask whether to print in Landscape or Portrait Orientation") ("Landscape" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE T) "Default printing to Landscape Orientation") ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE NIL) "Default printing to Portrait Orientation")))) (RPAQQ BackgroundMenu NIL) (DECLARE%: EVAL@COMPILE (RPAQQ GOLDEN.RATIO 1.618034) (RPAQQ \PS.SCALE0 100) (RPAQQ \PS.TEMPARRAYLEN 20) (CONSTANTS (GOLDEN.RATIO 1.618034) (\PS.SCALE0 100) (\PS.TEMPARRAYLEN 20)) ) (RPAQ? POSTSCRIPT.BITMAP.SCALE 1) (RPAQ? POSTSCRIPT.EOL 'CR) (RPAQ? POSTSCRIPT.IMAGESIZEFACTOR 1) (RPAQ? POSTSCRIPT.PREFER.LANDSCAPE NIL) (RPAQ? POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) (RPAQ? POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800)) (RPAQ? POSTSCRIPT.TEXTURE.SCALE 4) (RPAQ? POSTSCRIPTFONTDIRECTORIES (LIST (COND ((EQ (MACHINETYPE) 'MAIKO) "{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/") (T "{DSK}POSTSCRIPT>")))) (RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72) (DEFINEQ (POSTSCRIPTSEND - [LAMBDA (HOST FILE PRINTOPTIONS) (* ; "Edited 20-Nov-95 11:29 by ") - (* ; "Edited 20-Nov-95 11:26 by ") - - (* ;; "This is the send function for generic POSTSCRIPT printers. It branches on the architecture-specific function. The theory is that the send method is really a property of the operating system, not a property of specific postscript printers. These functions are contained in separate library files (or defined by user).") - - (SELECTQ (MKATOM (UNIX-GETPARM "ARCH")) - (dos (DOSPRINT HOST FILE PRINTOPTIONS)) - (UnixPrint HOST FILE PRINTOPTIONS]) ) (ADDTOVAR PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPTSEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (HELVETICAD . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . NEWCENTURYSCHLBK) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (OPTIMA . PALATINO) (TITAN . COURIER)) (ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC PSF)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT)))) (ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET \CREATECHARSET.PSC))) (RPAQ? POSTSCRIPT.PAGETYPE 'LETTER) (* ;; "NIL means initial clipping is same as paper size. Don't know why the other regions were specified--rmk" ) (APPENDTOVAR POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2)) (LEGAL (0 0 8.5 14) NIL (-0.1 -0.1 8.7 14.2)) (NOTE (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (POSTSCRIPT.INIT) ) (PUTPROPS POSTSCRIPTSTREAM FILETYPE :TCOMPL) (PUTPROPS POSTSCRIPTSTREAM MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND) ) (PUTPROPS POSTSCRIPTSTREAM COPYRIGHT ( "Venue This program or documentation contains confidential information and trade secrets of Venue. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Venue. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets" 1989 1990 1991 1992 1993 1994 1995 1997 1998)) (DECLARE%: DONTCOPY (FILEMAP (NIL (22671 26367 (POSTSCRIPT.INIT 22681 . 26365)) (27411 62195 (PSCFONT.READFONT 27421 . 29329) (PSCFONT.SPELLFILE 29331 . 29909) (PSCFONT.COERCEFILE 29911 . 31483) ( PSCFONTFROMCACHE.SPELLFILE 31485 . 32470) (PSCFONTFROMCACHE.COERCEFILE 32472 . 34124) ( PSCFONT.WRITEFONT 34126 . 35141) (READ-AFM-FILE 35143 . 41014) (CONVERT-AFM-FILES 41016 . 42228) ( POSTSCRIPT.GETFONTID 42230 . 43625) (POSTSCRIPT.FONTCREATE 43627 . 56026) ( \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 56028 . 58425) (POSTSCRIPT.FONTSAVAILABLE 58427 . 62193)) (62574 70739 (OPENPOSTSCRIPTSTREAM 62584 . 70405) (CLOSEPOSTSCRIPTSTREAM 70407 . 70737)) (70784 76605 ( POSTSCRIPT.HARDCOPYW 70794 . 74143) (POSTSCRIPT.TEDIT 74145 . 74625) (POSTSCRIPT.TEXT 74627 . 74918) ( POSTSCRIPTFILEP 74920 . 75556) (MAKEEPSFILE 75558 . 76603)) (76606 120412 (POSTSCRIPT.BITMAPSCALE 76616 . 79072) (POSTSCRIPT.CLOSESTRING 79074 . 79608) (POSTSCRIPT.ENDPAGE 79610 . 80481) ( POSTSCRIPT.OUTSTR 80483 . 81504) (POSTSCRIPT.PUTBITMAPBYTES 81506 . 90182) (POSTSCRIPT.PUTCOMMAND 90184 . 91308) (POSTSCRIPT.SET-FAKE-LANDSCAPE 91310 . 96758) (POSTSCRIPT.SHOWACCUM 96760 . 99018) ( POSTSCRIPT.STARTPAGE 99020 . 100675) (\POSTSCRIPTTAB 100677 . 101548) (\PS.BOUTFIXP 101550 . 102900) ( \PS.SCALEHACK 102902 . 105731) (\PS.SCALEREGION 105733 . 106293) (\SCALEDBITBLT.PSC 106295 . 110139) ( \SETPOS.PSC 110141 . 110603) (\SETXFORM.PSC 110605 . 112424) (\STRINGWIDTH.PSC 112426 . 112880) ( \SWITCHFONTS.PSC 112882 . 119039) (\TERPRI.PSC 119041 . 120410)) (120447 176167 (\BITBLT.PSC 120457 . 121010) (\BLTSHADE.PSC 121012 . 125294) (\CHARWIDTH.PSC 125296 . 126063) (\CREATECHARSET.PSC 126065 . 127763) (\DRAWARC.PSC 127765 . 130245) (\DRAWCIRCLE.PSC 130247 . 132656) (\DRAWCURVE.PSC 132658 . 136679) (\DRAWELLIPSE.PSC 136681 . 139158) (\DRAWLINE.PSC 139160 . 141510) (\DRAWPOINT.PSC 141512 . 142100) (\DRAWPOLYGON.PSC 142102 . 145216) (\DSPBOTTOMMARGIN.PSC 145218 . 145783) ( \DSPCLIPPINGREGION.PSC 145785 . 147228) (\DSPCOLOR.PSC 147230 . 148071) (\DSPFONT.PSC 148073 . 152283) (\DSPLEFTMARGIN.PSC 152285 . 152854) (\DSPLINEFEED.PSC 152856 . 153432) (\DSPPUSHSTATE.PSC 153434 . 155197) (\DSPPOPSTATE.PSC 155199 . 157708) (\DSPRESET.PSC 157710 . 158356) (\DSPRIGHTMARGIN.PSC 158358 . 158930) (\DSPROTATE.PSC 158932 . 159955) (\DSPSCALE.PSC 159957 . 160888) (\DSPSCALE2.PSC 160890 . 161709) (\DSPSPACEFACTOR.PSC 161711 . 162683) (\DSPTOPMARGIN.PSC 162685 . 163402) (\DSPTRANSLATE.PSC 163404 . 165978) (\DSPXPOSITION.PSC 165980 . 166579) (\DSPYPOSITION.PSC 166581 . 167153) ( \FILLCIRCLE.PSC 167155 . 169801) (\FILLPOLYGON.PSC 169803 . 173719) (\FIXLINELENGTH.PSC 173721 . 175215) (\MOVETO.PSC 175217 . 175968) (\NEWPAGE.PSC 175970 . 176165)) (176223 199375 ( \POSTSCRIPT.CHANGECHARSET 176233 . 177037) (\POSTSCRIPT.OUTCHARFN 177039 . 189896) ( \POSTSCRIPT.PRINTSLUG 189898 . 191865) (\POSTSCRIPT.SPECIALOUTCHARFN 191867 . 194299) (\UPDATE.PSC 194301 . 195524) (\POSTSCRIPT.ACCENTFN 195526 . 196468) (\POSTSCRIPT.ACCENTPAIR 196470 . 199373)) ( 199473 201118 (\PSC.SPACEDISP 199483 . 199762) (\PSC.SPACEWID 199764 . 200383) (\PSC.SYMBOLS 200385 . 201116)) (201227 204218 (\POSTSCRIPT.NSHASH 201237 . 204216)) (247978 248692 (POSTSCRIPTSEND 247988 . 248690))))) STOP \ No newline at end of file diff --git a/library/SAMEDIR.LCOM.~8~ b/library/SAMEDIR.LCOM.~8~ deleted file mode 100644 index d91baba9939c301cd1f73838cf59738c07e0269b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3484 zcmb_fOK;=W6_#amnnyJmr)W`lF+CyL31vjC_|hwdJ2XXEtSM3^DLW2YBpiz!3DJlG zCC|htvI+VJniNGAL4l^L?xF(O)+oBlze)apC*Qp!WsNZi0wi8sU*3D(_nhw>iEXoE zIcB9}*=EIZIxgMq>&BseV3J@tf$73NSDsok>k|ed%YD=yOBnoHoquF>84Jn?2sPyNyfB3;~2lFVI@4Xk!CgF6?j?co$ z-lJ$Zi7u2~ZErH3&(7i`!sbB|CKr3Y-ZR^lxBF(Z3=z$WK1-md3O$WhRca}+Ko62= zrKl9WKTGDnZjsS7jl+zY#!%nmItWUrb3U1ne=(2G7bL3{{rq8S`tI(oK*MkWgN5~T zx!Tg?mZ}Kf&F}B$CY3ZzlIUy{P9H{dTEuWh>^S~29+hd9M32Yu`JCGe5<%9k9jVq^ zs@$qJzHiKH<bidL8@wn!6i(*Yz8M@{>XPlWBQ&D-uTxMi>Ybb0lE&NkvJoa8$A z%d1Z(ujEu*RF8jMR~0|xOB%eFnc~dCk1v;3f8g|AeUe(Xyt4C+ zQ4rN8YM|>5?6wn-+K|cgJlA`TRINd}e>m_>k5r{jy+c3nP-6Iyd6Kg1?O3MWCKZ5U z*sYdt_4?>YDP6@p8t67DjRv7bp>+D#E5sTV`(oU?nM6ec60AXe3Q-EcU}cyh%Y??( z_biej1=@OMZy%<~wK^}id#G5`2wd+pwMo`$xhJwxU3nr`H3E77%1{`PlWl9&)mBrV zD-RT`=x?ggG*Dcsq;2Eg^ zuTxTRyYIHKsWn$u3Lb%>bp}@JSVjsU)Fp+z1Icy7jXzcP1ae)W7T_g-Np)zIl^S$N zO=f|FJM2{n>~+Xr=c}Vla5jXvXB~JtLtG!P&7Yqm7Ca#pLWOor7x6hg38xEmJ9-qp z7tvxA(Vs9mP&mDK5?%hCqA-buWi)J6mPi=SX&Qqce2?P!f-n+9 zkoOp)#u&qgm~Dg-DQb;GBmvJ=+FgrF))2}hBmSb}nnu^{*asBg1h_7WMpyTA1GxkN z*cxuzB-6FaWe{K@5uEr93LnJDf_nNP65KYSPeK-dE31T{3#ZZi4SJG{7ZHsYG>Vc4 zLsbo&1|}C45grYA62rxWhGRImh?5I6{xaU6RwBWTXY<#Ho}q>iWUx@FT+3!dPaahX zjtUr#5dVbE;^`DZG5oBggB?9UIK}gf!pG6{^#x7haL5L_giBmRQ@Ds|A*Bu+Sj(F- z8eZDX%jMGZGM`TndBb9n&w-|0=GN?TtC$#!a;F0nYLrUkU zlGT4Tzd|Q{<_bBh$=6kjB3%1Wq_laT8z+^IdY{LzzBqAkjsdr+~rIeQla%Az_U0gAII?Nz2(G6qlvzvS*(Mw!5#}T+jMN=JD@xkNIfA ze_yabtd4WTuk9`|vjZ0bSGD#7n7uA_g<7z&KM0WEeLpu7h~Gc;tb=ZVA34X-^gN<_ u^j4I_?~@THvp5MCKpj+16HO6|$`*|+HMZ2TG^@Z26c_u=gfej~yYvlu#8KJ+ diff --git a/library/SAMEDIR.~1~ b/library/SAMEDIR.~1~ deleted file mode 100644 index 27b1baf9..00000000 --- a/library/SAMEDIR.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 11:18:52" {DSK}local>lde>lispcore>library>SAMEDIR.;2 4863 changes to%: (VARS SAMEDIRCOMS) (FNS CHECKSAMEDIR) previous date%: "18-Dec-87 18:56:36" {DSK}local>lde>lispcore>library>SAMEDIR.;1) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SAMEDIRCOMS) (RPAQQ SAMEDIRCOMS ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE] (MIGRATIONS)) (GLOBALVARS MIGRATIONS))) (DEFINEQ (CHECKSAMEDIR [LAMBDA (FILE) (* ; "Edited 12-Jun-90 11:18 by mitani") (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) (RETURN)) [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (DIRECTORYNAME T)) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) OKHOST/DIRS :TEST 'STRING-EQUAL)) (* ;; "The file is going somewhere it has never been before. ") (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER 10 'Y (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `((O ,(CONCAT "Oops! Connect to " (SETQ HOST/DIR (  HOST&DIRECTORYFIELD (CDAR DATES))) " [confirm] ") CONFIRMFLG T) (C "Connect to other directory: ") (Y "Yes, write it here ") (N "No, abort MAKEFILE ")) NIL NIL '(NOECHOFLG T)) (Y (RETURN)) (N (ERROR!)) (C (SETQ HOST/DIR)) (O (TERPRI T)) (SHOULDNT)) [NLSETQ (CNDIR (OR HOST/DIR (READ T T] (GO AGAIN)) ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] (* ;; "A newer version appeared while the user was editing this file.") (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) "has since appeared)." "Do you want to make the file anyway")) (Y) (N (ERROR!)) (SHOULDNT]) (HOST&DIRECTORYFIELD (LAMBDA (FILENAME) (* ; "Edited 18-Dec-87 18:47 by bvm:") (* ;; "Returns the host&dir fields packed together.") (for TAIL on (UNPACKFILENAME.STRING FILENAME) by (CDDR TAIL) do (COND ((FMEMB (CAR TAIL) (QUOTE (HOST DIRECTORY DEVICE))) (push $$VAL (CAR TAIL) (CADR TAIL)))) finally (RETURN (CL:APPLY (FUNCTION PACKFILENAME.STRING) $$VAL)))) ) ) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MIGRATIONS) ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (795 4545 (CHECKSAMEDIR 805 . 4176) (HOST&DIRECTORYFIELD 4178 . 4543))))) STOP \ No newline at end of file diff --git a/library/SAMEDIR.~2~ b/library/SAMEDIR.~2~ deleted file mode 100644 index b8b26a55..00000000 --- a/library/SAMEDIR.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "15-Apr-2018 19:10:08" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;3 5140 changes to%: (FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) previous date%: "12-Jun-90 11:18:52" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;1) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SAMEDIRCOMS) (RPAQQ SAMEDIRCOMS ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE] (MIGRATIONS)) (GLOBALVARS MIGRATIONS))) (DEFINEQ (CHECKSAMEDIR [LAMBDA (FILE) (* ; "Edited 15-Apr-2018 19:09 by rmk:") (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) (RETURN)) (* ;  "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) OKHOST/DIRS :TEST 'STRING-EQUAL)) (* ;; "The file is going somewhere it has never been before. ") (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER 10 'Y (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `((O ,(CONCAT "Oops! Connect to " (SETQ HOST/DIR (  HOST&DIRECTORYFIELD (CDAR DATES))) " [confirm] ") CONFIRMFLG T) (C "Connect to other directory: ") (Y "Yes, write it here ") (N "No, abort MAKEFILE ")) NIL NIL '(NOECHOFLG T)) (Y (RETURN)) (N (ERROR!)) (C (SETQ HOST/DIR)) (O (TERPRI T)) (SHOULDNT)) [NLSETQ (CNDIR (OR HOST/DIR (READ T T] (GO AGAIN)) ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] (* ;; "A newer version appeared while the user was editing this file.") (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) "has since appeared)." "Do you want to make the file anyway")) (Y) (N (ERROR!)) (SHOULDNT]) (HOST&DIRECTORYFIELD [LAMBDA (FILENAME) (* ; "Edited 15-Apr-2018 19:05 by rmk:") (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD FILENAME 'DEVICE)) 'HOST (U-CASE (FILENAMEFIELD FILENAME 'HOST)) 'DIRECTORY (FILENAMEFIELD FILENAME 'DIRECTORY]) ) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MIGRATIONS) ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (815 4817 (CHECKSAMEDIR 825 . 4374) (HOST&DIRECTORYFIELD 4376 . 4815))))) STOP \ No newline at end of file diff --git a/library/SAMEDIR.~6~ b/library/SAMEDIR.~6~ deleted file mode 100644 index 39e4b996..00000000 --- a/library/SAMEDIR.~6~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Aug-2020 07:42:08" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;6 5337 changes to%: (VARS SAMEDIRCOMS) (FNS CHECKSAMEDIR) previous date%: "15-Apr-2018 19:10:08" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;2) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SAMEDIRCOMS) (RPAQQ SAMEDIRCOMS ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) (INITVARS (SAMEDIRWAIT 10) (SAMEDIRDEFAULT 'O)) (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE] (MIGRATIONS)) (GLOBALVARS MIGRATIONS))) (DEFINEQ (CHECKSAMEDIR [LAMBDA (FILE) (* ; "Edited 25-Aug-2020 07:41 by rmk:") (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) (RETURN)) (* ;  "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) OKHOST/DIRS :TEST 'STRING-EQUAL)) (* ;; "The file is going somewhere it has never been before. ") (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `[[O ,(CONCAT "Oops! Connect to " (SETQ HOST/DIR (  HOST&DIRECTORYFIELD (CDAR DATES] (C "Connect to other directory: ") (Y ,(CONCAT "Yes, write it here") (CHARACTER (CHARCODE EOL))) (N ,(CONCAT "No, abort MAKEFILE") (CHARACTER (CHARCODE EOL] NIL NIL '(NOECHOFLG T)) (Y (RETURN)) (N (ERROR!)) (C (SETQ HOST/DIR)) (O (TERPRI T)) (SHOULDNT)) [NLSETQ (CNDIR (OR HOST/DIR (READ T T] (GO AGAIN)) ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] (* ;; "A newer version appeared while the user was editing this file.") (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) "has since appeared)." "Do you want to make the file anyway")) (Y) (N (ERROR!)) (SHOULDNT]) (HOST&DIRECTORYFIELD [LAMBDA (FILENAME) (* ; "Edited 15-Apr-2018 19:05 by rmk:") (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD FILENAME 'DEVICE)) 'HOST (U-CASE (FILENAMEFIELD FILENAME 'HOST)) 'DIRECTORY (FILENAMEFIELD FILENAME 'DIRECTORY]) ) (RPAQ? SAMEDIRWAIT 10) (RPAQ? SAMEDIRDEFAULT 'O) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MIGRATIONS) ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (856 4950 (CHECKSAMEDIR 866 . 4507) (HOST&DIRECTORYFIELD 4509 . 4948))))) STOP \ No newline at end of file diff --git a/library/SAMEDIR.~7~ b/library/SAMEDIR.~7~ deleted file mode 100644 index a6b726d3..00000000 --- a/library/SAMEDIR.~7~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "30-Aug-2020 13:01:42" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;7 5299 changes to%: (FNS CHECKSAMEDIR) previous date%: "25-Aug-2020 07:42:08" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;6) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SAMEDIRCOMS) (RPAQQ SAMEDIRCOMS ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) (INITVARS (SAMEDIRWAIT 10) (SAMEDIRDEFAULT 'O)) (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE] (MIGRATIONS)) (GLOBALVARS MIGRATIONS))) (DEFINEQ (CHECKSAMEDIR [LAMBDA (FILE) (* ; "Edited 30-Aug-2020 13:01 by rmk:") (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) (RETURN)) (* ;  "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) OKHOST/DIRS :TEST 'STRING-EQUAL)) (* ;; "The file is going somewhere it has never been before. ") (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `[[O ,(CONCAT "Oops! Connect to " (SETQ HOST/DIR (  HOST&DIRECTORYFIELD (CDAR DATES] (C "Connect to other directory: ") (Y ,(CONCAT "Yes, write it here") (CHARACTER (CHARCODE EOL))) (N ,(CONCAT "No, abort MAKEFILE") (CHARACTER (CHARCODE EOL] NIL NIL '(NOECHOFLG T)) (Y (RETURN)) (N (ERROR!)) (C (SETQ HOST/DIR)) (O (TERPRI T)) (SHOULDNT)) [NLSETQ (/CNDIR (OR HOST/DIR (READ T T] (GO AGAIN)) ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] (* ;; "A newer version appeared while the user was editing this file.") (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) "has since appeared)." "Do you want to make the file anyway")) (Y) (N (ERROR!)) (SHOULDNT]) (HOST&DIRECTORYFIELD [LAMBDA (FILENAME) (* ; "Edited 15-Apr-2018 19:05 by rmk:") (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD FILENAME 'DEVICE)) 'HOST (U-CASE (FILENAMEFIELD FILENAME 'HOST)) 'DIRECTORY (FILENAMEFIELD FILENAME 'DIRECTORY]) ) (RPAQ? SAMEDIRWAIT 10) (RPAQ? SAMEDIRDEFAULT 'O) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MIGRATIONS) ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (817 4912 (CHECKSAMEDIR 827 . 4469) (HOST&DIRECTORYFIELD 4471 . 4910))))) STOP \ No newline at end of file diff --git a/library/SAMEDIR.~9~ b/library/SAMEDIR.~9~ deleted file mode 100644 index de7b1fbd..00000000 --- a/library/SAMEDIR.~9~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Sep-2020 11:40:26" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;9 5511 changes to%: (FNS CHECKSAMEDIR) previous date%: "25-Aug-2020 07:42:08" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;6) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SAMEDIRCOMS) (RPAQQ SAMEDIRCOMS ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) (INITVARS (SAMEDIRWAIT 10) (SAMEDIRDEFAULT 'O)) (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE] (MIGRATIONS)) (GLOBALVARS MIGRATIONS))) (DEFINEQ (CHECKSAMEDIR [LAMBDA (FILE) (* ; "Edited 1-Sep-2020 11:40 by rmk:") (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") [RESETSAVE (DIRECTORYNAME T) '(PROGN (CNDIR OLDVALUE] (* ;  "Assumes that MAKEFILE has RESETLST") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) (RETURN)) (* ;  "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) OKHOST/DIRS :TEST 'STRING-EQUAL)) (* ;; "The file is going somewhere it has never been before. ") (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR (  HOST&DIRECTORYFIELD (CDAR DATES] (C "Make file on other directory: ") (Y ,(CONCAT "Yes, write it here") (CHARACTER (CHARCODE EOL))) (N ,(CONCAT "No, abort MAKEFILE") (CHARACTER (CHARCODE EOL] NIL NIL '(NOECHOFLG T)) (Y (RETURN)) (N (ERROR!)) (C (SETQ HOST/DIR)) (O (TERPRI T)) (SHOULDNT)) [NLSETQ (CNDIR (OR HOST/DIR (READ T T] (GO AGAIN)) ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] (* ;; "A newer version appeared while the user was editing this file.") (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) "has since appeared)." "Do you want to make the file anyway")) (Y) (N (ERROR!)) (SHOULDNT]) (HOST&DIRECTORYFIELD [LAMBDA (FILENAME) (* ; "Edited 15-Apr-2018 19:05 by rmk:") (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD FILENAME 'DEVICE)) 'HOST (U-CASE (FILENAMEFIELD FILENAME 'HOST)) 'DIRECTORY (FILENAMEFIELD FILENAME 'DIRECTORY]) ) (RPAQ? SAMEDIRWAIT 10) (RPAQ? SAMEDIRDEFAULT 'O) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MIGRATIONS) ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (817 5124 (CHECKSAMEDIR 827 . 4681) (HOST&DIRECTORYFIELD 4683 . 5122))))) STOP \ No newline at end of file diff --git a/library/SEDIT-COMMONLISP.DFASL.~1~ b/library/SEDIT-COMMONLISP.DFASL.~1~ deleted file mode 100644 index d8429cd954fca445cc2c65d6b8697c1a976778f4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 19774 zcmeHvX>?oHnb>;|Ah?PGDN2?o$%093rUhD*Wm}?T87qkgfB*!57AZ=RxygV?kqQ^b za3(1wQ&ybe$e|S5xQ-k(PBNJ$>4Za1I$V@Nr*$84vE zM{J|R<0HNOw$o5=`=lop_|)NnRBdH@XuSbvD z-Ql*ja44w9B8`Wd*2MCL=pE_r9_#P39qaEK>L2avPVKQZJ!JED4~;`_ThqaVO?zwy zoA*A{{9se#nigj)$WJ!9#m9|K`)vO4LF%y|hS=AqUJxHIH&Mm=^t6lsq)q^GP+ zwz1)J_QC!q`v(yzXEhii{kf@lsrxaMQa!+opv_@KRhO&3@a??{)`<5+Y6kCJ|=dM~|?!_>(NHiQV zZH7Y4@{NQojai_f6qn`!gvAhn*5zQ@hV<2{^yf8%1dKX^k2#~U^XaQ*s3`Gx-9cy6 z+f4azDDDnNIw4=_340%N1|9H-2n?RSioJ{QIWfqT^CPftjK?W!4TfDja{9_tWxO-u zwTHaN>_^+fac_D$i>xbC_0)!VMYP&6V~^`?ULepA&?)SkGbrj{kR1fr9{Nzwt0tI| z+5kVMLx&Efr#{{}JZ?KXK00RW9vmIECAy#Nw|P4v;b=V8=nMvJgTvi@K<;D1wq8D5 zwy{KVl!$tdtq0Cna?CcG7#<(&8`?Ey>*==*_4oGnkB;JLfKH?RV>VAqs3q8nCET6H z^i`AC1<%*;@%GsGIXsATRI@nP0}tu9jit`PxrHNKzsJ@+)Mu-QuDFAymQW0qyb-Z) zkHw?y?s$7N4}*k|wM6?lv{I!t0-NczFRQJJdLu!nd-({PV(qR_*aNusIYX^pPeCtS zgSam}mB^p}>d2=xeAo`!CRO#)#%t>9Kv;rreogZOpa^t9ORl;_(K(Fo8Qm zY~YQ~I}ij+`@KaE#k|qgu(Vx5v;_4?1orsO&)F6PzUYkV$5)%oU6R07oXu8)&Q^Iy z%!_D7WZxO69)V(j7vjFF0B(cBp@&-amd;gxwk#)ed@ysHxSOze_i~7QB9<_9?IBMX zp27#|PIEU-&C_8x-y^m&<3j_sZJ@a1zw^Z_m4q)hlif*A4>KQ0bd#$fpPC2ht8O>4fLmM>8mAlj%;~bL{Dsw zM!kUcEM95p>+^_|xUWpyHiqkcki0rcbEZ57RH*8uFOWE<)F24M*>)YBxt$-EOig>~#;6X^0$Gsi#wy>ui#TewBhyslySps@zgm0ixEc>h@t4BaD1P?A9O7%L*_1L_@d$8&?- zDOjexdt`VVXyM%W$hqOs{!xCK8Uf8fgkeOG8DHJrmCBo?4aA(4>sBMJ7GR41z{G?j|C%W5ncecq?nlx1|QBJKw@O+^I<{x#6U zN_U1MEc4S-W)w}Rh5@heMsW(~K?%AtRYeRq5`|TDutFiaigrLlDQzM45_MZdY6DbN z6oQqClqOONOnWa(JK&&+c93SaG`m^Owedx+&p4be($cIx39(5+D7=596dW~eNomBNOKx(9HTQlqEmiMj?{F`X^k|iHT&#wC`CLFE1@uXPHRM>JI1QxTUP6I(fYwN@PLeV5jV)?W!?ni~*bp z?w7P8W}22`CO4OSESce;AyTxHu%aT8GNKN*wanG72jK|QzLv(t(?0REgH|?qkQexX zNbTXAP1LUwPnSb4Gbq4LQHQJD2dhOyyz5ryT(9G@aOIs>^qD#ruS^?Q!m8ub{y&g4 zX0CbJfWMHONW7dgPBM%ILYzY`8)!UHTU#sfbD*~7fPoNbAxg`YeH$}AdbHz57MUCP zVX4txMokPrC&tH*xK%RnRvFG8NRv~K@HidG3aWE!fb4xHMJbYGXhAaMQnzE{mmOn)I9{dS`4*5C(Qm) zw1dH{cD4uOc9E)w9_0nlz>TZ2toMLCjxV`p+t0X`W_KId(54esnYTC{35o3^Yl?t8 z6r-iWMR?HE9)-`YOl$@-HoA4l^Q9OkjlnC_8co&^9sz%{2XlSc)C0>I)(6m2q=!7- z4#18XNp~97yS`9k4Tb5HiMpdia_0{Kx=f+C?_L0{kP1ICG|+d};1Hi>`o-*d%3i`_ zR7P~nhqLaSNS&dk#m716;66S8WP-;5S+vwSMQX1|-NO(YM5>IX-a(1_7v+)-?#=Xl z+uT7MuK7j6%uJoHptvqUMXn^4vx`uAOEUz2#k{Vm^Tu{A_<^_=d^+QO!&`oau6b*b zAp$iUB*Qxq_+d>Z0GK}rTU{VTCFaZXbeEjW0Q{>iKx~=U4GtH3i&GC)Ffvn^Oo-Hz zB6U`zJ|h_xiVF|Vh=mov#9x@i>2sv|5$H=x?h5#HhdcT(K>_MSMCPfuS|(7?GN?%; zQ!PpKz@jezIxyntkU38W&dLyEy`P|E%pV3aS?l(B-2pn?MCfZiEmA`w#dLJ@q(}iy zLIi%(EmFIHr0ya$ndn&$+H(f2=(-15t5<5+1P$v8x*<8EIU~B(L7Ua+l&fZqT6+*R z_~)mzaFpio4*kA;KTtg7zE8iG==a~!?+;*44$D3HCUf37PUatnv#V@7zUZgSkCaSc zf%PoSll^vvdV(n}WopZ5oLE=&dzwa4d!18?4#`7b&jpNwaA zuOV-p#>sKZ?))4SB%s0`c5P zg7i^1SVbc+UL|<^J>WY6y%qg$qOKR$Uns`gpqhEkyi>S$@s^keD7^?LF2FepOV=Yn z&mXBxd1SdFvZ76yr8hUt=6t<4T1&YL%>SM#YNq1k13cRXN}e^0Ln>XuU49hie>4Fb z%G&4bX2Uv~GmIk8J|}$hGd2deX0&$>yfycnK^h(N4yR9dd-#OHfqC>FWs;}?;kFzS zsYaUTBJaWCT~xYW$%%y%T!RBB70#Xd^&#LP9j+QMm6+)&bf}l+eYX{^aAdOCBjA!S zXfeyH4bfYXt?~UDR7VL{wwQn-=-zVl_NCc%zS|m?%BX2(OrPB&b*5|!k$4}q!{dp< zY1o<8TyHu;vk&DePMl$b8Xzs1B>a|SaCsz_Y7}3MHo%&hUCvH_ffhSSzrezH&ic#5 z5NY&08{!7l$}?9+1(sg7&G`k(pe0xdtkw_HT6(PxCXYEjv5bV=d;!d1tnNc{#_290 z%Y{6T!U2bSB`vT*@+#txIgSel8g*#(RXD%pQE%3XO$<^^L+w3=lb@}cm>n(;jq3%t z)oMpI97niJbo4T2C!yQgWnN(hdIDN13^y=4C9uN|5Pxf9oo%jg&~CUNv7U~iS`As{ zF9BpD2?6QfWdA1=yv{ZRxB&pg+!n#|AHt(b+20P{RA%^TfRWZ28@=;~Xx8(!_%u*> zF#*j06J}30G3zCuzr*Yi%2MqC%KkmpHgT8xsOA?~W25YU!|ZyP$Xx~ED_@^Lh)V8W zB(_6Id0*_nh0=f2w(BI!ges|gp1*Qkm4YNFjG;8%&`vzz@Yoj6G3 znZpyPWo8aQnU8EOjd7~-R3&BjVm4gKA}B}Md~z4??3ZNxppaLB^{r?Yz)w|!+ZlKJ zz=aI*G-Qvs8}Odf66=hCv7r@#4!5Nt>yZaFAmj;pqjncqk|2a)4H}y36%C;vNT8!F zL1!zmX?2r^zTLGA;M{e4;r0eC9ROB8_`rBr_Ar$oBGs*?Qc5=isI{RzbPS$^?&>&P zsz}HZO;J$?K%XP%0O%5i|EZ$Zrv3X57Cj9QE{eeQO4C`$S-=Mig+81O*!?h2TO^KS zhK~^)s_Sh)nP$`s$%_Q8o0Ghu`{5Cm5MJg5chih^qpM;auM}sLT^O})(!guwI@Uch z1b**kTV!Myocm{OV`El`Rwh}KxoGxCbNdLS1ao^86XX8Nb{kpKEE6aF^i?i&{DuP5Gn)*Ra{wHK-Nm4EJaZ3hl;|bonIayKO6Y#&s~vKHvfONs~+;cym6W zEw*XjnR&tRihG4O>lMe1a2G3zMS5wAvlezvgTQcQf&D%mWkiwda?eoq+JYUeAV$M2Eg%@79$k0R#)g0?L$Sj+ zCcHN!>kbk78exxqz9O23fe}@qX~%&FS??^Gd~|mqeXQ)QoiESr-zCgmp>Y;5JHc6E zaLOX@=(D;=*{S~7ZIoQvgdSG}e}gyf4cs^{Y+PCPPEiqFXfKvnC_ya1Ok~7EK50r9 z=&G0i9;~vbWi537T@XD>=V#VRs;{4SOYKcgxa7_#X4aRMi zv?mO6!H_X!^IUVQ^!UKiY=?9Zn!89_Yrf{A!+j+&vokqUAK=QDxN=6imARJO$}by8 z%FNu$BY}yNnc3eZSP-5ZAhjgK5 zfl^(dw2Y4T3=Q`|0K-sU|5I@(${;e)5M|($ARj)6NRIdtbw@7S?4Y4R#j-!Zx}8JX^WdTOb4|b@4V!FJ*2%#Dy3`M4Bm`RN z%wPUNw3(M#=Q%XoG0=fz-IsycR=dMNylbI7M)cIDZ+rL7cP1fZ(W|*llH)_=MNVaQOu{&M67}A^x9G}lR!1X)_c+Tye@9XY_;bDb= zWxnpv@)Nz>*IgLTf;y6_5@Ly+PEz)jr!Y~g`#6bka+njg2&;J;ep-V&`9H8l`5FHF zoE4(~%*lV?ebc`4Gh5a9ICBa`CsO1?>(l0D z{^oH&fYMIKyK|0P!3pZi=Hc=?n>Xj>;X))^Uy_$E%gbBy^3{3y4S9J8Y{`yOo0s2` zm%lqNZ_D^7{+$*`KfIWadL0#c&#cVL|89K>+{5Sg?6=*&gpB#hDP@vG8}c@lvS1k+ zO$)lIYdUa#rcRynvBdo=zYoHwd=yC~MUgf?^EL?}I8EyztR!NmE2_MZ00?%W8zS-{ zN5gQ;>O|PA@v9T236R7nBDDVvq8Q(xz|)82zrdrXeigIdg0ZvGizJfv714psZ-E9_ z65{K*eOU1Wst4aD7QO~Q$}dC*S?TK6wgGT4M!vvP4nmXmx9IA@@IR*;{AXD6mvr8d zWobF?rM*H9Q|pYxy;`H; zW4S=z!d?#HMY#RKgUN0HuQSZ3tO1e>gfDpD7SW7-tb*`o7EUOs?+IM0`U~+eCVvg% z*>c|Dl|z7O`s$AXbiLV>y>O)4?cCj_`W+aITes&QJV>Z1+&CN>?V;&KxEycGbBp?QUtt)&NL$(}1$ZY60 z1e`JsFn+aCz8(R8X3MAbmM38oHNJtB&UUC@cRfd)`)0s+1bhUUj&kW(cn zl=s1cP1u;%P72!1%Oa~N)Xhqk>+?^j_3Cw;%~8<=!NOOuJx{Vrh*uDz1tGw5j`2TLtXF`O9s*X|+g#o#g#7@rs2Y7t zq6?&Y1oZy_)-p+aFU_8iihG{sp8%ELQ16ekvYQ`V9}iY8ebG1g{(l{OAAE2Z z2aA3Gej?EW_sL{N$Qbm_Y264m2e;kdOQJX;w_oWZk6&7va}cL}V)mW^c>@hGVe1C# zWq~8`mo6kG5-`q}3>aBGdsq(q0lU+n9=}13Y$iIK9Ow?Q7~D``X9gSteE;k>o=!x~ z-b3TQ++hrz9V=^ECMZfgx;(7rH!v&FPp596&AE)(wF0kERSpLr1M>d>wN@IJwZ_c@ z(&p>pC?*R;nq+oHLD}^Pa06vVR#9LN$$4sCcb1YG7K#_vU`cs~ z4g&KgqMct+H4);Ql)VViVW;t00l}~9oE+w4KSS^h)5UdEx?~1GbwhgUzF7ZYe=oc` zi?5oE_l}K^z+0>E(ks1gmOP!xzIq0E9Q$YKse5IY;UNG`$V=NhcKGM=j{nN)cl>7B zvsLc+YnftlSNxJzb}yrqJ6!Q66Sa7$Z^_`5K0OPs^${0ptw!$+sGBu2mA7anO1Ek% zrFSpCaHraBc)3nFyf4n)t3T945e-vdij;Hc3B}c?2y#0suRACxR^54&DyxE&tf&1^ zcbQLMQMpLFrtW6{$!?y}z1m26s__mt=BG!7&&qu(xF)C3_t3@l3&1bnDxBkf;7XiO z2tIYhLgVuLZ>rtP*A8kEC~r8eX{y~{aKpX-n&@CRhVp~N+_Bm@pGi32c&oRSr7vB4 z&ga;e`F(U<{GH=iZEbID=GaE*+n6(Q4f9U)e@^?)&xF)2^+rHDss4GJcB)c6WzB>u zwNusVshUigvXY-`Ik-1-Cq@*MVj%E z4YE?-rUUd(d8ixO{@Th89co8gUt8w7p$7D5 zXupYLhM@l?K&wBdEcz_|X?-j-jc>s;R`Q}y;|w<5qU@hwb_G8PHO^w=3ce9)d~J-9 zKSj?6<-Q%EQRs4l^o4?DmYqk$nA|-P)N=h=u zJ}Q~l^rIwIxrIeU+3Yq$%i=L_mys}`Zg6W=7_1y)1s!_yYV_u!ipo#}I@{<4#Riim zdgyh=f*0u9obG5CU!WH!R1?26&T5rmD3ZjRKp$_LGlCA6BpGbs5QK&}pt_P=soBTu zL+mKuvYdpbvTSYS7*=b$1DxP15@r0sAdlVEc^CD$ND98TTN?*`>3)Z48Y5}8IMgI8 ziB$xL>d>4}qHqSQBbm!XT;aCC?z268-4F#}Tk*>SplFdQud?C@-YZkU+X=s*FPiR! z*^;-9(19=FvTJ!O)NesApa&e}6o#-TAkv1vgrI#Km#P+Oa{E5y zLq<|>Uj0Kx8h*Q|1QCv3QotAbtx+#Hl;ZF$9y?aL=>tJk9o}fTLw+U$b)pDF*}}!0 z%L_r=UR9jJ&lo{MA2NXB3GcMvEjyf4pmXrT)BRsZ9KXG!K1kF^v*WlZ%65E>;+uLk zt|N<>0BH|FP^h8@UKEDihmShg;%&{%D}2vEh26p!9(BTeKRlL#j67j?JAP$>B9b-& z-t#UBiNdR(&f*Hg9eBh7*%FL_4LbEU69$o&7@v@^iJl74qru0m9(H&4!qpWe@!(O&D1O~&YSUx= zL*xCnowkntk>RJ{i)QdiixK+n2~b?|>-h5q{(KjIzK1_It7#|!pZBncQvURoD95Nh g)UL&vvSMyO15{9fcNzG(3;gDVg4fX6$@ky?zlZPv0{{R3 diff --git a/library/SEDIT-COMMONLISP.~1~ b/library/SEDIT-COMMONLISP.~1~ deleted file mode 100644 index 16a68889..00000000 --- a/library/SEDIT-COMMONLISP.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SEDIT" BASE 10) (IL:FILECREATED "11-Jan-91 23:44:41" IL:|{DSK}bane>LISP>SEDIT-COMMONLISP.;5| 47901 IL:|changes| IL:|to:| (IL:FNS INITIALIZE-COMMONLISP STRING-FLIP INSERT-FLIPPED-READ-TIME-CONDITIONAL ASSIGN-FORMAT-READ-TIME-CONDITIONAL CFV-READ-TIME-CONDITIONAL COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COPY-STRUCTURE-READ-TIME-CONDITIONAL CREATE-NEW-READ-TIME-CONDITIONAL LINEARIZE-READ-TIME-CONDITIONAL PARSE--CONDITIONAL-READ SET-POINT-READ-TIME-CONDITIONAL STRINGIFY-READ-TIME-CONDITIONAL INSERT-NEW-READ-TIME-CONDITIONAL-GAP REPLACE-READ-TIME-CONDITIONAL) (IL:VARS IL:SEDIT-COMMONLISPCOMS) (IL:FUNCTIONS ICL TM::MUNG-SEDIT-READ-TABLE ADD-NEW-QUOTE-LIKE) (IL:ADVICE SETUP-PROFILE) (IL:VARIABLES TM::*SEDIT-READ-TABLES*) IL:|previous| IL:|date:| "12-Jun-90 12:53:24" IL:|{DSK}local>lde>lispcore>library>SEDIT-COMMONLISP.;1|) ; Copyright (c) 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-COMMONLISPCOMS) (IL:RPAQQ IL:SEDIT-COMMONLISPCOMS ((IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:GLOBALVARS TYPE-NEW-QUOTE TYPE-READABLE-READ-TIME-CONDITIONAL TYPE-UNREADABLE-READ-TIME-CONDITIONAL) (IL:* IL:|;;;| "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP.") (IL:* IL:|;;| "Support for NEW-QUOTE, the type for #, and #.") (IL:FNS COPY-STRUCTURE-NEW-QUOTE INPUT-NEW-QUOTE PARSE--NEW-QUOTE REPLACE-NEW-QUOTE SUBNODE-CHANGED-NEW-QUOTE) (IL:* IL:|;;| "Support for READABLE-READ-TIME-CONDITIONAL and UNREADABLE-READ-TIME-CONDITIONAL, the types for #+ and #-") (IL:FNS ASSIGN-FORMAT-READ-TIME-CONDITIONAL BACKSPACE-READ-TIME-CONDITIONAL CFV-READ-TIME-CONDITIONAL COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COPY-STRUCTURE-READ-TIME-CONDITIONAL CREATE-NEW-READ-TIME-CONDITIONAL DELETE-READ-TIME-CONDITIONAL INPUT-CONDITIONAL-READ INSERT-READ-TIME-CONDITIONAL INSERT-FLIPPED-READ-TIME-CONDITIONAL LINEARIZE-READ-TIME-CONDITIONAL PARSE--CONDITIONAL-READ REPLACE-READ-TIME-CONDITIONAL SET-POINT-READ-TIME-CONDITIONAL SET-SELECTION-READ-TIME-CONDITIONAL STRINGIFY-READ-TIME-CONDITIONAL SUBNODE-CHANGED-READABLE-RTC SUBNODE-CHANGED-UNREADABLE-RTC UNDO-REPLACE-READ-TIME-CONDITIONAL) (IL:* IL:|;;| "Other junk including INITIALIZE-COMMONLISP, the installation function and STRING-FLIP, the convenient string/unstring key ") (IL:FNS CONDITIONALIZE-CURRENT-SELECTION CREATE-NEW-QUOTED-GAP INITIALIZE-COMMONLISP INSERT-NEW-QUOTED-GAP INSERT-NEW-READ-TIME-CONDITIONAL-GAP INPUT-PLUS-OR-MINUS STRING-FLIP) (IL:* IL:|;;| "Advice implementing readtable hack") (IL:FUNCTIONS ADD-NEW-QUOTE-LIKE ICL TM::MUNG-SEDIT-READ-TABLE) (IL:ADVISE SETUP-PROFILE) (IL:VARIABLES TM::*SEDIT-READ-TABLES*) (IL:* IL:|;;| "Temporarily commenting this out for playing-around purposes") (IL:P (INITIALIZE-COMMONLISP)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SEDIT-COMMONLISP))) (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:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS TYPE-NEW-QUOTE TYPE-READABLE-READ-TIME-CONDITIONAL TYPE-UNREADABLE-READ-TIME-CONDITIONAL) ) (IL:* IL:|;;;| "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP." ) (IL:* IL:|;;| "Support for NEW-QUOTE, the type for #, and #.") (IL:DEFINEQ (COPY-STRUCTURE-NEW-QUOTE (IL:LAMBDA (NODE) (IL:* IL:\; "Edited 18-Feb-88 16:07 by raf") (IL:REPLACE STRUCTURE IL:OF NODE IL:WITH (LET ((STRUC (TM::COPY-PREFIX-QUOTE (IL:FETCH STRUCTURE IL:OF NODE)))) (SETF (TM::PREFIX-QUOTE-CONTENTS STRUC) (IL:FETCH STRUCTURE IL:OF (SUBNODE 1 NODE))) STRUC)))) (INPUT-NEW-QUOTE (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 18-Feb-88 17:10 by raf") (IL:* IL:|;;;| "Control character command to insert a new quote type with gap.") (CASE (TYPE-OF-INPUT CONTEXT) (STRUCTURE (IL:* IL:\; "If we're structure pointing (between the hairs of the universe) a new quote object is made and inserted.") (CLOSE-OPEN-NODE CONTEXT) (INSERT-NEW-QUOTED-GAP CONTEXT CHARCODE QUOTE-TYPE)) (ATOM (IL:* IL:\; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (IL:APPLY* (IL:FETCH DEFAULT-CHAR-HANDLER IL:OF (IL:FETCH ENVIRONMENT IL:OF CONTEXT)) CONTEXT CHARCODE))))) (PARSE--NEW-QUOTE (IL:LAMBDA (STRUCTURE CONTEXT MODE) (IL:* IL:\; "Edited 18-Feb-88 17:24 by raf") (WHEN (AND (OR (NULL MODE) (EQ MODE 'DATA)) (TM::PREFIX-QUOTE-CONTENTS STRUCTURE)) (BUILD-NODE STRUCTURE CONTEXT TYPE-NEW-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) ) (TM::PREFIX-QUOTE-TYPE STRUCTURE))) (PARSE (TM::PREFIX-QUOTE-CONTENTS STRUCTURE) CONTEXT NIL) T))) (REPLACE-NEW-QUOTE (IL:LAMBDA (NODE CONTEXT WHERE SUBNODES POINT) (IL:* IL:\; "Edited 23-Feb-88 18:58 by raf") (LET ((SUBNODE (CAR SUBNODES))) (UNLESS (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) (SETF (TM::PREFIX-QUOTE-CONTENTS (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)))) (SUBNODE-CHANGED-NEW-QUOTE (IL:LAMBDA (NODE SUBNODE) (IL:* IL:\; "Edited 18-Feb-88 17:39 by raf") (SETF (TM::PREFIX-QUOTE-CONTENTS (IL:FETCH STRUCTURE IL:OF NODE)) (IL:FETCH STRUCTURE IL:OF SUBNODE)))) ) (IL:* IL:|;;| "Support for READABLE-READ-TIME-CONDITIONAL and UNREADABLE-READ-TIME-CONDITIONAL, the types for #+ and #-" ) (IL:DEFINEQ (ASSIGN-FORMAT-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT FORMAT) (IL:* IL:\; "Edited 2-Jan-91 22:15 by jrb:") (IL:* IL:|;;| "We only have to worry about setting up the expression node's list-format.") (LET ((EXPR-NODE (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (WHEN (EQ TYPE-LIST (IL:|fetch| NODE-TYPE IL:|of| EXPR-NODE)) (IL:|replace| UNASSIGNED IL:|of| EXPR-NODE IL:|with| (COND ((IL:|type?| LIST-FORMAT FORMAT) FORMAT) (T (OR (GETHASH (CAR (IL:|fetch| STRUCTURE IL:|of| EXPR-NODE)) LIST-FORMATS-TABLE) (GET-LIST-FORMAT :DEFAULT)))))))) ) (BACKSPACE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT INDEX) (IL:* IL:\; "Edited 18-Feb-88 15:26 by raf") (COND ((NULL INDEX) (IL:* IL:\;  "backspace from right boundary puts caret into the read.time.conditional's FORM.") (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:\;  "backspace from before first element deletes the read.time.conditional if its empty.") (IF (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 read.time.conditional is handled by that subnode.") (IL:SETQ NODE (SUBNODE INDEX NODE)) (IL:APPLY* (IL:FETCH BACK-SPACE IL:OF (IL:FETCH NODE-TYPE IL:OF NODE)) NODE CONTEXT))))) (CFV-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE ENVIRONMENT CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 13:30 by jrb:") (LET ((HASH-WIDTH (IL:|fetch| WIDTH IL:|of| (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| ENVIRONMENT) (ECASE (TM::READ-TIME-CONDITIONAL-SIGN (IL:|fetch| STRUCTURE IL:|of| NODE)) (#\+ :HASH-PLUS) (#\- :HASH-MINUS))))) (FEATURE (SECOND (IL:|fetch| SUB-NODES IL:|of| NODE))) (FORM (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (LET ((TOTAL-WIDTH (IL:IPLUS HASH-WIDTH (IL:|fetch| INLINE-WIDTH IL:|of| FEATURE) (IL:|fetch| PREFERRED-WIDTH IL:|of| FORM)))) (IL:|replace| INLINE-WIDTH IL:|of| NODE IL:|with| TOTAL-WIDTH) (IL:|replace| PREFERRED-WIDTH IL:|of| NODE IL:|with| TOTAL-WIDTH)))) ) (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL (IL:LAMBDA (POINT CONTEXT) (IL:* IL:\; "Edited 2-Jan-91 16:14 by jrb:") (IL:* IL:|;;| "I'm not !00% sure but I think this will work fof the new RTCs - JRB") (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 hash, 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 the point will follow.") (SETQ SUBNODE (SUBNODE (IL:FETCH POINT-INDEX IL:OF POINT) NODE)) (IL:|replace| POINT-LINE IL:|of| POINT IL:|with| (IL:|fetch| LAST-LINE IL:|of| SUBNODE)) (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) (IL:|if| (IL:SMALLP ITEM) IL:|then| (IL:* IL:\; "it's followed by space -- put the caret in the middle") (IL:IMIN (IL:HALF ITEM) 6) IL:|else| (IL:* IL:\; "it's followed by something else -- presumably the close paren -- so put the caret immediately after it") 0))))))) ) (COPY-STRUCTURE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE) (IL:* IL:\; "Edited 3-Jan-91 15:57 by jrb:") (IL:|replace| STRUCTURE IL:|of| NODE IL:|with| (LET ((NEWSTRUCT (FUNCALL (ETYPECASE (IL:|fetch| STRUCTURE IL:|of| NODE) (TM::HASH-IL-READABLE (QUOTE TM::COPY-HASH-IL-READABLE)) (TM::HASH-IL-UNREADABLE (QUOTE TM::COPY-HASH-IL-UNREADABLE))) (IL:|fetch| STRUCTURE IL:|of| NODE)))) (IL:* IL:|;;| "Mondo bizarro code below goes out into the node structure, finds the list structures that really belong in the FEATURE and FORM slots of the new node and puts them there. Since COPY-NODE copies the node-tree and THEN the underlying structure, the actual list structure that needs to be in the FEATURE and FORM slots has ALREADY been copied into the node-tree. In my opinion this is a *BUG*, and the structure should be copied FIRST, with the new tree reflecting the copy. Changing this behavior in COPY-NODE is easy, but God only knows what doing so will break, so I'm going to work around it... JRB") (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NEWSTRUCT) (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 1 NODE)) (TM::READ-TIME-CONDITIONAL-FORM NEWSTRUCT) (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 2 NODE))) NEWSTRUCT))) ) (CREATE-NEW-READ-TIME-CONDITIONAL (IL:LAMBDA (GAP CONTEXT TYPE) (IL:* IL:\; "Edited 2-Jan-91 22:55 by jrb:") (IL:* IL:|;;;| "Create a new read time conditional with gaps in it, and the node to represent it.") (LET* ((FEATURE-NODE (CREATE-GAP-NODE GAP)) (FORM-NODE (CREATE-GAP-NODE GAP)) (RTC-NODE (IL:|create| EDIT-NODE NODE-TYPE IL:_ TYPE-READABLE-READ-TIME-CONDITIONAL STRUCTURE IL:_ (TM::MAKE-HASH-IL-READABLE :FEATURE GAP :SIGN TYPE :FORM GAP) SUB-NODES IL:_ (LIST 2 FEATURE-NODE FORM-NODE)))) (IL:|replace| SUPER-NODE IL:|of| FEATURE-NODE IL:|with| RTC-NODE) (IL:|replace| SUPER-NODE IL:|of| FORM-NODE IL:|with| RTC-NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| FEATURE-NODE IL:|with| 1) (IL:|replace| SUB-NODE-INDEX IL:|of| FORM-NODE IL:|with| 2) (IL:|replace| LINEAR-FORM IL:|of| RTC-NODE IL:|with| (CREATE-WEAK-LINK RTC-NODE)) (NOTE-CHANGE RTC-NODE CONTEXT) RTC-NODE)) ) (DELETE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT START END SET.POINT?) (IL:* IL:\; "Edited 18-Feb-88 16:31 by raf") (IL:* IL:|;;| "Replace any deleted subnodes with gaps, since this is a fixed length object.") (WHEN (NOT (IL:SMALLP START)) (SETQ START (IL:FETCH SUB-NODE-INDEX IL:OF START)) (SETQ END START)) (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT START END (IL:FOR I IL:FROM START IL:TO END IL:COLLECT (CREATE-GAP-NODE BASIC-GAP))) (WHEN SET.POINT? (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT (SUBNODE END NODE)) (PENDING-DELETE SET.POINT? (IL:FETCH SELECTION IL:OF CONTEXT))) T)) (INPUT-CONDITIONAL-READ (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 24-Feb-88 18:43 by raf") (CASE (TYPE-OF-INPUT CONTEXT) (STRUCTURE (IL:* IL:\; "If we're structure pointing (between the hairs of the universe) a new read time conditional is made and inserted.") (CLOSE-OPEN-NODE CONTEXT) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP CONTEXT CHARCODE TYPE)) (ATOM (IL:* IL:\; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (IL:APPLY* (IL:FETCH DEFAULT-CHAR-HANDLER IL:OF (IL:FETCH ENVIRONMENT IL:OF CONTEXT)) CONTEXT CHARCODE))))) (INSERT-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT WHERE SUBNODES POINT) (IL:* IL:\; "Edited 18-Feb-88 17:17 by raf") (LET (START END) (IL:|if| (IL:|type?| EDIT-SELECTION WHERE) IL:|then| (SETQ START (IL:FETCH SELECT-START IL:OF WHERE)) (SETQ END (OR (IL:FETCH SELECT-END IL:OF WHERE) START)) IL:|elseif| (IL:|type?| EDIT-POINT WHERE) IL:|then| (SETQ END (IL:FETCH POINT-INDEX IL:OF WHERE)) (SETQ START (IL:ADD1 END)) IL:|else| (SETQ START (IL:FETCH SUB-NODE-INDEX IL:OF WHERE)) (SETQ END START)) (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT START END SUBNODES POINT)))) (INSERT-FLIPPED-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE FEATURE-NODE CONTEXT) (IL:* IL:\; "Edited 9-Jan-91 01:37 by jrb:") (IL:* IL:|;;| "NODE is a read-time-conditional whose FEATURE changed changing its readability; we're replacing it with a new node of the opposite readability, reading and unreading structure as necessary.") (LET ((READABLE? (EQ (IL:|fetch| NODE-TYPE IL:|of| NODE) TYPE-READABLE-READ-TIME-CONDITIONAL)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (OLD-FORM-NODE (SUBNODE 2 NODE)) (NEW-FORM-NODE (SUBNODE 2 NODE)) (OLD-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE)) NEW-FORM) (IL:* IL:|;;| "The following mess sets NEW-FORM and NEW-FORM-NODE to appropriate things. If the current form is a GAP, just use it; otherwise flip it between string-form and structure-form") (IL:|if| (EQ (IL:|fetch| NODE-TYPE IL:|of| OLD-FORM-NODE) TYPE-GAP) IL:|then| (SETQ NEW-FORM (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) IL:|else| (IL:|if| READABLE? IL:|then| (IL:* IL:\; "was readable, stringify it") (SETQ NEW-FORM (FORMAT NIL "~s" (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE))) (SETQ NEW-FORM-NODE (PARSE-NEW NEW-FORM CONTEXT)) IL:|else| (IL:* IL:\; "was unreadable, reread it from string") (WHEN (STRINGP (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (IL:* IL:|;;| "If the current structure ISN'T a string, who knows what may be wrong...") (WITH-INPUT-FROM-STRING (S (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (LET ((FORM (IL:NLSETQ (READ S)))) (COND (FORM (SETQ NEW-FORM (CAR FORM) NEW-FORM-NODE (PARSE-NEW (CAR FORM) CONTEXT))) (T (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Warning: Problem trying to read conditional expression. Not read.") (SETQ NEW-FORM (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE))))))))) (IL:* IL:|;;| "I now think the right thing to do here is to smash the current node's type in place. This may cause problems of its own, but the replace-it strategy was eating us alive.") (SETF (IL:|fetch| NODE-TYPE IL:|of| NODE) (IL:|if| READABLE? IL:|then| TYPE-UNREADABLE-READ-TIME-CONDITIONAL IL:|else| TYPE-READABLE-READ-TIME-CONDITIONAL)) (SETF (IL:|fetch| STRUCTURE IL:|of| NODE) (FUNCALL (IL:|if| READABLE? IL:|then| (FUNCTION TM::MAKE-HASH-IL-UNREADABLE) IL:|else| (FUNCTION TM::MAKE-HASH-IL-READABLE)) :FEATURE (IL:|fetch| STRUCTURE IL:|of| FEATURE-NODE) :SIGN (TM::READ-TIME-CONDITIONAL-SIGN OLD-STRUCTURE) :FORM (TM::READ-TIME-CONDITIONAL-FORM OLD-STRUCTURE))) (UNLESS (EQ OLD-FORM-NODE NEW-FORM-NODE) (REPLACE-NODE CONTEXT OLD-FORM-NODE NEW-FORM-NODE) (IL:* IL:|;;| "The old node is out there on the UNDO list; we need to mung its form so things will undo correctly (trust me...)") (SETF (IL:|fetch| STRUCTURE IL:|of| OLD-FORM-NODE) (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (IL:* IL:|;;| "Maybe this should be done elsewhere; we'll see...")) (IL:* IL:|;;| "The following seems to be sufficient to get the new structure sane before the next operation. These conniptions are necessary for the following strange reason: ") (IL:* IL:|;;| "Assume we're editing #+:interlisp(foo) and we select the 'l' in :interlisp and hit the delete key. We now have #+:interlsp(foo); SEdit hasn't closed the :interlsp node, so no other structure has had a chance to change. Now, take the mouse and click on foo. On the click, SEdit closes the :interlsp node, which changes the #+ from readable to unreadable, which causes this function to be run and (foo) to be replaced with \"(foo)\". Without the reformat-and relinearization below, that mouse-click will select something from the nodes for (foo), but these nodes are dead.") (IL:* IL:|;;| "Of course, with the reformatting below, that last mouse-click will cause the displayed structure to squirm out from under the mouse, but at least SEdit won't BREAK while doing it!") (SUBNODE-CHANGED NODE CONTEXT) (NOTE-CHANGE NODE CONTEXT) (COMPUTE-FORMATS-AND-FORMAT-VALUES NODE CONTEXT) (RELINEARIZE NODE CONTEXT) T)) ) (LINEARIZE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT RIGHT-MARGIN) (IL:* IL:\; "Edited 2-Jan-91 22:11 by jrb:") (LET ((HASH (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) (ECASE (TM::READ-TIME-CONDITIONAL-SIGN (IL:|fetch| STRUCTURE IL:|of| NODE)) (#\+ :HASH-PLUS) (#\- :HASH-MINUS)))) (FEATURE (SECOND (IL:|fetch| SUB-NODES IL:|of| NODE))) (FORM (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (OUTPUT-CONSTANT-STRING CONTEXT HASH) (LINEARIZE FEATURE CONTEXT RIGHT-MARGIN) (IL:* IL:|;;| "Should add some space between FEATURE and FORM here...") (LINEARIZE FORM CONTEXT RIGHT-MARGIN))) ) (PARSE--CONDITIONAL-READ (IL:LAMBDA (STRUCTURE CONTEXT MODE) (IL:* IL:\; "Edited 2-Jan-91 19:58 by jrb:") (COND ((TM::HASH-IL-READABLE-P STRUCTURE) (BUILD-NODE STRUCTURE CONTEXT TYPE-READABLE-READ-TIME-CONDITIONAL) (PARSE (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE) CONTEXT NIL) (PARSE (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) CONTEXT NIL) T) ((TM::HASH-IL-UNREADABLE-P STRUCTURE) (BUILD-NODE STRUCTURE CONTEXT TYPE-UNREADABLE-READ-TIME-CONDITIONAL) (PARSE (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE) CONTEXT NIL) (PARSE (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) CONTEXT NIL) T))) ) (REPLACE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT START END SUBNODES POINT) (IL:* IL:\; "Edited 7-Jan-91 14:33 by jrb:") (UNDO-BY UNDO-REPLACE-READ-TIME-CONDITIONAL NODE (IL:|for| I IL:|from| START IL:|to| END IL:|collect| (SUBNODE I NODE))) (IL:|for| I IL:|from| START IL:|to| END IL:|as| SUBNODE IL:|in| SUBNODES IL:|as| SMASHNODE IL:|on| (IL:NTH (CDR (IL:|fetch| SUB-NODES IL:|of| NODE)) START) IL:|do| (IL:* IL:|;;| "Update the EditNode itself.") (KILL-NODE (SUBNODE I NODE)) (RPLACA SMASHNODE SUBNODE) (IL:|replace| SUPER-NODE IL:|of| SUBNODE IL:|with| NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| SUBNODE IL:|with| I) (SET-DEPTH SUBNODE (IL:ADD1 (IL:|fetch| DEPTH IL:|of| NODE))) (SUBNODE-CHANGED SUBNODE CONTEXT) (IL:* IL:\; "Updates the data underlying this EditNode.")) (NOTE-CHANGE NODE CONTEXT) (WHEN POINT (PUNT-SET-POINT POINT CONTEXT NODE T)) NIL) ) (SET-POINT-READ-TIME-CONDITIONAL (IL:LAMBDA (POINT CONTEXT NODE INDEX OFFSET ITEM TYPE COMPUTE-LOCATION?) (IL:* IL:\; "Edited 2-Jan-91 16:15 by jrb:") (COND ((IL:|type?| STRING-ITEM ITEM) (IL:* IL:\; "pointing to the HASH.") (SETQ OFFSET (IL:ILESSP OFFSET (IL:HALF (IL:FETCH WIDTH IL:OF ITEM))))) (T (IL:|type?| EDIT-NODE ITEM) (SETQ TYPE (QUOTE STRUCTURE)))) (COND ((NULL INDEX) (PUNT-SET-POINT POINT CONTEXT NODE OFFSET COMPUTE-LOCATION?)) (T (COND ((AND (EQ TYPE (QUOTE ATOM)) (IL:NEQ INDEX 0) (IL:ILEQ INDEX 2)) (SET-POINT POINT CONTEXT (SUBNODE INDEX NODE) NIL OFFSET NIL (QUOTE ATOM) COMPUTE-LOCATION?)) ((EQ INDEX 2) (IL:* IL:\; "can't insert structure after the last item") (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 (SETQ INDEX (IL:SUB1 INDEX)))) (IL:|replace| POINT-TYPE IL:|of| POINT IL:|with| (QUOTE STRUCTURE)) (WHEN COMPUTE-LOCATION? (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL POINT CONTEXT))))))) ) (SET-SELECTION-READ-TIME-CONDITIONAL (IL:LAMBDA (SELECTION CONTEXT NODE INDEX OFFSET ITEM TYPE) (IL:* IL:\; "Edited 18-Feb-88 17:38 by raf") (IL:* IL:|;;| "Pointing to the hash selects the whole read.time.conditional.") (SET-SELECTION-ME SELECTION CONTEXT NODE))) (STRINGIFY-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE ENVIRONMENT) (IL:* IL:\; "Edited 2-Jan-91 16:38 by jrb:") (IL:* IL:|;;| "There used to be a lot of junk here about getting the sign and the stringification right; (let ((structure (IL:FETCH STRUCTURE IL:OF NODE)))(IL:CONCAT (LET ((*PACKAGE* IL:*KEYWORD-PACKAGE*)) (FORMAT NIL \"#~a~s\" (ETYPECASE STRUCTURE (TM::HASH-PLUS \"+\") (TM::HASH-MINUS \"-\")) (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE))) (IF (TM::READ-TIME-CONDITIONAL-UNREAD-P STRUCTURE) (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) (FORMAT NIL \"~S\" (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE)))))") (IL:* IL:|;;| "All that stuff is supposedly handled by the print methods for the RTC objects, isn't it?") (FORMAT NIL "~s" (IL:FETCH STRUCTURE IL:OF NODE))) ) (SUBNODE-CHANGED-READABLE-RTC (IL:LAMBDA (NODE SUBNODE CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 15:12 by jrb:") (LET ((SUBNODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (NODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE))) (CASE (IL:|fetch| SUB-NODE-INDEX IL:|of| SUBNODE) (1 (IL:* IL:\; "Changing the FEATURE. ") (IL:|if| (ECASE (TM::READ-TIME-CONDITIONAL-SIGN NODE-STRUCTURE) (#\+ (NOT (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE))) (#\- (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE))) IL:|then| (IL:* IL:|;;| "We became unreadable, dump this node and replace with an UNREADABLE-READ-TIME-CONDITIONAL.") (INSERT-FLIPPED-READ-TIME-CONDITIONAL NODE SUBNODE CONTEXT) IL:|else| (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NODE-STRUCTURE) SUBNODE-STRUCTURE))) (2 (IL:* IL:\; "Changing the FORM; just replace it.") (SETF (TM::READ-TIME-CONDITIONAL-FORM NODE-STRUCTURE) SUBNODE-STRUCTURE)) (T (IL:SHOULDNT "Bad subnode index"))) (NOTE-CHANGE NODE CONTEXT))) ) (SUBNODE-CHANGED-UNREADABLE-RTC (IL:LAMBDA (NODE SUBNODE CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 15:23 by jrb:") (LET ((SUBNODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (NODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE))) (CASE (IL:|fetch| SUB-NODE-INDEX IL:|of| SUBNODE) (1 (IL:* IL:\; "Changing the FEATURE. ") (IL:|if| (ECASE (TM::READ-TIME-CONDITIONAL-SIGN NODE-STRUCTURE) (#\+ (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE)) (#\- (NOT (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE)))) IL:|then| (IL:* IL:|;;| "We became readable, dump this node and replace with an UNREADABLE-READ-TIME-CONDITIONAL.") (INSERT-FLIPPED-READ-TIME-CONDITIONAL NODE SUBNODE CONTEXT) IL:|else| (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NODE-STRUCTURE) SUBNODE-STRUCTURE))) (2 (IL:* IL:\; "Changing the FORM; just replace it.") (IL:* IL:|;;| "This is one place where you COULD catch someone putting a non-string into an unreadable-rtc. I think a better thing to do is give users a \"stringify all unreadable-rtcs\" command, and hack the install for unreadable stuff to break and let you stringify (or even do it behind your back, what the heck...).") (SETF (TM::READ-TIME-CONDITIONAL-FORM NODE-STRUCTURE) SUBNODE-STRUCTURE)) (T (IL:SHOULDNT "Bad subnode index"))) (NOTE-CHANGE NODE CONTEXT))) ) (UNDO-REPLACE-READ-TIME-CONDITIONAL (IL:LAMBDA (CONTEXT NODE OLD-SUBNODES) (IL:* IL:\; "Edited 18-Feb-88 17:45 by raf") (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT (IL:FETCH SUB-NODE-INDEX IL:OF (CAR OLD-SUBNODES)) (IL:FETCH SUB-NODE-INDEX IL:OF (CAR (LAST OLD-SUBNODES))) OLD-SUBNODES NIL))) ) (IL:* IL:|;;| "Other junk including INITIALIZE-COMMONLISP, the installation function and STRING-FLIP, the convenient string/unstring key " ) (IL:DEFINEQ (CONDITIONALIZE-CURRENT-SELECTION (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 28-Dec-90 18:40 by jrb:") (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)) (CR-NODE)) (IL:* IL:|;;| "I'm unsure about this conditinalization below, and suspect it's wrong.") (WHEN (AND NODE (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) (QUOTE STRUCTURE))) (IL:SETQ CR-NODE (CREATE-NEW-READ-TIME-CONDITIONAL BASIC-GAP CONTEXT QUOTE-TYPE)) (START-UNDO-BLOCK) (REPLACE-NODE CONTEXT NODE CR-NODE) (REPLACE-NODE CONTEXT (SUBNODE 1 CR-NODE) NODE) (NOTE-CHANGE CR-NODE CONTEXT) (IL:* IL:|;;| "Set selection and point to the form-gap") (SET-SELECTION-ME SELECTION CONTEXT (SUBNODE 2 CR-NODE)) (PENDING-DELETE POINT SELECTION) (END-UNDO-BLOCK))) (IL:* IL:|;;| "must return non-NIL if command executed") T) ) (CREATE-NEW-QUOTED-GAP (IL:LAMBDA (GAP CONTEXT QUOTE-TYPE) (IL:* IL:\; "Edited 6-Apr-89 16:50 by raf") (IL:* IL:|;;;| "Create a new quote structure with a gap in it, and the node to represent it.") (LET* ((GAP-NODE (CREATE-GAP-NODE GAP)) (QUOTE-NODE (IL:|create| EDIT-NODE NODE-TYPE IL:_ TYPE-NEW-QUOTE STRUCTURE IL:_ (FUNCALL (CASE QUOTE-TYPE (:HASH-DOT #'TM::MAKE-HASH-DOT) (:HASH-COMMA #'TM::MAKE-HASH-COMMA) (:HASH-O #'TM::MAKE-HASH-O) (:HASH-X #'TM::MAKE-HASH-X) (:HASH-B #'TM::MAKE-HASH-B) (T (IL:SHOULDNT "Bad quote type " QUOTE-TYPE))) :CONTENTS 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))) (INITIALIZE-COMMONLISP (IL:LAMBDA NIL (IL:* IL:\; "Edited 11-Jan-91 23:41 by jrb:") "Creates SEdit nodes for Common Lisp presentation types. Fully re-entrant." (IL:* IL:|;;| "First, add the handling for #{b,o,x,r,*}; they get parsed and generally handled like litatoms (once we hack the SEdit readtable to generate them)") (DOLIST (P (QUOTE (TM::HASH-BASED-NUMBER TM::HASH-STAR))) (IL:LISTPUT (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT) P (QUOTE PARSE--LITATOM))) (IL:* IL:|;;| "Now for the weirder ones; #. and #, and #+ and #-") (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-NEW-QUOTE (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE NEW-QUOTE) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-QUOTE) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-QUOTE) LINEARIZE IL:_ (QUOTE LINEARIZE-QUOTE) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-NEW-QUOTE) SET-POINT IL:_ (QUOTE SET-POINT-QUOTE) SET-SELECTION IL:_ (QUOTE SET-SELECTION-QUOTE) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE REPLACE-NEW-QUOTE) DELETE IL:_ (QUOTE DELETE-QUOTE) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-NEW-QUOTE) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-QUOTE) BACK-SPACE IL:_ (QUOTE BACKSPACE-QUOTE))) (QUOTE ((TM::HASH-DOT :HASH-DOT "^Q" PARSE--NEW-QUOTE INPUT-NEW-QUOTE) (TM::HASH-COMMA :HASH-COMMA "^F" PARSE--NEW-QUOTE INPUT-NEW-QUOTE))) (QUOTE (("#." :HASH-DOT) ("#," :HASH-COMMA)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-READABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE READABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-READABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) (QUOTE ((TM::HASH-IL-READABLE NIL NIL PARSE--CONDITIONAL-READ) (TM::HASH-IL-UNREADABLE NIL NIL PARSE--CONDITIONAL-READ))) (QUOTE (("#+" :HASH-PLUS) ("#-" :HASH-MINUS)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-UNREADABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE UNREADABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-UNREADABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) NIL NIL) (IL:* IL:|;;| "Just for the heck of it, add a command for stringifying/unstringifying things. I'd put it in the command menu, but it's too much trouble") (SETF (GETHASH (CHARCODE "^S") (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) (QUOTE (STRING-FLIP NIL))) (IL:* IL:|;;| "And for the final indignity, mung the command table to add a minor flakiness in the handling of + and -") (IL:|for| CP IL:|in| (QUOTE ((#\+ INPUT-PLUS-OR-MINUS) (#\- INPUT-PLUS-OR-MINUS))) IL:|bind| (COMTAB IL:_ (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) IL:|do| (SETF (GETHASH (CHAR-CODE (FIRST CP)) COMTAB) (IL:BQUOTE ((IL:\\\, (SECOND CP)) NIL (IL:\\\, (FIRST CP)))))) T) ) (INSERT-NEW-QUOTED-GAP (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 24-Feb-88 18:44 by raf") (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) (SETQ NEW-QUOTE (CREATE-NEW-QUOTED-GAP BASIC-GAP CONTEXT QUOTE-TYPE)) (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)) (UNLESS (DEAD-NODE? NEW-QUOTE) (SET-SELECTION-ME SELECTION CONTEXT GAP) (PENDING-DELETE POINT SELECTION))) (IL:* IL:\;  "must return non-NIL if command executed") T))) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 28-Dec-90 19:19 by jrb:") (IL:* IL:|;;| "implements the command: insert a read time conditional with gaps") (WHEN (EQ (TYPE-OF-INPUT CONTEXT) (QUOTE STRUCTURE)) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-RTC GAP) (SETQ NEW-RTC (CREATE-NEW-READ-TIME-CONDITIONAL BASIC-GAP CONTEXT TYPE)) (SETQ GAP (SUBNODE 1 NEW-RTC)) (IL:* IL:\; "point us at the feature") (INSERT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) CONTEXT (LIST NEW-RTC)) (UNLESS (DEAD-NODE? NEW-RTC) (SET-SELECTION-ME SELECTION CONTEXT GAP) (PENDING-DELETE POINT SELECTION))) (IL:* IL:\; "must return non-NIL if command executed") T)) ) (INPUT-PLUS-OR-MINUS (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 2-Jan-91 22:12 by jrb:") (IL:* IL:|;;| "Serious weirdness afoot below; we're catching the case of typing a +/- right after a # and then creating a new readable-read-time-conditional (what the heck; assume it's readable until forced to believe otherwise). Strategy stolen from INPUT-QUOTE, with suitable modifications.") (SETQ CHARCODE (CODE-CHAR CHARCODE)) (IL:* IL:\; "Oops...") (IL:SELECTQ (TYPE-OF-INPUT CONTEXT) (STRUCTURE) (ATOM (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)))) (WHEN (AND SUPER-NODE (EQ 1 (IL:FETCH POINT-INDEX POINT)) (EQ (IL:CHARCODE \#) (IL:CHCON1 (IL:FETCH POINT-STRING IL:OF POINT)))) (COND ((EQ 1 (IL:NCHARS (IL:FETCH POINT-STRING IL:OF POINT))) (IL:* IL:|;;| "Just \"#+\"; close the node, get rid of it, and replace it with a readable-rtc. 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-NEW-READ-TIME-CONDITIONAL-GAP CONTEXT CHARCODE CHARCODE) T) (T (IL:* IL:|;;| "Some joker typed a + in the middle of \"#foo\": remove the #, close the node, shove it into a newly created readable-rtc (which might turn it into an unreadable-rtc), and pending-delete the form gap. 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) (CONDITIONALIZE-CURRENT-SELECTION CONTEXT CHARCODE CHARCODE) (END-UNDO-BLOCK) T))))) NIL)) ) (STRING-FLIP (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 11-Jan-91 23:25 by jrb:") (IL:* IL:|;;| "flip the current selection between structure and string") (IL:SELECTQ (TYPE-OF-INPUT CONTEXT) (STRUCTURE (CLOSE-OPEN-NODE CONTEXT) (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))) (IL:IF (AND (NULL START) (NULL END) (STRINGP (IL:FETCH STRUCTURE IL:OF NODE))) IL:THEN (IL:* IL:\; "It's already a string, try and read it") (WITH-INPUT-FROM-STRING (S (IL:|fetch| STRUCTURE IL:|of| NODE)) (LET ((FORM (IL:NLSETQ (READ S)))) (COND (FORM (REPLACE-NODE CONTEXT NODE (PARSE-NEW (CAR FORM) CONTEXT))) (T (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Problem trying to read from string. Not read.")))) T) IL:ELSE (IL:* IL:\; "It's something else, turn it into a string") (IL:IF (AND (NULL START) (NULL END)) IL:THEN (REPLACE-NODE CONTEXT NODE (PARSE-NEW (STRINGIFY NODE) CONTEXT)) IL:ELSE (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Select one thing to stringify/unstringify")) T))) (ATOM (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Select a structure to stringify/unstringify")) NIL)) ) ) (IL:* IL:|;;| "Advice implementing readtable hack") (DEFUN ADD-NEW-QUOTE-LIKE (EDIT-NODE-TYPE SUB-TYPE-LIST NEW-QUOTE-STRING-LIST) (IL:* IL:|;;| "This is a generalization of Ron's old INITIALIZE-COMMONLISP function; it adds a new \"quote-like\" presentation to SEdit's LISP-EDIT-ENVIRONMENT, taking care to do it in re-enterable fashion (you can call this more than once with the same arguments and you won't break SEdit).") (IL:* IL:|;;| "The format of the entries on the sub-type-list is:") (IL:* IL:|;;| "(object-type input-keyword create-key parse-function input-function)") (IL:* IL:|;;| "create-key can be anything ") (IL:* IL:|;;| "First add the new EDIT-NODE-TYPE; it has all the SEdit method names burned into it") (IL:FOR TL IL:ON TYPES IL:WHEN (EQ (IL:FFETCH (EDIT-NODE-TYPE NAME) IL:OF EDIT-NODE-TYPE) (IL:FFETCH (EDIT-NODE-TYPE NAME) IL:OF (CAR TL))) IL:DO (RPLACA TL EDIT-NODE-TYPE) (RETURN NIL) IL:FINALLY (PUSH EDIT-NODE-TYPE TYPES)) (IL:* IL:|;;| "Then walk the sub-type list adding everything in") (LET ((PARSE-INFO-TABLE (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT)) (COMMAND-TABLE (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT))) (DOLIST (ST SUB-TYPE-LIST) (DESTRUCTURING-BIND (OBJECT-TYPE QUOTE-KEYWORD CREATE-KEY PARSE-FUNCTION INPUT-FUNCTION) ST (IL:* IL:|;;| "First add the PARSE-- function") (IL:LISTPUT PARSE-INFO-TABLE OBJECT-TYPE PARSE-FUNCTION) (IL:* IL:|;;| "Then the create-key, if any") (SETQ CREATE-KEY (CHARCODE CREATE-KEY)) (WHEN CREATE-KEY (SETF (GETHASH CREATE-KEY COMMAND-TABLE) (LIST INPUT-FUNCTION NIL QUOTE-KEYWORD)))))) (IL:* IL:|;;| "Finally mung the quote strings, which are of the form (\"string\" :keyword)") (IL:FOR QSP IL:IN NEW-QUOTE-STRING-LIST IL:BIND QUOTE-STRING-LIST IL:_ (IL:|fetch| (EDIT-ENV QUOTE-STRING) IL:|of| LISP-EDIT-ENVIRONMENT) QUOTE-STRING-FONT IL:_ (IL:|fetch| (EDIT-ENV DEFAULT-FONT) IL:|of| LISP-EDIT-ENVIRONMENT) IL:DO (IL:LISTPUT QUOTE-STRING-LIST (SECOND QSP) (CREATE-STRING-ITEM (FIRST QSP) QUOTE-STRING-FONT)))) (DEFUN ICL NIL (IL:* IL:|;;| "First, add the handling for #{b,o,x,r,*}; they get parsed and generally handled like litatoms (once we hack the SEdit readtable to generate them)") (DOLIST (P (QUOTE (TM::HASH-BASED-NUMBER TM::HASH-STAR))) (IL:LISTPUT (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT) P (QUOTE PARSE--LITATOM))) (IL:* IL:|;;| "Now for the weirder ones; #. and #, and #+ and #-") (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-NEW-QUOTE (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE NEW-QUOTE) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-QUOTE) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-QUOTE) LINEARIZE IL:_ (QUOTE LINEARIZE-QUOTE) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-NEW-QUOTE) SET-POINT IL:_ (QUOTE SET-POINT-QUOTE) SET-SELECTION IL:_ (QUOTE SET-SELECTION-QUOTE) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE REPLACE-NEW-QUOTE) DELETE IL:_ (QUOTE DELETE-QUOTE) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-NEW-QUOTE) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-QUOTE) BACK-SPACE IL:_ (QUOTE BACKSPACE-QUOTE))) (QUOTE ((TM::HASH-DOT :HASH-DOT "^Q" PARSE--NEW-QUOTE INPUT-NEW-QUOTE) (TM::HASH-COMMA :HASH-COMMA "^F" PARSE--NEW-QUOTE INPUT-NEW-QUOTE))) (QUOTE (("#." :HASH-DOT) ("#," :HASH-COMMA)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-READABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE READABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-READABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) (QUOTE ((TM::HASH-IL-READABLE NIL NIL PARSE--CONDITIONAL-READ) (TM::HASH-IL-UNREADABLE NIL NIL PARSE--CONDITIONAL-READ))) (QUOTE (("#+" :HASH-PLUS) ("#-" :HASH-MINUS)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-UNREADABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE UNREADABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-UNREADABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) NIL NIL) (IL:* IL:|;;| "And for the final indignity, mung the command table to add a minor flakiness in the handling of + and -") (IL:|for| CP IL:|in| (QUOTE ((#\+ INPUT-PLUS-OR-MINUS) (#\- INPUT-PLUS-OR-MINUS))) IL:|bind| (COMTAB IL:_ (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) IL:|do| (SETF (GETHASH (CHAR-CODE (FIRST CP)) COMTAB) (IL:BQUOTE ((IL:\\\, (SECOND CP)) NIL (IL:\\\, (FIRST CP))))))) (DEFUN TM::MUNG-SEDIT-READ-TABLE (TM::CONTEXT) (IL:* IL:|;;| "Install a presentation-hacked readtable if the current readtable is IL:COMMONLISP-p and the thing being edited is a definer (and will hence be translated before installation)") (IF (AND (IL:FETCH IL:COMMONLISP IL:OF *READTABLE*) (GET (IL:FETCH EDIT-TYPE IL:OF TM::CONTEXT) :DEFINED-BY)) (LET (TM::NEWTBL) (IF (NULL (SETQ TM::NEWTBL (GETHASH *READTABLE* TM::*SEDIT-READ-TABLES*))) (PROGN (SETQ TM::NEWTBL (COPY-READTABLE *READTABLE*)) (WHEN (IL:FETCH IL:READTBLNAME IL:OF *READTABLE*) (SETF (IL:FETCH IL:READTBLNAME IL:OF TM::NEWTBL) (IL:CONCAT (IL:FETCH IL:READTBLNAME IL:OF *READTABLE*) "-SEDIT"))) (MAPHASH (FUNCTION (LAMBDA (TM::KEY TM::VAL) (IF (CONSP TM::KEY) (PROGN (MAKE-DISPATCH-MACRO-CHARACTER (CAR TM::KEY) T TM::NEWTBL) (SET-DISPATCH-MACRO-CHARACTER (CAR TM::KEY) (CDR TM::KEY) TM::VAL TM::NEWTBL)) (SET-MACRO-CHARACTER TM::KEY T TM::VAL TM::NEWTBL)))) TM::*SEDIT-READ-MACROS*))) (SETQ *READTABLE* TM::NEWTBL)))) (REINSTALL-ADVICE (QUOTE SETUP-PROFILE) :BEFORE (QUOTE ((:LAST (TM::MUNG-SEDIT-READ-TABLE IL:CONTEXT))))) (IL:READVISE SETUP-PROFILE) (DEFVAR TM::*SEDIT-READ-TABLES* (MAKE-HASH-TABLE) "Cache for readtables modified in support of TEXTMODULES") (IL:* IL:|;;| "Temporarily commenting this out for playing-around purposes") (INITIALIZE-COMMONLISP) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SEDIT" :BASE 10)) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1989 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3519 7696 (COPY-STRUCTURE-NEW-QUOTE 3532 . 4313) (INPUT-NEW-QUOTE 4315 . 5291) ( PARSE--NEW-QUOTE 5293 . 6195) (REPLACE-NEW-QUOTE 6197 . 7423) (SUBNODE-CHANGED-NEW-QUOTE 7425 . 7694)) (7829 27782 (ASSIGN-FORMAT-READ-TIME-CONDITIONAL 7842 . 8396) (BACKSPACE-READ-TIME-CONDITIONAL 8398 . 9984) (CFV-READ-TIME-CONDITIONAL 9986 . 10685) (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL 10687 . 12062) (COPY-STRUCTURE-READ-TIME-CONDITIONAL 12064 . 13274) (CREATE-NEW-READ-TIME-CONDITIONAL 13276 . 14156) (DELETE-READ-TIME-CONDITIONAL 14158 . 15127) (INPUT-CONDITIONAL-READ 15129 . 16043) ( INSERT-READ-TIME-CONDITIONAL 16045 . 16857) (INSERT-FLIPPED-READ-TIME-CONDITIONAL 16859 . 20814) ( LINEARIZE-READ-TIME-CONDITIONAL 20816 . 21450) (PARSE--CONDITIONAL-READ 21452 . 22046) ( REPLACE-READ-TIME-CONDITIONAL 22048 . 22920) (SET-POINT-READ-TIME-CONDITIONAL 22922 . 23952) ( SET-SELECTION-READ-TIME-CONDITIONAL 23954 . 24301) (STRINGIFY-READ-TIME-CONDITIONAL 24303 . 25080) ( SUBNODE-CHANGED-READABLE-RTC 25082 . 26045) (SUBNODE-CHANGED-UNREADABLE-RTC 26047 . 27334) ( UNDO-REPLACE-READ-TIME-CONDITIONAL 27336 . 27780)) (27933 40225 (CONDITIONALIZE-CURRENT-SELECTION 27946 . 28862) (CREATE-NEW-QUOTED-GAP 28864 . 30849) (INITIALIZE-COMMONLISP 30851 . 35286) ( INSERT-NEW-QUOTED-GAP 35288 . 36433) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP 36435 . 37193) ( INPUT-PLUS-OR-MINUS 37195 . 38988) (STRING-FLIP 38990 . 40223))))) IL:STOP \ No newline at end of file diff --git a/library/SKETCHELEMENTS.~1~ b/library/SKETCHELEMENTS.~1~ deleted file mode 100644 index 66b6113f..00000000 --- a/library/SKETCHELEMENTS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Jan-93 12:00:34" {DSK}lde>lispcore>library>SKETCHELEMENTS.;2 551304 changes to%: (FNS TEXT.DRAWFN1) previous date%: "12-Oct-92 12:42:39" {DSK}lde>lispcore>library>SKETCHELEMENTS.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHELEMENTSCOMS) (RPAQQ SKETCHELEMENTSCOMS ( (* ;  "contains the functions need to implement the sketch basic element types") (FNS INIT.SKETCH.ELEMENTS CREATE.SKETCH.ELEMENT.TYPE SKETCH.ELEMENT.TYPEP SKETCH.ELEMENT.NAMEP \CURSOR.IN.MIDDLE.MENU) (COMS (* ; "color and filling stuff") (FNS SKETCHINCOLORP READ.COLOR.CHANGE) (INITVARS (SKETCHINCOLORFLG) (FILLPOLYGONFLG T) (FILLINGMODEFLG T)) (INITVARS (SK.DEFAULT.BACKCOLOR) (SK.DEFAULT.OPERATION)) (GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR) (RECORDS SKFILLING) (* ;; "fns included until system is fixed so that it is ok to call DSPCOLOR in a system without color loaded. Should be removed after J release.") (FNS SK.CREATE.DEFAULT.FILLING SKFILLINGP SK.INSURE.FILLING SK.INSURE.COLOR) (FNS SK.TRANSLATE.MODE SK.CHANGE.FILLING.MODE READ.FILLING.MODE)) (COMS (FNS SKETCH.CREATE.CIRCLE CIRCLE.EXPANDFN CIRCLE.DRAWFN \CIRCLE.DRAWFN1 CIRCLE.INPUTFN SK.UPDATE.CIRCLE.AFTER.CHANGE SK.READ.CIRCLE.POINT SK.SHOW.CIRCLE CIRCLE.INSIDEFN CIRCLE.REGIONFN CIRCLE.GLOBALREGIONFN CIRCLE.TRANSLATE CIRCLE.READCHANGEFN CIRCLE.TRANSFORMFN CIRCLE.TRANSLATEPTS SK.CIRCLE.CREATE SET.CIRCLE.SCALE SK.BRUSH.READCHANGE) (FNS SK.INSURE.BRUSH SK.INSURE.DASHING) (RECORDS BRUSH) (DECLARE%: DONTCOPY (RECORDS LOCALCIRCLE CIRCLE)) (UGLYVARS CIRCLEICON) (CURSORS CIRCLE.CENTER CIRCLE.EDGE) (INITVARS [SK.DEFAULT.BRUSH (CONS 'ROUND (CONS 1 (CONS 'BLACK NIL] (* ;  "Original was (create BRUSH BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1 BRUSHCOLOR _ 'BLACK).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (SK.DEFAULT.DASHING) (SK.DEFAULT.TEXTURE)) (GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING SK.DEFAULT.TEXTURE)) (COMS (FNS SKETCH.CREATE.ELLIPSE ELLIPSE.EXPANDFN ELLIPSE.DRAWFN ELLIPSE.INPUTFN SK.READ.ELLIPSE.MAJOR.PT SK.SHOW.ELLIPSE.MAJOR.RADIUS SK.READ.ELLIPSE.MINOR.PT SK.SHOW.ELLIPSE.MINOR.RADIUS ELLIPSE.INSIDEFN ELLIPSE.CREATE SK.UPDATE.ELLIPSE.AFTER.CHANGE ELLIPSE.REGIONFN ELLIPSE.GLOBALREGIONFN ELLIPSE.TRANSLATEFN ELLIPSE.TRANSFORMFN ELLIPSE.TRANSLATEPTS MARK.SPOT DISTANCEBETWEEN SK.DISTANCE.TO SQUARE COMPUTE.ELLIPSE.ORIENTATION SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT) (DECLARE%: DONTCOPY (RECORDS LOCALELLIPSE ELLIPSE)) (UGLYVARS ELLIPSEICON) (CURSORS ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR)) (COMS (FNS SKETCH.CREATE.OPEN.CURVE OPENCURVE.INPUTFN SK.CURVE.CREATE MAXXEXTENT MAXYEXTENT KNOT.SET.SCALE.FIELD OPENCURVE.DRAWFN OPENCURVE.EXPANDFN OPENCURVE.READCHANGEFN OPENCURVE.TRANSFORMFN OPENCURVE.TRANSLATEFN OPENCURVE.TRANSLATEPTSFN SKETCH.CREATE.CLOSED.CURVE CLOSEDCURVE.DRAWFN CLOSEDCURVE.EXPANDFN CLOSEDCURVE.REGIONFN CLOSEDCURVE.GLOBALREGIONFN READ.LIST.OF.POINTS CLOSEDCURVE.INPUTFN CLOSEDCURVE.READCHANGEFN CLOSEDCURVE.TRANSFORMFN CLOSEDCURVE.TRANSLATEPTSFN INVISIBLEPARTP SHOWSKETCHPOINT SHOWSKETCHXY KNOTS.REGIONFN OPENWIRE.GLOBALREGIONFN CURVE.REGIONFN OPENCURVE.GLOBALREGIONFN KNOTS.TRANSLATEFN REGION.CONTAINING.PTS) (FNS CHANGE.ELTS.BRUSH.SIZE CHANGE.ELTS.BRUSH CHANGE.ELTS.BRUSH.SHAPE SK.CHANGE.BRUSH.SHAPE SK.CHANGE.BRUSH.COLOR SK.CHANGE.BRUSH.SIZE SK.CHANGE.ANGLE SK.CHANGE.ARC.DIRECTION SK.SET.DEFAULT.BRUSH.SIZE READSIZECHANGE) (FNS SK.CHANGE.ELEMENT.KNOTS) (FNS SK.INSURE.POINT.LIST SK.INSURE.POSITION) (DECLARE%: DONTCOPY (RECORDS KNOTELT LOCALCURVE OPENCURVE CLOSEDCURVE LOCALCLOSEDCURVE LOCALCLOSEDWIRE)) (UGLYVARS OPENCURVEICON CLOSEDCURVEICON) (CURSORS CURVE.KNOT)) (COMS (FNS SKETCH.CREATE.WIRE CLOSEDWIRE.EXPANDFN KNOTS.INSIDEFN OPEN.WIRE.DRAWFN WIRE.EXPANDFN SK.UPDATE.WIRE.ELT.AFTER.CHANGE OPENWIRE.READCHANGEFN OPENWIRE.TRANSFORMFN OPENWIRE.TRANSLATEFN OPENWIRE.TRANSLATEPTSFN WIRE.INPUTFN SK.READ.WIRE.POINTS SK.READ.POINTS.WITH.FEEDBACK OPENWIRE.FEEDBACKFN CLOSEDWIRE.FEEDBACKFN CLOSEDWIRE.REGIONFN CLOSEDWIRE.GLOBALREGIONFN SK.WIRE.CREATE WIRE.ADD.POINT.TO.END READ.ARROW.CHANGE CHANGE.ELTS.ARROWHEADS) (FNS SKETCH.CREATE.CLOSED.WIRE CLOSED.WIRE.INPUTFN CLOSED.WIRE.DRAWFN CLOSEDWIRE.READCHANGEFN CLOSEDWIRE.TRANSFORMFN CLOSEDWIRE.TRANSLATEPTSFN) (FNS SK.EXPAND.ARROWHEADS SK.COMPUTE.ARC.ARROWHEAD.POINTS ARC.ARROWHEAD.POINTS SET.ARC.ARROWHEAD.POINTS SET.OPENCURVE.ARROWHEAD.POINTS SK.COMPUTE.CURVE.ARROWHEAD.POINTS SET.WIRE.ARROWHEAD.POINTS SK.COMPUTE.WIRE.ARROWHEAD.POINTS SK.EXPAND.ARROWHEAD CHANGED.ARROW SK.CHANGE.ARROWHEAD SK.CHANGE.ARROWHEAD1 SK.CREATE.ARROWHEAD SK.ARROWHEAD.CREATE SK.ARROWHEAD.END.TEST READ.ARROWHEAD.END ARROW.HEAD.POSITIONS ARROWHEAD.POINTS.LIST CURVE.ARROWHEAD.POINTS LEFT.MOST.IS.BEGINP WIRE.ARROWHEAD.POINTS DRAWARROWHEADS \SK.DRAW.TRIANGLE.ARROWHEAD \SK.ENDPT.OF.ARROW \SK.ADJUST.FOR.ARROWHEADS SK.SET.ARROWHEAD.LENGTH SK.SET.ARROWHEAD.ANGLE SK.SET.ARROWHEAD.TYPE SK.SET.LINE.ARROWHEAD SK.UPDATE.ARROWHEAD.FORMAT SK.SET.LINE.LENGTH.MODE) (FNS SK.INSURE.ARROWHEADS SK.ARROWHEADP) (DECLARE%: DONTCOPY (RECORDS LOCALWIRE WIRE CLOSEDWIRE LOCALCLOSEDWIRE)) (RECORDS ARROWHEAD) (UGLYVARS VSHAPE.ARROWHEAD.BITMAP TRIANGLE.ARROWHEAD.BITMAP SOLIDTRIANGLE.ARROWHEAD.BITMAP CURVEDV.ARROWHEAD.BITMAP) (UGLYVARS WIREICON CLOSEDWIREICON) (INITVARS (SK.ARROWHEAD.ANGLE.INCREMENT 5) (SK.ARROWHEAD.LENGTH.INCREMENT 2)) (ADDVARS (SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID)) (INITVARS (SK.DEFAULT.ARROW.LENGTH 8) (SK.DEFAULT.ARROW.TYPE 'CURVE) (SK.DEFAULT.ARROW.ANGLE 18.0)) (GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE SK.ARROWHEAD.TYPES) (INITVARS (SK.ARROW.END.MENU) (SK.ARROW.EDIT.MENU))) (COMS (* ;  "stuff to support the text element type.") (FNS SKETCH.CREATE.TEXT TEXT.CHANGEFN TEXT.READCHANGEFN \SK.READ.FONT.SIZE1 SK.TEXT.ELT.WITH.SAME.FIELDS SK.READFONTFAMILY CLOSE.PROMPT.WINDOW TEXT.DRAWFN TEXT.DRAWFN1 TEXT.INSIDEFN TEXT.EXPANDFN SK.TEXT.LINE.REGIONS TEXT.UPDATE.GLOBAL.REGIONS REL.MOVE.REGION LTEXT.LINE.REGIONS TEXT.INPUTFN READ.TEXT TEXT.POSITION.AND.CREATE CREATE.TEXT.ELEMENT SK.UPDATE.TEXT.AFTER.CHANGE SK.TEXT.FROM.TEXTBOX TEXT.SET.GLOBAL.REGIONS TEXT.REGIONFN TEXT.GLOBALREGIONFN TEXT.TRANSLATEFN TEXT.TRANSFORMFN TEXT.TRANSLATEPTSFN TEXT.UPDATEFN SK.CHANGE.TEXT TEXT.SET.SCALES BREAK.AT.CARRIAGE.RETURNS) (FNS ADD.KNOWN.SKETCH.FONT SK.PICK.FONT SK.CHOOSE.TEXT.FONT SK.NEXTSIZEFONT SK.DECREASING.FONT.LIST SK.GUESS.FONTSAVAILABLE) (VARS (\KNOWN.SKETCH.FONTSIZES)) (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)) (DECLARE%: DONTCOPY (RECORDS TEXT LOCALTEXT)) (FNS SK.SET.FONT SK.SET.TEXT.FONT SK.SET.TEXT.SIZE SK.SET.TEXT.HORIZ.ALIGN SK.READFONTSIZE SK.COLLECT.FONT.SIZES SK.SET.TEXT.VERT.ALIGN SK.SET.TEXT.LOOKS SK.SET.DEFAULT.TEXT.FACE) (FNS CREATE.SKETCH.TERMTABLE) (FNS SK.FONT.LIST SK.INSURE.FONT SK.INSURE.STYLE SK.INSURE.TEXT) (VARS INDICATE.TEXT.SHADE) [INITVARS (SK.DEFAULT.FONT) (SK.DEFAULT.TEXT.ALIGNMENT '(CENTER BASELINE] (INITVARS \FONTSONFILE) (ADDVARS (SK.HORIZONTAL.STYLES LEFT RIGHT CENTER) (SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM)) (VARS (SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE))) (GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES)) (COMS (* ;  "stuff for supporting the TEXTBOX sketch element.") (FNS SKETCH.CREATE.TEXTBOX SK.COMPUTE.TEXTBOX.REGION.FOR.STRING SK.BREAK.INTO.LINES SK.BRUSH.SIZE SK.TEXTBOX.CREATE SK.TEXTBOX.CREATE1 SK.UPDATE.TEXTBOX.AFTER.CHANGE SK.TEXTBOX.POSITION.IN.BOX TEXTBOX.CHANGEFN TEXTBOX.DRAWFN SK.TEXTURE.AROUND.REGIONS ALL.EMPTY.REGIONS TEXTBOX.EXPANDFN TEXTBOX.INPUTFN TEXTBOX.INSIDEFN TEXTBOX.REGIONFN TEXTBOX.GLOBALREGIONFN TEXTBOX.SET.GLOBAL.REGIONS TEXTBOX.TRANSLATEFN TEXTBOX.TRANSLATEPTSFN TEXTBOX.TRANSFORMFN TEXTBOX.UPDATEFN TEXTBOX.READCHANGEFN SK.TEXTBOX.TEXT.POSITION SK.TEXTBOX.FROM.TEXT ADD.EOLS) (DECLARE%: DONTCOPY (RECORDS LOCALTEXTBOX TEXTBOX)) (COMS (* ;  "stuff to handle default alignment for text boxes") (FNS SK.SET.TEXTBOX.VERT.ALIGN SK.SET.TEXTBOX.HORIZ.ALIGN) (VARS TEXTBOXICON) [INITVARS (SK.DEFAULT.TEXTBOX.ALIGNMENT '(CENTER CENTER] (GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT))) (COMS (* ;  "functions to implement the box sketch element.") (FNS SKETCH.CREATE.BOX SK.BOX.DRAWFN BOX.DRAWFN1 KNOTS.OF.REGION SK.DRAWAREABOX SK.DRAWBOX SK.BOX.EXPANDFN SK.BOX.GETREGIONFN BOX.SET.SCALES SK.BOX.INPUTFN SK.BOX.CREATE SK.UPDATE.BOX.AFTER.CHANGE SK.BOX.INSIDEFN SK.BOX.REGIONFN SK.BOX.GLOBALREGIONFN SK.BOX.READCHANGEFN SK.CHANGE.FILLING SK.CHANGE.FILLING.COLOR SK.BOX.TRANSLATEFN SK.BOX.TRANSFORMFN SK.BOX.TRANSLATEPTSFN UNSCALE.REGION.TO.GRID INCREASEREGION INSUREREGIONSIZE EXPANDREGION REGION.FROM.COORDINATES) (DECLARE%: DONTCOPY (RECORDS BOX LOCALBOX)) (UGLYVARS BOXICON)) (COMS (* ;  "fns for the arc sketch element type") (FNS SKETCH.CREATE.ARC ARC.DRAWFN ARC.EXPANDFN ARC.INPUTFN SK.INVERT.CIRCLE SK.READ.ARC.ANGLE.POINT SK.SHOW.ARC ARC.CREATE SK.UPDATE.ARC.AFTER.CHANGE ARC.MOVEFN ARC.TRANSLATEPTS ARC.INSIDEFN ARC.REGIONFN ARC.GLOBALREGIONFN ARC.TRANSLATE ARC.TRANSFORMFN ARC.READCHANGEFN) (FNS SK.COMPUTE.ARC.ANGLE.PT SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE SK.COMPUTE.ARC.PTS SK.SET.ARC.DIRECTION SK.SET.ARC.DIRECTION.CW SK.SET.ARC.DIRECTION.CCW SK.COMPUTE.SLOPE.OF.LINE SK.CREATE.ARC.USING SET.ARC.SCALES) (FNS SK.INSURE.DIRECTION) (INITVARS (SK.NUMBER.OF.POINTS.IN.ARC 8)) (GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC) (DECLARE%: DONTCOPY (RECORDS ARC LOCALARC)) (CURSORS ARC.RADIUS.CURSOR ARC.ANGLE.CURSOR CW.ARC.ANGLE.CURSOR CW.ARC.RADIUS.CURSOR) (UGLYVARS ARCICON)) (COMS (* ;  "property getting and setting stuff") (FNS GETSKETCHELEMENTPROP \SK.GET.ARC.ANGLEPT \GETSKETCHELEMENTPROP1 \SK.GET.BRUSH \SK.GET.FILLING \SK.GET.ARROWHEADS \SK.GET.FONT \SK.GET.JUSTIFICATION \SK.GET.DIRECTION \SK.GET.DASHING PUTSKETCHELEMENTPROP \SK.PUT.FILLING ADDSKETCHELEMENTPROP REMOVESKETCHELEMENTPROP \SK.PUT.FONT \SK.PUT.JUSTIFICATION \SK.PUT.DIRECTION \SK.PUT.DASHING \SK.PUT.BRUSH \SK.PUT.ARROWHEADS SK.COPY.ELEMENT.PROPERTY.LIST SKETCH.UPDATE SKETCH.UPDATE1 \SKELT.GET.SCALE \SKELT.PUT.SCALE \SKELT.PUT.DATA SK.REPLACE.TEXT.IN.ELEMENT \SKELT.GET.DATA \SK.GET.1STCONTROLPT \SK.PUT.1STCONTROLPT \SK.GET.2NDCONTROLPT \SK.PUT.2NDCONTROLPT \SK.GET.3RDCONTROLPT \SK.PUT.3RDCONTROLPT) (FNS LOWERLEFTCORNER UPPERRIGHTCORNER)))) (* ; "contains the functions need to implement the sketch basic element types") (DEFINEQ (INIT.SKETCH.ELEMENTS [LAMBDA NIL (* ; "Edited 23-Jul-90 15:38 by matsuda") (* sets up the initial sketch  element types.) (* put the datatype for the element on the property list of the name and use  the name in the instances.) [COND ((NOT (SKETCH.ELEMENT.TYPEP 'CIRCLE)) (CREATE.SKETCH.ELEMENT.TYPE 'CIRCLE CIRCLEICON "Adds a circle to the figure." (FUNCTION CIRCLE.DRAWFN) (FUNCTION CIRCLE.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION CIRCLE.INPUTFN) (FUNCTION CIRCLE.INSIDEFN) (FUNCTION CIRCLE.REGIONFN) (FUNCTION CIRCLE.TRANSLATE) NIL (FUNCTION CIRCLE.READCHANGEFN) (FUNCTION CIRCLE.TRANSFORMFN) (FUNCTION CIRCLE.TRANSLATEPTS) (FUNCTION CIRCLE.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'ELLIPSE)) (CREATE.SKETCH.ELEMENT.TYPE 'ELLIPSE ELLIPSEICON "Adds an ellipse to the figure." (FUNCTION ELLIPSE.DRAWFN) (FUNCTION ELLIPSE.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION ELLIPSE.INPUTFN) (FUNCTION ELLIPSE.INSIDEFN) (FUNCTION ELLIPSE.REGIONFN) (FUNCTION ELLIPSE.TRANSLATEFN) NIL (FUNCTION SK.BRUSH.READCHANGE) (FUNCTION ELLIPSE.TRANSFORMFN) (FUNCTION ELLIPSE.TRANSLATEPTS) (FUNCTION ELLIPSE.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'ARC)) (CREATE.SKETCH.ELEMENT.TYPE 'ARC ARCICON "Adds an arc to the figure." (FUNCTION ARC.DRAWFN) (FUNCTION ARC.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION ARC.INPUTFN) (FUNCTION ARC.INSIDEFN) (FUNCTION ARC.REGIONFN) (FUNCTION ARC.TRANSLATE) NIL (FUNCTION ARC.READCHANGEFN) (FUNCTION ARC.TRANSFORMFN) (FUNCTION ARC.TRANSLATEPTS) (FUNCTION ARC.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'OPENCURVE)) (CREATE.SKETCH.ELEMENT.TYPE 'OPENCURVE OPENCURVEICON "Adds a curve by accepting points the curve goes through." (FUNCTION OPENCURVE.DRAWFN) (FUNCTION OPENCURVE.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION OPENCURVE.INPUTFN) (FUNCTION KNOTS.INSIDEFN) (FUNCTION CURVE.REGIONFN) (FUNCTION OPENCURVE.TRANSLATEFN) NIL (FUNCTION OPENCURVE.READCHANGEFN) (FUNCTION OPENCURVE.TRANSFORMFN) (FUNCTION OPENCURVE.TRANSLATEPTSFN) (FUNCTION OPENCURVE.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'CLOSEDCURVE)) (CREATE.SKETCH.ELEMENT.TYPE 'CLOSEDCURVE CLOSEDCURVEICON "Adds a closed curve by accepting points that it goes though." (FUNCTION CLOSEDCURVE.DRAWFN) (FUNCTION CLOSEDCURVE.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION CLOSEDCURVE.INPUTFN) (FUNCTION KNOTS.INSIDEFN) (FUNCTION CLOSEDCURVE.REGIONFN) (FUNCTION KNOTS.TRANSLATEFN) NIL (FUNCTION CLOSEDCURVE.READCHANGEFN) (FUNCTION CLOSEDCURVE.TRANSFORMFN) (FUNCTION CLOSEDCURVE.TRANSLATEPTSFN) (FUNCTION CLOSEDCURVE.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'WIRE)) (CREATE.SKETCH.ELEMENT.TYPE 'WIRE WIREICON "Adds a series of lines by accepting points." (FUNCTION OPEN.WIRE.DRAWFN) (FUNCTION WIRE.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION WIRE.INPUTFN) (FUNCTION KNOTS.INSIDEFN) (FUNCTION KNOTS.REGIONFN) (FUNCTION OPENWIRE.TRANSLATEFN) NIL (FUNCTION OPENCURVE.READCHANGEFN) (FUNCTION OPENWIRE.TRANSFORMFN) (FUNCTION OPENWIRE.TRANSLATEPTSFN) (FUNCTION OPENWIRE.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'CLOSEDWIRE)) (CREATE.SKETCH.ELEMENT.TYPE 'CLOSEDWIRE CLOSEDWIREICON "Adds a closed polygon by accepting the corners." (FUNCTION CLOSED.WIRE.DRAWFN) (FUNCTION CLOSEDWIRE.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION CLOSED.WIRE.INPUTFN) (FUNCTION KNOTS.INSIDEFN) (FUNCTION CLOSEDWIRE.REGIONFN) (FUNCTION KNOTS.TRANSLATEFN) NIL (FUNCTION CLOSEDWIRE.READCHANGEFN) (FUNCTION CLOSEDWIRE.TRANSFORMFN) (FUNCTION CLOSEDWIRE.TRANSLATEPTSFN) (FUNCTION CLOSEDWIRE.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'TEXT)) (CREATE.SKETCH.ELEMENT.TYPE 'TEXT NIL "text is added by pointing to its position and typing." (FUNCTION TEXT.DRAWFN) (FUNCTION TEXT.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION TEXT.INPUTFN) (FUNCTION TEXT.INSIDEFN) (FUNCTION TEXT.REGIONFN) (FUNCTION TEXT.TRANSLATEFN) (FUNCTION TEXT.UPDATEFN) (FUNCTION TEXT.READCHANGEFN) (FUNCTION TEXT.TRANSFORMFN) (FUNCTION TEXT.TRANSLATEPTSFN) (FUNCTION TEXT.GLOBALREGIONFN] [COND ((NOT (SKETCH.ELEMENT.TYPEP 'BOX)) (CREATE.SKETCH.ELEMENT.TYPE 'BOX BOXICON "Adds a box by accepting two corners." (FUNCTION SK.BOX.DRAWFN) (FUNCTION SK.BOX.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION SK.BOX.INPUTFN) (FUNCTION SK.BOX.INSIDEFN) (FUNCTION SK.BOX.REGIONFN) (FUNCTION SK.BOX.TRANSLATEFN) NIL (FUNCTION SK.BOX.READCHANGEFN) (FUNCTION SK.BOX.TRANSFORMFN) (FUNCTION SK.BOX.TRANSLATEPTSFN) (FUNCTION SK.BOX.GLOBALREGIONFN] (COND ((NOT (SKETCH.ELEMENT.TYPEP 'TEXTBOX)) (CREATE.SKETCH.ELEMENT.TYPE 'TEXTBOX TEXTBOXICON "Adds a box into which text can be typed." (FUNCTION TEXTBOX.DRAWFN) (FUNCTION TEXTBOX.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION TEXTBOX.INPUTFN) (FUNCTION TEXTBOX.INSIDEFN) (FUNCTION TEXTBOX.REGIONFN) (FUNCTION TEXTBOX.TRANSLATEFN) (FUNCTION TEXTBOX.UPDATEFN) (FUNCTION TEXTBOX.READCHANGEFN) (FUNCTION TEXTBOX.TRANSFORMFN) (FUNCTION TEXTBOX.TRANSLATEPTSFN) (FUNCTION TEXTBOX.GLOBALREGIONFN]) (CREATE.SKETCH.ELEMENT.TYPE [LAMBDA (SKETCHTYPE LABEL DOCSTR DRAWFN EXPANDFN OBSOLETE CHANGEFN INPUTFN INSIDEFN REGIONFN TRANSLATEFN UPDATEFN READCHANGEFN TRANSFORMFN TRANSLATEPTSFN GLOBALREGIONFN) (* rrb "18-Oct-85 17:18") (* creates a new sketch element type.) (COND ((AND OBSOLETE (NEQ OBSOLETE 'OBSOLETE)) (printout T OBSOLETE " will never be called. CREATE.SKETCH.ELEMENT.TYPE"))) (SETQ SKETCH.ELEMENT.TYPES (CONS (PUTPROP SKETCHTYPE 'SKETCHTYPE (create SKETCHTYPE LABEL _ LABEL DOCSTR _ DOCSTR DRAWFN _ DRAWFN EXPANDFN _ EXPANDFN CHANGEFN _ CHANGEFN INPUTFN _ INPUTFN INSIDEFN _ INSIDEFN REGIONFN _ REGIONFN TRANSLATEFN _ TRANSLATEFN UPDATEFN _ UPDATEFN READCHANGEFN _ READCHANGEFN TRANSFORMFN _ TRANSFORMFN TRANSLATEPTSFN _ TRANSLATEPTSFN GLOBALREGIONFN _ GLOBALREGIONFN)) SKETCH.ELEMENT.TYPES)) (OR (MEMB SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES) (SETQ SKETCH.ELEMENT.TYPE.NAMES (CONS SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES))) SKETCHTYPE]) (SKETCH.ELEMENT.TYPEP [LAMBDA (SKETCHTYPE) (* rrb "28-Dec-84 15:39") (* is SKETCHTYPE a sketch element  type?) (AND (MEMB SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES) (GETPROP SKETCHTYPE 'SKETCHTYPE]) (SKETCH.ELEMENT.NAMEP [LAMBDA (X) (* rrb "18-MAR-83 11:53") (* is X a sketch element type name?) (FMEMB X SKETCH.ELEMENT.TYPE.NAMES]) (\CURSOR.IN.MIDDLE.MENU [LAMBDA (MENU) (* rrb " 6-Nov-85 09:46") (* brings up the menu so that the cursor is in the middle.) (MENU MENU (create POSITION XCOORD _ (DIFFERENCE LASTMOUSEX (QUOTIENT (fetch (MENU IMAGEWIDTH) of MENU) 2)) YCOORD _ (DIFFERENCE LASTMOUSEY (QUOTIENT (fetch (MENU IMAGEHEIGHT) of MENU) 2]) ) (* ; "color and filling stuff") (DEFINEQ (SKETCHINCOLORP [LAMBDA NIL (* rrb "12-Jul-85 10:11") (* hook to determine if sketch should  allow color.) SKETCHINCOLORFLG]) (READ.COLOR.CHANGE [LAMBDA (MSG ALLOWNONEFLG CURRENTCOLOR) (* rrb "29-Oct-85 12:30") (* reads a color from the user and  returns it) (READCOLOR1 MSG ALLOWNONEFLG CURRENTCOLOR]) ) (RPAQ? SKETCHINCOLORFLG ) (RPAQ? FILLPOLYGONFLG T) (RPAQ? FILLINGMODEFLG T) (RPAQ? SK.DEFAULT.BACKCOLOR ) (RPAQ? SK.DEFAULT.OPERATION ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR) ) (DECLARE%: EVAL@COMPILE (RECORD SKFILLING (FILLING.TEXTURE FILLING.COLOR FILLING.OPERATION)) ) (* ;; "fns included until system is fixed so that it is ok to call DSPCOLOR in a system without color loaded. Should be removed after J release." ) (DEFINEQ (SK.CREATE.DEFAULT.FILLING [LAMBDA NIL (* rrb "21-Feb-86 11:22") (create SKFILLING FILLING.TEXTURE _ SK.DEFAULT.TEXTURE FILLING.COLOR _ SK.DEFAULT.BACKCOLOR FILLING.OPERATION _ SK.DEFAULT.OPERATION]) (SKFILLINGP [LAMBDA (FILLING) (* rrb "21-Feb-86 11:20") (* determines if FILLING is a legal  sketch filling.) (COND ((AND (LISTP FILLING) (TEXTUREP (fetch (SKFILLING FILLING.TEXTURE) of FILLING)) (NULL (CDDDR FILLING))) (* should also check if (fetch (SKFILLING FILLING.COLOR)) is a color and that  (SKFILLING FILLING.OPERATION) is an operation.) FILLING]) (SK.INSURE.FILLING [LAMBDA (FILLING SKW) (* rrb "16-Oct-85 15:47") (* converts several possible legal filling specifications into a sketch filling) (COND ((SKFILLINGP FILLING)) (T (PROG [(DEFAULTFILLING (COND [(WINDOWP SKW) (fetch (SKETCHCONTEXT SKETCHFILLING) of (WINDOWPROP SKW 'SKETCHCONTEXT] (T (SK.CREATE.DEFAULT.FILLING] (RETURN (COND ((NULL FILLING) DEFAULTFILLING) ((TEXTUREP FILLING) (create SKFILLING using DEFAULTFILLING FILLING.TEXTURE _ FILLING)) ((\POSSIBLECOLOR FILLING) (* note that small numbers can be either a texture or a color.  This algorithm will make them be a texture.) (create SKFILLING using DEFAULTFILLING FILLING.COLOR _ FILLING)) (T (* should be a check here for a color  too.) (\ILLEGAL.ARG FILLING]) (SK.INSURE.COLOR [LAMBDA (COLOR) (* rrb "16-Oct-85 18:05") (* checks the validity of a color  argument.) (COND ((NULL COLOR) NIL) ((\POSSIBLECOLOR COLOR)) (T (\ILLEGAL.ARG COLOR]) ) (DEFINEQ (SK.TRANSLATE.MODE [LAMBDA (OPERATION STREAM) (* rrb "10-Mar-86 17:20") (* picks the best operation for a  filling.) (COND ((EQ (DSPOPERATION NIL STREAM) 'ERASE) (* drawing should do its best job of erasing the current image) (SELECTQ OPERATION (INVERT 'INVERT) (ERASE (* don't know what to do because we don't know what bits were removed but this  at least lets the user know something happened wrt this element.) 'PAINT) 'ERASE)) (T OPERATION]) (SK.CHANGE.FILLING.MODE [LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 3-Mar-86 14:36") (* changes the texture in the element  ELTWITHFILLING.) (PROG (GFILLEDELT MODE FILLING NEWFILLING TYPE NEWELT) (RETURN (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING)) '(BOX TEXTBOX CLOSEDWIRE CIRCLE)) (* only works for things that have a filling, for now just boxes and polygons) (SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING)) [SETQ MODE (fetch (SKFILLING FILLING.OPERATION) of (SETQ FILLING (SELECTQ TYPE (BOX (fetch (BOX BOXFILLING) of GFILLEDELT)) (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) of GFILLEDELT)) (CIRCLE (fetch (CIRCLE CIRCLEFILLING) of GFILLEDELT)) (CLOSEDWIRE (fetch (CLOSEDWIRE CLOSEDWIREFILLING) of GFILLEDELT)) (SHOULDNT] (COND ((NOT (EQUAL HOW MODE)) (* new filling mode) (SETQ NEWFILLING (create SKFILLING using FILLING FILLING.OPERATION _ HOW)) (SETQ NEWELT (SELECTQ TYPE (BOX (create BOX using GFILLEDELT BOXFILLING _ NEWFILLING)) (TEXTBOX (create TEXTBOX using GFILLEDELT TEXTBOXFILLING _ NEWFILLING)) (CLOSEDWIRE (create CLOSEDWIRE using GFILLEDELT CLOSEDWIREFILLING _ NEWFILLING)) (CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING _ NEWFILLING)) (SHOULDNT))) (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHFILLING) INDIVIDUALGLOBALPART _ NEWELT) OLDELT _ ELTWITHFILLING PROPERTY _ 'FILLING NEWVALUE _ NEWFILLING OLDVALUE _ FILLING]) (READ.FILLING.MODE [LAMBDA NIL (* rrb " 3-Mar-86 14:30") (* reads a filling mode from the user.) (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "How should the filling merge with the covered figures?" MENUROWS _ 1 ITEMS _ '((REPLACE 'REPLACE "the filling completely covers anything under it." ) (PAINT 'PAINT "the black parts of the filling cover but the white parts show through." ) (ERASE 'ERASE "the black parts of the filling are erased.") (INVERT 'INVERT "the black parts of the filling are inverted."]) ) (DEFINEQ (SKETCH.CREATE.CIRCLE [LAMBDA (CENTERPT RADIUSPT BRUSH DASHING FILLING SCALE) (* rrb "11-Dec-85 10:43") (* creates a sketch circle element.) (SK.CIRCLE.CREATE (SK.INSURE.POSITION CENTERPT) (COND [(NUMBERP RADIUSPT) (create POSITION XCOORD _ (PLUS (fetch (POSITION XCOORD) of CENTERPT) RADIUSPT) YCOORD _ (PLUS (fetch (POSITION YCOORD) of CENTERPT] (T (SK.INSURE.POSITION RADIUSPT))) (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) (OR (NUMBERP SCALE) 1.0) (SK.INSURE.FILLING FILLING]) (CIRCLE.EXPANDFN [LAMBDA (GCIRCLE SCALE) (* rrb " 7-Dec-85 20:45") (* returns a screen elt that has a circle screen element calculated from the  global part.) (PROG (CENTER RADIUSPT BRUSH (INDGCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE))) (* check to make sure there is an initial scale field.  This change was introduced on Apr 27 and can be taken out the release after  Jazz It can also be taken out of the other expand fns as well.) [COND ((fetch (CIRCLE CIRCLEINITSCALE) of INDGCIRCLE)) (T (* old format didn't have an initial scale, default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE with (SETQ INDGCIRCLE (create CIRCLE using INDGCIRCLE CIRCLEINITSCALE _ 1.0] (RETURN (create SCREENELT LOCALPART _ (create LOCALCIRCLE CENTERPOSITION _ (SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER (fetch (CIRCLE CENTERLATLON) of INDGCIRCLE) SCALE)) RADIUSPOSITION _ (SETQ RADIUSPT (SK.SCALE.POSITION.INTO.VIEWER (fetch (CIRCLE RADIUSLATLON) of INDGCIRCLE) SCALE)) RADIUS _ (DISTANCEBETWEEN CENTER RADIUSPT) LOCALCIRCLEBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ BRUSH (fetch (CIRCLE BRUSH) of INDGCIRCLE] (* new format, old format had brush  width only.) BRUSH) (T [replace (CIRCLE BRUSH) of INDGCIRCLE with (SETQ BRUSH (create BRUSH BRUSHSIZE _ BRUSH BRUSHSHAPE _ 'ROUND] BRUSH)) (fetch (CIRCLE CIRCLEINITSCALE) of INDGCIRCLE) SCALE) LOCALCIRCLEFILLING _ (APPEND (fetch (CIRCLE CIRCLEFILLING) of INDGCIRCLE)) LOCALCIRCLEDASHING _ (fetch (CIRCLE DASHING) of INDGCIRCLE)) GLOBALPART _ GCIRCLE]) (CIRCLE.DRAWFN [LAMBDA (CIRCLEELT WINDOW REGION) (* rrb "20-Jun-86 17:08") (* draws a circle from a circle  element.) (PROG ((GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLEELT)) (LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLEELT)) CPOS DASHING FILLING) (SETQ CPOS (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE)) (SETQ DASHING (fetch (LOCALCIRCLE LOCALCIRCLEDASHING) of LCIRCLE)) (SETQ FILLING (fetch (LOCALCIRCLE LOCALCIRCLEFILLING) of LCIRCLE)) (COND ((fetch (SKFILLING FILLING.COLOR) of FILLING) (* if the circle is filled with a color call FILLCIRCLE with both the texture  and the color. This allows iris to do its thing before textures and colors are  merged.) (DSPOPERATION (PROG1 (DSPOPERATION (fetch (SKFILLING FILLING.OPERATION) of FILLING) WINDOW) (FILLCIRCLE (fetch (POSITION XCOORD) of CPOS) (fetch (POSITION YCOORD) of CPOS) (fetch (LOCALCIRCLE RADIUS) of LCIRCLE) FILLING WINDOW)) WINDOW)) ((fetch (SKFILLING FILLING.TEXTURE) of FILLING) (* if the circle is filled with  texture, call FILLCIRCLE.) (DSPOPERATION (PROG1 (DSPOPERATION (fetch (SKFILLING FILLING.OPERATION) of FILLING) WINDOW) (FILLCIRCLE (fetch (POSITION XCOORD) of CPOS) (fetch (POSITION YCOORD) of CPOS) (fetch (LOCALCIRCLE RADIUS) of LCIRCLE) (COND ((EQ (DSPOPERATION NIL WINDOW) 'ERASE) (* use black in case the window moved because of texture to window alignment  bug.) BLACKSHADE) (T (fetch (SKFILLING FILLING.TEXTURE) of FILLING))) WINDOW)) WINDOW))) (RETURN (\CIRCLE.DRAWFN1 CPOS (fetch (LOCALCIRCLE RADIUSPOSITION) of LCIRCLE) (fetch (LOCALCIRCLE RADIUS) of LCIRCLE) (fetch (LOCALCIRCLE LOCALCIRCLEBRUSH) of LCIRCLE) DASHING WINDOW]) (\CIRCLE.DRAWFN1 [LAMBDA (CENTERPT RADIUSPT RADIUS BRUSH DASHING WINDOW) (* ; "Edited 17-Apr-90 17:24 by matsuda") (* draws a circle for sketch from  some information. Calls by  CIRCLE.DRAWFN and ARC.DRAWFN) (COND (DASHING (* draw it with the arc drawing code  which does dashing.) (DRAWCURVE (SK.COMPUTE.ARC.PTS CENTERPT RADIUSPT [COND [(LESSP (FETCH (POSITION XCOORD) OF CENTERPT) (FETCH (POSITION XCOORD) OF RADIUSPT)) (PTPLUS RADIUSPT (CONSTANT (create POSITION XCOORD _ 0 YCOORD _ -1] [(GREATERP (FETCH (POSITION XCOORD) OF CENTERPT) (FETCH (POSITION XCOORD) OF RADIUSPT)) (PTPLUS RADIUSPT (CONSTANT (create POSITION XCOORD _ 0 YCOORD _ 1] [(LESSP (FETCH (POSITION YCOORD) OF CENTERPT) (FETCH (POSITION YCOORD) OF RADIUSPT)) (PTPLUS RADIUSPT (CONSTANT (create POSITION XCOORD _ 1 YCOORD _ 0] (T (PTPLUS RADIUSPT (CONSTANT (create POSITION XCOORD _ -1 YCOORD _ 0] NIL) T BRUSH DASHING WINDOW)) (T (DRAWCIRCLE (fetch (POSITION XCOORD) of CENTERPT) (fetch (POSITION YCOORD) of CENTERPT) RADIUS BRUSH DASHING WINDOW]) (CIRCLE.INPUTFN [LAMBDA (WINDOW) (* rrb "20-May-86 10:49") (* reads a two points from the user and returns a circle element that it  represents.) (PROG [CENTERPT RADIUSPT (SKETCHCONTEXT (WINDOWPROP WINDOW 'SKETCHCONTEXT] (STATUSPRINT WINDOW " " "Indicate center of circle") (COND ((NOT (SETQ CENTERPT (SK.READ.POINT.WITH.FEEDBACK WINDOW CIRCLE.CENTER NIL NIL NIL NIL SKETCH.USE.POSITION.PAD))) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTERPT) NIL WINDOW) (STATUSPRINT WINDOW " " "Indicate a point of the circumference of the circle") (SETQ RADIUSPT (SK.READ.CIRCLE.POINT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTERPT) CIRCLE.EDGE)) (* erase center mark) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTERPT) NIL WINDOW) (CLOSEPROMPTWINDOW WINDOW) (OR RADIUSPT (RETURN NIL)) (SETQ CENTERPT (SK.MAP.INPUT.PT.TO.GLOBAL CENTERPT WINDOW)) (SETQ RADIUSPT (SK.MAP.INPUT.PT.TO.GLOBAL RADIUSPT WINDOW)) (RETURN (SK.CIRCLE.CREATE CENTERPT RADIUSPT (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT ) (fetch (SKETCHCONTEXT SKETCHDASHING) of SKETCHCONTEXT) (SK.INPUT.SCALE WINDOW) (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT]) (SK.UPDATE.CIRCLE.AFTER.CHANGE [LAMBDA (GCIRELT) (* rrb " 7-Dec-85 19:50") (* updates the dependent fields of a circle element when a field changes.) (replace (CIRCLE CIRCLEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT) with NIL]) (SK.READ.CIRCLE.POINT [LAMBDA (WINDOW CENTERPT CURSOR) (* rrb "20-May-86 10:46") (* reads a point from the user prompting them with a circle that follows the  cursor) (SK.READ.POINT.WITH.FEEDBACK WINDOW CURSOR (AND SKETCH.VERBOSE.FEEDBACK (FUNCTION SK.SHOW.CIRCLE) ) CENTERPT 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.CIRCLE [LAMBDA (X Y WINDOW CENTERPT) (* rrb "15-Nov-85 14:18") (* xors a circle to X Y from CENTERPT in a window.  Used as the feedback function for reading the radius point for circles.) (* Mark the point too.) (SHOWSKETCHXY X Y WINDOW) (PROG ((CENTERX (fetch (POSITION XCOORD) of CENTERPT)) (CENTERY (fetch (POSITION YCOORD) of CENTERPT))) (DRAWCIRCLE CENTERX CENTERY (SK.DISTANCE.TO CENTERX CENTERY X Y) 1 NIL WINDOW]) (CIRCLE.INSIDEFN [LAMBDA (GCIRCLE WREG) (* rrb "20-Jan-87 14:44") (* determines if the global circle GCIRCLE is inside of WREG.) (REGIONSINTERSECTP WREG (CIRCLE.GLOBALREGIONFN GCIRCLE]) (CIRCLE.REGIONFN [LAMBDA (CIRCSCRELT) (* rrb " 3-Oct-85 17:12") (* returns the region occuppied by a  circle.) (PROG ((LOCALCIRCLE (fetch (SCREENELT LOCALPART) of CIRCSCRELT)) RADIUS) (SETQ RADIUS (IPLUS (FIX (ADD1 (fetch (LOCALCIRCLE RADIUS) of LOCALCIRCLE))) (LRSH [ADD1 (MAX 1 (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALCIRCLE LOCALCIRCLEBRUSH ) of LOCALCIRCLE ] 1))) (RETURN (CREATEREGION (IDIFFERENCE (fetch (POSITION XCOORD) of (SETQ LOCALCIRCLE (fetch (LOCALCIRCLE CENTERPOSITION ) of LOCALCIRCLE))) RADIUS) (IDIFFERENCE (fetch (POSITION YCOORD) of LOCALCIRCLE) RADIUS) (SETQ RADIUS (ITIMES RADIUS 2)) RADIUS]) (CIRCLE.GLOBALREGIONFN [LAMBDA (GCIRELT) (* rrb "18-Oct-85 16:32") (* returns the global region occupied by a global circle element.) (OR (fetch (CIRCLE CIRCLEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT)) (PROG ((INDVCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT)) RADIUS CENTER REGION) (* make the radius be too large by the amount of the brush to catch round off,  i.e. it should be half the brush size.) [SETQ RADIUS (PLUS (DISTANCEBETWEEN (SETQ CENTER (fetch (CIRCLE CENTERLATLON) of INDVCIRCLE)) (fetch (CIRCLE RADIUSLATLON) of INDVCIRCLE)) (fetch (BRUSH BRUSHSIZE) of (fetch (CIRCLE BRUSH) of INDVCIRCLE] (SETQ REGION (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of CENTER) RADIUS) (DIFFERENCE (fetch (POSITION YCOORD) of CENTER) RADIUS) (SETQ RADIUS (TIMES RADIUS 2)) RADIUS)) (replace (CIRCLE CIRCLEREGION) of INDVCIRCLE with REGION) (RETURN REGION]) (CIRCLE.TRANSLATE [LAMBDA (CIRCLESKELT DELTAPOS) (* rrb "18-Oct-85 11:00") (* returns a changed global circle element which has the circle translated by  DELTAPOS.) (PROG ((GCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of CIRCLESKELT))) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of CIRCLESKELT )) INDIVIDUALGLOBALPART _ (create CIRCLE using GCIRCLE CENTERLATLON _ (PTPLUS (fetch (CIRCLE CENTERLATLON ) of GCIRCLE) DELTAPOS) RADIUSLATLON _ (PTPLUS (fetch (CIRCLE RADIUSLATLON ) of GCIRCLE) DELTAPOS) CIRCLEREGION _ NIL]) (CIRCLE.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* ; "Edited 23-Jul-90 15:30 by matsuda") (* the users has selected SCRNELT to be changed this function reads a  specification of how the circle elements should change.) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Which aspect?" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '(("Brush color" 'BRUSHCOLOR "changes the color of the outline" ) ("Filling color" 'FILLINGCOLOR "changes the color of the filling" ] (T NIL)) [COND (FILLPOLYGONFLG '((Filling 'FILLING "allows changing of the filling texture of the box." ] [COND (FILLINGMODEFLG '(("Filling mode" 'FILLINGMODE "changes how the filling effects the figures it covers." ] '((Shape 'SHAPE "changes the shape of the brush") (Size 'SIZE "changes the size of the brush") (Dashing 'DASHING "changes the dashing of the line."] (SIZE (READSIZECHANGE "Change size how?" T)) (FILLING (READ.FILLING.CHANGE)) (FILLINGMODE (READ.FILLING.MODE)) (DASHING (READ.DASHING.CHANGE)) (SHAPE (READBRUSHSHAPE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART ) of (CAR SCRNELTS )) 'BRUSH]) (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T (fetch (SKFILLING FILLING.COLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'FILLING]) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) (CIRCLE.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 11:04") (* returns a copy of the global element that has had each of its control points  transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to  tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ (create CIRCLE using INDVPART CENTERLATLON _ (SK.TRANSFORM.POINT (fetch (CIRCLE CENTERLATLON) of INDVPART) TRANSFORMFN TRANSFORMDATA) RADIUSLATLON _ (SK.TRANSFORM.POINT (fetch (CIRCLE RADIUSLATLON) of INDVPART) TRANSFORMFN TRANSFORMDATA) BRUSH _ (SK.TRANSFORM.BRUSH (fetch (CIRCLE BRUSH) of INDVPART) SCALEFACTOR) CIRCLEREGION _ NIL]) (CIRCLE.TRANSLATEPTS [LAMBDA (CIRCLESPEC SELPTS GLOBALDELTA WINDOW) (* rrb " 9-Aug-85 09:55") (* returns a changed global circle element which has the part SELPOS moved to  NEWPOS.) (PROG ((LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLESPEC)) (GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLESPEC))) (RETURN (SK.CIRCLE.CREATE (COND ((MEMBER (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE) SELPTS) (* move the center) (PTPLUS (fetch (CIRCLE CENTERLATLON) of GCIRCLE) GLOBALDELTA)) (T (fetch (CIRCLE CENTERLATLON) of GCIRCLE))) (COND ((MEMBER (fetch (LOCALCIRCLE RADIUSPOSITION) of LCIRCLE) SELPTS) (* move the radius point.) (PTPLUS (fetch (CIRCLE RADIUSLATLON) of GCIRCLE) GLOBALDELTA)) (T (fetch (CIRCLE RADIUSLATLON) of GCIRCLE))) (fetch (CIRCLE BRUSH) of GCIRCLE) (fetch (CIRCLE DASHING) of GCIRCLE) (fetch (CIRCLE CIRCLEINITSCALE) of GCIRCLE) (fetch (CIRCLE CIRCLEFILLING) of GCIRCLE]) (SK.CIRCLE.CREATE [LAMBDA (CENTERPT RADIUSPT BRUSH DASHING INITSCALE FILLING)(* rrb "18-Oct-85 11:01") (* creates a sketch element) (* region is a cache that will be filled if needed.) (SET.CIRCLE.SCALE (create GLOBALPART INDIVIDUALGLOBALPART _ (create CIRCLE CENTERLATLON _ CENTERPT RADIUSLATLON _ RADIUSPT BRUSH _ BRUSH DASHING _ DASHING CIRCLEINITSCALE _ INITSCALE CIRCLEFILLING _ FILLING CIRCLEREGION _ NIL]) (SET.CIRCLE.SCALE [LAMBDA (GCIRCELT) (* rrb " 7-Feb-85 12:22") (* sets the scale fields in a circle. Sets scale so that it goes from radius 1  to 3000.0) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCELT)) RAD) (SETQ RAD (DISTANCEBETWEEN (fetch (CIRCLE CENTERLATLON) of INDVPART) (fetch (CIRCLE RADIUSLATLON) of INDVPART))) (replace (GLOBALPART COMMONGLOBALPART) of GCIRCELT with (create COMMONGLOBALPART MAXSCALE _ RAD MINSCALE _ (QUOTIENT RAD 3000.0))) (RETURN GCIRCELT]) (SK.BRUSH.READCHANGE [LAMBDA (SKW SCRNELTS) (* rrb " 6-Nov-85 09:49") (* changefn for curves) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "select aspect of brush to change" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '(("Color" 'BRUSHCOLOR "changes the color of the brush" ] (T NIL)) '((Shape 'SHAPE "changes the shape of the brush" ) (Size 'SIZE "changes the size of the brush" ) (Dashing 'DASHING "changes the dashing of the line." ] (SIZE (READSIZECHANGE "Change size how?")) (SHAPE (READBRUSHSHAPE)) (DASHING (READ.DASHING.CHANGE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change brush color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'BRUSH]) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) ) (DEFINEQ (SK.INSURE.BRUSH [LAMBDA (BRUSH) (* rrb "16-Oct-85 15:37") (* coerces BRUSH into a brush. Errors if it won't go.) (COND ((BRUSHP BRUSH)) ((NUMBERP BRUSH) (create BRUSH BRUSHSIZE _ BRUSH)) ((NULL BRUSH) SK.DEFAULT.BRUSH) (T (\ILLEGAL.ARG BRUSH]) (SK.INSURE.DASHING [LAMBDA (DASHING) (* rrb "16-Oct-85 17:04") (* checks the validity of a dashing argument.  NIL is ok and means no dashing.) (AND DASHING (OR (DASHINGP DASHING) (\ILLEGAL.ARG DASHING]) ) (DECLARE%: EVAL@COMPILE (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALCIRCLE ((CENTERPOSITION RADIUSPOSITION) LOCALHOTREGION RADIUS LOCALCIRCLEBRUSH LOCALCIRCLEFILLING LOCALCIRCLEDASHING )) (TYPERECORD CIRCLE (CENTERLATLON RADIUSLATLON BRUSH DASHING CIRCLEINITSCALE CIRCLEFILLING CIRCLEREGION)) ) ) (READVARS-FROM-STRINGS '(CIRCLEICON) "({(READBITMAP)(20 12 %"@AOH@@@@%" %"@COL@@@@%" %"@G@N@@@@%" %"@F@F@@@@%" %"@N@G@@@@%" %"@L@C@@@@%" %"@L@C@@@@%" %"@N@G@@@@%" %"@F@F@@@@%" %"@G@N@@@@%" %"@COL@@@@%" %"@AOH@@@@%")}) ") (RPAQ CIRCLE.CENTER (CURSORCREATE (QUOTE #*(16 16)@@@@@GL@AOO@CLGHG@ALF@@LN@@NL@@FL@@FL@@FN@@NF@@LG@ALCLGHAON@@GH@ ) (QUOTE NIL) 7 7)) (RPAQ CIRCLE.EDGE (CURSORCREATE (QUOTE #*(16 16)@@@L@@@D@@@F@@@B@@@C@@LA@@OA@@GMOOOO@@GM@@OA@@LC@@@B@@@F@@@D@@@L ) (QUOTE NIL) 15 7)) (RPAQ? SK.DEFAULT.BRUSH (CONS 'ROUND (CONS 1 (CONS 'BLACK NIL)))) (RPAQ? SK.DEFAULT.DASHING ) (RPAQ? SK.DEFAULT.TEXTURE ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING SK.DEFAULT.TEXTURE) ) (DEFINEQ (SKETCH.CREATE.ELLIPSE [LAMBDA (CENTERPT ORIENTATIONPT OTHERRADIUSPT BRUSH DASHING WILLBEFILLING SCALE) (* rrb "16-Oct-85 17:05") (* creates a sketch ellipse element.) (ELLIPSE.CREATE (SK.INSURE.POSITION CENTERPT) (SK.INSURE.POSITION ORIENTATIONPT) (SK.INSURE.POSITION OTHERRADIUSPT) (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) (OR (NUMBERP SCALE) 1.0]) (ELLIPSE.EXPANDFN [LAMBDA (GELLIPSE SCALE) (* rrb " 7-Dec-85 20:40") (* returns a screen elt that has a ellipse screen element calculated from the  global part.) (PROG (CENTER MINRAD MAJRAD BRUSH (INDGELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSE))) [COND ((fetch (ELLIPSE ELLIPSEINITSCALE) of INDGELLIPSE)) (T (* old format didn't have an initial scale, create one and default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSE with (SETQ INDGELLIPSE (create ELLIPSE using INDGELLIPSE ELLIPSEINITSCALE _ 1.0 ELLIPSEREGION _ NIL] (RETURN (create SCREENELT LOCALPART _ (create LOCALELLIPSE ELLIPSECENTER _ (SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER (fetch (ELLIPSE ELLIPSECENTERLATLON) of INDGELLIPSE) SCALE)) MINORRADIUSPOSITION _ (SETQ MINRAD (SK.SCALE.POSITION.INTO.VIEWER (fetch (ELLIPSE SEMIMINORLATLON) of INDGELLIPSE) SCALE)) MAJORRADIUSPOSITION _ (SETQ MAJRAD (SK.SCALE.POSITION.INTO.VIEWER (fetch (ELLIPSE SEMIMAJORLATLON) of INDGELLIPSE) SCALE)) SEMIMINORRADIUS _ (DISTANCEBETWEEN CENTER MINRAD) SEMIMAJORRADIUS _ (DISTANCEBETWEEN CENTER MAJRAD) LOCALELLIPSEBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ BRUSH (fetch (ELLIPSE BRUSH) of INDGELLIPSE] (* new format, old format had brush  width only.) BRUSH) (T [replace (ELLIPSE BRUSH) of INDGELLIPSE with (SETQ BRUSH (create BRUSH BRUSHSIZE _ BRUSH BRUSHSHAPE _ 'ROUND] BRUSH)) (fetch (ELLIPSE ELLIPSEINITSCALE) of INDGELLIPSE) SCALE) LOCALELLIPSEDASHING _ (fetch (ELLIPSE DASHING) of INDGELLIPSE)) GLOBALPART _ GELLIPSE]) (ELLIPSE.DRAWFN [LAMBDA (ELLIPSEELT WINDOW REGION) (* rrb " 7-Dec-85 20:40") (* draws a ellipse from a circle  element.) (PROG ((GELLIPSE (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELLIPSEELT)) (LELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSEELT)) CPOS DASHING ORIENTATION) (SETQ CPOS (fetch (LOCALELLIPSE ELLIPSECENTER) of LELLIPSE)) (SETQ DASHING (fetch (LOCALELLIPSE LOCALELLIPSEDASHING) of LELLIPSE)) (SETQ ORIENTATION (fetch (ELLIPSE ORIENTATION) of GELLIPSE)) (RETURN (COND (DASHING (* draw it with the curve drawing code which does dashing.) (PROG ((SINOR (SIN ORIENTATION)) (COSOR (COS ORIENTATION)) (CENTERX (fetch (POSITION XCOORD) of CPOS)) (CENTERY (fetch (POSITION YCOORD) of CPOS)) (SEMIMINORRADIUS (fetch (LOCALELLIPSE SEMIMINORRADIUS) of LELLIPSE)) (SEMIMAJORRADIUS (fetch (LOCALELLIPSE SEMIMAJORRADIUS) of LELLIPSE))) (DRAWCURVE [LIST (CREATEPOSITION (PLUS CENTERX (FTIMES COSOR SEMIMAJORRADIUS )) (PLUS CENTERY (FTIMES SINOR SEMIMAJORRADIUS ))) (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES SINOR SEMIMINORRADIUS)) (PLUS CENTERY (FTIMES COSOR SEMIMINORRADIUS ))) (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES COSOR SEMIMAJORRADIUS)) (DIFFERENCE CENTERY (FTIMES SINOR SEMIMAJORRADIUS) )) (CREATEPOSITION (PLUS CENTERX (FTIMES SINOR SEMIMINORRADIUS )) (DIFFERENCE CENTERY (FTIMES COSOR SEMIMINORRADIUS] T (fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LELLIPSE) DASHING WINDOW))) (T (DRAWELLIPSE (fetch (POSITION XCOORD) of CPOS) (fetch (POSITION YCOORD) of CPOS) (fetch (LOCALELLIPSE SEMIMINORRADIUS) of LELLIPSE) (fetch (LOCALELLIPSE SEMIMAJORRADIUS) of LELLIPSE) ORIENTATION (fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LELLIPSE) DASHING WINDOW]) (ELLIPSE.INPUTFN [LAMBDA (WINDOW) (* rrb "21-May-86 16:13") (* reads three points from the user and returns the ellipse figure element that  it represents.) (PROG (CENTER MAJRAD MINRAD) (STATUSPRINT WINDOW " " "Indicate center of ellipse") (COND ((SETQ CENTER (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.CENTER NIL NIL NIL NIL SKETCH.USE.POSITION.PAD)) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) NIL WINDOW)) (T (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate semi-major axis") (COND ((SETQ MAJRAD (SK.READ.ELLIPSE.MAJOR.PT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTER))) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of MAJRAD) NIL WINDOW)) (T (* erase center pt on way out) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) NIL WINDOW) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate semi-minor axis") (SETQ MINRAD (SK.READ.ELLIPSE.MINOR.PT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTER) (fetch (INPUTPT INPUT.POSITION) of MAJRAD))) (CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of MAJRAD) NIL WINDOW) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) NIL WINDOW) (OR MINRAD (RETURN NIL)) (RETURN (ELLIPSE.CREATE (SK.MAP.INPUT.PT.TO.GLOBAL CENTER WINDOW) (SK.MAP.INPUT.PT.TO.GLOBAL MINRAD WINDOW) (SK.MAP.INPUT.PT.TO.GLOBAL MAJRAD WINDOW) (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) (fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) (SK.INPUT.SCALE WINDOW]) (SK.READ.ELLIPSE.MAJOR.PT [LAMBDA (SKW CENTERPT) (* rrb "20-May-86 10:47") (* reads a position from the user that will be the major radius point of an  ellipse.) (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.SEMI.MAJOR (AND SKETCH.VERBOSE.FEEDBACK (FUNCTION SK.SHOW.ELLIPSE.MAJOR.RADIUS)) CENTERPT 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.ELLIPSE.MAJOR.RADIUS [LAMBDA (X Y WINDOW CENTERPT) (* rrb "14-Nov-85 16:46") (* xors a line from X Y to a point the opposite side of CENTERPT in a window.  Used as the feedback function for reading the major radius point for ellipses.) (* Mark the point too.) (SHOWSKETCHXY X Y WINDOW) (DRAWLINE X Y (PLUS X (TIMES 2 (DIFFERENCE (fetch (POSITION XCOORD) of CENTERPT) X))) (PLUS Y (TIMES 2 (DIFFERENCE (fetch (POSITION YCOORD) of CENTERPT) Y))) 1 'INVERT WINDOW]) (SK.READ.ELLIPSE.MINOR.PT [LAMBDA (SKW CENTERPT MAJORPT) (* rrb "20-May-86 10:47") (* reads a position from the user that will be the major radius point of an  ellipse.) (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.SEMI.MINOR (AND SKETCH.VERBOSE.FEEDBACK (FUNCTION SK.SHOW.ELLIPSE.MINOR.RADIUS)) (LIST CENTERPT (DISTANCEBETWEEN CENTERPT MAJORPT) (COMPUTE.ELLIPSE.ORIENTATION CENTERPT MAJORPT)) 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.ELLIPSE.MINOR.RADIUS [LAMBDA (X Y WINDOW ELLIPSEARGS) (* rrb "15-Nov-85 14:17") (* xors a line from X Y to a point the opposite side of CENTERPT in a window.  Used as the feedback function for reading the major radius point for ellipses.) (* Mark the point too.) (SHOWSKETCHXY X Y WINDOW) (PROG ((CENTERX (CAR ELLIPSEARGS)) CENTERY) (SETQ CENTERY (fetch (POSITION YCOORD) of CENTERX)) (SETQ CENTERX (fetch (POSITION XCOORD) of CENTERX)) (DRAWELLIPSE CENTERX CENTERY (SK.DISTANCE.TO CENTERX CENTERY X Y) (CADR ELLIPSEARGS) (CADDR ELLIPSEARGS) 1 NIL WINDOW]) (ELLIPSE.INSIDEFN [LAMBDA (GELLIPSE WREG) (* rrb "20-Jan-87 14:45") (* determines if the global ellipse GELLIPSE is inside of WREG.) (REGIONSINTERSECTP WREG (ELLIPSE.GLOBALREGIONFN GELLIPSE]) (ELLIPSE.CREATE [LAMBDA (CENTERPT MINPT MAJPT BRUSH DASHING INITSCALE) (* rrb "19-Jul-85 14:26") (* creates a global ellipse element.) (PROG ((MAXRAD (MAX (DISTANCEBETWEEN CENTERPT MINPT) (DISTANCEBETWEEN CENTERPT MAJPT))) ORIENTATION) (RETURN (create GLOBALPART COMMONGLOBALPART _ (create COMMONGLOBALPART MAXSCALE _ MAXRAD MINSCALE _ (QUOTIENT MAXRAD 3000.0)) INDIVIDUALGLOBALPART _ (create ELLIPSE ORIENTATION _ (SETQ ORIENTATION (COMPUTE.ELLIPSE.ORIENTATION CENTERPT MAJPT)) BRUSH _ BRUSH DASHING _ DASHING ELLIPSECENTERLATLON _ CENTERPT SEMIMINORLATLON _ (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT CENTERPT MAJPT MINPT ORIENTATION) SEMIMAJORLATLON _ MAJPT ELLIPSEINITSCALE _ INITSCALE]) (SK.UPDATE.ELLIPSE.AFTER.CHANGE [LAMBDA (GELLIPSEELT) (* rrb " 7-Dec-85 19:54") (* updates the dependent fields of an ellipse element when a field changes.) (replace (ELLIPSE ELLIPSEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSEELT) with NIL]) (ELLIPSE.REGIONFN [LAMBDA (ELLIPSCRELT) (* rrb " 3-Oct-85 17:10") (* returns the region occuppied by an  ellipse.) (PROG ((LOCALELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSCRELT)) MAJORRADPT CENTERX CENTERY BRUSHADJ HALFWID HALFHGHT RADRATIO DELTAX DELTAY) (SETQ MAJORRADPT (fetch (LOCALELLIPSE MAJORRADIUSPOSITION) of LOCALELLIPSE)) (SETQ CENTERY (fetch (LOCALELLIPSE ELLIPSECENTER) of LOCALELLIPSE)) [SETQ RADRATIO (ABS (FQUOTIENT (fetch (LOCALELLIPSE SEMIMINORRADIUS) of LOCALELLIPSE) (fetch (LOCALELLIPSE SEMIMAJORRADIUS) of LOCALELLIPSE] [SETQ DELTAX (ABS (IDIFFERENCE (SETQ CENTERX (fetch (POSITION XCOORD) of CENTERY)) (fetch (POSITION XCOORD) of MAJORRADPT] [SETQ DELTAY (ABS (IDIFFERENCE (SETQ CENTERY (fetch (POSITION YCOORD) of CENTERY)) (fetch (POSITION YCOORD) of MAJORRADPT] (SETQ BRUSHADJ (LRSH (ADD1 (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LOCALELLIPSE))) 1)) (SETQ HALFWID (FIXR (PLUS DELTAX (FTIMES RADRATIO DELTAY) BRUSHADJ))) (SETQ HALFHGHT (FIXR (PLUS DELTAY (FTIMES RADRATIO DELTAX) BRUSHADJ))) (* use the rectangle that contains the rectangle made by the extreme points of  the ellipse. This gets more than is called for when the orientation isn't 0 or  90.0) (RETURN (CREATEREGION (IDIFFERENCE CENTERX HALFWID) (IDIFFERENCE CENTERY HALFHGHT) (ITIMES HALFWID 2) (ITIMES HALFHGHT 2]) (ELLIPSE.GLOBALREGIONFN [LAMBDA (GELELT) (* rrb "20-Nov-85 16:09") (* returns the global region occupied by a global ellipse element.) (OR (fetch (ELLIPSE ELLIPSEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELELT)) (PROG ((INDVELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELELT)) CENTERPT HALFBOXSIZE MAXRAD REGION) (SETQ CENTERPT (fetch (ELLIPSE ELLIPSECENTERLATLON) of INDVELLIPSE)) [SETQ MAXRAD (MAX (DISTANCEBETWEEN CENTERPT (fetch (ELLIPSE SEMIMAJORLATLON) of INDVELLIPSE)) (DISTANCEBETWEEN CENTERPT (fetch (ELLIPSE SEMIMINORLATLON) of INDVELLIPSE] [SETQ HALFBOXSIZE (PLUS MAXRAD (fetch (BRUSH BRUSHSIZE) of (fetch (ELLIPSE BRUSH) of INDVELLIPSE] (* use a square about the center as wide as the largest radius.  This gets too much but is easy to calculate.) (SETQ REGION (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of CENTERPT) HALFBOXSIZE) (DIFFERENCE (fetch (POSITION YCOORD) of CENTERPT) HALFBOXSIZE) (ITIMES HALFBOXSIZE 2) (ITIMES HALFBOXSIZE 2))) (replace (ELLIPSE ELLIPSEREGION) of INDVELLIPSE with REGION) (RETURN REGION]) (ELLIPSE.TRANSLATEFN [LAMBDA (SKELT DELTAPOS) (* rrb "18-Oct-85 17:08") (* returns a global ellipse element which has been translated by DELTAPOS.) (PROG ((GLOBALEL (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT))) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) INDIVIDUALGLOBALPART _ (create ELLIPSE using GLOBALEL ORIENTATION _ (fetch (ELLIPSE ORIENTATION) of GLOBALEL) ELLIPSECENTERLATLON _ (PTPLUS (fetch (ELLIPSE ELLIPSECENTERLATLON ) of GLOBALEL) DELTAPOS) SEMIMINORLATLON _ (PTPLUS (fetch (ELLIPSE SEMIMINORLATLON ) of GLOBALEL) DELTAPOS) SEMIMAJORLATLON _ (PTPLUS (fetch (ELLIPSE SEMIMAJORLATLON ) of GLOBALEL) DELTAPOS) ELLIPSEREGION _ NIL]) (ELLIPSE.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 16:21") (* returns a copy of the global ellipse element that has had each of its  control points transformed by transformfn.  TRANSFORMDATA is arbitrary data that is passed to tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (ELLIPSE.CREATE (SK.TRANSFORM.POINT (fetch (ELLIPSE ELLIPSECENTERLATLON) of INDVPART) TRANSFORMFN TRANSFORMDATA) (SK.TRANSFORM.POINT (fetch (ELLIPSE SEMIMINORLATLON) of INDVPART) TRANSFORMFN TRANSFORMDATA) (SK.TRANSFORM.POINT (fetch (ELLIPSE SEMIMAJORLATLON) of INDVPART) TRANSFORMFN TRANSFORMDATA) (SK.TRANSFORM.BRUSH (fetch (ELLIPSE BRUSH) of INDVPART) SCALEFACTOR) (fetch (ELLIPSE DASHING) of INDVPART) (fetch (ELLIPSE ELLIPSEINITSCALE) of INDVPART]) (ELLIPSE.TRANSLATEPTS [LAMBDA (ELLIPSESPEC SELPTS GLOBALDELTA WINDOW) (* rrb " 5-May-85 16:41") (* returns a new global ellipse element which has the points on SELPTS moved by  a global distance.) (PROG ((LELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSESPEC)) (GELLIPSE (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELLIPSESPEC))) (RETURN (ELLIPSE.CREATE (COND ((MEMBER (fetch (LOCALELLIPSE ELLIPSECENTER) of LELLIPSE) SELPTS) (* move the center) (PTPLUS (fetch (ELLIPSE ELLIPSECENTERLATLON) of GELLIPSE) GLOBALDELTA)) (T (fetch (ELLIPSE ELLIPSECENTERLATLON) of GELLIPSE))) (COND ((MEMBER (fetch (LOCALELLIPSE MINORRADIUSPOSITION) of LELLIPSE) SELPTS) (* move the radius point.) (PTPLUS (fetch (ELLIPSE SEMIMINORLATLON) of GELLIPSE) GLOBALDELTA)) (T (fetch (ELLIPSE SEMIMINORLATLON) of GELLIPSE))) (COND ((MEMBER (fetch (LOCALELLIPSE MAJORRADIUSPOSITION) of LELLIPSE) SELPTS) (* move the radius point.) (PTPLUS (fetch (ELLIPSE SEMIMAJORLATLON) of GELLIPSE) GLOBALDELTA)) (T (fetch (ELLIPSE SEMIMAJORLATLON) of GELLIPSE))) (fetch (ELLIPSE BRUSH) of GELLIPSE) (fetch (ELLIPSE DASHING) of GELLIPSE) (fetch (ELLIPSE ELLIPSEINITSCALE) of GELLIPSE]) (MARK.SPOT [LAMBDA (X/POSITION Y WINDOW) (* rrb "14-JAN-83 15:40") (PROG [X WIDTH HEIGHT (COLORDS (WINDOWPROP WINDOW 'INCOLOR] (COND ((POSITIONP X/POSITION) (SETQ X (fetch (POSITION XCOORD) of X/POSITION)) (SETQ Y (fetch (POSITION YCOORD) of X/POSITION))) (T (SETQ X X/POSITION))) (SETQ WIDTH (BITMAPWIDTH SPOTMARKER)) (SETQ HEIGHT (BITMAPHEIGHT SPOTMARKER)) (BITBLT (COND [COLORDS (COND ((AND (BITMAPP COLORSPOTMARKER) (EQ (BITSPERPIXEL COLORSPOTMARKER) (COLORNUMBERBITSPERPIXEL))) COLORSPOTMARKER) (T (SETQ COLORSPOTMARKER (COLORIZEBITMAP SPOTMARKER 0 (MAXIMUMCOLOR) (COLORNUMBERBITSPERPIXEL] (T SPOTMARKER)) 0 0 (OR COLORDS WINDOW) (IDIFFERENCE X (IQUOTIENT WIDTH 2)) (IDIFFERENCE Y (IQUOTIENT HEIGHT 2)) WIDTH HEIGHT 'INPUT 'INVERT]) (DISTANCEBETWEEN [LAMBDA (P1 P2) (* rrb " 5-JAN-83 12:17") (* returns the distance between two  points) (SQRT (PLUS (SQUARE (DIFFERENCE (fetch (POSITION XCOORD) of P1) (fetch (POSITION XCOORD) of P2))) (SQUARE (DIFFERENCE (fetch (POSITION YCOORD) of P1) (fetch (POSITION YCOORD) of P2]) (SK.DISTANCE.TO [LAMBDA (X1 Y1 X2 Y2) (* rrb "15-Nov-85 14:17") (* returns the distance between two  points) (SQRT (PLUS (SQUARE (DIFFERENCE X1 X2)) (SQUARE (DIFFERENCE Y1 Y2]) (SQUARE [LAMBDA (X) (TIMES X X]) (COMPUTE.ELLIPSE.ORIENTATION [LAMBDA (CENTERPT MAJRADPT) (* rrb "19-Oct-85 12:44") (* computes the orientation of an ellipse from its center point and its major  radius point.) (PROG [(DELTAX (IDIFFERENCE (fetch (POSITION XCOORD) of MAJRADPT) (fetch (POSITION XCOORD) of CENTERPT] (RETURN (COND ((ZEROP DELTAX) 90.0) (T (ARCTAN2 (IDIFFERENCE (fetch (POSITION YCOORD) of MAJRADPT) (fetch (POSITION YCOORD) of CENTERPT)) DELTAX]) (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT [LAMBDA (CENTER MAJORRADPT MINORPT ORIENTATION) (* rrb "19-Jul-85 14:23") (* computes the point that is on the minor radius of an ellipse about CENTER  with major radius and axis determined by MAJORRADPT and minor radius determines  by MINORPT.) (PROG ((SINOR (SIN ORIENTATION)) (COSOR (COS ORIENTATION)) (SEMIMINORRADIUS (DISTANCEBETWEEN CENTER MINORPT)) (SEMIMAJORRADIUS (DISTANCEBETWEEN CENTER MAJORRADPT))) (RETURN (CREATEPOSITION (DIFFERENCE (fetch (POSITION XCOORD) of CENTER) (FTIMES SINOR SEMIMINORRADIUS)) (PLUS (fetch (POSITION YCOORD) of CENTER) (FTIMES COSOR SEMIMINORRADIUS]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALELLIPSE ((ELLIPSECENTER MINORRADIUSPOSITION MAJORRADIUSPOSITION) LOCALHOTREGION SEMIMINORRADIUS SEMIMAJORRADIUS LOCALELLIPSEBRUSH LOCALELLIPSEDASHING LOCALELLIPSEFILLING)) (TYPERECORD ELLIPSE (ELLIPSECENTERLATLON SEMIMINORLATLON SEMIMAJORLATLON ORIENTATION BRUSH DASHING ELLIPSEINITSCALE ELLIPSEFILLING ELLIPSEREGION)) ) ) (READVARS-FROM-STRINGS '(ELLIPSEICON) "({(READBITMAP)(20 12 %"@COL@@@@%" %"AOOOH@@@%" %"CN@GL@@@%" %"G@@@N@@@%" %"N@@@G@@@%" %"L@@@C@@@%" %"L@@@C@@@%" %"N@@@G@@@%" %"G@@@N@@@%" %"CN@GL@@@%" %"AOOOH@@@%" %"@COL@@@@%")}) ") (RPAQ ELLIPSE.CENTER (CURSORCREATE (QUOTE #*(16 16)@@@@@GL@AOO@CLGHG@ALF@@LN@@NL@@FL@@FL@@FN@@NF@@LG@ALCLGHAOO@@GL@ ) (QUOTE NIL) 7 7)) (RPAQ ELLIPSE.SEMI.MAJOR (CURSORCREATE (QUOTE #*(16 16)@@@L@@@D@@@F@@@B@@@C@@LA@@OA@@GMOOOO@@GM@@OA@@LC@@@B@@@F@@@D@@@L ) (QUOTE NIL) 15 7)) (RPAQ ELLIPSE.SEMI.MINOR (CURSORCREATE (QUOTE #*(16 16)@ON@CICHNCHNHCHC@GL@@GL@@ON@@MF@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@ ) (QUOTE NIL) 7 15)) (DEFINEQ (SKETCH.CREATE.OPEN.CURVE [LAMBDA (POINTS BRUSH DASHING ARROWHEADS SCALE) (* rrb "16-Oct-85 17:14") (* creates a sketch open curve  element.) (SK.CURVE.CREATE (SK.INSURE.POINT.LIST POINTS) NIL (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) (OR (NUMBERP SCALE) 1.0) (SK.INSURE.ARROWHEADS ARROWHEADS]) (OPENCURVE.INPUTFN [LAMBDA (W) (* rrb "19-Mar-86 17:40") (* reads a spline {series of points}  from the user.) (PROG ((SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) KNOTS) (RETURN (SK.CURVE.CREATE (SETQ KNOTS (for PT in (READ.LIST.OF.POINTS W T) collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W))) NIL (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT) (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT) (SK.INPUT.SCALE W) (SK.ARROWHEAD.CREATE W KNOTS]) (SK.CURVE.CREATE [LAMBDA (GKNOTS CLOSED BRUSH DASHING INITSCALE ARROWHEADS) (* rrb "19-Mar-86 17:40") (* creates a sketch element  representing a curve.) (AND GKNOTS (KNOT.SET.SCALE.FIELD (create GLOBALPART INDIVIDUALGLOBALPART _ (COND (CLOSED (create CLOSEDCURVE LATLONKNOTS _ GKNOTS BRUSH _ BRUSH DASHING _ DASHING CLOSEDCURVEINITSCALE _ INITSCALE)) (T (SET.OPENCURVE.ARROWHEAD.POINTS (create OPENCURVE LATLONKNOTS _ GKNOTS BRUSH _ BRUSH DASHING _ DASHING OPENCURVEINITSCALE _ INITSCALE CURVEARROWHEADS _ ARROWHEADS]) (MAXXEXTENT [LAMBDA (PTS) (* rrb " 1-APR-83 17:24") (* returns the maximum width between any two points on pts) (COND ((NULL PTS) 0) (T (PROG ((XMIN (fetch (POSITION XCOORD) of (CAR PTS))) XMAX) (SETQ XMAX XMIN) [for PT in (CDR PTS) do (COND ((GREATERP (SETQ PT (fetch (POSITION XCOORD) of PT)) XMAX) (SETQ XMAX PT))) (COND ((GREATERP XMIN PT) (SETQ XMIN PT] (RETURN (DIFFERENCE XMAX XMIN]) (MAXYEXTENT [LAMBDA (PTS) (* rrb " 1-APR-83 17:24") (* returns the maximum height between any two points on pts) (COND ((NULL PTS) 0) (T (PROG ((YMIN (fetch (POSITION YCOORD) of (CAR PTS))) YMAX) (SETQ YMAX YMIN) [for PT in (CDR PTS) do (COND ((GREATERP (SETQ PT (fetch (POSITION YCOORD) of PT)) YMAX) (SETQ YMAX PT))) (COND ((GREATERP YMIN PT) (SETQ YMIN PT] (RETURN (DIFFERENCE YMAX YMIN]) (KNOT.SET.SCALE.FIELD [LAMBDA (GKNOTELT) (* rrb "31-Jan-85 18:22") (* updates the scale field after a change in the knots of a knotted element.) (PROG [(PTS (fetch (KNOTELT LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GKNOTELT] (replace (GLOBALPART MINSCALE) of GKNOTELT with 0.0) (* show it as long as it is two points wide or high.) (replace (GLOBALPART MAXSCALE) of GKNOTELT with (FQUOTIENT (MAX 8 (MAXXEXTENT PTS) (MAXYEXTENT PTS)) 2.0)) (RETURN GKNOTELT]) (OPENCURVE.DRAWFN [LAMBDA (CURVEELT WINDOW REGION) (* rrb " 6-May-86 17:42") (* draws a curve figure element.) (PROG ((GCURVE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CURVEELT)) (LCURVE (fetch (SCREENELT LOCALPART) of CURVEELT)) BRUSH LOCALPTS LOCALARROWPTS GARROWSPECS) (AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION CURVEELT))) (RETURN)) (SETQ GARROWSPECS (fetch (OPENCURVE CURVEARROWHEADS) of GCURVE)) (SETQ LOCALARROWPTS (fetch (LOCALCURVE ARROWHEADPTS) of LCURVE)) (SETQ LOCALPTS (\SK.ADJUST.FOR.ARROWHEADS (fetch (LOCALCURVE KNOTS) of LCURVE) LOCALARROWPTS GARROWSPECS WINDOW)) (DRAWCURVE LOCALPTS NIL (SETQ BRUSH (fetch (LOCALCURVE LOCALCURVEBRUSH) of LCURVE)) (fetch (LOCALCURVE LOCALCURVEDASHING) of LCURVE) WINDOW) (DRAWARROWHEADS GARROWSPECS LOCALARROWPTS WINDOW BRUSH]) (OPENCURVE.EXPANDFN [LAMBDA (GELT SCALE) (* rrb " 2-May-86 10:50") (* returns a local record which has the LATLONKNOTS field of the global element  GELT translated into window coordinats. Used for open curves) (PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) LOCALKNOTS TMP) [COND ((fetch (OPENCURVE OPENCURVEINITSCALE) of INDGELT)) (T (* old format didn't have an initial scale, default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SETQ INDGELT (create OPENCURVE using INDGELT OPENCURVEINITSCALE _ 1.0 OPENCURVEREGION _ NIL] (COND ((AND (fetch (OPENCURVE CURVEARROWHEADS) of INDGELT) (NOT (fetch (OPENCURVE OPENCURVEARROWHEADPOINTS) of INDGELT))) (* old form didn't have global points,  update it) (SET.OPENCURVE.ARROWHEAD.POINTS INDGELT))) (SETQ LOCALKNOTS (for LATLONPT in (fetch (OPENCURVE LATLONKNOTS) of INDGELT) collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE))) (RETURN (create SCREENELT LOCALPART _ (create LOCALCURVE KNOTS _ LOCALKNOTS ARROWHEADPTS _ (SK.EXPAND.ARROWHEADS (fetch (OPENCURVE OPENCURVEARROWHEADPOINTS ) of INDGELT) SCALE) LOCALCURVEBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ TMP (fetch (OPENCURVE BRUSH) of INDGELT] (* new format, old format had brush  width only.) TMP) (T [replace (OPENCURVE BRUSH) of INDGELT with (SETQ TMP (create BRUSH BRUSHSIZE _ TMP BRUSHSHAPE _ 'ROUND] TMP)) (fetch (OPENCURVE OPENCURVEINITSCALE) of INDGELT) SCALE) LOCALCURVEDASHING _ (fetch (OPENCURVE DASHING) of INDGELT)) GLOBALPART _ GELT]) (OPENCURVE.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb "17-Dec-85 16:22") (* changefn for curves) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Which aspect?" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '((Color 'BRUSHCOLOR "Changes the color of the curve." ] (T NIL)) '((Arrowheads 'ARROW "allows changing of arrow head charactistics." ) (Shape 'SHAPE "changes the shape of the brush" ) (Size 'SIZE "changes the size of the brush" ) (Dashing 'DASHING "changes the dashing of the line." ) ("Add point" 'ADDPOINT "adds a point to the curve." ] (SIZE (READSIZECHANGE "Change size how?")) (SHAPE (READBRUSHSHAPE)) (ARROW (READ.ARROW.CHANGE SCRNELTS)) (DASHING (READ.DASHING.CHANGE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change curve color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'BRUSH]) (ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS) SKW)) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) (OPENCURVE.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "19-Mar-86 17:40") (* returns a copy of the global OPENCURVE element that has had each of its  control points transformed by transformfn.  TRANSFORMDATA is arbitrary data that is passed to tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ (SET.OPENCURVE.ARROWHEAD.POINTS (create OPENCURVE using INDVPART LATLONKNOTS _ (SK.TRANSFORM.POINT.LIST (fetch (OPENCURVE LATLONKNOTS) of INDVPART) TRANSFORMFN TRANSFORMDATA) BRUSH _ (SK.TRANSFORM.BRUSH (fetch (OPENCURVE BRUSH) of INDVPART) SCALEFACTOR) CURVEARROWHEADS _ (SK.TRANSFORM.ARROWHEADS (fetch (OPENCURVE CURVEARROWHEADS ) of INDVPART) SCALEFACTOR) OPENCURVEREGION _ NIL]) (OPENCURVE.TRANSLATEFN [LAMBDA (OCELT DELTAPOS) (* rrb "20-Mar-86 15:09") (* translates an opencurve element) (PROG ((NEWOCELT (KNOTS.TRANSLATEFN OCELT DELTAPOS))) (SET.OPENCURVE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWOCELT)) (RETURN NEWOCELT]) (OPENCURVE.TRANSLATEPTSFN [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 17:49") (* returns a curve element which has the knots that are members of SELPTS  translated by the global amount GDELTA.) (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) (RETURN (SK.CURVE.CREATE (for PT in (fetch (LOCALCURVE KNOTS) of (fetch (SCREENELT LOCALPART) of KNOTELT)) as LATLONPT in (fetch LATLONKNOTS of GKNOTELT) collect (COND ((MEMBER PT SELPTS) (PTPLUS LATLONPT GDELTA)) (T LATLONPT))) NIL (fetch (OPENCURVE BRUSH) of GKNOTELT) (fetch (OPENCURVE DASHING) of GKNOTELT) (fetch (OPENCURVE OPENCURVEINITSCALE) of GKNOTELT) (fetch (OPENCURVE CURVEARROWHEADS) of GKNOTELT]) (SKETCH.CREATE.CLOSED.CURVE [LAMBDA (POINTS BRUSH DASHING WILLBEFILLING SCALE) (* rrb "16-Oct-85 17:15") (* creates a sketch closed curve  element.) (SK.CURVE.CREATE (SK.INSURE.POINT.LIST POINTS) T (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) (OR (NUMBERP SCALE) 1.0]) (CLOSEDCURVE.DRAWFN [LAMBDA (CURVEELT WINDOW REGION) (* rrb " 7-Dec-85 20:45") (* draws a curve figure element.) (PROG ((LCURVE (fetch (SCREENELT LOCALPART) of CURVEELT))) (* make sure this curve might be in the REGION of interest.) (AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION CURVEELT))) (RETURN)) (DRAWCURVE (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEKNOTS) of LCURVE) T (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEBRUSH) of LCURVE) (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEDASHING) of LCURVE) WINDOW]) (CLOSEDCURVE.EXPANDFN [LAMBDA (GELT SCALE) (* rrb " 7-Dec-85 20:45") (* returns a local record which has the LATLONKNOTS field of the global element  GELT translated into window coordinats. Used for curves and wires.) (PROG ((INDVKNOTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) BRSH) [COND ((fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of INDVKNOTELT)) (T (* old format didn't have an initial scale, default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SETQ INDVKNOTELT (create CLOSEDCURVE using INDVKNOTELT CLOSEDCURVEINITSCALE _ 1.0 CLOSEDCURVEREGION _ NIL] (RETURN (create SCREENELT LOCALPART _ (create LOCALCLOSEDCURVE LOCALCLOSEDCURVEKNOTS _ (for LATLONPT in (fetch LATLONKNOTS of INDVKNOTELT) collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE)) LOCALCLOSEDCURVEBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ BRSH (fetch (CLOSEDCURVE BRUSH) of INDVKNOTELT] (* new format, old format had brush  width only.) BRSH) (T [replace (CLOSEDCURVE BRUSH) of INDVKNOTELT with (SETQ BRSH (create BRUSH BRUSHSIZE _ BRSH BRUSHSHAPE _ 'ROUND] BRSH)) (fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of INDVKNOTELT) SCALE) LOCALCLOSEDCURVEFILLING _ (APPEND (fetch (CLOSEDCURVE CLOSEDCURVEFILLING) of INDVKNOTELT)) LOCALCLOSEDCURVEDASHING _ (fetch (CLOSEDCURVE DASHING) of INDVKNOTELT )) GLOBALPART _ GELT]) (CLOSEDCURVE.REGIONFN [LAMBDA (KNOTSCRELT) (* rrb " 2-Dec-85 20:40") (* returns the region occuppied by a list of knots which represent a curve.) (* uses the heuristic that the region containing the curve is not more than  20% larger than the knots. This was determined empirically on several curves.) (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT)) 1.4) (IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEBRUSH) of (fetch (SCREENELT LOCALPART) of KNOTSCRELT] 2]) (CLOSEDCURVE.GLOBALREGIONFN [LAMBDA (GCLOSEDCURVEELT) (* rrb "18-Oct-85 16:37") (* returns the global region occupied by a global closed curve element.) (OR (fetch (CLOSEDCURVE CLOSEDCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDCURVEELT)) (PROG ((INDVCLOSEDCURVE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDCURVEELT)) REGION) (* uses the heuristic that the region containing the curve is not more than  40% larger than the knots. This was determined empirically on several curves.) [SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (CLOSEDCURVE LATLONKNOTS) of INDVCLOSEDCURVE )) 1.4) (SK.BRUSH.SIZE (fetch (CLOSEDCURVE BRUSH) of INDVCLOSEDCURVE] (replace (CLOSEDCURVE CLOSEDCURVEREGION) of INDVCLOSEDCURVE with REGION) (RETURN REGION]) (READ.LIST.OF.POINTS [LAMBDA (W ALLOWDUPS?) (* rrb "10-Jun-86 15:43") (* reads a spline {series of points}  from the user.) (PROG (PT PTS ERRSTAT) (STATUSPRINT W " " "Enter the points the curve goes through using the left button. Click outside the window to stop.") LP (COND ((AND [SETQ ERRSTAT (ERSETQ (SETQ PT (SK.READ.POINT.WITH.FEEDBACK W POINTREADINGCURSOR NIL NIL NIL NIL (AND SKETCH.USE.POSITION.PAD 'MULTIPLE] PT) (* add the point to the list and mark  it.) [COND ([OR ALLOWDUPS? (NOT (EQUAL (fetch (INPUTPT INPUT.POSITION) of (CAR (LAST PTS))) (fetch (INPUTPT INPUT.POSITION) of PT] (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of PT) W PTS) (SETQ PTS (NCONC1 PTS PT] (GO LP))) (* erase point markers.) (for PTTAIL on PTS do (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL)) W (CDR PTTAIL))) (CLOSEPROMPTWINDOW W) (CLRPROMPT) (COND (ERRSTAT (* no error.) (RETURN PTS)) (T (* had an error, pass it on) (ERROR!]) (CLOSEDCURVE.INPUTFN [LAMBDA (W) (* rrb " 4-Sep-85 15:49") (* reads a spline {series of points}  from the user.) (SK.CURVE.CREATE (for PT in (READ.LIST.OF.POINTS W T) collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W)) T (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT)) (fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP W 'SKETCHCONTEXT)) (SK.INPUT.SCALE W]) (CLOSEDCURVE.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb "20-Nov-85 11:09") (* changefn for curves) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "select aspect of brush to change" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '(("Color" 'BRUSHCOLOR "changes the color of the brush" ] (T NIL)) '((Shape 'SHAPE "changes the shape of the brush" ) (Size 'SIZE "changes the size of the brush" ) (Dashing 'DASHING "changes the dashing of the line." ) ("Add point" 'ADDPOINT "adds a point to the curve." ] (SIZE (READSIZECHANGE "Change size how?")) (SHAPE (READBRUSHSHAPE)) (DASHING (READ.DASHING.CHANGE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change brush color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'BRUSH]) (ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS) SKW)) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) (CLOSEDCURVE.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:52") (* returns a copy of the global CLOSEDCURVE element that has had each of its  control points transformed by transformfn.  TRANSFORMDATA is arbitrary data that is passed to tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ (create CLOSEDCURVE using INDVPART LATLONKNOTS _ (SK.TRANSFORM.POINT.LIST (fetch (CLOSEDCURVE LATLONKNOTS) of INDVPART) TRANSFORMFN TRANSFORMDATA) BRUSH _ (SK.TRANSFORM.BRUSH (fetch (CLOSEDCURVE BRUSH) of INDVPART) SCALEFACTOR) CLOSEDCURVEREGION _ NIL]) (CLOSEDCURVE.TRANSLATEPTSFN [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 18:35") (* returns a closed curve element which has the knots that are members of  SELPTS translated by the global amount GDELTA.) (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) (RETURN (SK.CURVE.CREATE (for PT in (fetch (LOCALCURVE KNOTS) of (fetch (SCREENELT LOCALPART) of KNOTELT)) as LATLONPT in (fetch LATLONKNOTS of GKNOTELT) collect (COND ((MEMBER PT SELPTS) (PTPLUS LATLONPT GDELTA)) (T LATLONPT))) T (fetch (CLOSEDCURVE BRUSH) of GKNOTELT) (fetch (CLOSEDCURVE DASHING) of GKNOTELT) (fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of GKNOTELT) NIL]) (INVISIBLEPARTP [LAMBDA (WINDOW POINT) (* rrb "30-NOV-82 17:25") (* determines if POINT is in the visible part of a window.) (INSIDE? (DSPCLIPPINGREGION NIL WINDOW) (fetch (POSITION XCOORD) of POINT) (fetch (POSITION YCOORD) of POINT]) (SHOWSKETCHPOINT [LAMBDA (NEWPT W PTS) (* rrb "12-May-85 18:50") (* puts down the marker for a new point unless it is already a member of  points.) (OR (MEMBER NEWPT PTS) (MARKPOINT NEWPT W SPOTMARKER]) (SHOWSKETCHXY [LAMBDA (X Y WINDOW) (* rrb " 2-Oct-85 09:58") (* puts down a marker for a point at position X,Y) (BITBLT SPOTMARKER NIL NIL WINDOW (IDIFFERENCE X (LRSH (fetch (BITMAP BITMAPWIDTH) of SPOTMARKER) 1)) (IDIFFERENCE Y (LRSH (fetch (BITMAP BITMAPHEIGHT) of SPOTMARKER) 1)) NIL NIL 'INPUT 'INVERT]) (KNOTS.REGIONFN [LAMBDA (KNOTSCRELT) (* rrb "29-May-85 21:17") (* returns the region occuppied by a  list of knots) (* increase by half the brush size plus 2 This has the nice property of  insuring that the region always has both height and width.) (INCREASEREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT)) (IPLUS 3 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALWIRE LOCALOPENWIREBRUSH) of (fetch (SCREENELT LOCALPART) of KNOTSCRELT))) 2]) (OPENWIRE.GLOBALREGIONFN [LAMBDA (GOPENWIREELT) (* rrb "23-Oct-85 11:30") (* returns the global region occupied by a global open curve element.) (OR (fetch (WIRE OPENWIREREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENWIREELT)) (PROG ((INDVOPENWIRE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENWIREELT)) REGION) [SETQ REGION (INCREASEREGION (REGION.CONTAINING.PTS (fetch (WIRE LATLONKNOTS) of INDVOPENWIRE)) (SK.BRUSH.SIZE (fetch (WIRE BRUSH) of INDVOPENWIRE] (replace (WIRE OPENWIREREGION) of INDVOPENWIRE with REGION) (RETURN REGION]) (CURVE.REGIONFN [LAMBDA (OPENCURVESCRELT) (* rrb "18-Oct-85 16:36") (* returns the region occuppied by a list of knots which represent a curve.) (* uses the heuristic that the region containing the curve is not more than  40% larger than the knots. This was determined empirically on several curves.) (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of OPENCURVESCRELT )) 1.4) (IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALCURVE LOCALCURVEBRUSH) of (fetch (SCREENELT LOCALPART) of OPENCURVESCRELT] 2]) (OPENCURVE.GLOBALREGIONFN [LAMBDA (GOPENCURVEELT) (* rrb "18-Oct-85 16:36") (* returns the global region occupied by a global open curve element.) (OR (fetch (OPENCURVE OPENCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENCURVEELT )) (PROG ((INDVOPENCURVE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENCURVEELT)) REGION) (* uses the heuristic that the region containing the curve is not more than  40% larger than the knots. This was determined empirically on several curves.) [SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (OPENCURVE LATLONKNOTS) of INDVOPENCURVE)) 1.4) (SK.BRUSH.SIZE (fetch (OPENCURVE BRUSH) of INDVOPENCURVE] (replace (OPENCURVE OPENCURVEREGION) of INDVOPENCURVE with REGION) (RETURN REGION]) (KNOTS.TRANSLATEFN [LAMBDA (SKELT DELTAPOS) (* rrb " 4-Apr-86 11:31") (* replaces the knots field of the global part of a screen element with knots  that have been translated DELTAPOS.) (PROG [(GKNOTELT (APPEND (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT] (replace (KNOTELT LATLONKNOTS) of GKNOTELT with (for PT in (fetch (KNOTELT LATLONKNOTS) of GKNOTELT) collect (PTPLUS PT DELTAPOS))) (* clear the region cache.) (replace (KNOTELT KNOTREGION) of GKNOTELT with NIL) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) INDIVIDUALGLOBALPART _ GKNOTELT]) (REGION.CONTAINING.PTS [LAMBDA (PTLST) (* rrb " 7-Sep-84 11:26") (* returns the region that contains all of the points on PTLST.) (AND PTLST (PROG ((XMIN (fetch (POSITION XCOORD) of (CAR PTLST))) (XMAX (fetch (POSITION XCOORD) of (CAR PTLST))) (YMIN (fetch (POSITION YCOORD) of (CAR PTLST))) (YMAX (fetch (POSITION YCOORD) of (CAR PTLST))) TMP) [for PT in (CDR PTLST) do (COND ((GREATERP (SETQ TMP (fetch (POSITION XCOORD) of PT)) XMAX) (SETQ XMAX TMP)) ((GREATERP XMIN TMP) (SETQ XMIN TMP))) (COND ((GREATERP (SETQ TMP (fetch (POSITION YCOORD) of PT)) YMAX) (SETQ YMAX TMP)) ((GREATERP YMIN TMP) (SETQ YMIN TMP] (RETURN (CREATEREGION XMIN YMIN (DIFFERENCE XMAX XMIN) (DIFFERENCE YMAX YMIN]) ) (DEFINEQ (CHANGE.ELTS.BRUSH.SIZE [LAMBDA (HOWTOCHANGE ELTSWITHBRUSH SKW) (* rrb "10-Jan-85 14:00") (* * function that prompts for how the line thickness should change and changes  it for all elements in ELTSWITHBRUSH that have a brush size or thickness.) (* knows about the various types of sketch elements types and shouldn't.) (AND HOWTOCHANGE (for LINEDELT in ELTSWITHBRUSH collect (SK.CHANGE.BRUSH.SIZE LINEDELT HOWTOCHANGE SKW]) (CHANGE.ELTS.BRUSH [LAMBDA (CURVELTS SKW HOW) (* rrb " 4-Jan-85 14:55") (* changefn for curves Actually makes  the change.) (SELECTQ (CAR HOW) (SIZE (CHANGE.ELTS.BRUSH.SIZE (CADR HOW) CURVELTS SKW)) (SHAPE (CHANGE.ELTS.BRUSH.SHAPE (CADR HOW) CURVELTS SKW)) NIL]) (CHANGE.ELTS.BRUSH.SHAPE [LAMBDA (NEWSHAPE CURVELTS SKW) (* rrb "10-Jan-85 16:49") (* changes the brush shape of a list of curve elements.  Knows about the various sketch element types and shouldn't need to.) (AND NEWSHAPE (for CURVELT in CURVELTS collect (SK.CHANGE.BRUSH.SHAPE CURVELT NEWSHAPE SKW]) (SK.CHANGE.BRUSH.SHAPE [LAMBDA (ELTWITHBRUSH HOW SKW) (* rrb "10-Mar-86 16:07") (* changes the brush shape in the  element ELTWITHBRUSH.) (PROG (GCURVELT BRUSH TYPE NEWELT NEWBRUSH) (RETURN (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHBRUSH)) '(CLOSEDCURVE OPENCURVE ELLIPSE CIRCLE ARC CLOSEDWIRE WIRE)) (* only works for things of curve  type.) (SETQ GCURVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHBRUSH)) (SETQ BRUSH (SELECTQ TYPE (CIRCLE (fetch (CIRCLE BRUSH) of GCURVELT)) (ARC (fetch (ARC ARCBRUSH) of GCURVELT)) (ELLIPSE (fetch (ELLIPSE BRUSH) of GCURVELT)) (WIRE (fetch (WIRE BRUSH) of GCURVELT)) (CLOSEDWIRE (fetch (CLOSEDWIRE BRUSH) of GCURVELT)) (fetch (OPENCURVE BRUSH) of GCURVELT))) (COND ((NEQ HOW (fetch (BRUSH BRUSHSHAPE) of BRUSH)) (* new brush shape) (SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHSHAPE _ HOW)) (SETQ NEWELT (SELECTQ TYPE (CLOSEDCURVE (create CLOSEDCURVE using GCURVELT BRUSH _ NEWBRUSH)) (OPENCURVE (create OPENCURVE using GCURVELT BRUSH _ NEWBRUSH)) (CIRCLE (create CIRCLE using GCURVELT BRUSH _ NEWBRUSH)) (ARC (create ARC using GCURVELT ARCBRUSH _ NEWBRUSH)) (ELLIPSE (create ELLIPSE using GCURVELT BRUSH _ NEWBRUSH)) (WIRE (create WIRE using GCURVELT BRUSH _ NEWBRUSH)) (CLOSEDWIRE (create CLOSEDWIRE using GCURVELT BRUSH _ NEWBRUSH)) (SHOULDNT))) (create SKHISTORYCHANGESPEC OLDELT _ ELTWITHBRUSH NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHBRUSH) INDIVIDUALGLOBALPART _ NEWELT) PROPERTY _ 'BRUSH NEWVALUE _ NEWBRUSH OLDVALUE _ BRUSH]) (SK.CHANGE.BRUSH.COLOR [LAMBDA (ELTWITHLINE COLOR SKW) (* rrb " 8-Jan-86 17:25") (* changes the brush color of ELTWITHLINE if it has a brush) (* knows about the various types of sketch elements types and shouldn't.) (PROG ((GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE)) TYPE BRUSH NEWBRUSH NEWELT) (COND [(MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE)) '(WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)) (* only works for things of wire type.) (* the brush is stored in the different place for all element types.) (SETQ BRUSH (SELECTQ TYPE (CIRCLE (fetch (CIRCLE BRUSH) of GLINELT)) (ELLIPSE (fetch (ELLIPSE BRUSH) of GLINELT)) (TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of GLINELT)) (CLOSEDCURVE (fetch (CLOSEDCURVE BRUSH) of GLINELT)) (BOX (fetch (BOX BRUSH) of GLINELT)) (ARC (fetch (ARC ARCBRUSH) of GLINELT)) (fetch (OPENCURVE BRUSH) of GLINELT))) (COND ((NOT (EQUAL COLOR (fetch (BRUSH BRUSHCOLOR) of BRUSH))) (SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHCOLOR _ COLOR)) (SETQ NEWELT (SELECTQ TYPE (WIRE (create WIRE using GLINELT BRUSH _ NEWBRUSH)) (BOX (create BOX using GLINELT BRUSH _ NEWBRUSH)) (ARC (create ARC using GLINELT ARCBRUSH _ NEWBRUSH)) (TEXTBOX (create TEXTBOX using GLINELT TEXTBOXBRUSH _ NEWBRUSH TEXTCOLOR _ COLOR)) (CLOSEDWIRE (create CLOSEDWIRE using GLINELT BRUSH _ NEWBRUSH)) (CLOSEDCURVE (create CLOSEDCURVE using GLINELT BRUSH _ NEWBRUSH)) (OPENCURVE (create OPENCURVE using GLINELT BRUSH _ NEWBRUSH)) (CIRCLE (create CIRCLE using GLINELT BRUSH _ NEWBRUSH)) (ELLIPSE (create ELLIPSE using GLINELT BRUSH _ NEWBRUSH)) (SHOULDNT))) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHLINE) INDIVIDUALGLOBALPART _ NEWELT) OLDELT _ ELTWITHLINE PROPERTY _ 'BRUSH NEWVALUE _ NEWBRUSH OLDVALUE _ BRUSH] ((EQ TYPE 'TEXT) (* change the color of text too.) (COND ((NOT (EQUAL COLOR (fetch (TEXT TEXTCOLOR) of GLINELT))) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHLINE) INDIVIDUALGLOBALPART _ (create TEXT using GLINELT TEXTCOLOR _ COLOR)) OLDELT _ ELTWITHLINE PROPERTY _ 'TEXTCOLOR NEWVALUE _ COLOR OLDVALUE _ (fetch (TEXT TEXTCOLOR) of GLINELT]) (SK.CHANGE.BRUSH.SIZE [LAMBDA (ELTWITHLINE HOW SKW) (* rrb "10-Jan-86 13:57") (* changes the line size of ELTWITHLINE if it has a brush size or thickness and  returns a change event.) (* knows about the various types of sketch elements types and shouldn't.) (PROG (SIZE GLINELT TYPE BRUSH NEWBRUSH NEWELT) (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE)) '(WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)) (SETQ GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE)) (SETQ BRUSH (SELECTQ TYPE (CIRCLE (fetch (CIRCLE BRUSH) of GLINELT)) (ELLIPSE (fetch (ELLIPSE BRUSH) of GLINELT)) (TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of GLINELT)) (CLOSEDCURVE (fetch (CLOSEDCURVE BRUSH) of GLINELT)) (BOX (fetch (BOX BRUSH) of GLINELT)) (ARC (fetch (ARC ARCBRUSH) of GLINELT)) (fetch (OPENCURVE BRUSH) of GLINELT))) (* the change to the brush size must take into account the current scale and  the scale at which the brush was entered.) (COND ((GEQ [SETQ SIZE (COND ((NUMBERP HOW) HOW) (T (SELECTQ HOW (SMALLER (FQUOTIENT (fetch (BRUSH BRUSHSIZE) of BRUSH) 2.0)) (FTIMES (fetch (BRUSH BRUSHSIZE) of BRUSH) 2.0] 0) (* don't let the brush size go  negative.) (SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHSIZE _ SIZE)) (SETQ NEWELT (SELECTQ TYPE (WIRE (create WIRE using GLINELT BRUSH _ NEWBRUSH OPENWIREREGION _ NIL)) (BOX (create BOX using GLINELT BRUSH _ NEWBRUSH)) (ARC (create ARC using GLINELT ARCBRUSH _ NEWBRUSH ARCREGION _ NIL )) (TEXTBOX (* since this may change the location of characters in the box, clear the  selection. Probably should happen somewhere else.) (SKED.CLEAR.SELECTION SKW) (create TEXTBOX using GLINELT TEXTBOXBRUSH _ NEWBRUSH)) (CLOSEDWIRE (create CLOSEDWIRE using GLINELT BRUSH _ NEWBRUSH CLOSEDWIREREGION _ NIL)) (CLOSEDCURVE (create CLOSEDCURVE using GLINELT BRUSH _ NEWBRUSH CLOSEDCURVEREGION _ NIL)) (OPENCURVE (create OPENCURVE using GLINELT BRUSH _ NEWBRUSH OPENCURVEREGION _ NIL )) (CIRCLE (create CIRCLE using GLINELT BRUSH _ NEWBRUSH CIRCLEREGION _ NIL)) (ELLIPSE (create ELLIPSE using GLINELT BRUSH _ NEWBRUSH ELLIPSEREGION _ NIL)) (SHOULDNT))) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHLINE) INDIVIDUALGLOBALPART _ NEWELT) OLDELT _ ELTWITHLINE PROPERTY _ 'BRUSH NEWVALUE _ NEWBRUSH OLDVALUE _ BRUSH]) (SK.CHANGE.ANGLE [LAMBDA (ELTWITHARC HOW SKW) (* rrb "20-Jun-86 17:18") (* changes the arc size of ELTWITHARC if it is an arc element) (PROG (GARCLT ARMANGLE RADIUS CENTERPT RADIUSPT CENTERX NEWANGLEPT CENTERY) (COND ((EQ (fetch (GLOBALPART GTYPE) of ELTWITHARC) 'ARC) (* only works for things of arc type.) (SETQ GARCLT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHARC)) (SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GARCLT)) (SETQ CENTERX (fetch (POSITION XCOORD) of CENTERPT)) (SETQ CENTERY (fetch (POSITION YCOORD) of CENTERPT)) (SETQ RADIUSPT (fetch (ARC ARCRADIUSPT) of GARCLT)) [SETQ ARMANGLE (COND ((fetch (ARC ARCDIRECTION) of GARCLT) (* clockwise direction) (DIFFERENCE (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT) HOW)) (T (* positive direction) (PLUS (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT) HOW] (SETQ RADIUS (DISTANCEBETWEEN CENTERPT RADIUSPT)) (* calculate a position on the circle the right number of degrees out.) [SETQ NEWANGLEPT (COND ((OR (GEQ ARMANGLE 360.0) (LEQ ARMANGLE -360.0))(* mark greater than 360 by T) T) (T (create POSITION XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS (COS ARMANGLE] YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS (SIN ARMANGLE] (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHARC) INDIVIDUALGLOBALPART _ (SET.ARC.ARROWHEAD.POINTS (create ARC using GARCLT ARCANGLEPT _ NEWANGLEPT ARCREGION _ NIL))) OLDELT _ ELTWITHARC PROPERTY _ '3RDCONTROLPT NEWVALUE _ NEWANGLEPT OLDVALUE _ (fetch (ARC ARCRADIUSPT) of GARCLT]) (SK.CHANGE.ARC.DIRECTION [LAMBDA (ELTWITHARC HOW SKW) (* rrb "19-Mar-86 17:16") (* changes the direction around the circle that the arc element goes.) (PROG (GARCLT NOWDIRECTION) (COND ((EQ (fetch (GLOBALPART GTYPE) of ELTWITHARC) 'ARC) (* only works for things of arc type.) (SETQ GARCLT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHARC)) (SETQ NOWDIRECTION (fetch (ARC ARCDIRECTION) of GARCLT)) (COND ((OR (AND (EQ HOW 'CLOCKWISE) (NULL NOWDIRECTION)) (AND (EQ HOW 'COUNTERCLOCKWISE) NOWDIRECTION)) (* spec calls for one direction and it is currently going the other.) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHARC) INDIVIDUALGLOBALPART _ (SET.ARC.ARROWHEAD.POINTS (create ARC using GARCLT ARCDIRECTION _ (NOT NOWDIRECTION ) ARCREGION _ NIL)) ) OLDELT _ ELTWITHARC PROPERTY _ 'DIRECTION NEWVALUE _ HOW OLDVALUE _ (COND (NOWDIRECTION 'CLOCKWISE) (T 'COUNTERCLOCKWISE]) (SK.SET.DEFAULT.BRUSH.SIZE [LAMBDA (NEWBRUSHSIZE SKW) (* rrb "12-Jan-85 10:13") (* sets the default brush size to  NEWBRUSHSIZE) (AND (NUMBERP NEWBRUSHSIZE) (replace (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW 'SKETCHCONTEXT) with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW 'SKETCHCONTEXT)) BRUSHSIZE _ NEWBRUSHSIZE]) (READSIZECHANGE [LAMBDA (MENUTITLE ALLOWZEROFLG) (* rrb "14-May-86 19:26") (* interacts to get whether a line size should be increased or decreased.) (PROG [(NEWVALUE (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ MENUTITLE ITEMS _ '(("smaller line" 'SMALLER "decreases the line thickness by 1." ) ("LARGER LINE" 'LARGER "increases the line thickness by 1." ) ("Set line size" 'SETSIZE "sets the line thickness to an entered value." )) CENTERFLG _ T] (RETURN (COND ((EQ NEWVALUE 'SETSIZE) (SETQ NEWVALUE (RNUMBER "Enter the new line thickness." NIL NIL NIL T T T T)) (COND ((AND (NULL ALLOWZEROFLG) (EQ NEWVALUE 0)) NIL) ((GREATERP 0 NEWVALUE) (* don't allow negative values) (MINUS NEWVALUE)) (T NEWVALUE))) (T NEWVALUE]) ) (DEFINEQ (SK.CHANGE.ELEMENT.KNOTS [LAMBDA (ELTWITHKNOTS NEWKNOTS) (* rrb "19-Mar-86 17:50") (* changes the knots in the element  ELTWITHKNOTS) (PROG ((GCURVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHKNOTS)) NEWELT) (SETQ NEWELT (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of GCURVELT) (CLOSEDCURVE (create CLOSEDCURVE using GCURVELT LATLONKNOTS _ NEWKNOTS)) (OPENCURVE (SET.OPENCURVE.ARROWHEAD.POINTS (create OPENCURVE using GCURVELT LATLONKNOTS _ NEWKNOTS))) (WIRE (SET.WIRE.ARROWHEAD.POINTS (create WIRE using GCURVELT LATLONKNOTS _ NEWKNOTS))) (CLOSEDWIRE (create CLOSEDWIRE using GCURVELT LATLONKNOTS _ NEWKNOTS)) (RETURN))) (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART ) of ELTWITHKNOTS) INDIVIDUALGLOBALPART _ NEWELT]) ) (DEFINEQ (SK.INSURE.POINT.LIST [LAMBDA (POINTLST) (* rrb "16-Oct-85 17:01") (* makes sure POINTLST is a list of  positions.) (COND ((LISTP POINTLST) (AND (EVERY POINTLST (FUNCTION SK.INSURE.POSITION)) POINTLST)) (T (\ILLEGAL.ARG POINTLST]) (SK.INSURE.POSITION [LAMBDA (POSITION) (* rrb "16-Oct-85 17:02") (OR (POSITIONP POSITION) (\ILLEGAL.ARG POSITION]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD KNOTELT (LATLONKNOTS BRUSH DASHING NIL NIL KNOTREGION)) (RECORD LOCALCURVE (KNOTS LOCALHOTREGION ARROWHEADPTS LOCALCURVEBRUSH LOCALCURVEDASHING)) (TYPERECORD OPENCURVE (LATLONKNOTS BRUSH DASHING CURVEARROWHEADS OPENCURVEINITSCALE OPENCURVEREGION OPENCURVEARROWHEADPOINTS)) (TYPERECORD CLOSEDCURVE (LATLONKNOTS BRUSH DASHING CLOSEDCURVEINITSCALE CLOSEDCURVEFILLING CLOSEDCURVEREGION)) (RECORD LOCALCLOSEDCURVE (LOCALCLOSEDCURVEKNOTS LOCALCLOSEDCURVEHOTREGION LOCALCLOSEDCURVEBRUSH LOCALCLOSEDCURVEFILLING LOCALCLOSEDCURVEDASHING)) (RECORD LOCALCLOSEDWIRE (KNOTS LOCALHOTREGION LOCALCLOSEDWIREBRUSH LOCALCLOSEDWIREFILLING)) ) ) (READVARS-FROM-STRINGS '(OPENCURVEICON CLOSEDCURVEICON) "({(READBITMAP)(20 12 %"@@@@@@@@%" %"@L@@@@@@%" %"@L@@F@@@%" %"AL@@O@@@%" %"AH@@G@@@%" %"CH@@C@@@%" %"CH@@C@@@%" %"CH@@G@@@%" %"AN@@N@@@%" %"@OCLN@@@%" %"@COOL@@@%" %"@@NCH@@@%")} {(READBITMAP)(20 12 %"@@C@@@@@%" %"ALGO@@@@%" %"CNLOL@@@%" %"GCLAN@@@%" %"FAAHF@@@%" %"L@CLC@@@%" %"N@CFC@@@%" %"F@FFG@@@%" %"C@FGF@@@%" %"CLFCL@@@%" %"AON@H@@@%" %"@GL@@@@@%")}) ") (RPAQ CURVE.KNOT (CURSORCREATE (QUOTE #*(16 16)@GN@AOOHCLCLG@@NFDBFNJEGLEJCLBDCLBDCLEJCNJEGFDBFG@@NCLCLAOOH@GN@ ) (QUOTE NIL) 0 8)) (DEFINEQ (SKETCH.CREATE.WIRE [LAMBDA (POINTS BRUSH DASHING ARROWHEADS SCALE) (* rrb "16-Oct-85 17:05") (* creates a sketch wire element.) (SK.WIRE.CREATE (SK.INSURE.POINT.LIST POINTS) (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) NIL (OR (NUMBERP SCALE) 1.0) (SK.INSURE.ARROWHEADS ARROWHEADS) NIL]) (CLOSEDWIRE.EXPANDFN [LAMBDA (GELT SCALE) (* rrb " 2-Dec-85 20:42") (* returns a local record which has the LATLONKNOTS field of the global element  GELT translated into window coordinats. Used for closed wires.) (PROG ((INDVKNOTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) BRSH) [COND ((fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of INDVKNOTELT)) (T (* old format didn't have an initial scale, default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SETQ INDVKNOTELT (create CLOSEDWIRE using INDVKNOTELT CLOSEDWIREINITSCALE _ 1.0 CLOSEDWIREREGION _ NIL] (RETURN (create SCREENELT LOCALPART _ (create LOCALCLOSEDWIRE KNOTS _ (for LATLONPT in (fetch LATLONKNOTS of INDVKNOTELT) collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE)) LOCALCLOSEDWIREBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ BRSH (fetch (CLOSEDWIRE BRUSH) of INDVKNOTELT] (* new format, old format had brush  width only.) BRSH) (T [replace (CLOSEDWIRE BRUSH) of INDVKNOTELT with (SETQ BRSH (create BRUSH BRUSHSIZE _ BRSH BRUSHSHAPE _ 'ROUND] BRSH)) (fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of INDVKNOTELT) SCALE) LOCALCLOSEDWIREFILLING _ (APPEND (fetch (CLOSEDWIRE CLOSEDWIREFILLING ) of INDVKNOTELT))) GLOBALPART _ GELT]) (KNOTS.INSIDEFN [LAMBDA (KNOTELT WREG) (* rrb "21-Jan-87 09:37") (* determines if the global curve GCURVE is inside of WREG.) (* this should be broken down between wires and curves but isn't here so it  can be loaded as a patch.) (SELECTQ (fetch (GLOBALPART GTYPE) of KNOTELT) (WIRE (REGIONSINTERSECTP WREG (OPENWIRE.GLOBALREGIONFN KNOTELT))) (CLOSEDWIRE (REGIONSINTERSECTP WREG (CLOSEDWIRE.GLOBALREGIONFN KNOTELT))) (CLOSEDCURVE (REGIONSINTERSECTP WREG (CLOSEDCURVE.GLOBALREGIONFN KNOTELT))) (REGIONSINTERSECTP WREG (OPENCURVE.GLOBALREGIONFN KNOTELT]) (OPEN.WIRE.DRAWFN [LAMBDA (OPENWIREELT WIN REG OPERATION) (* rrb " 7-Dec-85 20:11") (* draws an open wire element.) (WB.DRAWLINE OPENWIREELT WIN REG OPERATION NIL (fetch (LOCALWIRE LOCALWIREDASHING) of (fetch (SCREENELT LOCALPART) of OPENWIREELT) ) (fetch (LOCALWIRE LOCALOPENWIREBRUSH) of (fetch (SCREENELT LOCALPART) of OPENWIREELT]) (WIRE.EXPANDFN [LAMBDA (GELT SCALE) (* rrb " 2-May-86 10:50") (* returns a local record which has the LATLONKNOTS field of the global element  GELT translated into window coordinats. Used for wires.) (PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) LOCALKNOTS TMP) [COND ((fetch (WIRE OPENWIREINITSCALE) of INDGELT)) (T (* old format didn't have an initial scale, default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SETQ INDGELT (create WIRE using INDGELT OPENWIREINITSCALE _ 1.0 OPENWIREREGION _ NIL] (COND ((AND (fetch (WIRE WIREARROWHEADS) of INDGELT) (NOT (fetch (WIRE OPENWIREARROWHEADPOINTS) of INDGELT))) (* old form didn't have global points,  update it) (SET.WIRE.ARROWHEAD.POINTS INDGELT))) (SETQ LOCALKNOTS (for LATLONPT in (fetch (WIRE LATLONKNOTS) of INDGELT) collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE))) (RETURN (create SCREENELT LOCALPART _ (create LOCALWIRE KNOTS _ LOCALKNOTS ARROWHEADPTS _ (SK.EXPAND.ARROWHEADS (fetch (WIRE OPENWIREARROWHEADPOINTS ) of INDGELT) SCALE) LOCALOPENWIREBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ TMP (fetch (WIRE BRUSH) of INDGELT] (* new format, old format had brush  width only.) TMP) (T [replace (WIRE BRUSH) of INDGELT with (SETQ TMP (create BRUSH BRUSHSIZE _ TMP BRUSHSHAPE _ 'ROUND] TMP)) (fetch (WIRE OPENWIREINITSCALE) of INDGELT) SCALE) LOCALWIREDASHING _ (fetch (WIRE OPENWIREDASHING) of INDGELT)) GLOBALPART _ GELT]) (SK.UPDATE.WIRE.ELT.AFTER.CHANGE [LAMBDA (GWIRELT) (* rrb "11-Dec-85 11:27") (* updates the dependent fields of a wire element after one of the fields  changes.) (* clear the region cache) (replace (OPENCURVE OPENCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GWIRELT) with NIL) (KNOT.SET.SCALE.FIELD GWIRELT]) (OPENWIRE.READCHANGEFN [LAMBDA (SKW WIREELTS) (* rrb "17-Dec-85 16:22") (* * change function for line elements.) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Which aspect?" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '(("Brush color" 'BRUSHCOLOR "changes the color of the outline" ] (T NIL)) '((Arrowheads 'ARROW "allows changing of arrow head characteristics." ) (Size 'SIZE "changes the size of the brush" ) (Dashing 'DASHING "changes the dashing of the line." ] (SIZE (READSIZECHANGE "Change size how?")) (ARROW (READ.ARROW.CHANGE WIREELTS)) (DASHING (READ.DASHING.CHANGE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change line color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR WIREELTS)) 'BRUSH]) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) (OPENWIRE.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "19-Mar-86 17:51") (* returns a copy of the global WIRE element that has had each of its control  points transformed by transformfn. TRANSFORMDATA is arbitrary data that is  passed to tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ (SET.WIRE.ARROWHEAD.POINTS (create WIRE using INDVPART LATLONKNOTS _ (SK.TRANSFORM.POINT.LIST (fetch (WIRE LATLONKNOTS) of INDVPART) TRANSFORMFN TRANSFORMDATA) BRUSH _ (SK.TRANSFORM.BRUSH (fetch (WIRE BRUSH) of INDVPART) SCALEFACTOR) WIREARROWHEADS _ (SK.TRANSFORM.ARROWHEADS (fetch (WIRE WIREARROWHEADS) of INDVPART) SCALEFACTOR) OPENWIREREGION _ NIL]) (OPENWIRE.TRANSLATEFN [LAMBDA (WIREELT DELTAPOS) (* rrb "20-Mar-86 15:08") (* translates an open wire element) (PROG ((NEWWIREELT (KNOTS.TRANSLATEFN WIREELT DELTAPOS))) (SET.WIRE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWWIREELT)) (RETURN NEWWIREELT]) (OPENWIRE.TRANSLATEPTSFN [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb "26-Sep-85 17:45") (* returns an open wire element which has the knots that are members of SELPTS  translated by the global amount GDELTA.) (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) (RETURN (SK.WIRE.CREATE (for PT in (fetch (LOCALWIRE KNOTS) of (fetch (SCREENELT LOCALPART) of KNOTELT)) as LATLONPT in (fetch (WIRE LATLONKNOTS) of GKNOTELT) collect (COND ((MEMBER PT SELPTS) (PTPLUS LATLONPT GDELTA)) (T LATLONPT))) (fetch (WIRE BRUSH) of GKNOTELT) (fetch (WIRE OPENWIREDASHING) of GKNOTELT) NIL (fetch (WIRE OPENWIREINITSCALE) of GKNOTELT) (fetch (WIRE WIREARROWHEADS) of GKNOTELT]) (WIRE.INPUTFN [LAMBDA (W GPTLIST CLOSEDFLG BRUSH DEFSCALE DASHING FILLING) (* rrb "15-Nov-85 11:39") (* creates a wire {a series of straight lines through a list of points} from a  list of points passed in or a list that is read from the user via mouse.) (PROG ((SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) KNOTS) (RETURN (SK.WIRE.CREATE [SETQ KNOTS (OR GPTLIST (for PT in (SK.READ.WIRE.POINTS W CLOSEDFLG ) collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W] (COND ((NUMBERP BRUSH) (* called with a number from the sketch stream drawline operation.  Make it a round brush.) (create BRUSH BRUSHSIZE _ BRUSH BRUSHSHAPE _ 'ROUND)) (T (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT))) (OR (DASHINGP DASHING) (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT)) CLOSEDFLG (OR (NUMBERP DEFSCALE) (SK.INPUT.SCALE W)) (SK.ARROWHEAD.CREATE W KNOTS) FILLING]) (SK.READ.WIRE.POINTS [LAMBDA (SKW CLOSEDFLG) (* rrb "12-May-86 18:31") (* reads a list of points for a wire.) (SK.READ.POINTS.WITH.FEEDBACK SKW NIL (AND SKETCH.VERBOSE.FEEDBACK (COND (CLOSEDFLG (FUNCTION CLOSEDWIRE.FEEDBACKFN)) (T (FUNCTION OPENWIRE.FEEDBACKFN]) (SK.READ.POINTS.WITH.FEEDBACK [LAMBDA (W ALLOWDUPS? FEEDBACKFN) (* rrb "10-Jun-86 15:44") (* reads a {series of points} from the  user.) (PROG (PT PTS ERRSTAT) (STATUSPRINT W " " "Enter the points the curve goes through using the left button. Click outside the window to stop.") LP (COND ((AND [SETQ ERRSTAT (ERSETQ (SETQ PT (SK.READ.POINT.WITH.FEEDBACK W POINTREADINGCURSOR FEEDBACKFN PTS 'MIDDLE NIL (AND SKETCH.USE.POSITION.PAD 'MULTIPLE] PT) (* add the point to the list and mark  it.) [COND ([OR ALLOWDUPS? (NOT (EQUAL (fetch (INPUTPT INPUT.POSITION) of (CAR (LAST PTS))) (fetch (INPUTPT INPUT.POSITION) of PT] (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of PT) W PTS) (* draw the line so it will remain displayed while the user adds other points.  This will not close it.) (AND PTS (DRAWBETWEEN (fetch (INPUTPT INPUT.POSITION) of (CAR (LAST PTS))) (fetch (INPUTPT INPUT.POSITION) of PT) 1 'INVERT W)) (SETQ PTS (NCONC1 PTS PT] (GO LP))) (* erase point markers.) (for PTTAIL on PTS do (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL)) W (CDR PTTAIL)) (* erase line) (AND (CDR PTTAIL) (DRAWBETWEEN (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL)) (fetch (INPUTPT INPUT.POSITION) of (CADR PTTAIL)) 1 'INVERT W))) (CLRPROMPT) (CLOSEPROMPTWINDOW W) (COND (ERRSTAT (* no error.) (RETURN PTS)) (T (* had an error, pass it on) (ERROR!]) (OPENWIRE.FEEDBACKFN [LAMBDA (X Y WINDOW PREVPTS) (* rrb "15-Nov-85 11:32") (* provides the rubberbanding feedback for the user inputting a point for an  open wire.) (SHOWSKETCHXY X Y WINDOW) (AND PREVPTS (PROG (LASTPT) (RETURN (DRAWLINE [fetch (POSITION XCOORD) of (SETQ LASTPT (fetch (INPUTPT INPUT.POSITION) of (CAR (LAST PREVPTS] (fetch (POSITION YCOORD) of LASTPT) X Y 1 'INVERT WINDOW]) (CLOSEDWIRE.FEEDBACKFN [LAMBDA (X Y WINDOW PREVPTS) (* rrb "15-Nov-85 11:31") (* provides the rubberbanding feedback for the user inputting a point for an  open wire.) (SHOWSKETCHXY X Y WINDOW) (* draw from the first pt to the new  pt) (PROG (ENDPT) (AND PREVPTS (DRAWLINE [fetch (POSITION XCOORD) of (SETQ ENDPT (fetch (INPUTPT INPUT.POSITION ) of (CAR PREVPTS] (fetch (POSITION YCOORD) of ENDPT) X Y 1 'INVERT WINDOW)) (* draw from the last pt to the new pt) (AND (CDR PREVPTS) (DRAWLINE [fetch (POSITION XCOORD) of (SETQ ENDPT (fetch (INPUTPT INPUT.POSITION) of (CAR (LAST PREVPTS] (fetch (POSITION YCOORD) of ENDPT) X Y 1 'INVERT WINDOW]) (CLOSEDWIRE.REGIONFN [LAMBDA (KNOTSCRELT) (* rrb " 2-Jun-85 17:15") (* returns the region occuppied by a  closed wire) (* increase by half the brush size plus 2 This has the nice property of  insuring that the region always has both height and width.) (INCREASEREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT)) (IPLUS 3 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREBRUSH) of (fetch (SCREENELT LOCALPART) of KNOTSCRELT))) 2]) (CLOSEDWIRE.GLOBALREGIONFN [LAMBDA (GCLOSEDWIREELT) (* rrb "23-Oct-85 11:30") (* returns the global region occupied by a global closed curve element.) (OR (fetch (CLOSEDWIRE CLOSEDWIREREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDWIREELT )) (PROG ((INDVCLOSEDWIRE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDWIREELT)) REGION) [SETQ REGION (INCREASEREGION (REGION.CONTAINING.PTS (fetch (CLOSEDWIRE LATLONKNOTS) of INDVCLOSEDWIRE)) (SK.BRUSH.SIZE (fetch (CLOSEDWIRE BRUSH) of INDVCLOSEDWIRE] (replace (CLOSEDWIRE CLOSEDWIREREGION) of INDVCLOSEDWIRE with REGION) (RETURN REGION]) (SK.WIRE.CREATE [LAMBDA (KNOTS BRUSH DASHING CLOSED SCALE ARROWHEADS FILLING) (* rrb "19-Mar-86 17:51") (* creates a wire sketch element.) (AND KNOTS (KNOT.SET.SCALE.FIELD (create GLOBALPART INDIVIDUALGLOBALPART _ (COND (CLOSED (create CLOSEDWIRE LATLONKNOTS _ KNOTS BRUSH _ BRUSH CLOSEDWIREDASHING _ DASHING CLOSEDWIREINITSCALE _ SCALE CLOSEDWIREFILLING _ FILLING)) (T (SET.WIRE.ARROWHEAD.POINTS (create WIRE LATLONKNOTS _ KNOTS BRUSH _ BRUSH WIREARROWHEADS _ ARROWHEADS OPENWIREDASHING _ DASHING OPENWIREINITSCALE _ SCALE]) (WIRE.ADD.POINT.TO.END [LAMBDA (WIREELT PT SKW) (* rrb "11-Jul-85 11:26") (* adds a point onto the end of a wire element.) (PROG ((NEWPOS (SK.MAP.INPUT.PT.TO.GLOBAL PT SKW)) KNOTS GWIREELT) (SETQ GWIREELT (fetch (SCREENELT GLOBALPART) of WIREELT)) (SETQ KNOTS (fetch LATLONKNOTS of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GWIREELT))) (RETURN (COND ((EQUAL NEWPOS (CAR (LAST KNOTS))) (* don't add duplicate points) WIREELT) (T (* add point at the end.) (SK.UPDATE.ELEMENT GWIREELT (WIRE.INPUTFN SKW (APPEND KNOTS (CONS NEWPOS)) NIL) SKW]) (READ.ARROW.CHANGE [LAMBDA (SCRELTS SKW) (DECLARE (GLOBALVARS SK.ARROW.EDIT.MENU)) (* rrb "17-Dec-85 17:09") (* gets a description of how to change the arrow heads of a wire or curve.) (OR (type? MENU SK.ARROW.EDIT.MENU) (SETQ SK.ARROW.EDIT.MENU (create MENU TITLE _ "specify change" ITEMS _ (APPEND '((Add% Arrow 'ADD "Adds an arrow head.") ("Remove Arrow" 'DELETE "Removes the arrow head.") ("Same as First" 'SAME "Makes all of the arrowheads be the same as the first one selected." ) (Wider 'WIDER "Makes the angle of the head wider." ) (Narrower 'NARROWER "Makes the angle of the head smaller." ) (Larger 'LARGER "Makes the arrow head larger.") (Smaller 'SMALLER "Makes the arrow head smaller.")) (LIST (LIST VSHAPE.ARROWHEAD.BITMAP ''OPEN "Makes the head be the side lines only." ) (LIST CURVEDV.ARROWHEAD.BITMAP ''OPENCURVE "Makes the arrowhead have curved side lines." ) (LIST TRIANGLE.ARROWHEAD.BITMAP ''CLOSED "Makes the head be two sides and a base." ) (LIST SOLIDTRIANGLE.ARROWHEAD.BITMAP ''SOLID "makes a solid triangular arrowhead." ))) CENTERFLG _ T))) (PROG (HOW) (RETURN (LIST (OR (READ.ARROWHEAD.END) (RETURN)) (COND ((EQ (SETQ HOW (\CURSOR.IN.MIDDLE.MENU SK.ARROW.EDIT.MENU)) 'SAME) (* if the user chooses SAME, determine  the characteristics.) (OR (bind NOWARROWS INDGELT for ELT in SCRELTS do (SETQ INDGELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELT)) [COND ((SETQ NOWARROWS (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of INDGELT) (OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS ) of INDGELT)) (ARC (fetch (ARC ARCARROWHEADS) of INDGELT)) (WIRE (fetch (WIRE WIREARROWHEADS) of INDGELT)) NIL)) (COND [(CAR NOWARROWS) (RETURN (CONS 'SAME (CAR NOWARROWS] ((CADR NOWARROWS) (RETURN (CONS 'SAME (CADR NOWARROWS] finally (STATUSPRINT SKW "None of the selected elements have arrowheads.")) (RETURN))) (HOW) (T (RETURN]) (CHANGE.ELTS.ARROWHEADS [LAMBDA (CHANGESPEC ELTSWITHARROWS SKW) (* rrb "10-Jan-85 16:58") (* * function that changes the arrow characteristics for all elements in  ELTSWITHARROWS that can have arrows.) (AND CHANGESPEC (for ARROWELT in ELTSWITHARROWS collect (SK.CHANGE.ARROWHEADS ARROWELT CHANGESPEC SKW]) ) (DEFINEQ (SKETCH.CREATE.CLOSED.WIRE [LAMBDA (POINTS BRUSH DASHING FILLING SCALE) (* rrb "16-Oct-85 17:12") (* creates a sketch closed wire  element.) (SK.WIRE.CREATE (SK.INSURE.POINT.LIST POINTS) (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) T (OR (NUMBERP SCALE) 1.0) NIL (SK.INSURE.FILLING FILLING]) (CLOSED.WIRE.INPUTFN [LAMBDA (W PTLIST) (* rrb "13-Dec-84 10:10") (* creates a closed wire {a series of straight lines through a list of points}  from a list of points passed in or a list that is read from the user via mouse.) (WIRE.INPUTFN W PTLIST T]) (CLOSED.WIRE.DRAWFN [LAMBDA (CLOSEDWIREELT WIN REG OPERATION) (* ; "Edited 3-Mar-87 10:09 by rrb") (* draws a closed wire element.) (PROG ((GINDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of CLOSEDWIREELT)) (LOCALPART (fetch (SCREENELT LOCALPART) of CLOSEDWIREELT)) VARX) (SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREFILLING) of LOCALPART)) [COND ((OR (fetch (SKFILLING FILLING.TEXTURE) of VARX) (fetch (SKFILLING FILLING.COLOR) of VARX)) (* if there isn't any filling, don't  fill.) (FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART) [COND (SKETCHINCOLORFLG VARX) ((fetch (SKFILLING FILLING.TEXTURE) of VARX)) (T (* simulate color) (TEXTUREOFCOLOR (fetch (SKFILLING FILLING.COLOR) of VARX] WIN (COND ((EQ (DSPOPERATION NIL WIN) 'ERASE) (* if the stream is erasing, erase.) 'ERASE) (T (* otherwise use the element's mode.) (fetch (SKFILLING FILLING.OPERATION) of VARX] (OR (EQ (fetch (BRUSH BRUSHSIZE) of (SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREBRUSH ) of LOCALPART))) 0) (WB.DRAWLINE CLOSEDWIREELT WIN REG OPERATION T (fetch (CLOSEDWIRE CLOSEDWIREDASHING) of GINDVELT) VARX]) (CLOSEDWIRE.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb " 5-Mar-86 13:35") (* the users has selected SCRNELT to be changed this function reads a  specification of how the closed wire elements should change.) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Which aspect?" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '(("Brush color" 'BRUSHCOLOR "changes the color of the outline" ) ("Filling color" 'FILLINGCOLOR "changes the color of the filling" ] (T NIL)) [COND (FILLPOLYGONFLG '((Filling 'FILLING "allows changing of the filling texture of the box." ] [COND (FILLINGMODEFLG '(("Filling mode" 'FILLINGMODE "changes how the filling effects the figures it covers." ] '((Shape 'SHAPE "changes the shape of the brush") (Size 'SIZE "changes the size of the brush") (Dashing 'DASHING "changes the dashing of the line.") ("Add point" 'ADDPOINT "adds a point to the curve."] (SIZE (READSIZECHANGE "Change size how?" T)) (FILLING (READ.FILLING.CHANGE)) (FILLINGMODE (READ.FILLING.MODE)) (DASHING (READ.DASHING.CHANGE)) (SHAPE (READBRUSHSHAPE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART ) of (CAR SCRNELTS )) 'BRUSH]) (ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS) SKW)) (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T (fetch (SKFILLING FILLING.COLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'FILLING]) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) (CLOSEDWIRE.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:46") (* returns a copy of the global CLOSEDWIRE element that has had each of its  control points transformed by transformfn.  TRANSFORMDATA is arbitrary data that is passed to tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ (create CLOSEDWIRE using INDVPART LATLONKNOTS _ (SK.TRANSFORM.POINT.LIST (fetch (CLOSEDWIRE LATLONKNOTS) of INDVPART) TRANSFORMFN TRANSFORMDATA) BRUSH _ (SK.TRANSFORM.BRUSH (fetch (CLOSEDWIRE BRUSH) of INDVPART) SCALEFACTOR) CLOSEDWIREREGION _ NIL]) (CLOSEDWIRE.TRANSLATEPTSFN [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb "27-Sep-85 18:58") (* returns a closed wire element which has the knots that are members of SELPTS  translated by the global amount GDELTA.) (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) (RETURN (SK.WIRE.CREATE (for PT in (fetch (LOCALCLOSEDWIRE KNOTS) of (fetch (SCREENELT LOCALPART) of KNOTELT)) as LATLONPT in (fetch (CLOSEDWIRE LATLONKNOTS) of GKNOTELT) collect (COND ((MEMBER PT SELPTS) (PTPLUS LATLONPT GDELTA)) (T LATLONPT))) (fetch (CLOSEDWIRE BRUSH) of GKNOTELT) (fetch (CLOSEDWIRE CLOSEDWIREDASHING) of GKNOTELT) T (fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of GKNOTELT) NIL (fetch (CLOSEDWIRE CLOSEDWIREFILLING) of GKNOTELT]) ) (DEFINEQ (SK.EXPAND.ARROWHEADS [LAMBDA (GARROWHEADPOINTS SCALE) (* rrb " 2-May-86 10:50") (* returns a list of local arrowhead points from the list of global arrowhead  points.) (for ARROWHEAD in GARROWHEADPOINTS collect (SK.EXPAND.ARROWHEAD ARROWHEAD SCALE]) (SK.COMPUTE.ARC.ARROWHEAD.POINTS [LAMBDA (ARROWSPEC CENTERPT RADPT ARCANGLEPT DIRECTION) (* rrb "19-Mar-86 17:09") (* returns a list of global arrowhead points from the specs and points that  define an arc.) (PROG (SPEC) (OR ARROWSPEC (RETURN NIL)) (* format keeps arrow specs as  (FIRST LAST T)%.) (RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC)) (ARC.ARROWHEAD.POINTS CENTERPT RADPT DIRECTION (fetch (ARROWHEAD ARROWANGLE) of SPEC) (fetch (ARROWHEAD ARROWLENGTH) of SPEC) (fetch (ARROWHEAD ARROWTYPE) of SPEC))) (AND (SETQ SPEC (CADR ARROWSPEC)) (ARC.ARROWHEAD.POINTS CENTERPT ARCANGLEPT (NOT DIRECTION) (fetch (ARROWHEAD ARROWANGLE) of SPEC) (fetch (ARROWHEAD ARROWLENGTH) of SPEC) (fetch (ARROWHEAD ARROWTYPE) of SPEC]) (ARC.ARROWHEAD.POINTS [LAMBDA (CENTERPT ENDPT CLOCKWISEFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE) (* rrb "20-Mar-86 09:12") (* returns a list of arrowhead points for an arc.  If CLOCKWISEFLG is T, it is to go on the clockwise direction.) (ARROWHEAD.POINTS.LIST ENDPT HEAD.ANGLE HEAD.LENGTH (TIMES (COND (CLOCKWISEFLG -1) (T 1)) (DIFFERENCE (fetch (POSITION YCOORD) of ENDPT) (fetch (POSITION YCOORD) of CENTERPT))) (TIMES (COND (CLOCKWISEFLG 1) (T -1)) (DIFFERENCE (fetch (POSITION XCOORD) of ENDPT) (fetch (POSITION XCOORD) of CENTERPT))) HEAD.TYPE]) (SET.ARC.ARROWHEAD.POINTS [LAMBDA (INDVDARCELT) (* rrb "20-Jun-86 13:56") (* * updates the global arrowhead points field of an element.) (PROG ((ARROWSPECS (fetch (ARC ARCARROWHEADS) of INDVDARCELT))) [COND (ARROWSPECS (SK.INSURE.HAS.LENGTH INDVDARCELT (SK.RECORD.LENGTH 'ARC) 'ARC) (replace (ARC ARCARROWHEADPOINTS) of INDVDARCELT with (SK.COMPUTE.ARC.ARROWHEAD.POINTS ARROWSPECS (fetch (ARC ARCCENTERPT) of INDVDARCELT) (fetch (ARC ARCRADIUSPT) of INDVDARCELT) (\SK.GET.ARC.ANGLEPT INDVDARCELT) (fetch (ARC ARCDIRECTION) of INDVDARCELT] (RETURN INDVDARCELT]) (SET.OPENCURVE.ARROWHEAD.POINTS [LAMBDA (INDVOPENCURVEELT) (* rrb "20-Mar-86 14:30") (* * updates the global arrowhead points field of an element.) (PROG ((ARROWSPECS (fetch (OPENCURVE CURVEARROWHEADS) of INDVOPENCURVEELT))) [COND (ARROWSPECS (SK.INSURE.HAS.LENGTH INDVOPENCURVEELT (SK.RECORD.LENGTH 'OPENCURVE) 'OPENCURVE) (replace (OPENCURVE OPENCURVEARROWHEADPOINTS) of INDVOPENCURVEELT with (SK.COMPUTE.CURVE.ARROWHEAD.POINTS ARROWSPECS (fetch (OPENCURVE LATLONKNOTS) of INDVOPENCURVEELT] (RETURN INDVOPENCURVEELT]) (SK.COMPUTE.CURVE.ARROWHEAD.POINTS [LAMBDA (ARROWSPEC KNOTS) (* rrb "19-Mar-86 17:32") (* returns a list of global arrowhead points from the specs and points that  define an curve.) (PROG (SPEC) (OR ARROWSPEC (RETURN NIL)) (* format keeps arrow specs as  (FIRST LAST T)%.) (RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC)) (CURVE.ARROWHEAD.POINTS KNOTS T (fetch (ARROWHEAD ARROWANGLE) of SPEC) (fetch (ARROWHEAD ARROWLENGTH) of SPEC) (fetch (ARROWHEAD ARROWTYPE) of SPEC))) (AND (SETQ SPEC (CADR ARROWSPEC)) (CURVE.ARROWHEAD.POINTS KNOTS NIL (fetch (ARROWHEAD ARROWANGLE) of SPEC) (fetch (ARROWHEAD ARROWLENGTH) of SPEC) (fetch (ARROWHEAD ARROWTYPE) of SPEC]) (SET.WIRE.ARROWHEAD.POINTS [LAMBDA (INDVWIREELT) (* rrb "20-Mar-86 14:31") (* * updates the global arrowhead points field of an element.) (PROG ((ARROWSPECS (fetch (WIRE WIREARROWHEADS) of INDVWIREELT))) [COND (ARROWSPECS (SK.INSURE.HAS.LENGTH INDVWIREELT (SK.RECORD.LENGTH 'WIRE) 'WIRE) (replace (WIRE OPENWIREARROWHEADPOINTS) of INDVWIREELT with (SK.COMPUTE.WIRE.ARROWHEAD.POINTS ARROWSPECS (fetch (WIRE LATLONKNOTS) of INDVWIREELT] (RETURN INDVWIREELT]) (SK.COMPUTE.WIRE.ARROWHEAD.POINTS [LAMBDA (ARROWSPEC KNOTS) (* rrb "19-Mar-86 17:46") (* returns a list of global arrowhead points from the specs and points that  define an curve.) (PROG (SPEC) (OR ARROWSPEC (RETURN NIL)) (* format keeps arrow specs as  (FIRST LAST T)%.) (RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC)) (WIRE.ARROWHEAD.POINTS KNOTS T (fetch (ARROWHEAD ARROWANGLE) of SPEC) (fetch (ARROWHEAD ARROWLENGTH) of SPEC) (fetch (ARROWHEAD ARROWTYPE) of SPEC))) (AND (SETQ SPEC (CADR ARROWSPEC)) (WIRE.ARROWHEAD.POINTS KNOTS NIL (fetch (ARROWHEAD ARROWANGLE) of SPEC) (fetch (ARROWHEAD ARROWLENGTH) of SPEC) (fetch (ARROWHEAD ARROWTYPE) of SPEC]) (SK.EXPAND.ARROWHEAD [LAMBDA (ARROWHEAD SCALE) (* rrb "11-Jul-86 15:54") (* expands an arrowhead to a given scale.  The format of Arrowhead points is (HEADPT ONESIDEENDPT OTHERSIDEENDPT) or  (HEADPT (SIDE1PT1 SIDE1PT2) (SIDE2PT1 SIDE2PT2))) (AND ARROWHEAD (CONS (SK.SCALE.POSITION.INTO.VIEWER (CAR ARROWHEAD) SCALE) (COND ((POSITIONP (CADR ARROWHEAD)) (for PT in (CDR ARROWHEAD) collect (SK.SCALE.POSITION.INTO.VIEWER PT SCALE))) (T (* form is (HEADPT (SIDE1PT1 SIDE1PT2)  (SIDE2PT1 SIDE2PT2))) (for PTLST in (CDR ARROWHEAD) collect (for PT in PTLST collect (SK.SCALE.POSITION.INTO.VIEWER PT SCALE]) (CHANGED.ARROW [LAMBDA (ARROW HOWTOCHANGE SCALE DEFARROW) (* rrb "17-Dec-85 17:04") (* * returns an arrow that has been changed according to the spec HOWTOCHANGE.) (COND ((EQ HOWTOCHANGE 'ADD) (* if there already is one, leave it  alone.) (OR ARROW (SK.CREATE.ARROWHEAD DEFARROW SCALE))) ((OR (EQ HOWTOCHANGE 'DELETE) (NULL ARROW)) NIL) ((EQ (CAR HOWTOCHANGE) 'SAME) (* make it the same as the one given.) (APPEND (CDR HOWTOCHANGE))) (T (SELECTQ HOWTOCHANGE (WIDER (create ARROWHEAD using ARROW ARROWANGLE _ (PLUS SK.ARROWHEAD.ANGLE.INCREMENT (fetch (ARROWHEAD ARROWANGLE) of ARROW)))) (NARROWER (create ARROWHEAD using ARROW ARROWANGLE _ (DIFFERENCE (fetch (ARROWHEAD ARROWANGLE) of ARROW) SK.ARROWHEAD.ANGLE.INCREMENT ))) (LARGER (create ARROWHEAD using ARROW ARROWLENGTH _ (PLUS (TIMES SK.ARROWHEAD.LENGTH.INCREMENT SCALE) (fetch (ARROWHEAD ARROWLENGTH ) of ARROW)))) (SMALLER (create ARROWHEAD using ARROW ARROWLENGTH _ (MAX (DIFFERENCE (fetch (ARROWHEAD ARROWLENGTH) of ARROW) (TIMES SK.ARROWHEAD.LENGTH.INCREMENT SCALE)) SCALE))) (OPEN (create ARROWHEAD using ARROW ARROWTYPE _ 'LINE)) (CLOSED (create ARROWHEAD using ARROW ARROWTYPE _ 'CLOSEDLINE)) (SOLID (create ARROWHEAD using ARROW ARROWTYPE _ 'SOLID)) (OPENCURVE (create ARROWHEAD using ARROW ARROWTYPE _ 'CURVE)) ARROW]) (SK.CHANGE.ARROWHEAD [LAMBDA (ARROWELT HOW SKW) (* rrb " 1-May-86 16:27") (* changes the arrow heads of an element and returns the new element if any  actually occurred.) (SK.CHANGE.ARROWHEAD1 ARROWELT (CAR HOW) (CADR HOW) (SK.INPUT.SCALE SKW) (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP SKW 'SKETCHCONTEXT]) (SK.CHANGE.ARROWHEAD1 [LAMBDA (GARROWELT WHICHEND HOWTOCHANGE SCALE DEFAULTARROWHEAD) (* rrb "20-Jun-86 13:57") (PROG (INDGARROWELT NEWARROWS NOWARROWS CHANGEDFLG TYPE KNOTS) (RETURN (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of GARROWELT)) '(WIRE OPENCURVE ARC)) (* only works for things of wire type.) (SETQ INDGARROWELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARROWELT)) [SETQ NOWARROWS (OR (SELECTQ TYPE (OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS) of INDGARROWELT)) (ARC (fetch (ARC ARCARROWHEADS) of INDGARROWELT)) (fetch (WIRE WIREARROWHEADS) of INDGARROWELT)) '(NIL NIL T] (SETQ KNOTS (SELECTQ TYPE (ARC (* calculate the knots for the left  most test) (LIST (fetch (ARC ARCRADIUSPT) of INDGARROWELT) (\SK.GET.ARC.ANGLEPT INDGARROWELT))) (fetch LATLONKNOTS of INDGARROWELT))) (* the brush is stored in the same place for all element types.) (SETQ NEWARROWS (bind NEWARROW for ARROW in NOWARROWS as END in '(FIRST LAST) collect (SETQ NEWARROW (COND ((SK.ARROWHEAD.END.TEST WHICHEND END KNOTS) (* change the spec) (CHANGED.ARROW ARROW HOWTOCHANGE SCALE DEFAULTARROWHEAD)) (T ARROW))) (COND ((NOT (EQUAL NEWARROW ARROW)) (* keep track of whether or not any arrow was changed.) (SETQ CHANGEDFLG T))) NEWARROW)) (AND CHANGEDFLG (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of GARROWELT) INDIVIDUALGLOBALPART _ (SELECTQ TYPE (WIRE (SET.WIRE.ARROWHEAD.POINTS (create WIRE using INDGARROWELT WIREARROWHEADS _ NEWARROWS))) (ARC (SET.ARC.ARROWHEAD.POINTS (create ARC using INDGARROWELT ARCARROWHEADS _ NEWARROWS))) (OPENCURVE (SET.OPENCURVE.ARROWHEAD.POINTS (create OPENCURVE using INDGARROWELT CURVEARROWHEADS _ NEWARROWS) )) (SHOULDNT))) OLDELT _ GARROWELT PROPERTY _ 'ARROWHEADS NEWVALUE _ NEWARROWS OLDVALUE _ NOWARROWS]) (SK.CREATE.ARROWHEAD [LAMBDA (DEFAULTARROWHEAD SCALE) (* rrb " 5-May-85 17:39") (* creates a new arrowhead which is the default DEFAULTARROWHEAD scaled to  SCALE.) (create ARROWHEAD using DEFAULTARROWHEAD ARROWLENGTH _ (TIMES (fetch (ARROWHEAD ARROWLENGTH) of DEFAULTARROWHEAD) SCALE]) (SK.ARROWHEAD.CREATE [LAMBDA (SKW KNOTS) (* rrb " 2-May-86 11:11") (* creates the arrowhead specs that go with a global element from the current  context.) (PROG ((SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) ARROWHEADWHERE) (SETQ ARROWHEADWHERE (fetch (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKCONTEXT)) (RETURN (COND ([NOT (MEMB ARROWHEADWHERE '(NIL NEITHER] (* compute the arrowheads) (* T is indicator of new format.) (NCONC1 [for END in '(FIRST LAST) collect (COND ((SK.ARROWHEAD.END.TEST ARROWHEADWHERE END KNOTS) (* change the spec) (SK.CREATE.ARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of SKCONTEXT) (SK.INPUT.SCALE SKW] T]) (SK.ARROWHEAD.END.TEST [LAMBDA (WHICHENDS END KNOTS) (* rrb " 5-May-85 17:36") (* predicate which determines it END which is one of FIRST or LAST matches with  WHICHENDS which is one of (FIRST LAST BOTH RIGHT LEFT) on the series of points  KNOTS.) (OR (EQ WHICHENDS END) (SELECTQ WHICHENDS (BOTH T) (LEFT (* determine if the specified end is  END) [COND ((LEFT.MOST.IS.BEGINP KNOTS) (EQ END 'FIRST)) ((EQ END 'LAST]) (RIGHT [COND ((LEFT.MOST.IS.BEGINP KNOTS) (EQ END 'LAST)) ((EQ END 'FIRST]) NIL]) (READ.ARROWHEAD.END [LAMBDA NIL (* rrb " 6-Nov-85 09:46") (* reads a specification of which end of a line or curve to put an arrowhead  on.) (\CURSOR.IN.MIDDLE.MENU (COND ((type? MENU SK.ARROW.END.MENU) SK.ARROW.END.MENU) (T (SETQ SK.ARROW.END.MENU (create MENU TITLE _ "Which end?" ITEMS _ '((|Left | 'LEFT "changes will affect the left (or upper) end of the line." ) (| Right| 'RIGHT "changes will affect the right (or lower) end of the line." ) (Both 'BOTH "changes will affect both ends of the line." ) (First 'FIRST "changes will affect the end whose point was placed first." ) (Last 'LAST "changes will affect the end placed last." )) CENTERFLG _ T]) (ARROW.HEAD.POSITIONS [LAMBDA (TAIL.POSITION HEAD.POSITION HEAD.ANGLE HEAD.LENGTH) (* edited%: "16-MAR-83 11:56") (PROG (X0 Y0 X1 Y1 DX DY COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2) (SETQ X0 (fetch (POSITION XCOORD) of TAIL.POSITION)) (SETQ Y0 (fetch (POSITION YCOORD) of TAIL.POSITION)) (SETQ X1 (fetch (POSITION XCOORD) of HEAD.POSITION)) (SETQ Y1 (fetch (POSITION YCOORD) of HEAD.POSITION)) (SETQ DX (IDIFFERENCE X1 X0)) (SETQ DY (IDIFFERENCE Y1 Y0)) [SETQ LL (SQRT (PLUS (TIMES DX DX) (TIMES DY DY] (SETQ COS.RHO (QUOTIENT DX LL)) (SETQ SIN.RHO (QUOTIENT DY LL)) (SETQ COS.THETA (COS HEAD.ANGLE)) (SETQ SIN.THETA (SIN HEAD.ANGLE)) [SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA) (TIMES SIN.RHO SIN.THETA] [SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA) (TIMES SIN.THETA COS.RHO] [SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA) (TIMES SIN.RHO SIN.THETA] [SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA) (TIMES SIN.THETA COS.RHO] (RETURN (CONS (create POSITION XCOORD _ (IDIFFERENCE X1 (FIX XP1)) YCOORD _ (IDIFFERENCE Y1 (FIX YP1))) (create POSITION XCOORD _ (IDIFFERENCE X1 (FIX XP2)) YCOORD _ (IDIFFERENCE Y1 (FIX YP2]) (ARROWHEAD.POINTS.LIST [LAMBDA (HEAD.POSITION HEAD.ANGLE HEAD.LENGTH DX DY HEAD.TYPE) (* rrb " 1-May-86 16:15") (* * returns a list of end points for an arrowhead ending on HEAD.POSITION with  a slope of DX DY with an angle of HEAD.ANGLE and a length of HEAD.LENGTH If  HEAD.TYPE is LINE or CLOSEDLINE, the result is a list of  (HEADPT ONESIDEENDPT OTHERSIDEENDPT) If HEAD.TYPE is CURVE, the result is  (HEADPT (SIDE1PT1 SIDE1PT2) (SIDE2PT1 SIDE2PT2))) (PROG (X1 Y1 COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2 ENDPT1 ENDPT2) (SETQ X1 (fetch (POSITION XCOORD) of HEAD.POSITION)) (SETQ Y1 (fetch (POSITION YCOORD) of HEAD.POSITION)) [SETQ LL (SQRT (PLUS (TIMES DX DX) (TIMES DY DY] (SETQ COS.RHO (QUOTIENT DX LL)) (SETQ SIN.RHO (QUOTIENT DY LL)) (SETQ COS.THETA (COS HEAD.ANGLE)) (SETQ SIN.THETA (SIN HEAD.ANGLE)) [SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA) (TIMES SIN.RHO SIN.THETA] [SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA) (TIMES SIN.THETA COS.RHO] [SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA) (TIMES SIN.RHO SIN.THETA] [SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA) (TIMES SIN.THETA COS.RHO] (SETQ ENDPT1 (create POSITION XCOORD _ (DIFFERENCE X1 XP1) YCOORD _ (DIFFERENCE Y1 YP1))) (SETQ ENDPT2 (create POSITION XCOORD _ (DIFFERENCE X1 XP2) YCOORD _ (DIFFERENCE Y1 YP2))) (RETURN (SELECTQ HEAD.TYPE ((LINE CLOSEDLINE SOLID) (LIST HEAD.POSITION ENDPT1 ENDPT2)) (CURVE (* redo calculations with half the angle and half the length for a midpoint in  the curve.) (SETQ HEAD.ANGLE (QUOTIENT HEAD.ANGLE 1.5)) (SETQ HEAD.LENGTH (QUOTIENT HEAD.LENGTH 2.0)) (SETQ COS.THETA (COS HEAD.ANGLE)) (SETQ SIN.THETA (SIN HEAD.ANGLE)) [SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA) (TIMES SIN.RHO SIN.THETA] [SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA) (TIMES SIN.THETA COS.RHO] [SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA) (TIMES SIN.RHO SIN.THETA] [SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA) (TIMES SIN.THETA COS.RHO] (LIST HEAD.POSITION (LIST (create POSITION XCOORD _ (FIXR (DIFFERENCE X1 XP1)) YCOORD _ (FIXR (DIFFERENCE Y1 YP1))) ENDPT1) (LIST (create POSITION XCOORD _ (FIXR (DIFFERENCE X1 XP2)) YCOORD _ (FIXR (DIFFERENCE Y1 YP2))) ENDPT2))) NIL]) (CURVE.ARROWHEAD.POINTS [LAMBDA (KNOTS BEGFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE) (* rrb "19-Mar-86 17:32") (* returns a list of arrowhead points for a curve.  If BEGFLG is T, it is to go on the first end.) (PROG [(SLOPE (\CURVESLOPE KNOTS (NOT BEGFLG] (RETURN (ARROWHEAD.POINTS.LIST [COND (BEGFLG (CAR KNOTS)) (T (CAR (LAST KNOTS] HEAD.ANGLE HEAD.LENGTH (COND (BEGFLG (MINUS (CAR SLOPE))) (T (CAR SLOPE))) (COND (BEGFLG (MINUS (CDR SLOPE))) (T (CDR SLOPE))) HEAD.TYPE]) (LEFT.MOST.IS.BEGINP [LAMBDA (KNOTLST) (* rrb "30-Nov-84 16:55") (* * returns T if the beginning of the curve thru KNOTLST is to the left of its  end.) (COND ((NULL (CDR (LISTP KNOTLST))) (ERROR KNOTLST "should have at least two elements.")) (T (PROG ((FIRST (CAR KNOTLST)) (LAST (CAR (LAST KNOTLST))) FIRSTX LASTX) (RETURN (OR (GREATERP (SETQ LASTX (fetch (POSITION XCOORD) of LAST)) (SETQ FIRSTX (fetch (POSITION XCOORD) of FIRST))) (AND (EQP LASTX FIRSTX) (GREATERP (fetch (POSITION YCOORD) of FIRST) (fetch (POSITION YCOORD) of LAST]) (WIRE.ARROWHEAD.POINTS [LAMBDA (KNOTS FIRSTFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE) (* rrb "19-Mar-86 17:46") (* returns a list of arrowhead points for a wire.  If FIRSTFLG is T, it is to go on the first end.) (PROG (HEADPT TAILPT) (COND (FIRSTFLG (SETQ HEADPT (CAR KNOTS)) (SETQ TAILPT (CADR KNOTS))) ((CDR KNOTS) (for KNOTTAIL on KNOTS when (NULL (CDDR KNOTTAIL)) do (SETQ TAILPT (CAR KNOTTAIL)) (SETQ HEADPT (CADR KNOTTAIL)) (RETURN))) (T (* only one point, don't put on an  arrowhead.) (RETURN))) (RETURN (ARROWHEAD.POINTS.LIST HEADPT HEAD.ANGLE HEAD.LENGTH (COND (TAILPT (DIFFERENCE (fetch (POSITION XCOORD) of HEADPT) (fetch (POSITION XCOORD) of TAILPT))) (T 1)) (COND (TAILPT (DIFFERENCE (fetch (POSITION YCOORD) of HEADPT) (fetch (POSITION YCOORD) of TAILPT))) (T 0)) HEAD.TYPE]) (DRAWARROWHEADS [LAMBDA (ARROWSPECS ARROWPTS WINDOW SIZE OPERATION) (* rrb " 6-May-86 18:19") (* * draws the arrowhead from the specs in ARROWSPECS and the points in  ARROWPTS) (* PTS may be NIL in the case where an arrowhead was added to a closed knot  element that only has one point.) (bind ARROWTYPE for SPEC in ARROWSPECS as PTS in ARROWPTS when (AND SPEC PTS) do (SELECTQ (SETQ ARROWTYPE (fetch (ARROWHEAD ARROWTYPE) of SPEC)) (CURVE (* curve type. ARROWPTS format is  (headPt (side1pt1 side1pt2)  (side2pt1 side2pt2))) (DRAWCURVE (CONS (CAR PTS) (CADR PTS)) NIL SIZE NIL WINDOW) (DRAWCURVE (CONS (CAR PTS) (CADDR PTS)) NIL SIZE NIL WINDOW)) (SOLID (* solid triangle) (COND ((IMAGESTREAMTYPEP WINDOW 'PRESS) (* PRESS doesn't implement filled  areas.) (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW T)) (T (COND ((OR (WINDOWP WINDOW) (IMAGESTREAMTYPEP WINDOW 'DISPLAY)) (* DISPLAY code doesn't fill out the  entire area.) (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW T))) (FILLPOLYGON PTS BLACKSHADE WINDOW)))) (LINE (* straight line form of arrow.) (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW NIL)) (CLOSEDLINE (* triangle form of arrow.) (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW T)) NIL]) (\SK.DRAW.TRIANGLE.ARROWHEAD [LAMBDA (ARROWHEADPTS BRUSH STREAM CLOSED?) (* rrb " 6-May-86 18:15") (* draws a triangle form arrowhead.) (* could be replaced with a drawpolygon call if this were implemented in  everybody.) (COND ((OR [NOT (OR (WINDOWP STREAM) (IMAGESTREAMTYPEP STREAM 'DISPLAY] (EQ (SK.BRUSH.SIZE BRUSH) 1)) (* call draw line instead because draw curve is off by 1 and makes arrowheads  look bad.) (DRAWBETWEEN (CAR ARROWHEADPTS) (CADR ARROWHEADPTS) (SK.BRUSH.SIZE BRUSH) NIL STREAM) (DRAWBETWEEN (CAR ARROWHEADPTS) (CADDR ARROWHEADPTS) (SK.BRUSH.SIZE BRUSH) NIL STREAM) (AND CLOSED? (DRAWBETWEEN (CADR ARROWHEADPTS) (CADDR ARROWHEADPTS) (SK.BRUSH.SIZE BRUSH) NIL STREAM))) (T (* use curve drawing because the end pts of the lines look better) (DRAWCURVE (LIST (CAR ARROWHEADPTS) (CADR ARROWHEADPTS)) NIL BRUSH NIL STREAM) (DRAWCURVE (LIST (CAR ARROWHEADPTS) (CADDR ARROWHEADPTS)) NIL BRUSH NIL STREAM) (AND CLOSED? (DRAWCURVE (LIST (CADR ARROWHEADPTS) (CADDR ARROWHEADPTS)) NIL BRUSH NIL STREAM]) (\SK.ENDPT.OF.ARROW [LAMBDA (LOCALARROWHEADPTS) (* rrb " 2-May-86 10:58") (* returns the point inside an arrowhead that the last point of the line should  hit.) (PROG ((LASTPT (CADDR LOCALARROWHEADPTS))) (* make it |1/4| of the way from the base mid point to the tip.) (RETURN (create POSITION XCOORD _ (QUOTIENT (PLUS (fetch (POSITION XCOORD) of (CAR LOCALARROWHEADPTS) ) (TIMES (QUOTIENT (PLUS (fetch (POSITION XCOORD) of (CADR LOCALARROWHEADPTS )) (fetch (POSITION XCOORD) of LASTPT)) 2) 3)) 4) YCOORD _ (QUOTIENT (PLUS (fetch (POSITION YCOORD) of (CAR LOCALARROWHEADPTS) ) (TIMES (QUOTIENT (PLUS (fetch (POSITION YCOORD) of (CADR LOCALARROWHEADPTS )) (fetch (POSITION YCOORD) of LASTPT)) 2) 3)) 4]) (\SK.ADJUST.FOR.ARROWHEADS [LAMBDA (LOCALKNOTS LOCALARROWPTSLST GARROWHEADSPECS STREAM) (* rrb " 6-May-86 17:43") (* returns a list of the knots that LOCALKNOTS should really be drawn through.  This is different when the arrowhead is solid because wide lines will make the  arrow look funny if they are run out all the way to the end.) [COND ((IMAGESTREAMTYPEP STREAM 'PRESS) (* PRESS doesn't implement filled  areas.) LOCALKNOTS) (T (PROG (LASTFIXED X) (SETQ LASTFIXED (COND ((AND (CADR LOCALARROWPTSLST) (EQ (fetch (ARROWHEAD ARROWTYPE) of (CADR GARROWHEADSPECS)) 'SOLID)) (RPLACA (LAST (SETQ X (APPEND LOCALKNOTS))) (\SK.ENDPT.OF.ARROW (CADR LOCALARROWPTSLST))) X) (T LOCALKNOTS))) (RETURN (COND ((AND (CAR LOCALARROWPTSLST) (EQ (fetch (ARROWHEAD ARROWTYPE) of (CAR GARROWHEADSPECS)) 'SOLID)) (CONS (\SK.ENDPT.OF.ARROW (CAR LOCALARROWPTSLST)) (CDR LASTFIXED))) (T LASTFIXED] (PROG (LASTFIXED X) (SETQ LASTFIXED (COND ((AND (CADR LOCALARROWPTSLST) (EQ (fetch (ARROWHEAD ARROWTYPE) of (CADR GARROWHEADSPECS)) 'SOLID)) (RPLACA (LAST (SETQ X (APPEND LOCALKNOTS))) (\SK.ENDPT.OF.ARROW (CADR LOCALARROWPTSLST))) X) (T LOCALKNOTS))) (RETURN (COND ((AND (CAR LOCALARROWPTSLST) (EQ (fetch (ARROWHEAD ARROWTYPE) of (CAR GARROWHEADSPECS)) 'SOLID)) (CONS (\SK.ENDPT.OF.ARROW (CAR LOCALARROWPTSLST)) (CDR LASTFIXED))) (T LASTFIXED]) (SK.SET.ARROWHEAD.LENGTH [LAMBDA (W) (* rrb "14-May-86 19:27") (* sets the size of the default  arrowhead.) (PROG [NEWSIZE (NOWARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W ' SKETCHCONTEXT] (SETQ NEWSIZE (RNUMBER (CONCAT "New arrowhead size in screen pts. Current arrowhead size is " (MKSTRING (fetch (ARROWHEAD ARROWLENGTH) of NOWARROWHEAD))) NIL NIL NIL T T T)) (RETURN (COND ((OR (NULL NEWSIZE) (IGEQ 0 NEWSIZE)) NIL) (T (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W 'SKETCHCONTEXT) with (create ARROWHEAD using NOWARROWHEAD ARROWLENGTH _ NEWSIZE]) (SK.SET.ARROWHEAD.ANGLE [LAMBDA (W) (* rrb "14-May-86 19:27") (* sets the angle of the default  arrowhead.) (PROG [NEWSIZE (NOWARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W ' SKETCHCONTEXT] (SETQ NEWSIZE (RNUMBER (CONCAT "New head angle in degrees. Current arrowhead angle is " (MKSTRING (fetch (ARROWHEAD ARROWANGLE) of NOWARROWHEAD))) NIL NIL NIL T T T)) (RETURN (COND ((OR (NULL NEWSIZE) (IGEQ 0 NEWSIZE)) NIL) (T (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W 'SKETCHCONTEXT) with (create ARROWHEAD using NOWARROWHEAD ARROWANGLE _ NEWSIZE]) (SK.SET.ARROWHEAD.TYPE [LAMBDA (W VALUE) (* rrb "19-Mar-86 10:25") (* Sets the type of the default  arrowhead) (PROG ([NEWSHAPE (COND ((MEMB VALUE '(LINE CURVE CLOSEDLINE SOLID)) VALUE) (T (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Choose style" ITEMS _ (LIST (LIST VSHAPE.ARROWHEAD.BITMAP ''LINE "arrowhead consists of two line segments." ) (LIST CURVEDV.ARROWHEAD.BITMAP ''CURVE "arrowhead has curved side lines." ) (LIST TRIANGLE.ARROWHEAD.BITMAP ''CLOSEDLINE "arrowhead consists of a triangle." ) (LIST SOLIDTRIANGLE.ARROWHEAD.BITMAP ''SOLID "makes a solid triangular arrowhead." )) ITEMHEIGHT _ (PLUS 2 (BITMAPHEIGHT VSHAPE.ARROWHEAD.BITMAP )) CENTERFLG _ T] SKETCHCONTEXT) (RETURN (AND NEWSHAPE (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (SETQ SKETCHCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) with (create ARROWHEAD using (fetch (SKETCHCONTEXT SKETCHARROWHEAD ) of SKETCHCONTEXT) ARROWTYPE _ NEWSHAPE]) (SK.SET.LINE.ARROWHEAD [LAMBDA (W NEWVALUE) (* rrb " 6-Nov-85 09:50") (* sets whether or not the default line has an arrowhead.) (PROG [(ARROWHEADEND (COND ((MEMB NEWVALUE '(FIRST LAST BOTH NEITHER LEFT RIGHT)) NEWVALUE) (T (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Which end?" ITEMS _ '((First 'FIRST "An arrowhead will be at the first point of any new lines or curves." ) (Last 'LAST "An arrowhead will be at the last point of any new lines or curves." ) (Both 'BOTH "Arrowheads will be both ends of any new lines or curves." ) (Neither 'NEITHER "New lines will not have any arrowheads." ) (|Left | 'LEFT "An arrowhead will be at the leftmost end of any new lines or curves." ) (| Right| 'RIGHT "An arrowhead will be at the rightmost end of any new lines or curves." )) CENTERFLG _ T] (RETURN (AND ARROWHEADEND (replace (SKETCHCONTEXT SKETCHUSEARROWHEAD) of (WINDOWPROP W 'SKETCHCONTEXT) with ARROWHEADEND]) (SK.UPDATE.ARROWHEAD.FORMAT [LAMBDA (GELT) (* rrb "25-Apr-85 10:28") (* makes sure that the element GELT is in new format.) (* the fields of this are first arrowhead, last arrowhead and new format  indicator. The old format had left arrowhead and right arrowhead.) (PROG ((INDGARROWELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) NOWARROWS) (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of INDGARROWELT) (OPENCURVE [AND (SETQ NOWARROWS (fetch (OPENCURVE CURVEARROWHEADS) of INDGARROWELT)) (NULL (CDDR NOWARROWS)) (replace (OPENCURVE CURVEARROWHEADS) of INDGARROWELT with (COND ((LEFT.MOST.IS.BEGINP (fetch LATLONKNOTS of INDGARROWELT)) (LIST (CAR NOWARROWS) (CADR NOWARROWS) T)) (T (LIST (CADR NOWARROWS) (CAR NOWARROWS) T]) (WIRE [AND (SETQ NOWARROWS (fetch (WIRE WIREARROWHEADS) of INDGARROWELT)) (NULL (CDDR NOWARROWS)) (replace (WIRE WIREARROWHEADS) of INDGARROWELT with (COND ((LEFT.MOST.IS.BEGINP (fetch LATLONKNOTS of INDGARROWELT)) (LIST (CAR NOWARROWS) (CADR NOWARROWS) T)) (T (LIST (CADR NOWARROWS) (CAR NOWARROWS) T]) NIL) (RETURN GELT]) (SK.SET.LINE.LENGTH.MODE [LAMBDA (W VAL?) (* rrb " 6-Nov-85 09:51") (* sets whether the lines drawn with the middle button connect e.g the next  segment begins where the last one left off or whether it takes two clicks to  get a single segment line.) (PROG [(LINEMODE (COND ((MEMBER VAL? '(YES NO)) VAL?) (T (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Connect middle button lines?" ITEMS _ '((Yes 'YES "The lines drawn with the middle button will pick up where the last one left off." ) (No 'NO "Sets the default so that two middle clicks make a line." )) CENTERFLG _ T] (RETURN (AND LINEMODE (replace (SKETCHCONTEXT SKETCHLINEMODE) of (WINDOWPROP W ' SKETCHCONTEXT) with (EQ LINEMODE 'NO]) ) (DEFINEQ (SK.INSURE.ARROWHEADS [LAMBDA (ARROWHEADSPECS) (* ; "Edited 8-Jan-87 19:46 by rrb") (* makes sure ARROWHEADSPECS is a legal list of two arrowhead specifications.) (* slap a T on the end of it so it will be recognized as the new format.) (COND ((NULL ARROWHEADSPECS) NIL) ((SK.ARROWHEADP ARROWHEADSPECS) (* the user passed in only one spec, make it be the end.) (LIST NIL ARROWHEADSPECS T)) ((APPEND [for SPEC in ARROWHEADSPECS collect (COND ((NULL SPEC) NIL) ((SK.ARROWHEADP SPEC)) ((EQ SPEC T) (create ARROWHEAD ARROWTYPE _ SK.DEFAULT.ARROW.TYPE ARROWANGLE _ SK.DEFAULT.ARROW.ANGLE ARROWLENGTH _ SK.DEFAULT.ARROW.LENGTH)) (T (\ILLEGAL.ARG ARROWHEADSPECS] '(T]) (SK.ARROWHEADP [LAMBDA (ARROWHEAD) (* rrb "16-Oct-85 16:24") (* determines if ARROWHEAD is a legal  arrowhead specification.) (AND (EQLENGTH ARROWHEAD 3) (MEMB (fetch (ARROWHEAD ARROWTYPE) of ARROWHEAD) SK.ARROWHEAD.TYPES) (NUMBERP (fetch (ARROWHEAD ARROWANGLE) of ARROWHEAD)) (NUMBERP (fetch (ARROWHEAD ARROWLENGTH) of ARROWHEAD)) ARROWHEAD]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALWIRE (KNOTS LOCALHOTREGION ARROWHEADPTS LOCALOPENWIREBRUSH LOCALWIREDASHING)) (TYPERECORD WIRE (LATLONKNOTS BRUSH WIREARROWHEADS OPENWIREDASHING OPENWIREINITSCALE OPENWIREREGION OPENWIREARROWHEADPOINTS)) (TYPERECORD CLOSEDWIRE (LATLONKNOTS BRUSH CLOSEDWIREDASHING CLOSEDWIREINITSCALE CLOSEDWIREFILLING CLOSEDWIREREGION)) (RECORD LOCALCLOSEDWIRE (KNOTS LOCALHOTREGION LOCALCLOSEDWIREBRUSH LOCALCLOSEDWIREFILLING)) ) ) (DECLARE%: EVAL@COMPILE (RECORD ARROWHEAD (ARROWTYPE ARROWANGLE ARROWLENGTH)) ) (READVARS-FROM-STRINGS '(VSHAPE.ARROWHEAD.BITMAP TRIANGLE.ARROWHEAD.BITMAP SOLIDTRIANGLE.ARROWHEAD.BITMAP CURVEDV.ARROWHEAD.BITMAP) "({(READBITMAP)(24 18 %"@@@@@@@@%" %"@@L@@@@@%" %"@@C@@@@@%" %"@@@L@@@@%" %"@@@C@@@@%" %"@@@@L@@@%" %"@@@@C@@@%" %"@@@@@L@@%" %"@@@@@B@@%" %"OOOOOO@@%" %"@@@@@B@@%" %"@@@@@L@@%" %"@@@@C@@@%" %"@@@@L@@@%" %"@@@C@@@@%" %"@@@L@@@@%" %"@@C@@@@@%" %"@@L@@@@@%")} {(READBITMAP)(24 18 %"@@@@@@@@%" %"@@L@@@@@%" %"@@K@@@@@%" %"@@HL@@@@%" %"@@HC@@@@%" %"@@H@L@@@%" %"@@H@C@@@%" %"@@H@@L@@%" %"@@H@@B@@%" %"OOOOOO@@%" %"@@H@@B@@%" %"@@H@@L@@%" %"@@H@C@@@%" %"@@H@L@@@%" %"@@HC@@@@%" %"@@HL@@@@%" %"@@K@@@@@%" %"@@L@@@@@%")} {(READBITMAP)(24 18 %"@@@@@@@@%" %"@@L@@@@@%" %"@@O@@@@@%" %"@@OL@@@@%" %"@@OO@@@@%" %"@@OOL@@@%" %"@@OOO@@@%" %"@@OOOL@@%" %"@@OOON@@%" %"OOOOOO@@%" %"@@OOON@@%" %"@@OOOL@@%" %"@@OOO@@@%" %"@@OOL@@@%" %"@@OO@@@@%" %"@@OL@@@@%" %"@@O@@@@@%" %"@@L@@@@@%")} {(READBITMAP)(24 18 %"@@@@@@@@%" %"@@@@@@@@%" %"@A@@@@@@%" %"@@H@@@@@%" %"@@D@@@@@%" %"@@C@@@@@%" %"@@@N@@@@%" %"@@@AL@@@%" %"@@@@CH@@%" %"OOOOOO@@%" %"@@@@CH@@%" %"@@@AL@@@%" %"@@@N@@@@%" %"@@C@@@@@%" %"@@D@@@@@%" %"@@H@@@@@%" %"@A@@@@@@%" %"@@@@@@@@%")}) ") (READVARS-FROM-STRINGS '(WIREICON CLOSEDWIREICON) "({(READBITMAP)(20 12 %"@D@@@@@@%" %"@L@@@@@@%" %"AH@@@@@@%" %"C@GOL@@@%" %"F@OOL@@@%" %"L@L@L@@@%" %"LAH@L@@@%" %"FAHAH@@@%" %"CC@C@@@@%" %"AK@C@@@@%" %"@N@F@@@@%" %"@F@L@@@@%")} {(READBITMAP)(20 12 %"@G@GN@@@%" %"@OHON@@@%" %"AMMLN@@@%" %"CHOIL@@@%" %"G@GCH@@@%" %"N@@G@@@@%" %"G@@N@@@@%" %"CH@GH@@@%" %"AL@AN@@@%" %"@O@@F@@@%" %"@GOON@@@%" %"@COON@@@%")}) ") (RPAQ? SK.ARROWHEAD.ANGLE.INCREMENT 5) (RPAQ? SK.ARROWHEAD.LENGTH.INCREMENT 2) (ADDTOVAR SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID) (RPAQ? SK.DEFAULT.ARROW.LENGTH 8) (RPAQ? SK.DEFAULT.ARROW.TYPE 'CURVE) (RPAQ? SK.DEFAULT.ARROW.ANGLE 18.0) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE SK.ARROWHEAD.TYPES) ) (RPAQ? SK.ARROW.END.MENU ) (RPAQ? SK.ARROW.EDIT.MENU ) (* ; "stuff to support the text element type.") (DEFINEQ (SKETCH.CREATE.TEXT [LAMBDA (STRING POSITION FONT JUSTIFICATION COLOR SCALE) (* rrb " 4-Dec-85 20:51") (* creates a text element.) (CREATE.TEXT.ELEMENT (SK.INSURE.TEXT STRING) (SK.INSURE.POSITION POSITION) (OR (NUMBERP SCALE) 1.0) (SK.INSURE.STYLE JUSTIFICATION SK.DEFAULT.TEXT.ALIGNMENT) (SK.INSURE.FONT FONT) (SK.INSURE.COLOR COLOR]) (TEXT.CHANGEFN [LAMBDA (SCRNELTS SKW HOW) (* rrb "10-Jan-85 16:58") (* the users has selected SCRNELT to  be changed) (for ELTWITHTEXT inside SCRNELTS collect (SK.CHANGE.TEXT ELTWITHTEXT HOW SKW]) (TEXT.READCHANGEFN [LAMBDA (SKW SCRNELTS INTEXTBOXFLG) (* rrb " 3-Oct-86 15:26") (* the users has selected SCRNELT to be changed this function reads a  specification of how the text elements should change.) (PROG ((COMMAND (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Change text how?" ITEMS _ [APPEND (COND [(SKETCHINCOLORP) '(("Color" 'BRUSHCOLOR "changes the color of the text" ] (T NIL)) [COND ((SCREENELEMENTP SCRNELTS) NIL) (T '(("look same" 'SAME "makes the font characteristics the same as those of the first selected piece of text." ] [COND ((AND (NULL INTEXTBOXFLG) (SKETCH.ELEMENT.TYPEP 'TEXTBOX)) '(("box the text" 'BOX "makes the selected text into boxed text." ] [COND ((DATATYPEP 'LOOKEDSTRING) '(("Fancy format" 'LOOKEDSTRING "changes to a form that can have complete character formatting." ] '(("different font" 'NEWFONT "prompts for a new font family.") ("smaller font" 'SMALLER "Make the text smaller") ("LARGER FONT" 'LARGER "Make the text font larger.") ("set font size" 'SETSIZE "makes all fonts a prompted for size" ) ("set family & size" 'FAMILY&SIZE "allows changing both the family and the size" ) ("BOLD" 'BOLD "makes the text bold.") ("unbold" 'UNBOLD "removes the bold look of text.") ("italic" 'ITALIC "makes the text italic.") ("unitalic" 'UNITALIC "removes the italic look of text." ) ("center justify" 'CENTER "centers the text about its location" ) ("left justify " 'LEFT "left justifies the text to its location" ) (" right justify" 'RIGHT "right justifies the text to its location." ) ("top justify" 'TOP "makes the location be the top of the text." ) ("bottom justify" 'BOTTOM "makes the location be the bottom of the text." ) ("middle justify" 'MIDDLE "makes the control point specify the mid-height of the text." ) ("baseline justify" 'BASELINE "makes the control popint specify the baseline of the text." ] CENTERFLG _ T))) FIRSTTEXTELT VAL) (OR COMMAND (RETURN)) (SKED.CLEAR.SELECTION SKW) [SETQ VAL (SELECTQ COMMAND (SETSIZE (* read the new font size once) (\SK.READ.FONT.SIZE1 SCRNELTS SKW)) (FAMILY&SIZE (* gets both a font size and a family) (AND (SETQ VAL (SK.READFONTFAMILY SKW "New font family?")) (\SK.READ.FONT.SIZE1 SCRNELTS SKW VAL))) (SAME (* set the text characteristics from  the first selection.) (AND (SETQ FIRSTTEXTELT (for SCRNELT inside SCRNELTS when (MEMB (fetch (SCREENELT GTYPE) of SCRNELT) '(TEXTBOX TEXT)) do (RETURN SCRNELT))) (fetch (SCREENELT GLOBALPART) of FIRSTTEXTELT))) (NEWFONT (* get a new font family) (SK.READFONTFAMILY SKW "New font family?")) (BRUSHCOLOR [READ.COLOR.CHANGE "Change text color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'BRUSH]) (RETURN (LIST 'TEXT COMMAND] (RETURN (AND VAL (LIST COMMAND VAL]) (\SK.READ.FONT.SIZE1 [LAMBDA (SELECTEDELTS SKETCHW NEWFAMILY) (* rrb "14-Jul-86 13:43") (* reads a font size from the user. If NEWFONT is NIL, use the one of the first  selected element.) (PROG (FIRSTTEXTELT NEWSIZE NOWFONT NEWFONT) (OR (SETQ FIRSTTEXTELT (for SCRNELT inside SELECTEDELTS when (MEMB (fetch (SCREENELT GTYPE) of SCRNELT) '(TEXTBOX TEXT)) do (RETURN SCRNELT))) (RETURN)) (SETQ FIRSTTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of FIRSTTEXTELT)) (SETQ NOWFONT (fetch (TEXT FONT) of FIRSTTEXTELT)) (STATUSPRINT SKETCHW "Size of " (COND ((SCREENELEMENTP SELECTEDELTS) "text") (T "first selected text")) " is " (FONTPROP NOWFONT 'SIZE)) (SETQ NEWSIZE (SK.READFONTSIZE NIL [OR NEWFAMILY (SETQ NEWFAMILY (FONTPROP NOWFONT 'FAMILY] SKETCHW)) (RETURN (COND ((NULL NEWSIZE) (CLOSE.PROMPT.WINDOW SKETCHW) NIL) ((NULL (SETQ NEWFONT (FONTCREATE NEWFAMILY NEWSIZE (FONTPROP NOWFONT 'FACE) NIL NIL T))) (STATUSPRINT SKETCHW NEWFAMILY NEWSIZE " not found.") NIL) (T (CLOSE.PROMPT.WINDOW SKETCHW) (SK.FONTNAMELIST NEWFONT]) (SK.TEXT.ELT.WITH.SAME.FIELDS [LAMBDA (NEWONE ORGONE) (* rrb "18-Jul-85 14:16") (* returns an element of the type of ORGONE whose text fields are the same as  NEWONE.) (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of ORGONE) (TEXT (create TEXT LOCATIONLATLON _ (fetch (TEXT LOCATIONLATLON) of ORGONE) LISTOFCHARACTERS _ (fetch (TEXT LISTOFCHARACTERS) of ORGONE) INITIALSCALE _ (fetch (TEXT INITIALSCALE) of NEWONE) TEXTSTYLE _ (fetch (TEXT TEXTSTYLE) of NEWONE) FONT _ (fetch (TEXT FONT) of NEWONE) LISTOFREGIONS _ (fetch (TEXT LISTOFREGIONS) of NEWONE) TEXTCOLOR _ (fetch (TEXT TEXTCOLOR) of NEWONE))) (TEXTBOX (create TEXTBOX TEXTBOXREGION _ (fetch (TEXTBOX TEXTBOXREGION) of ORGONE) LISTOFCHARACTERS _ (fetch (TEXT LISTOFCHARACTERS) of ORGONE) INITIALSCALE _ (fetch (TEXT INITIALSCALE) of NEWONE) TEXTSTYLE _ (fetch (TEXT TEXTSTYLE) of NEWONE) FONT _ (fetch (TEXT FONT) of NEWONE) LISTOFREGIONS _ (fetch (TEXT LISTOFREGIONS) of NEWONE) TEXTCOLOR _ (fetch (TEXT TEXTCOLOR) of NEWONE) TEXTBOXBRUSH _ (fetch (TEXTBOX TEXTBOXBRUSH) of ORGONE))) NIL]) (SK.READFONTFAMILY [LAMBDA (SKW TITLE) (* rrb "21-Nov-85 11:28") (* reads a font family name.) (PROG ([KNOWNFAMILIES (UNION (for X in \FONTSONFILE collect (CAR X)) (for X in \FONTSINCORE collect (CAR X] FAMILY) (* offers a menu of possible choices.) (COND ((AND KNOWNFAMILIES (NEQ (SETQ FAMILY (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ (APPEND '(("other" 'OTHER "prompts for a family not on the menu." )) KNOWNFAMILIES) TITLE _ (OR TITLE "Choose font") CENTERFLG _ T))) 'OTHER)) (RETURN FAMILY)) (T (* grab the tty.) (TTY.PROCESS (THIS.PROCESS)) (RETURN (CAR (ERSETQ (MKATOM (U-CASE (PROMPTFORWORD "New family: " NIL NIL (GETPROMPTWINDOW SKW]) (CLOSE.PROMPT.WINDOW [LAMBDA (WINDOW) (* rrb "28-Oct-84 14:14") (* gets rid of the prompt window.) (PROG (PRMPTWIN) (RETURN (COND ((SETQ PRMPTWIN (GETPROMPTWINDOW WINDOW NIL NIL T)) (DETACHWINDOW PRMPTWIN) (CLOSEW PRMPTWIN]) (TEXT.DRAWFN [LAMBDA (TEXTELT WINDOW) (* rrb " 9-Aug-85 09:38") (* shows a text element) (TEXT.DRAWFN1 (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART) of TEXTELT)) (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of TEXTELT)) (fetch (LOCALTEXT LOCALFONT) of (fetch (SCREENELT LOCALPART) of TEXTELT)) (fetch (TEXT TEXTCOLOR) of (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTELT)) WINDOW]) (TEXT.DRAWFN1 [LAMBDA (STRS REGIONS FONT COLOR SKWINDOW OPERATION) (* ; "Edited 3-Oct-89 13:48 by rmk:") (* ; "Edited 3-Oct-89 13:47 by rmk:") (* rrb " 3-Mar-86 21:37") (* ;; "draws the image of a list of string in their local regions on a sketch window. It is broken out as a subfunction so that it can be called by the update function also.") (COND ((AND COLOR (SKETCHINCOLORP)) (DSPCOLOR COLOR SKWINDOW))) (PROG (DESCENT OLDFONT) (COND ((NULL FONT) (* ;  "text is too small or too large to be at this scale.") (RETURN)) ((FONTP FONT) (* ; "font was found.") (SETQ OLDFONT (DSPFONT FONT SKWINDOW)) (* ; "Install font, then refetch it from window/stream, in case there was device coercion, so descent will be right.") (SETQ DESCENT (FONTPROP (DSPFONT NIL SKWINDOW) 'DESCENT)) (DSPOPERATION (PROG1 (DSPOPERATION OPERATION SKWINDOW) (RESETFORM (SETTERMTABLE SKETCH.TERMTABLE) (for REGION in REGIONS as CHARS in STRS do (MOVETO (fetch (REGION LEFT) of REGION) (PLUS (fetch (REGION BOTTOM) of REGION) DESCENT) SKWINDOW) (PRIN3 CHARS SKWINDOW)))) SKWINDOW) (* ;  "return to original font so that messages come out ok.") (DSPFONT OLDFONT SKWINDOW)) (T (* ;  "if no font, just gray in regions") (* ;;; "This code was left by RRB on the theory that hardcopy can't support bitblt, which I think is wrong--RMK. (COND ((EQ (IMAGESTREAMTYPE SKWINDOW) 'DISPLAY) (for REGION in REGIONS do (BITBLT NIL NIL NIL SKWINDOW (fetch LEFT of REGION) (fetch BOTTOM of REGION) (fetch WIDTH of REGION) (IQUOTIENT (ADD1 (fetch HEIGHT of REGION)) 2) 'TEXTURE OPERATION INDICATE.TEXT.SHADE))) (T ; hardcopy can't support bitblt, draw a line instead. (bind MIDHGHT for REGION in REGIONS do (DRAWLINE (fetch LEFT of REGION) (SETQ MIDHGHT (PLUS (fetch BOTTOM of REGION) (IQUOTIENT (ADD1 (fetch HEIGHT of REGION)) 2))) (fetch RIGHT of REGION) MIDHGHT (fetch HEIGHT of REGION) OPERATION SKWINDOW))))") (for REGION in REGIONS do (BITBLT NIL NIL NIL SKWINDOW (fetch LEFT of REGION) (fetch BOTTOM of REGION) (fetch WIDTH of REGION) (IQUOTIENT (ADD1 (fetch HEIGHT of REGION)) 2) 'TEXTURE OPERATION INDICATE.TEXT.SHADE]) (TEXT.INSIDEFN [LAMBDA (GTEXT WREG) (* rrb " 5-AUG-83 16:54") (* determines if the global text element is inside of WREG.) (for GREG in (fetch (TEXT LISTOFREGIONS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXT)) when (REGIONSINTERSECTP GREG WREG) do (RETURN T]) (TEXT.EXPANDFN [LAMBDA (GTEXTPART SCALE STREAM) (* rrb "19-Mar-86 15:59") (* creates a local text screen element from a global text element.) (PROG ((GTEXT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTPART)) TEXTPOS LOCALFONT STYLE LINEREGIONS) [COND ((NLISTP (SETQ STYLE (fetch (TEXT TEXTSTYLE) of GTEXT))) (* old format had horizontal positioning only, now has vertical too.  Fill in old default.) (replace (TEXT TEXTSTYLE) of GTEXT with (SETQ STYLE '(CENTER CENTER] (SETQ LOCALFONT (SK.CHOOSE.TEXT.FONT GTEXT SCALE STREAM)) [SETQ LINEREGIONS (SK.TEXT.LINE.REGIONS (fetch (TEXT LISTOFCHARACTERS) of GTEXT) (SETQ TEXTPOS (SK.SCALE.POSITION.INTO.VIEWER (fetch (TEXT LOCATIONLATLON ) of GTEXT) SCALE)) (fetch (TEXT LISTOFREGIONS) of GTEXT) LOCALFONT STYLE SCALE (COND ((STREAMP STREAM)) (T (WINDOWPROP STREAM 'DSP] (RETURN (create SCREENELT LOCALPART _ (create LOCALTEXT DISPLAYPOSITION _ TEXTPOS LINEREGIONS _ LINEREGIONS LOCALFONT _ LOCALFONT LOCALLISTOFCHARACTERS _ (APPEND (fetch (TEXT LISTOFCHARACTERS) of GTEXT))) GLOBALPART _ GTEXTPART]) (SK.TEXT.LINE.REGIONS [LAMBDA (LISTOFTEXT TEXTPOS GREGIONS LOCALFONT STYLE SCALE IMAGESTREAM) (* rrb "19-Mar-86 15:44") (* calculates the list of regions that each line of text in LISTOFTEXT will  occupy. Used by both TEXT.EXPANDFN and TEXTBOX.EXPANDFN.  Captures those things which are common to the two elements.) (COND [(FONTP LOCALFONT) (LTEXT.LINE.REGIONS LISTOFTEXT TEXTPOS (COND ((IMAGESTREAMTYPEP IMAGESTREAM 'HARDCOPY) (* actually make the font be the font of the stream so that the stream can be  passed to STRINGWIDTH to get hardcopy characteristics.) (DSPFONT LOCALFONT IMAGESTREAM) IMAGESTREAM) (T LOCALFONT)) STYLE (FIXR (TIMES (QUOTIENT (fetch (REGION HEIGHT) of (CAR GREGIONS)) SCALE) (LENGTH LISTOFTEXT] (T (for GREG in GREGIONS collect (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT) of GREG) SCALE)) (FIXR (QUOTIENT (fetch (REGION BOTTOM) of GREG) SCALE)) (FIXR (QUOTIENT (fetch (REGION WIDTH) of GREG) SCALE)) 1]) (TEXT.UPDATE.GLOBAL.REGIONS [LAMBDA (GTEXTELT NEWGPOS OLDGPOS) (* rrb "12-Sep-84 11:36") (* updates the list of regions occupied by the text in the global coordinate  space.) (* this is used to determine the extent of a text element in a region.) (PROG ((XDIFF (DIFFERENCE (fetch (POSITION XCOORD) of NEWGPOS) (fetch (POSITION XCOORD) of OLDGPOS))) (YDIFF (DIFFERENCE (fetch (POSITION YCOORD) of NEWGPOS) (fetch (POSITION YCOORD) of OLDGPOS))) (INDTEXTGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT))) (replace (TEXT LISTOFREGIONS) of INDTEXTGELT with (for GREG in (fetch (TEXT LISTOFREGIONS) of INDTEXTGELT) collect (REL.MOVE.REGION GREG XDIFF YDIFF))) (RETURN GTEXTELT]) (REL.MOVE.REGION [LAMBDA (REGION DELTAX DELTAY) (* rrb "15-AUG-83 17:30") (* moves a region by an amount DELTAX  DELTAY) (CREATEREGION (PLUS DELTAX (fetch (REGION LEFT) of REGION)) (PLUS DELTAY (fetch (REGION BOTTOM) of REGION)) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION]) (LTEXT.LINE.REGIONS [LAMBDA (LINES LPOSITION STREAMORFONT STYLE TOTALHEIGHT) (* rrb " 4-Dec-85 11:51") (* returns the regions occupied by the lines of text LINES to format them in  STYLE in font FONT at position LPOSITION.) (AND STREAMORFONT (PROG ((FONT (FONTCREATE STREAMORFONT)) (TEXTXPOS (fetch (POSITION XCOORD) of LPOSITION)) (TEXTYPOS (fetch (POSITION YCOORD) of LPOSITION)) HEIGHT HEIGHTOFLOCALTEXT LINEWIDTH) [SETQ HEIGHT (COND ((STREAMP STREAMORFONT) (* use the line feed height because in hardcopy streams this is more correct.) (MINUS (DSPLINEFEED NIL STREAMORFONT))) (T (FONTPROP FONT 'HEIGHT] (SETQ HEIGHTOFLOCALTEXT (TIMES HEIGHT (LENGTH LINES))) (RETURN (for CHARS in LINES as Y from [PLUS TEXTYPOS (SELECTQ (CADR STYLE) (BASELINE (* vertically center the baseline. The baseline alignment should probably be  independent of the top -  bottom alignment eventually.) [DIFFERENCE (DIFFERENCE (QUOTIENT HEIGHTOFLOCALTEXT 2.0) HEIGHT) (MINUS (FONTPROP FONT 'DESCENT]) (CENTER (DIFFERENCE (QUOTIENT HEIGHTOFLOCALTEXT 2.0 ) HEIGHT)) (TOP (DIFFERENCE 1 HEIGHT)) (BOTTOM (DIFFERENCE HEIGHTOFLOCALTEXT HEIGHT)) (ERROR "illegal vertical text style" (CADR STYLE] by (IMINUS HEIGHT) collect [SETQ LINEWIDTH (DIFFERENCE (STRINGWIDTH CHARS STREAMORFONT) (COND ((EQ (NTHCHARCODE CHARS -1) (CHARCODE CR)) (CHARWIDTH (CHARCODE CR) STREAMORFONT)) (T 0] (CREATEREGION (SELECTQ (CAR STYLE) (CENTER (DIFFERENCE TEXTXPOS (QUOTIENT LINEWIDTH 2.0))) (LEFT TEXTXPOS) (DIFFERENCE TEXTXPOS LINEWIDTH)) Y LINEWIDTH HEIGHT]) (TEXT.INPUTFN [LAMBDA (WINDOW) (* rrb "12-Dec-84 11:44") (* reads text and a place to put it from the user and returns a TEXTELT that  represents it. Can return NIL if the user positions it outside of the window.) (TEXT.POSITION.AND.CREATE (READ.TEXT "Text to be added: ") (fetch (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) WINDOW "locate the text"]) (READ.TEXT [LAMBDA (PRMPT) (* rrb " 9-AUG-83 12:42") (PROG ([CLOSEWFLG (COND ((EQ (TTYDISPLAYSTREAM) \DEFAULTTTYDISPLAYSTREAM) T) ((AND (WFROMDS (TTYDISPLAYSTREAM)) (NOT (OPENWP (TTYDISPLAYSTREAM] LST) (AND PRMPT (PRIN1 PRMPT T)) (SETQ LST (CONS (READ T) (READLINE))) (AND CLOSEWFLG (CLOSEW (TTYDISPLAYSTREAM))) (RETURN (APPLY (FUNCTION CONCAT) (CONS (CAR LST) (for WORD in (CDR LST) join (LIST '% WORD]) (TEXT.POSITION.AND.CREATE [LAMBDA (TEXT FONT WINDOW PROMPTMSG) (* rrb "16-Oct-85 18:29") (* gets a position for a piece of text from the user and returns a text element  that represents it. The text location is the center position of the text.) (* later this should change the cursor to the image being placed.) (PROG [P1 LOCATION DISPLAYPOSITION (SCALE (SK.INPUT.SCALE WINDOW)) NEW.BITMAP DSP (WDTH (STRINGWIDTH TEXT FONT)) (HGHT (FONTHEIGHT FONT)) (TEXTALIGNMENT (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of (WINDOWPROP WINDOW 'SKETCHCONTEXT] (SETQ NEW.BITMAP (BITMAPCREATE WDTH HGHT)) (SETQ DSP (DSPCREATE NEW.BITMAP)) (DSPFONT FONT DSP) (MOVETO 0 (FONTDESCENT FONT) DSP) (PRIN3 TEXT DSP) [SETQ P1 (GET.BITMAP.POSITION WINDOW NEW.BITMAP 'PAINT PROMPTMSG (IMINUS (SELECTQ (CAR TEXTALIGNMENT) (CENTER (LRSH (ADD1 WDTH) 1)) (LEFT 0) (SUB1 WDTH))) (IMINUS (SELECTQ (CADR TEXTALIGNMENT) (BASELINE (FONTPROP FONT 'DESCENT)) (CENTER (LRSH (ADD1 HGHT) 1)) (TOP (SUB1 HGHT)) 0] (* scale range goes from 20 to 1.0 Use FONT as an initial.) (RETURN (AND P1 (CREATE.TEXT.ELEMENT (CONS TEXT) (SK.MAP.INPUT.PT.TO.GLOBAL P1 WINDOW) SCALE TEXTALIGNMENT FONT (fetch (BRUSH BRUSHCOLOR) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP WINDOW ' SKETCHCONTEXT]) (CREATE.TEXT.ELEMENT [LAMBDA (STRLST GPOSITION SCALE JUSTIFICATION FONT COLOR) (* rrb " 4-Dec-85 20:50") (* creates a text element for a sketch) (SK.UPDATE.TEXT.AFTER.CHANGE (create GLOBALPART INDIVIDUALGLOBALPART _ (create TEXT LOCATIONLATLON _ GPOSITION LISTOFCHARACTERS _ STRLST INITIALSCALE _ SCALE TEXTSTYLE _ JUSTIFICATION FONT _ FONT TEXTCOLOR _ COLOR]) (SK.UPDATE.TEXT.AFTER.CHANGE [LAMBDA (GTEXTELT) (* rrb " 4-Dec-85 20:50") (* updates the dependent fields in a text element that has had its text field  changed.) (TEXT.SET.GLOBAL.REGIONS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT)) (TEXT.SET.SCALES GTEXTELT) GTEXTELT]) (SK.TEXT.FROM.TEXTBOX [LAMBDA (TEXTBOXELT SKW) (* rrb "30-Sep-86 18:34") (* returns change event spec with a textbox that replaces GTEXTBOXELT.) (PROG ((INDTEXTBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTBOXELT)) TEXTSTYLE REGION NEWTEXTELT) (SETQ TEXTSTYLE (fetch (TEXTBOX TEXTSTYLE) of INDTEXTBOXELT)) (SETQ REGION (APPLY (FUNCTION SK.UNIONREGIONS) (fetch (TEXTBOX LISTOFREGIONS) of INDTEXTBOXELT))) (SETQ NEWTEXTELT (CREATE.TEXT.ELEMENT (ADD.EOLS (fetch (TEXTBOX LISTOFCHARACTERS) of INDTEXTBOXELT)) (MAP.GLOBAL.PT.ONTO.GRID [create POSITION XCOORD _ (SELECTQ (CAR TEXTSTYLE) (LEFT (fetch (REGION LEFT) of REGION)) (RIGHT (fetch (REGION RIGHT) of REGION)) (PLUS (fetch (REGION LEFT) of REGION) (QUOTIENT (fetch (REGION WIDTH) of REGION) 2))) YCOORD _ (SELECTQ (CADR TEXTSTYLE) (TOP (fetch (REGION TOP) of REGION)) (BOTTOM (fetch (REGION BOTTOM) of REGION)) (PLUS (fetch (REGION BOTTOM) of REGION) (QUOTIENT (fetch (REGION HEIGHT ) of REGION) 2] SKW) (fetch (TEXTBOX INITIALSCALE) of INDTEXTBOXELT) (COND ((EQ (CADR TEXTSTYLE) 'CENTER) (* make center into baseline because it looks better and because it is  converted the other direction.) (LIST (CAR TEXTSTYLE) 'BASELINE)) (T TEXTSTYLE)) (fetch (TEXTBOX FONT) of INDTEXTBOXELT) (fetch (TEXTBOX TEXTCOLOR) of INDTEXTBOXELT))) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ NEWTEXTELT OLDELT _ TEXTBOXELT PROPERTY _ 'HASBOX NEWVALUE _ NEWTEXTELT OLDVALUE _ TEXTBOXELT]) (TEXT.SET.GLOBAL.REGIONS [LAMBDA (GTEXTELT) (* rrb "29-Jan-85 14:50") (* updates the list of regions occupied by the text in the global coordinate  space.) (* this is used to determine the extent of a text element in a region.) (PROG ((SCALE (fetch (TEXT INITIALSCALE) of GTEXTELT))) (replace (TEXT LISTOFREGIONS) of GTEXTELT with (for LREG in [LTEXT.LINE.REGIONS (fetch (TEXT LISTOFCHARACTERS) of GTEXTELT) (SK.SCALE.POSITION.INTO.VIEWER (fetch (TEXT LOCATIONLATLON) of GTEXTELT) SCALE) (fetch (TEXT FONT) of GTEXTELT) (fetch (TEXT TEXTSTYLE) of GTEXTELT) (ITIMES (FONTHEIGHT (fetch (TEXT FONT) of GTEXTELT)) (LENGTH (fetch (TEXT LISTOFCHARACTERS) of GTEXTELT] collect (UNSCALE.REGION LREG SCALE))) (RETURN GTEXTELT]) (TEXT.REGIONFN [LAMBDA (SCRTEXTELT) (* rrb " 2-Oct-84 16:36") (* determines the local region covered  by TEXTELT.) (PROG [REG (LINEREGIONS (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of SCRTEXTELT] (RETURN (COND ((NULL LINEREGIONS) NIL) (T (SETQ REG (CAR LINEREGIONS)) (for LINEREG in (CDR LINEREGIONS) do (SETQ REG (UNIONREGIONS REG LINEREG))) REG]) (TEXT.GLOBALREGIONFN [LAMBDA (GTEXTELT) (* rrb "18-Oct-85 16:43") (* returns the global region occupied by a global text element.) (PROG [REG (LINEREGIONS (fetch (TEXT LISTOFREGIONS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT] (RETURN (COND ((NULL LINEREGIONS) NIL) (T (SETQ REG (CAR LINEREGIONS)) (for LINEREG in (CDR LINEREGIONS) do (SETQ REG (UNIONREGIONS REG LINEREG))) REG]) (TEXT.TRANSLATEFN [LAMBDA (GTEXT DELTAPOS WINDOW) (* rrb "28-Apr-85 18:45") (* moves a text figure element to a  new position.) (PROG ((INDTEXTELT (COPY (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXT))) NEWGPOS NEWTEXTELT) (* update the region positions.) (TEXT.UPDATE.GLOBAL.REGIONS (SETQ NEWTEXTELT (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of GTEXT)) INDIVIDUALGLOBALPART _ INDTEXTELT)) (SETQ NEWGPOS (PTPLUS DELTAPOS (fetch (TEXT LOCATIONLATLON) of INDTEXTELT))) (fetch (TEXT LOCATIONLATLON) of INDTEXTELT)) (replace (TEXT LOCATIONLATLON) of INDTEXTELT with NEWGPOS) (RETURN NEWTEXTELT]) (TEXT.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "16-Oct-85 18:30") (* returns a copy of the global TEXT element that has had each of its control  points transformed by transformfn. TRANSFORMDATA is arbitrary data that is  passed to tranformfn. SCALEFACTOR is the amount the transformation scales by  and is used to reset the size of the text.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (CREATE.TEXT.ELEMENT (fetch (TEXT LISTOFCHARACTERS) of INDVPART) (SK.TRANSFORM.POINT (fetch (TEXT LOCATIONLATLON) of INDVPART) TRANSFORMFN TRANSFORMDATA) (FTIMES (fetch (TEXT INITIALSCALE) of INDVPART) SCALEFACTOR) (fetch (TEXT TEXTSTYLE) of INDVPART) (fetch (TEXT FONT) of INDVPART) (fetch (TEXT TEXTCOLOR) of INDVPART]) (TEXT.TRANSLATEPTSFN [LAMBDA (TEXTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 18:05") (* returns a text element that has its  position translated.) (* shouldn't ever happen because a text element only has one control pt and its  translatefn should get used.) (fetch (SCREENELT GLOBALPART) of TEXTELT]) (TEXT.UPDATEFN [LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb "11-Jul-86 15:51") (* update function for text. Tries to repaint only the lines of text that have  changed.) (PROG ((NEWTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)) (OLDTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of OLDLOCALELT)) LOCALTEXT NEWSCREENELT) (COND ((AND (EQUAL (fetch (TEXT FONT) of NEWTEXTELT) (fetch (TEXT FONT) of OLDTEXTELT)) (EQUAL (fetch (TEXT TEXTSTYLE) of NEWTEXTELT) (fetch (TEXT TEXTSTYLE) of OLDTEXTELT)) (EQUAL (fetch (TEXT LOCATIONLATLON) of NEWTEXTELT) (fetch (TEXT LOCATIONLATLON) of OLDTEXTELT)) (EQUAL (fetch (TEXT INITIALSCALE) of NEWTEXTELT) (fetch (TEXT INITIALSCALE) of OLDTEXTELT)) (EQUAL (LENGTH (fetch (TEXT LISTOFCHARACTERS) of NEWTEXTELT)) (LENGTH (fetch (TEXT LISTOFCHARACTERS) of OLDTEXTELT))) (EQUAL (fetch (TEXT TEXTCOLOR) of NEWTEXTELT) (fetch (TEXT TEXTCOLOR) of OLDTEXTELT))) (* if font, style or number of lines has changed, erase and redraw.) (SETQ LOCALTEXT (fetch (SCREENELT LOCALPART) of OLDLOCALELT)) (SETQ NEWSCREENELT (SK.ADD.ITEM NEWGELT SKETCHW)) (* update the screen display) [PROG ((NEWSTRS (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART ) of NEWSCREENELT))) (OLDSTRS (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of LOCALTEXT)) (NEWLOCALREGIONS (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of NEWSCREENELT))) (OLDLOCALREGIONS (fetch (LOCALTEXT LINEREGIONS) of LOCALTEXT))) (COND ((NEQ (LENGTH NEWSTRS) (LENGTH OLDSTRS)) (* creating the new element caused the line filling routines to change the  number of lines so the partial redrawing algorithms don't work and we have to  redraw the whole element. Do this by erasing the old one then drawing the new  one.) (SK.ERASE.ELT OLDLOCALELT SKETCHW) (SK.DRAWFIGURE NEWSCREENELT SKETCHW NIL (VIEWER.SCALE SKETCHW)) (RETURN NEWSCREENELT))) LP (COND ((OR NEWSTRS OLDSTRS) (* continue until both new and old are  exhausted.) [COND ([NOT (AND (EQUAL (CAR NEWSTRS) (CAR OLDSTRS)) (EQUAL (CAR NEWLOCALREGIONS) (CAR OLDLOCALREGIONS] (* this line is the different, redraw  it.) (AND OLDLOCALREGIONS (DSPFILL (CAR OLDLOCALREGIONS) BLACKSHADE 'ERASE SKETCHW)) (AND NEWSTRS (TEXT.DRAWFN1 (LIST (CAR NEWSTRS)) (LIST (CAR NEWLOCALREGIONS)) (fetch (LOCALTEXT LOCALFONT) of LOCALTEXT) (fetch (TEXT TEXTCOLOR) of OLDTEXTELT) SKETCHW] (SETQ NEWSTRS (CDR NEWSTRS)) (SETQ OLDSTRS (CDR OLDSTRS)) (SETQ NEWLOCALREGIONS (CDR NEWLOCALREGIONS)) (SETQ OLDLOCALREGIONS (CDR OLDLOCALREGIONS)) (GO LP] (RETURN NEWSCREENELT]) (SK.CHANGE.TEXT [LAMBDA (ELTWITHTEXT HOW SKW) (* ; "Edited 7-Apr-87 13:41 by rrb") (PROG ((COMMAND (CADR HOW)) (PROPERTY 'FONT) NEWVALUE GINDTEXTELT NEWGTEXT OLDVALUE OLDFACE GTYPE) (OR HOW (RETURN)) (* take down the caret before any  change.) (SKED.CLEAR.SELECTION SKW) (COND ((MEMB (SETQ GTYPE (fetch (GLOBALPART GTYPE) of ELTWITHTEXT)) '(TEXTBOX TEXT)) (SETQ GINDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHTEXT)) (* set the old value to the old font. In the case where the thing that changes  is the justification, this will get re-set) (SETQ OLDVALUE (fetch (TEXT FONT) of GINDTEXTELT)) (SETQ NEWGTEXT (SELECTQ (CAR HOW) (TEXT (SELECTQ COMMAND ((SMALLER LARGER) (* change the font) [COND [[SETQ NEWVALUE (SK.NEXTSIZEFONT COMMAND (LIST (FONTPROP OLDVALUE 'FAMILY) (FONTPROP OLDVALUE 'SIZE] (* if there is an appropriate size  font, use it.) [SETQ NEWVALUE (LIST (FONTPROP NEWVALUE 'FAMILY) (FONTPROP NEWVALUE 'SIZE) (FONTPROP OLDVALUE 'FACE] (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE] (T (* otherwise just scale the area some.) (SETQ NEWVALUE (FTIMES (SETQ OLDVALUE (fetch (TEXT INITIALSCALE ) of GINDTEXTELT)) (SELECTQ COMMAND (LARGER 1.4) 0.7142858))) (SETQ PROPERTY 'SCALE) (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT INITIALSCALE _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT INITIALSCALE _ NEWVALUE]) ((CENTER LEFT RIGHT) (* change the horizontal justification) [SETQ NEWVALUE (LIST COMMAND (CADR (SETQ OLDVALUE (fetch (TEXT TEXTSTYLE) of GINDTEXTELT] (SETQ PROPERTY 'JUSTIFICATION) (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT TEXTSTYLE _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT TEXTSTYLE _ NEWVALUE)))) ((TOP BOTTOM MIDDLE BASELINE) (* change the vertical justification) [SETQ NEWVALUE (LIST (CAR (SETQ OLDVALUE (fetch (TEXT TEXTSTYLE) of GINDTEXTELT))) (COND ((EQ COMMAND 'MIDDLE) 'CENTER) (T COMMAND] (SETQ PROPERTY 'JUSTIFICATION) (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT TEXTSTYLE _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT TEXTSTYLE _ NEWVALUE)))) ((BOLD UNBOLD ITALIC UNITALIC) (* change the face) (SETQ OLDFACE (FONTPROP OLDVALUE 'FACE)) [SETQ NEWVALUE (LIST (FONTPROP OLDVALUE 'FAMILY) (FONTPROP OLDVALUE 'SIZE) (LIST (SELECTQ COMMAND (BOLD 'BOLD) (UNBOLD 'MEDIUM) (CAR OLDFACE)) (SELECTQ COMMAND (ITALIC 'ITALIC) (UNITALIC 'REGULAR) (CADR OLDFACE)) (CADDR OLDFACE] (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE)))) (BOX (* if it is a text element, BOX it) [COND ((EQ GTYPE 'TEXT) (RETURN (SK.TEXTBOX.FROM.TEXT ELTWITHTEXT SKW]) (UNBOX (* if it is a text box, unbox it.) [COND ((EQ GTYPE 'TEXTBOX) (RETURN (SK.TEXT.FROM.TEXTBOX ELTWITHTEXT SKW]) (LOOKEDSTRING [COND ((EQ GTYPE 'TEXT) (RETURN (SK.LOOKEDSTRING.FROM.TEXT ELTWITHTEXT SKW]) (SHOULDNT))) (SETSIZE (SETQ NEWVALUE COMMAND) (COND [(EQ (FONTPROP NEWVALUE 'FAMILY) (FONTPROP OLDVALUE 'FAMILY)) (* if the families are the same, change them, otherwise don't as it isn't known  whether or not this family has the right size.) (COND [(EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT FONT _ (LIST (FONTPROP OLDVALUE 'FAMILY) (FONTPROP NEWVALUE 'SIZE) (FONTPROP OLDVALUE 'FACE] (T (create TEXTBOX using GINDTEXTELT FONT _ (LIST (FONTPROP OLDVALUE 'FAMILY) (FONTPROP NEWVALUE 'SIZE) (FONTPROP OLDVALUE 'FACE] (T (RETURN)))) (NEWFONT (* set the font family) [SETQ NEWVALUE (LIST COMMAND (FONTPROP OLDVALUE 'SIZE) (FONTPROP OLDVALUE 'FACE] (COND ((NULL (FONTCREATE NEWVALUE NIL NIL NIL NIL T)) (STATUSPRINT SKW " Couldn't find " (CAR NEWVALUE) " in size " (CADR NEWVALUE)) (RETURN))) (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE)))) (FAMILY&SIZE (* set the font family and size) [SETQ NEWVALUE (LIST (CAR COMMAND) (CADR COMMAND) (FONTPROP (fetch (TEXT FONT) of GINDTEXTELT) 'FACE] (COND ((EQ GTYPE 'TEXT) (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE)))) (SAME (* set all of the font characteristics from the first selected one.) (* set the variables to cause the right things to go into the change spec  event.) (SETQ OLDVALUE ELTWITHTEXT) (SETQ PROPERTY 'LOOKSAME) (SETQ NEWVALUE (SK.TEXT.ELT.WITH.SAME.FIELDS (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of COMMAND) GINDTEXTELT))) (SHOULDNT))) [SETQ NEWGTEXT (COND [(EQ GTYPE 'TEXT) (* adjust the scales at which this appears because font or scale may have  changed.) (TEXT.SET.SCALES (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART ) of ELTWITHTEXT) INDIVIDUALGLOBALPART _ (  TEXT.SET.GLOBAL.REGIONS NEWGTEXT] (T (* scaling for text boxes depends on the box size which can't change in this  function.) (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHTEXT) INDIVIDUALGLOBALPART _ (TEXTBOX.SET.GLOBAL.REGIONS NEWGTEXT ] (RETURN (create SKHISTORYCHANGESPEC NEWELT _ NEWGTEXT OLDELT _ ELTWITHTEXT PROPERTY _ PROPERTY NEWVALUE _ NEWVALUE OLDVALUE _ OLDVALUE]) (TEXT.SET.SCALES [LAMBDA (GTEXTELT) (* rrb "12-May-85 16:29") (* sets the min and max scale properties of a global text element.  Called after something about the text changes.) (PROG [(COMMONPART (fetch (GLOBALPART COMMONGLOBALPART) of GTEXTELT)) (ORIGSCALE (fetch (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT] (replace (COMMONGLOBALPART MINSCALE) of COMMONPART with (QUOTIENT ORIGSCALE 20.0)) (replace (COMMONGLOBALPART MAXSCALE) of COMMONPART with (FTIMES (FONTHEIGHT (fetch (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT))) ORIGSCALE)) (RETURN GTEXTELT]) (BREAK.AT.CARRIAGE.RETURNS [LAMBDA (STRING) (* rrb "16-Oct-85 18:24") (* returns a list of strings breaking string at carriage returns.) (PROG (STRLST (STR (OR (STRINGP STRING) (MKSTRING STRING))) (PREV 0) (WHERE 0)) LP (COND ((SETQ WHERE (STRPOS " " STR (ADD1 WHERE))) [SETQ STRLST (NCONC1 STRLST (COND ((EQ WHERE (ADD1 PREV)) "") (T (SUBSTRING STR (ADD1 PREV) (SUB1 WHERE] (SETQ PREV WHERE) (GO LP))) (RETURN (NCONC1 STRLST (OR (SUBSTRING STR (ADD1 PREV) -1) ""]) ) (DEFINEQ (ADD.KNOWN.SKETCH.FONT [LAMBDA (FAMILY WID DEVICE FONT) (* ; "Edited 21-Feb-89 15:06 by snow") (* ;; "add to the globally cached font list") (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES)) (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES)) (CACHED)) (COND [(NULL CACHE) (if \KNOWN.SKETCH.FONTSIZES then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT] else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE (CONS WID FONT] (T (COND ((SETQ CACHED (ASSOC DEVICE CACHE)) (NCONC1 CACHED (CONS WID FONT))) (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT]) (SK.PICK.FONT [LAMBDA (WID STRING DEVICE FAMILY) (* ; "Edited 22-Feb-89 07:53 by snow") (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide") (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES)) (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT) (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES] THEN (RETURN (CDR CACHEDFONT))) (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE) when (NOT (GREATERP [SETQ LASTSIZE (COND ((SETQ SCALE (FONTPROP FONT 'SCALE)) (* ;;  "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.") (QUOTIENT (STRINGWIDTH STRING FONT) SCALE)) ((SETQ DISPLAYFONT (FONTCOPY (SETQ LASTFONT FONT) 'DEVICE 'DISPLAY 'NOERROR T)) (* ; "use display if it exists.") (STRINGWIDTH STRING DISPLAYFONT)) (T (* ;  "in some cases, font exists for devices other than display.") (QUOTIENT (STRINGWIDTH STRING FONT) (FONTPROP FONT 'SCALE] WID)) do (* ;  "return a font for the proper device even though the display fonts are used to pick a size.") (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE (FONTCOPY FONT 'DEVICE DEVICE)) (RETURN (FONTCOPY FONT 'DEVICE DEVICE)) finally (RETURN (COND ((OR (NULL LASTFONT) (GREATERP LASTSIZE (TIMES 1.5 WID))) 'SHADE) (T (* ;  "use the smallest if it isn't too large.") (FONTCOPY LASTFONT 'DEVICE DEVICE]) (SK.CHOOSE.TEXT.FONT [LAMBDA (GTEXT SCALE VIEWER) (* ; "Edited 1-Nov-91 16:56 by jds") (* ;; "returns the font that text in the individual global part of a text or textbox element GTEXT should be displayed in when shown in VIEWER.") (PROG ([VIEWERFONTCACHE (OR (AND (WINDOWP VIEWER) (WINDOWPROP VIEWER 'PICKFONTCACHE)) (AND (STREAMP VIEWER) (STREAMPROP VIEWER 'PICKFONTCACHE] (GFONT (fetch (TEXT FONT) of GTEXT)) LOCALFONT) [COND ((SETQ LOCALFONT (SASSOC GFONT VIEWERFONTCACHE))(* ;  "look in the viewer's font cache.") (RETURN (CDR LOCALFONT] (RETURN (PROG ((CANONICALTESTSTR "AWIaiw") CANONICALWIDTH DEVICE) [SETQ DEVICE (COND ((STREAMP VIEWER) (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of VIEWER))) (T 'DISPLAY] [COND ((EQUAL (TIMES SCALE (DSPSCALE NIL VIEWER)) (fetch (TEXT INITIALSCALE) of GTEXT)) (* ;; "special case scales being the same so there is not a large delay when first character is typed and to avoid font look up problems when hardcopying at scale 1") (SETQ LOCALFONT (FONTCREATE GFONT NIL NIL NIL DEVICE))) (T (* ;; "use a canonical string to determine the font size so that all strings of a given font at a given scale look the same. If font is determined by the width of the particular string, two different string will appear in different fonts. In particular, the string may change fonts as the user is typing into it.") (* ;; "don't use the face information when determining string width because in some cases HELVETICA 10, the bold is smaller than the regular.") [SETQ CANONICALWIDTH (FIXR (QUOTIENT (TIMES [STRINGWIDTH CANONICALTESTSTR (LIST (FONTPROP GFONT 'FAMILY) (FONTPROP GFONT 'SIZE] (fetch (TEXT INITIALSCALE) of GTEXT)) (TIMES SCALE (DSPSCALE NIL VIEWER] (* ; "calculate the local font.") (SETQ LOCALFONT (SK.PICK.FONT CANONICALWIDTH CANONICALTESTSTR DEVICE (CAR GFONT))) (COND ((FONTP LOCALFONT) (SETQ LOCALFONT (FONTCOPY LOCALFONT 'FACE (CADDR GFONT] [COND ((WINDOWP VIEWER) (WINDOWPROP VIEWER 'PICKFONTCACHE (CONS (CONS GFONT LOCALFONT) VIEWERFONTCACHE))) ((STREAMP VIEWER) (STREAMPROP VIEWER 'PICKFONTCACHE (CONS (CONS GFONT LOCALFONT) VIEWERFONTCACHE] (RETURN LOCALFONT]) (SK.NEXTSIZEFONT [LAMBDA (WHICHDIR NOWFONT) (* rrb "14-Jul-86 13:43") (* returns the next sized font either SMALLER or LARGER that on of size FONT.) (PROG [(NOWSIZE (FONTPROP NOWFONT 'HEIGHT)) (DECREASEFONTLST (SK.DECREASING.FONT.LIST (CAR NOWFONT) 'DISPLAY] (RETURN (COND [(EQ WHICHDIR 'LARGER) (COND ((IGEQ NOWSIZE (FONTPROP (CAR DECREASEFONTLST) 'HEIGHT)) (* nothing larger) NIL) (T (for FONTTAIL on DECREASEFONTLST when [AND (CDR FONTTAIL) (IGEQ NOWSIZE (FONTPROP (CADR FONTTAIL) 'HEIGHT] do (RETURN (SK.FONTNAMELIST (CAR FONTTAIL] (T (for FONT in DECREASEFONTLST when (LESSP (FONTPROP FONT 'HEIGHT) NOWSIZE) do (RETURN (SK.FONTNAMELIST FONT]) (SK.DECREASING.FONT.LIST [LAMBDA (FAMILY DEVICETYPE) (* ;  "Edited 12-Oct-92 12:39 by sybalsky:mv:envos") (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE") [COND ((NULL FAMILY) (SETQ FAMILY 'MODERN] (* ;; "convert to families that exist on the known devices.") (* ;;; "NOTE: this is a very bad way to convert the family. It HARDCODES in the conversions for PRESS and INTERPRESS and does nothing for new device types. I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.) --was 2/19/89") (LET ((CONVERSION)) [COND [(EQ DEVICETYPE 'PRESS) (COND ((EQ FAMILY 'MODERN) (SETQ FAMILY 'HELVETICA)) ((EQ FAMILY 'CLASSIC) (SETQ FAMILY 'TIMESROMAN)) ((EQ FAMILY 'TERMINAL) (SETQ FAMILY 'GACHA] [(EQ DEVICETYPE 'INTERPRESS) (COND ((EQ FAMILY 'HELVETICA) (SETQ FAMILY 'MODERN)) ((EQ FAMILY 'TIMESROMAN) (SETQ FAMILY 'CLASSIC)) ((EQ FAMILY 'GACHA) (SETQ FAMILY 'TERMINAL] ((EQ DEVICETYPE 'POSTSCRIPT) (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.ALIST)) then (* ;;  "convert the family here for postscript as well as the other well known devices.") (SETQ FAMILY (CDR CONVERSION] (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE) collect (FONTCOPY FONT 'DEVICE DEVICETYPE]) (SK.GUESS.FONTSAVAILABLE [LAMBDA (FAMILY HDCPYTYPE) (* rrb " 9-Oct-85 16:10") (* returns a list of all fonts of a FAMILY in decreasing order.) (PROG (FILEFONTS CACHE DISPLAYFONTSIZES) (SETQ HDCPYTYPE (COND ((NULL HDCPYTYPE) (PRINTERTYPE)) ((NLISTP HDCPYTYPE) HDCPYTYPE) (T HDCPYTYPE))) (* cache the file fonts.) [COND [[SETQ FILEFONTS (ASSOC HDCPYTYPE (CDR (ASSOC FAMILY \FONTSONFILE] (* note if a cache has been calculated. Use it even if it is NIL) (* \FONTSONFILE seems to group things such as CLASSICTHIN under CLASSIC so make  sure to remove anything that has the wrong family.) (SETQ FILEFONTS (SUBSET (CDR FILEFONTS) (FUNCTION (LAMBDA (X) (EQ (CAR X) FAMILY] (T (RESETFORM (CURSOR WAITINGCURSOR) (SETQ FILEFONTS (FONTSAVAILABLE FAMILY '* '(MEDIUM REGULAR REGULAR) NIL HDCPYTYPE T)) (* Since there is no way to determine the real sizes for PRESS fonts with size  of 0 {meaning the widths scale}, guess that they are available in 10) [COND [(EQ HDCPYTYPE 'PRESS) (* make sure to look for anything that has a display font.) (SETQ DISPLAYFONTSIZES (for FONT in (FONTSAVAILABLE FAMILY '* '(MEDIUM REGULAR REGULAR) NIL 'DISPLAY) collect (CADR FONT))) (SETQ FILEFONTS (for FONT in FILEFONTS join (COND [(EQ (CADR FONT) 0) (for SIZE in (UNION DISPLAYFONTSIZES '(36 30 24 18 14 12 10 8 6)) when (FONTCREATE (CAR FONT) SIZE NIL NIL 'DISPLAY T) collect (CONS (CAR FONT) (CONS SIZE (CDDR FONT] (T (CONS FONT] ((EQ HDCPYTYPE 'DISPLAY) (* patch around the bug in FONTSAVAILABLE.  Remove after J release.) (SETQ FILEFONTS (SUBSET FILEFONTS (FUNCTION (LAMBDA (FONT) (EQUAL (CADDR FONT) '(MEDIUM REGULAR REGULAR] (* remove duplicates and sort) [SETQ FILEFONTS (SORT (INTERSECTION FILEFONTS FILEFONTS) (FUNCTION (LAMBDA (A B) (GREATERP (CADR A) (CADR B] (COND ((NULL (SETQ CACHE (ASSOC FAMILY \FONTSONFILE))) (SETQ \FONTSONFILE (CONS (LIST FAMILY (CONS HDCPYTYPE FILEFONTS)) \FONTSONFILE))) (T (NCONC1 CACHE (CONS HDCPYTYPE FILEFONTS] (* reget the fonts in core since they may have changed since last time.) (RETURN (SORT (UNION (FONTSAVAILABLE FAMILY '* NIL NIL HDCPYTYPE) FILEFONTS) (FUNCTION (LAMBDA (A B) (COND ((EQ (CADR A) (CADR B)) (* in case both TIMESROMAN and TIMESROMAND for example make it in.) (ALPHORDER (CADR A) (CADR B))) (T (GREATERP (CADR A) (CADR B]) ) (RPAQQ \KNOWN.SKETCH.FONTSIZES NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD TEXT (LOCATIONLATLON LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS TEXTCOLOR)) (RECORD LOCALTEXT ((DISPLAYPOSITION) LOCALHOTREGION LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS)) ) ) (DEFINEQ (SK.SET.FONT [LAMBDA (W NEWFONT) (* rrb " 2-Oct-85 14:55") (* sets the entire default font. Used when a sketch stream is created.  or any of the defaults are changed. NEWFONT is a list of  (FAMILY SIZE FACE)) (COND (NEWFONT (COND ((FONTCREATE NEWFONT NIL NIL NIL NIL T) (* clear the cache of looked up fonts. This provides the user a way of clearing  the cache that shouldn't happen too much and is documented.) (AND (FASSOC (CAR NEWFONT) \FONTSONFILE) (SETQ \FONTSONFILE (for BUCKET in \FONTSONFILE when (NEQ (CAR BUCKET) (CAR NEWFONT)) collect BUCKET))) (replace (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP W 'SKETCHCONTEXT) with NEWFONT )) (T (STATUSPRINT W (CAR NEWFONT) " " (CADR NEWFONT) " " (SELECTQ (CAR (CADDR NEWFONT)) (BOLD 'BOLD) "") (SELECTQ (CADR (CADDR NEWFONT)) (ITALIC 'ITALIC) "") " not found"]) (SK.SET.TEXT.FONT [LAMBDA (W) (* rrb " 4-Oct-85 16:21") (* sets the size of the default  arrowhead.) (PROG [NEWFONT NOWFONT (SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT] (SETQ NEWFONT (SK.READFONTFAMILY W (PACK* "now: " (CAR (SETQ NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of SKCONTEXT))) " " (CADR NOWFONT) ". New?"))) (COND (NEWFONT (SK.SET.FONT W (LIST NEWFONT (CADR NOWFONT) (CADDR NOWFONT]) (SK.SET.TEXT.SIZE [LAMBDA (W) (* rrb " 2-Oct-85 14:36") (* sets the size of the default font.) (PROG (NEWSIZE (SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) NOWFONT) (SETQ NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of SKCONTEXT)) (SETQ NEWSIZE (SK.READFONTSIZE NIL (FONTPROP NOWFONT 'FAMILY) W)) (COND (NEWSIZE (SK.SET.FONT W (LIST (CAR NOWFONT) NEWSIZE (CADDR NOWFONT]) (SK.SET.TEXT.HORIZ.ALIGN [LAMBDA (SKW NEWALIGN) (* rrb " 6-Nov-85 09:51") (* * reads a new value for the horizontal justification) (PROG ([NEWJUST (COND ((MEMB NEWALIGN '(CENTER LEFT RIGHT)) NEWALIGN) (T (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ '((" Center " 'CENTER "New text will be centered around its position" ) ("Left " 'LEFT "the left edge of the text will be at its position." ) (" Right" 'RIGHT "the right edge of the text will be at its position." ] SKCONTEXT) (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) with (CONS NEWJUST (CDR (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of SKCONTEXT]) (SK.READFONTSIZE [LAMBDA (TITLE FONTFAMILY SKW) (* rrb " 6-Nov-85 09:51") (* * gets a legal known font size from the user.) (* this should have MENUROWS _ 1 when title height bug in menu package gets  fixed.) (PROG ((FONTSIZES (SK.COLLECT.FONT.SIZES FONTFAMILY)) NEWSIZE) (COND ((NULL FONTSIZES) (GO MORE))) (SETQ NEWSIZE (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ (COND (TITLE) (FONTFAMILY (CONCAT "new " FONTFAMILY " size?")) (T "New font size?")) ITEMS _ (CONS '(More 'MORE "will look on font directories to find more sizes." ) FONTSIZES) CENTERFLG _ T))) (COND ((NEQ NEWSIZE 'MORE) (RETURN NEWSIZE))) MORE (* do longer search of files) (SETQ NEWSIZE (SK.COLLECT.FONT.SIZES FONTFAMILY T)) (COND ((NULL NEWSIZE) (* could not find any fonts of that  family) (RETURN NIL)) ((EQUAL NEWSIZE FONTSIZES) (* not new ones found) (STATUSPRINT SKW " No more font sizes found."))) (RETURN (MENU (create MENU TITLE _ (OR TITLE "New font size?") ITEMS _ NEWSIZE CENTERFLG _ T]) (SK.COLLECT.FONT.SIZES [LAMBDA (FAMILY FILESTOOFLG) (* rrb " 2-Oct-85 10:43") (* collects all of the sizes that are known.  If FAMILY is given, gets just those sizes.) (PROG (INCORESIZES FILESIZES) [COND [FAMILY (for TYPEBUCKET in (CDR (FASSOC FAMILY \FONTSONFILE)) do (for FFONT in (CDR TYPEBUCKET) do (OR (MEMB (CADR FFONT) INCORESIZES) (SETQ INCORESIZES (CONS (CADR FFONT) INCORESIZES] (T (* look at all fonts) (for FAMILYBUCKET in \FONTSONFILE do (for TYPEBUCKET in (CDR FAMILYBUCKET) do (for FFONT in (CDR TYPEBUCKET) do (OR (MEMB (CADR FFONT) INCORESIZES) (SETQ INCORESIZES (CONS (CADR FFONT) INCORESIZES] (RETURN (SORT (UNION INCORESIZES (COND [FILESTOOFLG (* wants those on files too, Flip the cursor to note wait.) (RESETFORM (CURSOR WAITINGCURSOR) (bind SIZES for FONT in (FONTSAVAILABLE (OR FAMILY '*) '* NIL NIL 'DISPLAY T) do (OR (MEMB (FONTPROP FONT 'SIZE) SIZES) (SETQ SIZES (CONS (FONTPROP FONT 'SIZE) SIZES))) finally (RETURN SIZES] (T (bind SIZES for FONT in (FONTSAVAILABLE (OR FAMILY '*) '* NIL NIL 'DISPLAY FILESTOOFLG) do (OR (MEMB (FONTPROP FONT 'SIZE) SIZES) (SETQ SIZES (CONS (FONTPROP FONT 'SIZE) SIZES))) finally (RETURN SIZES]) (SK.SET.TEXT.VERT.ALIGN [LAMBDA (SKW NEWALIGN) (* rrb " 6-Nov-85 09:52") (* * reads a new value for the vertical justification) (PROG ([NEWJUST (COND ((MEMB NEWALIGN '(TOP CENTER BASELINE BOTTOM)) NEWALIGN) (T (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "New vertical alignment?" ITEMS _ '(("Top" 'TOP "the top of new text's vertical extent will be at its position" ) ("Center" 'CENTER "New text's vertical extent will be centered around its position" ) ("Baseline" 'BASELINE "The baseline of new text will be at its position." ) ("Bottom" 'BOTTOM "the bottom of new text's vertical extent will be at its position" )) CENTERFLG _ T] SKCONTEXT) (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) with (LIST (CAR (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of SKCONTEXT)) NEWJUST]) (SK.SET.TEXT.LOOKS [LAMBDA (W) (* rrb " 6-Nov-85 09:52") (* * reads a new value for the looks of default text) (SK.SET.DEFAULT.TEXT.FACE (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ '((regular '(MEDIUM REGULAR REGULAR) "new text will be neither bold nor italic." ) (bold '(BOLD REGULAR REGULAR) "new text will be bold.") (italic '(MEDIUM ITALIC REGULAR) "new text will be italic.") (bold/italic '(BOLD ITALIC REGULAR) "new text will be bold and italic." )) TITLE _ "New default look" CENTERFLG _ T)) W]) (SK.SET.DEFAULT.TEXT.FACE [LAMBDA (NEWDEFAULTFACE SKW) (* rrb " 4-Oct-85 16:24") (* changes the default text face to  NEWDEFAULTFACE.) (PROG [(NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP SKW 'SKETCHCONTEXT] (RETURN (AND NEWDEFAULTFACE (SK.SET.FONT SKW (LIST (CAR NOWFONT) (CADR NOWFONT) NEWDEFAULTFACE]) ) (DEFINEQ (CREATE.SKETCH.TERMTABLE [LAMBDA NIL (* rrb " 2-Oct-85 10:40") (* returns a terminal table that has most characters printing as REAL) (* it is used by TEXT.DRAWFN1 to print strings in sketch.) (PROG ((TTBL (COPYTERMTABLE NIL))) (for I from 128 to 255 do (AND (EQ (ECHOCHAR I NIL TTBL) 'INDICATE) (ECHOCHAR I 'REAL TTBL))) (RETURN TTBL]) ) (DEFINEQ (SK.FONT.LIST [LAMBDA (FONTDESCRIPTOR) (* rrb " 2-Oct-85 14:41") (* returns the font family, and size of a font descriptor) (LIST (FONTPROP FONTDESCRIPTOR 'FAMILY) (FONTPROP FONTDESCRIPTOR 'SIZE) (FONTPROP FONTDESCRIPTOR 'FACE]) (SK.INSURE.FONT [LAMBDA (FONT) (* rrb "16-Oct-85 17:46") (* checks the validity of a font argument for a sketch element.) (COND [(NULL FONT) (SK.FONT.LIST (OR (AND SK.DEFAULT.FONT (FONTCREATE SK.DEFAULT.FONT)) (DEFAULTFONT 'DISPLAY] ((FONTP FONT) (SK.FONT.LIST FONT)) ((FONTCREATE FONT) (SK.FONT.LIST (FONTCREATE FONT))) (T (\ILLEGAL.ARG FONT]) (SK.INSURE.STYLE [LAMBDA (STYLE DEFAULT) (* rrb "16-Oct-85 17:51") (* checks the validity of a STYLE argument for a sketch element) (COND ((NULL STYLE) DEFAULT) ((AND (LISTP STYLE) (MEMB (CAR STYLE) SK.HORIZONTAL.STYLES) (MEMB (CAR (LISTP (CDR STYLE))) SK.VERTICAL.STYLES) (NULL (CDDR STYLE))) STYLE) (T (\ILLEGAL.ARG STYLE]) (SK.INSURE.TEXT [LAMBDA (TEXTTHING) (* rrb " 4-Nov-85 18:53") (* puts something in the form necessary for a text list of characters.) (COND ((NLISTP TEXTTHING) (BREAK.AT.CARRIAGE.RETURNS TEXTTHING)) (T (for X in TEXTTHING join (BREAK.AT.CARRIAGE.RETURNS X]) ) (RPAQQ INDICATE.TEXT.SHADE 23130) (RPAQ? SK.DEFAULT.FONT ) (RPAQ? SK.DEFAULT.TEXT.ALIGNMENT '(CENTER BASELINE)) (RPAQ? \FONTSONFILE NIL) (ADDTOVAR SK.HORIZONTAL.STYLES LEFT RIGHT CENTER) (ADDTOVAR SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM) (RPAQ SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES) ) (* ; "stuff for supporting the TEXTBOX sketch element.") (DEFINEQ (SKETCH.CREATE.TEXTBOX [LAMBDA (STRING REGION FONT JUSTIFICATION BOXBRUSH BOXDASHING FILLING TEXTCOLOR SCALE) (* rrb " 6-Aug-86 17:06") (* creates a sketch box element.) (PROG ((XBRUSH (SK.INSURE.BRUSH BOXBRUSH)) [XTEXT (COND ((NLISTP STRING) (BREAK.AT.CARRIAGE.RETURNS STRING)) (T (for X in STRING join (BREAK.AT.CARRIAGE.RETURNS X] (XFONT (SK.INSURE.FONT FONT)) (XJUSTIFICATION (SK.INSURE.STYLE JUSTIFICATION SK.DEFAULT.TEXTBOX.ALIGNMENT)) XREGION) (* calculate the region the textbox is to have.  This is complicated in the case where REGION is a position because all of the  other parameters must be know to calculate the region.) [SETQ XREGION (COND ((REGIONP REGION)) ((POSITIONP REGION) (SK.COMPUTE.TEXTBOX.REGION.FOR.STRING REGION XTEXT XFONT XBRUSH XJUSTIFICATION)) (T (\ILLEGAL.ARG REGION] (RETURN (SK.TEXTBOX.CREATE1 XREGION XBRUSH XTEXT (OR (NUMBERP SCALE) 1.0) XJUSTIFICATION XFONT (SK.INSURE.DASHING BOXDASHING) (SK.INSURE.FILLING FILLING) (SK.INSURE.COLOR TEXTCOLOR]) (SK.COMPUTE.TEXTBOX.REGION.FOR.STRING [LAMBDA (POSITION STRLST FONT BRUSH JUSTIFICATION) (* rrb "30-Jul-86 14:30") (* returns the region of the box around STRLST whose control point is POSITION.) (PROG ((TEXTWIDTH (bind NOWWIDTH (WIDTH _ 0) for STR in STRLST do (COND ((GREATERP (SETQ NOWWIDTH (STRINGWIDTH STR FONT)) WIDTH) (SETQ WIDTH NOWWIDTH))) finally (RETURN WIDTH))) (TEXTHEIGHT (TIMES (LENGTH STRLST) (FONTHEIGHT FONT))) (MARGIN (SK.BRUSH.SIZE BRUSH))) (* leave two extra points for the width because it looks better.) (SETQ TEXTWIDTH (PLUS MARGIN MARGIN TEXTWIDTH 2)) (SETQ TEXTHEIGHT (PLUS MARGIN MARGIN TEXTHEIGHT)) (RETURN (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of POSITION) (SELECTQ (CAR JUSTIFICATION) (LEFT 0) (RIGHT TEXTWIDTH) (CENTER (QUOTIENT TEXTWIDTH 2.0)) (SHOULDNT))) (DIFFERENCE (fetch (POSITION YCOORD) of POSITION) (SELECTQ (CADR JUSTIFICATION) (BASELINE (PLUS (QUOTIENT (DIFFERENCE TEXTHEIGHT (FONTHEIGHT FONT)) 2.0) (FONTPROP FONT 'DESCENT))) (TOP TEXTHEIGHT) (BOTTOM 0) (CENTER (QUOTIENT TEXTHEIGHT 2.0)) (SHOULDNT))) TEXTWIDTH TEXTHEIGHT]) (SK.BREAK.INTO.LINES [LAMBDA (STRLST FONT WIDTH) (* rrb "14-Jun-85 18:04") (* returns a list of lines {as strings} of the text stored on STRLST broken so  that as many words as possible fit on a line WIDTH wide.) (COND [(OR (FONTP FONT) (WINDOWP FONT)) (PROG ((SPACEWIDTH (CHARWIDTH (CHARCODE % ) FONT)) (REMAINING WIDTH) THISLINE NEWLST PREVCHARCR) (for STR in STRLST do (PROG ((BEGPTR 1) (CHPTR 1) (CHARSWID 0) (LIMITPTR (ADD1 (NCHARS STR))) CHCODE ENDPTR) CHLP (COND ((EQ CHPTR LIMITPTR) (* ran out of characters.) (COND ((EQ LIMITPTR 1) (* empty line, ignore it.) (RETURN)) [(ILEQ CHARSWID REMAINING) (* this whole thing fits.) (SETQ THISLINE (CONS [COND ((EQ BEGPTR 1) (* save substring call.) STR) (T (* put substring in.) (SUBSTRING STR BEGPTR (SUB1 CHPTR] (COND (THISLINE (* put a space in) (CONS " " THISLINE] (ENDPTR (* found a word or words that will fit, put them on this line and finish this  line.) (SETQ NEWLST (CONS [CONS (COND ((EQ ENDPTR 0) (* line began with a space and only it  fit) " ") (T (SUBSTRING STR BEGPTR ENDPTR)) ) (COND (THISLINE (* put a space in) (CONS " " THISLINE] NEWLST)) (SETQ THISLINE (CONS (OR (SUBSTRING STR (PLUS ENDPTR 2) (SUB1 CHPTR)) ""))) (SETQ REMAINING WIDTH)) (T (* the remainder of this string goes on the next line.) (AND THISLINE (SETQ NEWLST (CONS THISLINE NEWLST))) [SETQ THISLINE (CONS (COND ((EQ BEGPTR 1) (* save substring call.) STR) (T (* put substring in.) (SUBSTRING STR BEGPTR (SUB1 CHPTR] (SETQ REMAINING WIDTH))) (* decrement space remaining.) (SETQ REMAINING (IDIFFERENCE REMAINING (IPLUS CHARSWID SPACEWIDTH))) (RETURN) (* put the part of this line that didn't fit on the next line.) ) ((EQ (CHARCODE % ) (SETQ CHCODE (NTHCHARCODE STR CHPTR))) (* got to a space) [COND ((ILEQ CHARSWID REMAINING) (* mark the end of something that we  know fits.) (* decrement space remaining.) (SETQ REMAINING (DIFFERENCE REMAINING CHARSWID))) (ENDPTR (* found a word or words that will fit, put them on this line and finish this  line.) (SETQ NEWLST (CONS [CONS (OR (SUBSTRING STR BEGPTR ENDPTR) "") (COND (THISLINE (* put a space in) (CONS " " THISLINE] NEWLST)) (* reset the pointers to note this  beginning.) (SETQ THISLINE NIL) (* ENDPTR is always just before a space, put the beginning at the character  following the space.) (SETQ BEGPTR (PLUS ENDPTR 2)) (SETQ REMAINING (DIFFERENCE WIDTH CHARSWID))) (T (* the rest of the current string goes on the next line.) (COND (THISLINE (SETQ NEWLST (CONS THISLINE NEWLST)) (SETQ THISLINE NIL))) (SETQ REMAINING (DIFFERENCE WIDTH CHARSWID] (SETQ ENDPTR (SUB1 CHPTR)) (SETQ CHARSWID 0)) ((EQ CHCODE (CHARCODE EOL)) (* CR, end a line.) [COND ((GREATERP CHARSWID REMAINING) (* the last word before the CR doesn't fit on this line.) (COND (ENDPTR (* put some of it on the previous line) (SETQ NEWLST (CONS [CONS (OR (SUBSTRING STR BEGPTR ENDPTR ) "") (COND (THISLINE (* put a space in) (CONS " " THISLINE] NEWLST)) (SETQ THISLINE NIL) (SETQ BEGPTR (PLUS ENDPTR 2))) (T (* end the previous line and put this stuff on a new one.) (COND (THISLINE (SETQ NEWLST (CONS THISLINE NEWLST)) (SETQ THISLINE NIL] [SETQ THISLINE (CONS (COND ((AND (EQ (ADD1 CHPTR) LIMITPTR) (EQ BEGPTR 1)) (* last character of str, save  substring call. for efficiency) STR) (T (* put substring in.) (SUBSTRING STR BEGPTR CHPTR))) (COND (THISLINE (* put a space in) (CONS " " THISLINE] (SETQ NEWLST (CONS THISLINE NEWLST)) (SETQ THISLINE NIL) (SETQ CHARSWID 0) (SETQ REMAINING WIDTH) (COND ((EQ (ADD1 CHPTR) LIMITPTR) (SETQ PREVCHARCR T) (RETURN)) (T (SETQ BEGPTR (ADD1 CHPTR)) (SETQ ENDPTR))) (SETQ CHPTR (ADD1 CHPTR)) (GO CHLP))) (SETQ CHARSWID (PLUS CHARSWID (CHARWIDTH CHCODE FONT))) (SETQ CHPTR (ADD1 CHPTR)) (SETQ PREVCHARCR NIL) (GO CHLP))) (RETURN (for LINE in [REVERSE (COND (THISLINE (CONS THISLINE NEWLST)) (NEWLST (COND (PREVCHARCR (* if end of last line was a CR, put an empty line in so cursor shows there.) (CONS "" NEWLST)) (T NEWLST))) (T (LIST ""] collect (APPLY (FUNCTION CONCAT) (REVERSE LINE] (T (* if there isn't any font, it is probably SHADE.  Just leave the strings alone) STRLST]) (SK.BRUSH.SIZE [LAMBDA (SKBRUSH) (* rrb "30-Dec-84 13:38") (* returns the size of a brush. This is used in places where the brush can be  either an instance of the record BRUSH or a thickness.) (COND ((NUMBERP SKBRUSH)) (T (fetch (BRUSH BRUSHSIZE) of SKBRUSH]) (SK.TEXTBOX.CREATE [LAMBDA (SKETCHREGION BRUSH SCALE WINDOW) (* rrb "16-Oct-85 17:59") (* * creates a sketch element from a region) (PROG [(CONTEXT (WINDOWPROP WINDOW 'SKETCHCONTEXT] (RETURN (SK.TEXTBOX.CREATE1 SKETCHREGION BRUSH (LIST "") SCALE (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of CONTEXT) (fetch (SKETCHCONTEXT SKETCHFONT) of CONTEXT) (fetch (SKETCHCONTEXT SKETCHDASHING) of CONTEXT) (fetch (SKETCHCONTEXT SKETCHFILLING) of CONTEXT) (fetch (BRUSH BRUSHCOLOR) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of CONTEXT]) (SK.TEXTBOX.CREATE1 [LAMBDA (SKETCHREGION BRUSH LSTOFSTRS INITSCALE STYLE INITFONT DASHING FILLING TEXTCOLOR) (* rrb " 4-Dec-85 20:45") (SK.UPDATE.TEXTBOX.AFTER.CHANGE (create GLOBALPART INDIVIDUALGLOBALPART _ (create TEXTBOX TEXTBOXREGION _ SKETCHREGION LISTOFCHARACTERS _ LSTOFSTRS INITIALSCALE _ INITSCALE TEXTSTYLE _ STYLE FONT _ INITFONT TEXTCOLOR _ TEXTCOLOR TEXTBOXBRUSH _ BRUSH TEXTBOXDASHING _ DASHING TEXTBOXFILLING _ FILLING]) (SK.UPDATE.TEXTBOX.AFTER.CHANGE [LAMBDA (GTEXTBOXELT) (* rrb " 4-Dec-85 21:51") (* updates the dependent fields in a textbox element that has had its text  field changed.) (PROG ((INDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT))) (TEXTBOX.SET.GLOBAL.REGIONS INDELT) (BOX.SET.SCALES (fetch (TEXTBOX TEXTBOXREGION) of INDELT) GTEXTBOXELT) (RETURN GTEXTBOXELT]) (SK.TEXTBOX.POSITION.IN.BOX [LAMBDA (REGION STYLE FONT BRUSHWIDTH) (* rrb "31-Jul-86 15:43") (* returns the position that the text should be put at to have it look right  within box REGION, sytle STYLE in font FONT) (create POSITION XCOORD _ (SELECTQ (CAR STYLE) (LEFT (PLUS (fetch (REGION LEFT) of REGION) BRUSHWIDTH)) (RIGHT (DIFFERENCE (fetch (REGION RIGHT) of REGION) BRUSHWIDTH)) (CENTER (PLUS (fetch (REGION LEFT) of REGION) (QUOTIENT (fetch (REGION WIDTH) of REGION) 2.0))) (SHOULDNT)) YCOORD _ (SELECTQ (CADR STYLE) (TOP (DIFFERENCE (fetch (REGION TOP) of REGION) BRUSHWIDTH)) (BOTTOM (PLUS (fetch (REGION BOTTOM) of REGION) BRUSHWIDTH)) (CENTER (PLUS (fetch (REGION BOTTOM) of REGION) (QUOTIENT (fetch (REGION HEIGHT) of REGION) 2.0))) (BASELINE [PLUS (fetch (REGION BOTTOM) of REGION) (PLUS (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of REGION) (FONTPROP FONT 'HEIGHT)) 2.0) (FONTPROP FONT 'DESCENT]) (SHOULDNT]) (TEXTBOX.CHANGEFN [LAMBDA (SCRNELTS SKW HOW) (* rrb " 6-Jan-85 19:03") (* the users has selected SCRNELT to  be changed) (SELECTQ (CAR HOW) (TEXT (TEXT.CHANGEFN SCRNELTS SKW HOW)) (SIZE (CHANGE.ELTS.BRUSH.SIZE (CADR HOW) SCRNELTS SKW)) NIL]) (TEXTBOX.DRAWFN [LAMBDA (TEXTBOXELT WINDOW WINREG OPERATION) (* rrb " 3-Mar-86 21:38") (* draws a text box element.) (PROG ((LOCALPART (fetch (SCREENELT LOCALPART) of TEXTBOXELT)) FILLING BRUSH ELTOPERATION) (OR (NULL WINREG) (REGIONSINTERSECTP WINREG (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART)) (RETURN)) (SETQ BRUSH (fetch (LOCALTEXTBOX LOCALTEXTBOXBRUSH) of LOCALPART)) (SETQ FILLING (fetch (LOCALTEXTBOX LOCALTEXTBOXFILLING) of LOCALPART)) (SETQ ELTOPERATION (fetch (SKFILLING FILLING.OPERATION) of FILLING)) (* just put texture where there won't  be any text.) (SK.TEXTURE.AROUND.REGIONS (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART) (fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART) (fetch (SKFILLING FILLING.TEXTURE) of FILLING) WINDOW (fetch (SKFILLING FILLING.COLOR) of FILLING) ELTOPERATION (fetch (BRUSH BRUSHSIZE) of BRUSH)) (BOX.DRAWFN1 (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART) (fetch (BRUSH BRUSHSIZE) of BRUSH) WINDOW WINREG ELTOPERATION (fetch (LOCALTEXTBOX LOCALTEXTBOXDASHING) of LOCALPART) NIL (fetch (BRUSH BRUSHCOLOR) of BRUSH)) (TEXT.DRAWFN1 (fetch (LOCALTEXTBOX LOCALLISTOFCHARACTERS) of LOCALPART) (fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART) (fetch (LOCALTEXTBOX LOCALFONT) of LOCALPART) (fetch (BRUSH BRUSHCOLOR) of BRUSH) WINDOW ELTOPERATION]) (SK.TEXTURE.AROUND.REGIONS [LAMBDA (BOXREGION INREGIONS TEXTURE STREAM COLOR OPERATION BRUSHSIZE) (* ; "Edited 29-Sep-92 23:18 by jds") (* ;; "puts texture inside of a box but not in a collection of interior regions. Assumes INREGIONS are in order from top to bottom and abut in the Y direction.") (* ;; " JDS 9/29/92 -- CHANGED TO AVOID DOING THIS WHEN TEXTURE IS NIL, THE MOST COMMON CASE IN TEXTBOXES. This speeds up PostScript printing something fierce.") (AND TEXTURE (PROG (BOXLEFT BOXRIGHT BOXTOP BOXBOTTOM X Y (MARGIN (TIMES 2 (DSPSCALE NIL STREAM)) ) (USEOP (SK.TRANSLATE.MODE OPERATION STREAM))) [SETQ BOXLEFT (PLUS (fetch (REGION LEFT) of BOXREGION) (ADD1 (IQUOTIENT BRUSHSIZE 2] [SETQ BOXBOTTOM (PLUS (fetch (REGION BOTTOM) of BOXREGION) (ADD1 (IQUOTIENT BRUSHSIZE 2] (SETQ BOXTOP (DIFFERENCE (fetch (REGION TOP) of BOXREGION) (IQUOTIENT (ADD1 BRUSHSIZE) 2))) (SETQ BOXRIGHT (DIFFERENCE (fetch (REGION RIGHT) of BOXREGION) (IQUOTIENT (ADD1 BRUSHSIZE) 2))) (COND ((OR (NULL INREGIONS) (ALL.EMPTY.REGIONS INREGIONS)) (DSPFILL (CREATEREGION BOXLEFT BOXBOTTOM (ADD1 (DIFFERENCE BOXRIGHT BOXLEFT)) (ADD1 (DIFFERENCE BOXTOP BOXBOTTOM))) TEXTURE USEOP STREAM) (RETURN))) (COND ([GREATERP BOXTOP (SETQ X (fetch (REGION TOP) of (CAR INREGIONS] (* ;  "fill area above the first region") (BLTSHADE TEXTURE STREAM BOXLEFT (ADD1 X) (ADD1 (DIFFERENCE BOXRIGHT BOXLEFT)) (DIFFERENCE BOXTOP X) USEOP NIL COLOR))) [for LEAVEREGION in INREGIONS do (COND ((ZEROP (fetch (REGION WIDTH) of LEAVEREGION)) (* ;  "this line doesn't have any characters, just fill all the way across.") (BLTSHADE TEXTURE STREAM BOXLEFT (fetch (REGION BOTTOM) of LEAVEREGION) (ADD1 (DIFFERENCE BOXRIGHT BOXLEFT)) (fetch (REGION HEIGHT) of LEAVEREGION) USEOP NIL COLOR)) (T (* ;  "look for the part before and after the characters on this line.") (COND ((GREATERP (SETQ X (DIFFERENCE (fetch (REGION LEFT) of LEAVEREGION) MARGIN)) BOXLEFT) (* ;  "fill area to the left of this region") (BLTSHADE TEXTURE STREAM BOXLEFT (fetch (REGION BOTTOM ) of LEAVEREGION) (DIFFERENCE X BOXLEFT) (fetch (REGION HEIGHT) of LEAVEREGION) USEOP NIL COLOR))) (COND ((GREATERP BOXRIGHT (SETQ X (PLUS (fetch (REGION RIGHT) of LEAVEREGION) MARGIN))) (* ;  "fill area to the right of this region") (BLTSHADE TEXTURE STREAM (ADD1 X) (fetch (REGION BOTTOM) of LEAVEREGION) (DIFFERENCE BOXRIGHT X) (fetch (REGION HEIGHT) of LEAVEREGION) USEOP NIL COLOR] (COND ((GREATERP [SETQ X (fetch (REGION BOTTOM) of (CAR (LAST INREGIONS] BOXBOTTOM) (* ; "fill area below the last region") (BLTSHADE TEXTURE STREAM BOXLEFT BOXBOTTOM (ADD1 (DIFFERENCE BOXRIGHT BOXLEFT)) (DIFFERENCE X BOXBOTTOM) USEOP NIL COLOR]) (ALL.EMPTY.REGIONS [LAMBDA (REGIONLST) (* rrb " 3-Mar-86 20:42") (* returns T if REGIONLST contains  nothing but empty regions.) (for REG in REGIONLST always (OR (ZEROP (fetch (REGION WIDTH) of REG)) (ZEROP (fetch (REGION HEIGHT) of REG]) (TEXTBOX.EXPANDFN [LAMBDA (GTEXTBOXELT SCALE STREAM) (* rrb "30-Jul-86 15:23") (* creates a local textbox screen element from a global text box element) (PROG ((GTEXTBOX (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT)) (CANONICALTESTSTR "AWIaiw") LREG TEXTPOS LOCALFONT STYLE IMAGESTREAM LINEREGIONS BRUSHWIDTH NEWLISTOFSTRS LOCALBRUSH) (* calculate the local brush) (SETQ LOCALBRUSH (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ LOCALBRUSH (fetch (TEXTBOX TEXTBOXBRUSH ) of GTEXTBOX] (* new format, old format had brush  width only.) LOCALBRUSH) (T [replace (TEXTBOX TEXTBOXBRUSH) of GTEXTBOX with (SETQ LOCALBRUSH (create BRUSH BRUSHSIZE _ LOCALBRUSH BRUSHSHAPE _ 'ROUND] LOCALBRUSH)) (fetch (TEXTBOX INITIALSCALE) of GTEXTBOX) SCALE)) [COND ((TEXTUREP (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOX)) (* old format, update to new one which has a list of  (texture color)) (replace (TEXTBOX TEXTBOXFILLING) of GTEXTBOX with (create SKFILLING FILLING.TEXTURE _ (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOX) FILLING.COLOR _ NIL] (* calculate the local region for the  text box.) (SETQ BRUSHWIDTH (ADD1 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of LOCALBRUSH) 2))) (SETQ LREG (SK.SCALE.REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOX) SCALE)) (* calculate the local font.) (SETQ LOCALFONT (SK.CHOOSE.TEXT.FONT GTEXTBOX SCALE STREAM)) (* recalculate the line breaks for the particular stream given.  This is necessary because the difference between display and hardcopy must be  taken into account.) [SETQ IMAGESTREAM (COND ((STREAMP STREAM)) (T (WINDOWPROP STREAM 'DSP] [SETQ NEWLISTOFSTRS (COND [(FONTP LOCALFONT) (SK.BREAK.INTO.LINES (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOX) (COND ((IMAGESTREAMTYPEP IMAGESTREAM 'HARDCOPY) IMAGESTREAM) (T LOCALFONT)) (COND [(IMAGESTREAMTYPEP IMAGESTREAM 'HARDCOPY) (* do the split on the basis of the hardcopy font) (FIXR (TIMES (IDIFFERENCE (fetch (REGION WIDTH) of LREG) (ITIMES BRUSHWIDTH 2)) (PROGN (* the scale should be a parameter of the hardcopy font, maybe font widths  scale. but for now assume widths are in micas.) MICASPERPT] (T (IDIFFERENCE (fetch (REGION WIDTH) of LREG) (ITIMES BRUSHWIDTH 2] (T (* if not local font, leave line  breaks alone.) (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOX] (SETQ STYLE (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOX)) (SETQ LINEREGIONS (SK.TEXT.LINE.REGIONS (OR NEWLISTOFSTRS '("")) (SK.TEXTBOX.POSITION.IN.BOX LREG STYLE (OR LOCALFONT (fetch (TEXTBOX FONT) of GTEXTBOX)) BRUSHWIDTH) (fetch (TEXTBOX LISTOFREGIONS) of GTEXTBOX) LOCALFONT STYLE SCALE IMAGESTREAM)) (RETURN (create SCREENELT LOCALPART _ (create LOCALTEXTBOX TEXTBOXLL _ (create POSITION XCOORD _ (fetch (REGION LEFT) of LREG) YCOORD _ (fetch (REGION BOTTOM) of LREG)) TEXTBOXUR _ (create POSITION XCOORD _ (fetch (REGION PRIGHT) of LREG) YCOORD _ (fetch (REGION PTOP) of LREG)) LINEREGIONS _ LINEREGIONS LOCALFONT _ LOCALFONT LOCALTEXTBOXREGION _ LREG LOCALLISTOFCHARACTERS _ NEWLISTOFSTRS LOCALTEXTBOXBRUSH _ LOCALBRUSH LOCALTEXTBOXFILLING _ (APPEND (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOX)) LOCALTEXTBOXDASHING _ (fetch (TEXTBOX TEXTBOXDASHING) of GTEXTBOX)) GLOBALPART _ GTEXTBOXELT]) (TEXTBOX.INPUTFN [LAMBDA (W LREGION) (* rrb "11-Jul-86 15:48") (* creates a box element for a sketch window.  Prompts the user for one if none is given.) (PROG (LOCALREG) (COND ((REGIONP LREGION) (SETQ LOCALREG LREGION)) [(NULL LREGION) (COND [[SETQ LOCALREG (CAR (ERSETQ (GETWREGION W (FUNCTION SK.BOX.GETREGIONFN) W] (* WINDOWPROP will get exterior of window which should really be reduced to the  interior.) (* make sure the last selected point  wasn't outside.) (COND ((OR (NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W) LOCALREG)) (AND (EQ (fetch (REGION WIDTH) of LOCALREG) 0) (EQ (fetch (REGION HEIGHT) of LOCALREG) 0))) (RETURN] (T (RETURN] (T (\ILLEGAL.ARG LREGION))) (RETURN (SK.TEXTBOX.CREATE (UNSCALE.REGION.TO.GRID LOCALREG (VIEWER.SCALE W)) (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT)) (SK.INPUT.SCALE W) W]) (TEXTBOX.INSIDEFN [LAMBDA (GTEXTBOX WREG) (* rrb "30-Dec-84 17:23") (* determines if the global TEXTBOX GTEXTBOX is inside of WREG.) (REGIONSINTERSECTP (fetch (TEXTBOX TEXTBOXREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOX)) WREG]) (TEXTBOX.REGIONFN [LAMBDA (TEXTBOXSCRELT) (* rrb " 3-May-85 16:47") (* returns the region occuppied by a  box.) (* is increased by the brush size This has the nice property of insuring that  the region always has both height and width.) (INCREASEREGION (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of (fetch (SCREENELT LOCALPART) of TEXTBOXSCRELT)) (SK.BRUSH.SIZE (fetch (TEXTBOX TEXTBOXBRUSH) of (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTBOXSCRELT]) (TEXTBOX.GLOBALREGIONFN [LAMBDA (GTEXTBOXELT) (* rrb "18-Oct-85 17:11") (* returns the global region occupied by a global textbox element.) (fetch (TEXTBOX TEXTBOXREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT]) (TEXTBOX.SET.GLOBAL.REGIONS [LAMBDA (GTEXTBOXELT) (* rrb "30-Jul-86 14:48") (* updates the list of characters and list of regions occupied by the textbox  in the global coordinate space.) (* this is used to determine the extent of a text element in a region.) (PROG [(SCALE (fetch (TEXTBOX INITIALSCALE) of GTEXTBOXELT)) (FONT (fetch (TEXTBOX FONT) of GTEXTBOXELT)) (LISTOFSTRS (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOXELT)) (TEXTSTYLE (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOXELT)) (REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT)) (BRUSHWIDTH (SK.BRUSH.SIZE (fetch (TEXTBOX TEXTBOXBRUSH) of GTEXTBOXELT] (replace (TEXTBOX LISTOFREGIONS) of GTEXTBOXELT with (for LREG in (LTEXT.LINE.REGIONS LISTOFSTRS (SK.TEXTBOX.POSITION.IN.BOX REGION TEXTSTYLE FONT BRUSHWIDTH) FONT TEXTSTYLE (ITIMES (FONTHEIGHT FONT) (LENGTH LISTOFSTRS))) collect LREG)) (RETURN GTEXTBOXELT]) (TEXTBOX.TRANSLATEFN [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:46") (* * returns a textbox element which has been translated by DELTAPOS) (PROG ((GTEXTBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT)) OLDREG NEWREG) (SETQ NEWREG (REL.MOVE.REGION (SETQ OLDREG (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT)) (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS))) (RETURN (TEXT.UPDATE.GLOBAL.REGIONS (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART ) of SKELT)) INDIVIDUALGLOBALPART _ (create TEXTBOX using GTEXTBOXELT TEXTBOXREGION _ NEWREG)) (create POSITION XCOORD _ (fetch (REGION LEFT) of NEWREG) YCOORD _ (fetch (REGION BOTTOM) of NEWREG)) (create POSITION XCOORD _ (fetch (REGION LEFT) of OLDREG) YCOORD _ (fetch (REGION BOTTOM) of OLDREG]) (TEXTBOX.TRANSLATEPTSFN [LAMBDA (TEXTBOXELT SELPTS GDELTA WINDOW) (* rrb "16-Oct-85 17:59") (* returns a closed wire element which has the knots that are members of SELPTS  translated by the global amount GDELTA.) (PROG ((GTEXTBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTBOXELT)) OLDGLOBALREGION LLX LLY URX URY) (SETQ OLDGLOBALREGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT)) [COND [(MEMBER (fetch (LOCALTEXTBOX TEXTBOXLL) of (fetch (SCREENELT LOCALPART) of TEXTBOXELT)) SELPTS) (* lower left point is moving.) (SETQ LLX (PLUS (fetch (REGION LEFT) of OLDGLOBALREGION) (fetch (POSITION XCOORD) of GDELTA))) (SETQ LLY (PLUS (fetch (REGION BOTTOM) of OLDGLOBALREGION) (fetch (POSITION YCOORD) of GDELTA] (T (SETQ LLX (fetch (REGION LEFT) of OLDGLOBALREGION)) (SETQ LLY (fetch (REGION BOTTOM) of OLDGLOBALREGION] [COND [(MEMBER (fetch (LOCALTEXTBOX TEXTBOXUR) of (fetch (SCREENELT LOCALPART) of TEXTBOXELT)) SELPTS) (* upper right point) (SETQ URX (PLUS (fetch (REGION PRIGHT) of OLDGLOBALREGION) (fetch (POSITION XCOORD) of GDELTA))) (SETQ URY (PLUS (fetch (REGION PTOP) of OLDGLOBALREGION) (fetch (POSITION YCOORD) of GDELTA] (T (SETQ URX (fetch (REGION PRIGHT) of OLDGLOBALREGION)) (SETQ URY (fetch (REGION PTOP) of OLDGLOBALREGION] (RETURN (SK.TEXTBOX.CREATE1 (CREATEREGION (MIN LLX URX) (MIN LLY URY) (ABS (DIFFERENCE LLX URX)) (ABS (DIFFERENCE LLY URY))) (fetch (TEXTBOX TEXTBOXBRUSH) of GTEXTBOXELT) (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOXELT) (fetch (TEXTBOX INITIALSCALE) of GTEXTBOXELT) (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOXELT) (fetch (TEXTBOX FONT) of GTEXTBOXELT) (fetch (TEXTBOX TEXTBOXDASHING) of GTEXTBOXELT) (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOXELT) (fetch (TEXTBOX TEXTCOLOR) of GTEXTBOXELT]) (TEXTBOX.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "16-Oct-85 17:59") (* returns a copy of the global TEXTBOX element that has had each of its  control points transformed by transformfn.  TRANSFORMDATA is arbitrary data that is passed to tranformfn.  SCALEFACTOR is how much the transformation scales the figure and is used to  determine the size of the font.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (* transform the font by changing the scale according to how much the width of  the box around the first line of text changes from the transformation.) (RETURN (SK.TEXTBOX.CREATE1 (SK.TRANSFORM.REGION (fetch (TEXTBOX TEXTBOXREGION) of INDVPART) TRANSFORMFN TRANSFORMDATA) (fetch (TEXTBOX TEXTBOXBRUSH) of INDVPART) (fetch (TEXTBOX LISTOFCHARACTERS) of INDVPART) (FTIMES (fetch (TEXTBOX INITIALSCALE) of INDVPART) SCALEFACTOR) (fetch (TEXTBOX TEXTSTYLE) of INDVPART) (fetch (TEXTBOX FONT) of INDVPART) (fetch (TEXTBOX TEXTBOXDASHING) of INDVPART) (fetch (TEXTBOX TEXTBOXFILLING) of INDVPART) (fetch (TEXTBOX TEXTCOLOR) of INDVPART]) (TEXTBOX.UPDATEFN [LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb " 5-Dec-85 18:02") (* update function for text inside of textboxes.  Tries to repaint only the lines of text that have changed.) (* takes advantage of the fact that all relevant text fields are in the same  place in TEXT and TEXTBOX records.) (* if the box size has changed, reprint the whole thing anyway.) (PROG ((NEWTB (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)) (OLDTB (fetch (SCREENELT INDIVIDUALGLOBALPART) of OLDLOCALELT)) (OLDLOCALTB (fetch (SCREENELT LOCALPART) of OLDLOCALELT))) (RETURN (COND ((AND (EQUAL (fetch (TEXTBOX TEXTBOXBRUSH) of NEWTB) (fetch (TEXTBOX TEXTBOXBRUSH) of OLDTB)) (EQUAL (fetch (TEXTBOX TEXTBOXDASHING) of NEWTB) (fetch (LOCALTEXTBOX LOCALTEXTBOXDASHING) of OLDLOCALTB)) (EQUAL (fetch (TEXTBOX TEXTBOXFILLING) of NEWTB) (fetch (LOCALTEXTBOX LOCALTEXTBOXFILLING) of OLDLOCALTB)) (EQUAL (fetch (TEXTBOX TEXTCOLOR) of NEWTB) (fetch (TEXTBOX TEXTCOLOR) of OLDTB))) (DSPOPERATION (PROG1 (DSPOPERATION 'REPLACE SKETCHW) (* change to replace mode to erase  background.) (SETQ NEWTB (TEXT.UPDATEFN OLDLOCALELT NEWGELT SKETCHW))) SKETCHW) NEWTB]) (TEXTBOX.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb " 5-Mar-86 13:33") (* reads how the user wants to change  a textbox.) (PROG ((COMMAND (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Change which part?" ITEMS _ [APPEND (COND [(SKETCHINCOLORP) '(("Outline color" 'BRUSHCOLOR "changes the color of the outline" ) ("Filling color" 'FILLINGCOLOR "changes the color of the filling" ] (T NIL)) '(("The text" 'TEXT "allows changing the properties of the text." ) ("Box thickness" 'SIZE "changes the size of the brush") (Dashing 'DASHING "changes the dashing of the box.") ("Unbox the text" '(TEXT UNBOX) "takes the text out of any selected text boxes." ) (Filling 'FILLING "allows changing of the filling texture of the box." )) (COND (FILLINGMODEFLG '(("Filling mode" 'FILLINGMODE "changes how the filling effects the figures it covers." ] CENTERFLG _ T))) HOW) (RETURN (SELECTQ COMMAND (TEXT (TEXT.READCHANGEFN SKW SCRNELTS T)) (COND ((LISTP COMMAND) COMMAND) ((SETQ HOW (SELECTQ COMMAND (FILLING (READ.FILLING.CHANGE)) (FILLINGMODE (READ.FILLING.MODE)) (SIZE (READSIZECHANGE "Change size how?" T)) (DASHING (READ.DASHING.CHANGE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS) ) 'BRUSH]) (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T (fetch (SKFILLING FILLING.COLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'FILLING]) COMMAND)) (LIST COMMAND HOW]) (SK.TEXTBOX.TEXT.POSITION [LAMBDA (GTEXTBOXELT) (* returns the position of the text in a text box element.) (create POSITION XCOORD _ (fetch (REGION LEFT) of (SETQ GTEXTBOXELT (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT))) YCOORD _ (fetch (REGION TOP) of GTEXTBOXELT]) (SK.TEXTBOX.FROM.TEXT [LAMBDA (TEXTELT SKW) (* rrb "30-Sep-86 18:34") (* returns a textbox that replaces  GTEXTELT.) (PROG ((INDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTELT)) BRUSH STYLE CONTEXT NEWTEXTBOXELT) [SETQ BRUSH (fetch (SKETCHCONTEXT SKETCHBRUSH) of (SETQ CONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT] (SETQ NEWTEXTBOXELT (SK.TEXTBOX.CREATE1 (INCREASEREGION (APPLY (FUNCTION SK.UNIONREGIONS) (fetch (TEXT LISTOFREGIONS) of INDTEXTELT)) (IQUOTIENT (ADD1 (SK.BRUSH.SIZE (fetch (BRUSH BRUSHSIZE) of BRUSH))) 2)) BRUSH (fetch (TEXT LISTOFCHARACTERS) of INDTEXTELT) (fetch (TEXT INITIALSCALE) of INDTEXTELT) (COND ((EQ (CADR (SETQ STYLE (fetch (TEXT TEXTSTYLE) of INDTEXTELT) )) 'BASELINE) (* change from baseline to center because this usually looks better.) (LIST (CAR STYLE) 'CENTER)) (T STYLE)) (fetch (TEXT FONT) of INDTEXTELT) (fetch (SKETCHCONTEXT SKETCHDASHING) of CONTEXT) (fetch (SKETCHCONTEXT SKETCHFILLING) of CONTEXT) (fetch (BRUSH BRUSHCOLOR) of BRUSH))) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ NEWTEXTBOXELT OLDELT _ TEXTELT PROPERTY _ 'HASBOX NEWVALUE _ NEWTEXTBOXELT OLDVALUE _ TEXTELT]) (ADD.EOLS [LAMBDA (STRLST) (* rrb "22-Jul-86 15:23") (* adds an eol to every string in STRLST that doesn't end in one.) (for STRTAIL on STRLST collect (COND ((EQ (CHARCODE EOL) (NTHCHARCODE (CAR STRTAIL) -1)) (CAR STRTAIL)) ((CDR STRTAIL) (* don't put a cr after the last line.) (CONCAT (CAR STRTAIL) " ")) (T (CAR STRTAIL]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALTEXTBOX ((TEXTBOXLL TEXTBOXUR) LOCALHOTREGION LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS LOCALTEXTBOXREGION LOCALTEXTBOXBRUSH LOCALTEXTBOXFILLING LOCALTEXTBOXDASHING)) (TYPERECORD TEXTBOX (TEXTBOXREGION LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS TEXTCOLOR TEXTBOXBRUSH TEXTBOXDASHING TEXTBOXFILLING)) ) ) (* ; "stuff to handle default alignment for text boxes") (DEFINEQ (SK.SET.TEXTBOX.VERT.ALIGN [LAMBDA (SKW) (* rrb " 6-Nov-85 09:52") (* * reads a new value for the vertical justification default for text boxes) (PROG ((NEWJUST (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "New vertical alignment?" ITEMS _ '(("Top" 'TOP "the top of new text's vertical extent will be at its position" ) ("Center" 'CENTER "New text's vertical extent will be centered around its position" ) ("Baseline" 'BASELINE "The baseline of new text will be at its position." ) ("Bottom" 'BOTTOM "the bottom of new text's vertical extent will be at its position" )) CENTERFLG _ T))) SKCONTEXT) (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) with (LIST (CAR (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of SKCONTEXT)) NEWJUST]) (SK.SET.TEXTBOX.HORIZ.ALIGN [LAMBDA (SKW NEWALIGN) (* rrb " 6-Nov-85 09:52") (* * reads a new value for the horizontal justification default for text boxes) (PROG ([NEWJUST (OR NEWALIGN (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ '((" Center " 'CENTER "New text will be centered around its position" ) ("Left " 'LEFT "the left edge of the text will be at its position." ) (" Right" 'RIGHT "the right edge of the text will be at its position." ] SKCONTEXT) (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) with (CONS NEWJUST (CDR (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of SKCONTEXT]) ) (RPAQQ TEXTBOXICON #*(36 12)OOOOOOOOO@@@OOOOOOOOO@@@L@@@@@@@C@@@ML@@@N@@C@@@LIMELIBEC@@@LIDHHOEBC@@@LILHHIEBC@@@LIADHIEEC@@@LIMDHNBEC@@@L@@@@@@@C@@@OOOOOOOOO@@@OOOOOOOOO@@@ ) (RPAQ? SK.DEFAULT.TEXTBOX.ALIGNMENT '(CENTER CENTER)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT) ) (* ; "functions to implement the box sketch element.") (DEFINEQ (SKETCH.CREATE.BOX [LAMBDA (REGION BRUSH DASHING FILLING SCALE) (* rrb "16-Oct-85 17:31") (* creates a sketch box element.) (SK.BOX.CREATE (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) (OR (NUMBERP SCALE) 1.0) (SK.INSURE.FILLING FILLING]) (SK.BOX.DRAWFN [LAMBDA (BOXELT WIN WINREG) (* rrb "21-Feb-86 11:36") (* draws a box from its sketch  element.) (PROG ((LOCALBOXELT (fetch (SCREENELT LOCALPART) of BOXELT)) FILLING BRUSH) (SETQ FILLING (fetch (LOCALBOX LOCALBOXFILLING) of LOCALBOXELT)) (RETURN (BOX.DRAWFN1 (fetch (LOCALBOX LOCALREGION) of LOCALBOXELT) (fetch (BRUSH BRUSHSIZE) of (SETQ BRUSH (fetch (LOCALBOX LOCALBOXBRUSH) of LOCALBOXELT))) WIN WINREG (fetch (SKFILLING FILLING.OPERATION) of FILLING) (fetch (LOCALBOX LOCALBOXDASHING) of LOCALBOXELT) (fetch (SKFILLING FILLING.TEXTURE) of FILLING) (fetch (BRUSH BRUSHCOLOR) of BRUSH) (fetch (SKFILLING FILLING.COLOR) of FILLING]) (BOX.DRAWFN1 [LAMBDA (REG SIZE WIN WINREG OPERATION DASHING TEXTURE OUTLINECOLOR FILLINGCOLOR) (* rrb " 5-Mar-86 14:27") (* draws a box. Used by both box and text box elements.) (COND ((OR (NULL WINREG) (REGIONSINTERSECTP WINREG REG)) (COND ((AND SKETCHINCOLORFLG (OR FILLINGCOLOR TEXTURE)) (* call the filling routine that does  color.) (FILLPOLYGON (KNOTS.OF.REGION REG SIZE) (create SKFILLING FILLING.TEXTURE _ TEXTURE FILLING.COLOR _ FILLINGCOLOR) WIN)) (TEXTURE (DSPFILL REG (COND ((EQ (DSPOPERATION NIL WIN) 'ERASE) (* use black in case the window moved because of texture to window alignment  bug.) BLACKSHADE) (T TEXTURE)) (SK.TRANSLATE.MODE OPERATION WIN) WIN)) (FILLINGCOLOR (* if no texture, use the color.) (DSPFILL REG (TEXTUREOFCOLOR FILLINGCOLOR) OPERATION WIN))) (* code to fix white space bug in Interpress.  It works but Masters are larger and the one I tried wouldn't print.  (SELECTQ (IMAGESTREAMTYPE WIN) ((NIL DISPLAY PRESS)  (* special case DISPLAY for speed and PRESS because rounded corners don't work  for large brushes.) (SK.DRAWAREABOX (fetch  (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG)  (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) SIZE OPERATION WIN  DASHING OUTLINECOLOR)) (PROG ((LFT (fetch  (REGION LEFT) of REG)) (BTM (fetch (REGION BOTTOM) of REG))  (TOP (fetch (REGION TOP) of REG)) (RGHT (fetch  (REGION RIGHT) of REG))) (DRAWCURVE (LIST  (CREATEPOSITION LFT BTM) (CREATEPOSITION LFT TOP)  (CREATEPOSITION RIGHT TOP) (CREATEPOSITION RIGHT BTM)) T  (create BRUSH BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ SIZE BRUSHCOLOR _  OUTLINECOLOR) DASHING WIN)))) (SK.DRAWAREABOX (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) SIZE (SK.TRANSLATE.MODE OPERATION WIN) WIN DASHING OUTLINECOLOR]) (KNOTS.OF.REGION [LAMBDA (REGION BORDER) (* rrb "18-Jul-85 09:49") (* returns the knots of the interior rectangle of a region.) (PROG (LFT BTM TP RGHT (HLFBORDER (FQUOTIENT BORDER 2.0))) (SETQ LFT (PLUS (fetch (REGION LEFT) of REGION) HLFBORDER)) (SETQ BTM (PLUS (fetch (REGION BOTTOM) of REGION) HLFBORDER)) (SETQ TP (DIFFERENCE (fetch (REGION TOP) of REGION) HLFBORDER)) (SETQ RGHT (DIFFERENCE (fetch (REGION RIGHT) of REGION) HLFBORDER)) (RETURN (LIST (create POSITION XCOORD _ LFT YCOORD _ BTM) (create POSITION XCOORD _ LFT YCOORD _ TP) (create POSITION XCOORD _ RGHT YCOORD _ TP) (create POSITION XCOORD _ RGHT YCOORD _ BTM]) (SK.DRAWAREABOX [LAMBDA (LEFT BOTTOM WIDTH HEIGHT BORDER OP W DASHING COLOR) (* rrb "16-Sep-86 16:12") (* draws lines along the region. Copied from the function DRAWAREABOX in  GRAPHER and changed to be the same as drawing lines between the corner points.) (COND [[OR DASHING (AND COLOR (NEQ COLOR 'BLACK] (* start a line at each corner so that the corners will have black on them.) (COND ((OR (IMAGESTREAMTYPEP W 'PRESS) (IMAGESTREAMTYPEP W 'INTERPRESS)) (* both these use BUTT, overlap the  lines) (PROG (BIG/HALF SM/HALF TOP RIGHT) (SETQ BIG/HALF (LRSH (ADD1 BORDER) 1)) (SETQ SM/HALF (DIFFERENCE BORDER BIG/HALF)) (SETQ TOP (PLUS BOTTOM HEIGHT)) (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) (DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF) LEFT (PLUS TOP BIG/HALF) BORDER OP W COLOR DASHING) (* draw top.) (DRAWLINE (IDIFFERENCE LEFT SM/HALF) TOP (IPLUS RIGHT BIG/HALF) TOP BORDER OP W COLOR DASHING) (* draw right edge) (DRAWLINE RIGHT (PLUS TOP BIG/HALF) RIGHT (DIFFERENCE BOTTOM SM/HALF) BORDER OP W COLOR DASHING) (* draw bottom) (DRAWLINE (IPLUS RIGHT BIG/HALF) BOTTOM (IDIFFERENCE LEFT SM/HALF) BOTTOM BORDER OP W COLOR DASHING))) (T (PROG (TOP RIGHT HALFBORDER) (SETQ TOP (PLUS BOTTOM HEIGHT)) (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) (DRAWLINE LEFT BOTTOM LEFT TOP BORDER OP W COLOR DASHING) (* draw top) (DRAWLINE LEFT TOP RIGHT TOP BORDER OP W COLOR DASHING) (* draw right edge) (DRAWLINE RIGHT TOP RIGHT BOTTOM BORDER OP W COLOR DASHING) (* draw bottom) (DRAWLINE RIGHT BOTTOM LEFT BOTTOM BORDER OP W COLOR DASHING] ((IMAGESTREAMTYPEP W 'PRESS) (* overlap the ends of the lines.) (PROG (BIG/HALF SM/HALF TOP HORIZLEFT HORIZRIGHT RIGHT) (SETQ BIG/HALF (LRSH (ADD1 BORDER) 1)) (SETQ SM/HALF (DIFFERENCE BORDER BIG/HALF)) (SETQ TOP (PLUS BOTTOM HEIGHT)) (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) (DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF) LEFT (PLUS TOP BIG/HALF) BORDER OP W COLOR DASHING) (* draw top.) (DRAWLINE (SETQ HORIZLEFT (IPLUS LEFT BIG/HALF)) TOP (SETQ HORIZRIGHT (SUB1 (IDIFFERENCE RIGHT SM/HALF))) TOP BORDER OP W COLOR DASHING) (* draw right edge) (DRAWLINE RIGHT (DIFFERENCE BOTTOM SM/HALF) RIGHT (PLUS TOP BIG/HALF) BORDER OP W COLOR DASHING) (* draw bottom) (DRAWLINE HORIZLEFT BOTTOM HORIZRIGHT BOTTOM BORDER OP W COLOR DASHING))) ((IMAGESTREAMTYPEP W 'INTERPRESS) (* kludge for interpress in koto because BLTSHADE rounds down so brushes of 1  don't show, Drawline is always BUTT and DRAWPOLYGON isn't implemented.) (PROG (BIG/HALF SM/HALF TOP HORIZLEFT HORIZRIGHT RIGHT) (SETQ BIG/HALF (LRSH (ADD1 BORDER) 1)) (SETQ SM/HALF (DIFFERENCE BORDER BIG/HALF)) (SETQ TOP (PLUS BOTTOM HEIGHT)) (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) (DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF) LEFT (PLUS TOP BIG/HALF) BORDER OP W COLOR DASHING) (* draw top. 9 is to fix an error on the 8044 which may be from rounding to its  pixel size.) (DRAWLINE (SETQ HORIZLEFT (DIFFERENCE (IPLUS LEFT BIG/HALF) 9)) TOP (SETQ HORIZRIGHT (SUB1 (IDIFFERENCE RIGHT SM/HALF))) TOP BORDER OP W COLOR DASHING) (* draw right edge) (DRAWLINE RIGHT (DIFFERENCE BOTTOM SM/HALF) RIGHT (PLUS TOP BIG/HALF) BORDER OP W COLOR DASHING) (* draw bottom) (DRAWLINE HORIZLEFT BOTTOM HORIZRIGHT BOTTOM BORDER OP W COLOR DASHING))) (T (* do other cases with bitblt) (PROG (BIG/HALF SM/HALF HORIZLEFT BOXBOTTOM SIDEWIDTH SIDEHEIGHT) (SETQ BIG/HALF (LRSH BORDER 1)) (SETQ SM/HALF (SUB1 (DIFFERENCE BORDER BIG/HALF))) (* draw left edge) (BLTSHADE BLACKSHADE W (DIFFERENCE LEFT SM/HALF) (SETQ BOXBOTTOM (DIFFERENCE BOTTOM SM/HALF)) BORDER (SETQ SIDEHEIGHT (PLUS HEIGHT BORDER)) OP) (* draw right edge) (BLTSHADE BLACKSHADE W (DIFFERENCE (PLUS LEFT WIDTH) SM/HALF) BOXBOTTOM BORDER SIDEHEIGHT OP) (* draw top) (BLTSHADE BLACKSHADE W (SETQ HORIZLEFT (ADD1 (PLUS LEFT BIG/HALF))) (DIFFERENCE (PLUS BOTTOM HEIGHT) SM/HALF) (SETQ SIDEWIDTH (DIFFERENCE WIDTH BORDER)) BORDER OP) (BLTSHADE BLACKSHADE W HORIZLEFT BOXBOTTOM SIDEWIDTH BORDER OP]) (SK.DRAWBOX [LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) (* rrb "14-Jul-86 13:51") (* draws lines inside the region.) (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* draw left edge) (BITBLT NIL NIL NIL W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT 'TEXTURE OP TEXTURE) (* draw top) (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) BORDER) (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER 'TEXTURE OP TEXTURE) (* draw bottom) (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) BOXBOTTOM (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER 'TEXTURE OP TEXTURE) (* draw right edge) (BITBLT NIL NIL NIL W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) BORDER) BOXBOTTOM BORDER BOXHEIGHT 'TEXTURE OP TEXTURE]) (SK.BOX.EXPANDFN [LAMBDA (GBOX SCALE) (* rrb "11-Jul-86 15:56") (* returns a local record which has the region field of the global element GELT  translated into window coordinats.) (* for now only allow to move the left-bottom or right-top corner.) (PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOX)) LREG) [COND ((fetch (BOX BOXINITSCALE) of INDGELT)) (T (* old format didn't have an initial scale, default it to 1.0) (replace (GLOBALPART INDIVIDUALGLOBALPART) of GBOX with (SETQ INDGELT (create BOX using INDGELT BOXINITSCALE _ 1.0] [COND ((TEXTUREP (fetch (BOX BOXFILLING) of INDGELT)) (* old format, update to new one which has a list of  (texture color)) (replace (BOX BOXFILLING) of INDGELT with (create SKFILLING FILLING.TEXTURE _ (fetch (BOX BOXFILLING ) of INDGELT) FILLING.COLOR _ NIL] (SETQ LREG (SK.SCALE.REGION (fetch (BOX GLOBALREGION) of INDGELT) SCALE)) (RETURN (create SCREENELT LOCALPART _ (create LOCALBOX BOXLL _ (create POSITION XCOORD _ (fetch (REGION LEFT) of LREG) YCOORD _ (fetch (REGION BOTTOM) of LREG)) BOXUR _ (create POSITION XCOORD _ (fetch (REGION PRIGHT) of LREG) YCOORD _ (fetch (REGION PTOP) of LREG)) LOCALREGION _ LREG LOCALBOXBRUSH _ (SCALE.BRUSH (COND ([NOT (NUMBERP (SETQ LREG (fetch (BOX BRUSH) of INDGELT] (* new format, old format had brush  width only.) LREG) (T [replace (BOX BRUSH) of INDGELT with (SETQ LREG (create BRUSH BRUSHSIZE _ LREG BRUSHSHAPE _ 'ROUND] LREG)) (fetch (BOX BOXINITSCALE) of INDGELT) SCALE) LOCALBOXFILLING _ (APPEND (fetch (BOX BOXFILLING) of INDGELT)) LOCALBOXDASHING _ (fetch (BOX BOXDASHING) of INDGELT)) GLOBALPART _ GBOX]) (SK.BOX.GETREGIONFN [LAMBDA (FIXPT MOVINGPT W) (* rrb "12-May-86 18:38") (* getregion fn that generates an error if a point is clicked outside of  window. Also puts things on the window grid.) (SKETCHW.UPDATE.LOCATORS W) (COND [MOVINGPT (* this test the fixed pt every time which is unnecessary but does allow us to  catch button down.) (PROG [(REG (WINDOWPROP W 'REGION] (RETURN (COND ((INSIDEP REG FIXPT) (COND ((INSIDEP REG MOVINGPT) (MAP.SCREEN.POSITION.ONTO.GRID MOVINGPT W (LASTMOUSESTATE MIDDLE) )) (T (* if the cursor is outside, return the fixed point so the feedback box  disappears.) FIXPT))) (T (ERROR!] (T (MAP.SCREEN.POSITION.ONTO.GRID FIXPT W (LASTMOUSESTATE RIGHT]) (BOX.SET.SCALES [LAMBDA (GREG GBOXELT) (* rrb " 7-Feb-85 12:30") (* updates the scale field after a change in the region of a box element.) (* removed the part of the scale that was limiting it to defaults.  If it has to go back in, please leave a note as to why.) (PROG (WIDTH HEIGHT) (replace (GLOBALPART MINSCALE) of GBOXELT with (FQUOTIENT (MIN (SETQ WIDTH (fetch (REGION WIDTH) of GREG)) (SETQ HEIGHT (fetch (REGION HEIGHT) of GREG))) 1000.0)) (replace (GLOBALPART MAXSCALE) of GBOXELT with (FQUOTIENT (MAX WIDTH HEIGHT) 2.0)) (RETURN GBOXELT]) (SK.BOX.INPUTFN [LAMBDA (W LREGION) (* rrb "11-Jul-86 15:48") (* creates a box element for a sketch window.  Prompts the user for one if none is given.) (PROG (LOCALREG SKCONTEXT) (COND ((REGIONP LREGION) (SETQ LOCALREG LREGION)) [(NULL LREGION) (COND [[SETQ LOCALREG (CAR (ERSETQ (GETWREGION W (FUNCTION SK.BOX.GETREGIONFN) W] (* WINDOWPROP will get exterior of window which should really be reduced to the  interior.) (* make sure the last selected point  wasn't outside.) (COND ((OR (NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W) LOCALREG)) (AND (EQ (fetch (REGION WIDTH) of LOCALREG) 0) (EQ (fetch (REGION HEIGHT) of LOCALREG) 0))) (RETURN] (T (RETURN] (T (\ILLEGAL.ARG LREGION))) (RETURN (SK.BOX.CREATE (UNSCALE.REGION.TO.GRID LOCALREG (VIEWER.SCALE W)) [fetch (SKETCHCONTEXT SKETCHBRUSH) of (SETQ SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT] (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT) (SK.INPUT.SCALE W) (fetch (SKETCHCONTEXT SKETCHFILLING) of SKCONTEXT]) (SK.BOX.CREATE [LAMBDA (SKETCHREGION BRUSH DASHING INITSCALE FILLING) (* rrb "12-Dec-85 14:33") (* * creates a sketch element from a region) (SK.UPDATE.BOX.AFTER.CHANGE (create GLOBALPART INDIVIDUALGLOBALPART _ (create BOX GLOBALREGION _ SKETCHREGION BRUSH _ BRUSH BOXDASHING _ DASHING BOXINITSCALE _ INITSCALE BOXFILLING _ FILLING]) (SK.UPDATE.BOX.AFTER.CHANGE [LAMBDA (GBOXELT) (* rrb "12-Dec-85 14:33") (* changes dependent fields after a  box element changes.) (BOX.SET.SCALES (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOXELT)) GBOXELT]) (SK.BOX.INSIDEFN [LAMBDA (GBOX WREG) (* rrb " 5-AUG-83 16:04") (* determines if the global BOX GBOX is inside of WREG.) (REGIONSINTERSECTP (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOX)) WREG]) (SK.BOX.REGIONFN [LAMBDA (BOXSCRLET) (* rrb " 7-Dec-85 19:41") (* returns the region occupied by a  box.) (INCREASEREGION (fetch (LOCALBOX LOCALREGION) of (fetch (SCREENELT LOCALPART) of BOXSCRLET)) (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALBOX LOCALBOXBRUSH) of (fetch (SCREENELT LOCALPART ) of BOXSCRLET]) (SK.BOX.GLOBALREGIONFN [LAMBDA (GBOXELT) (* ; "Edited 20-Feb-87 16:20 by rrb") (* returns the global region occupied by a global box element.) (INCREASEREGION (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOXELT)) (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (BOX BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GBOXELT))) 2]) (SK.BOX.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb " 5-Mar-86 13:35") (* the users has selected SCRNELT to be changed this function reads a  specification of how the box elements should change.) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Which aspect?" ITEMS _ (APPEND (COND [(SKETCHINCOLORP) '(("Outline color" 'BRUSHCOLOR "changes the color of the outline" ) ("Filling color" 'FILLINGCOLOR "changes the color of the filling" ] (T NIL)) [COND (FILLINGMODEFLG '(("Filling mode" 'FILLINGMODE "changes how the filling effects the figures it covers." ] '((Filling 'FILLING "allows changing of the filling texture of the box." ) ("Outline size" 'SIZE "changes the size of the brush") ("Outline dashing" 'DASHING "changes the dashing of the line."] (SIZE (READSIZECHANGE "Change size how?" T)) (FILLING (READ.FILLING.CHANGE)) (FILLINGMODE (READ.FILLING.MODE)) (DASHING (READ.DASHING.CHANGE)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'BRUSH]) (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T (fetch (SKFILLING FILLING.COLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART ) of (CAR SCRNELTS)) 'FILLING]) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) (SK.CHANGE.FILLING [LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 9-Jan-86 16:57") (* changes the texture in the element  ELTWITHFILLING.) (PROG (GFILLEDELT TEXTURE OLDFILLING NEWFILLING TYPE NEWELT) (AND (EQ HOW 'NONE) (SETQ HOW NIL)) (RETURN (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING)) '(BOX TEXTBOX CLOSEDWIRE CIRCLE)) (* only works for things that have a filling, for now just boxes and polygons) (SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING)) [SETQ TEXTURE (fetch (SKFILLING FILLING.TEXTURE) of (SETQ OLDFILLING (SELECTQ TYPE (BOX (fetch (BOX BOXFILLING) of GFILLEDELT)) (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) of GFILLEDELT)) (CLOSEDWIRE (fetch (CLOSEDWIRE CLOSEDWIREFILLING ) of GFILLEDELT)) (CIRCLE (fetch (CIRCLE CIRCLEFILLING) of GFILLEDELT)) (SHOULDNT] (COND ((NOT (EQUAL HOW TEXTURE)) (* new filling) (SETQ NEWFILLING (create SKFILLING using OLDFILLING FILLING.TEXTURE _ HOW)) (SETQ NEWELT (SELECTQ TYPE (BOX (create BOX using GFILLEDELT BOXFILLING _ NEWFILLING)) (TEXTBOX (create TEXTBOX using GFILLEDELT TEXTBOXFILLING _ NEWFILLING)) (CLOSEDWIRE (create CLOSEDWIRE using GFILLEDELT CLOSEDWIREFILLING _ NEWFILLING)) (CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING _ NEWFILLING)) (SHOULDNT))) (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHFILLING) INDIVIDUALGLOBALPART _ NEWELT) OLDELT _ ELTWITHFILLING PROPERTY _ 'FILLING NEWVALUE _ NEWFILLING OLDVALUE _ OLDFILLING]) (SK.CHANGE.FILLING.COLOR [LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 9-Jan-86 19:42") (* changes the texture in the element  ELTWITHFILLING.) (PROG (GFILLEDELT COLOR FILLING NEWFILLING TYPE NEWELT) (AND (EQ HOW 'NONE) (SETQ HOW NIL)) (RETURN (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING)) '(BOX TEXTBOX CLOSEDWIRE CIRCLE)) (* only works for things that have a filling, for now just boxes and polygons) (SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING)) [SETQ COLOR (fetch (SKFILLING FILLING.COLOR) of (SETQ FILLING (SELECTQ TYPE (BOX (fetch (BOX BOXFILLING) of GFILLEDELT)) (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) of GFILLEDELT)) (CIRCLE (fetch (CIRCLE CIRCLEFILLING) of GFILLEDELT)) (CLOSEDWIRE (fetch (CLOSEDWIRE CLOSEDWIREFILLING ) of GFILLEDELT)) (SHOULDNT] (COND ((NOT (EQUAL HOW COLOR)) (* new filling) (SETQ NEWFILLING (create SKFILLING using FILLING FILLING.COLOR _ HOW)) (SETQ NEWELT (SELECTQ TYPE (BOX (create BOX using GFILLEDELT BOXFILLING _ NEWFILLING)) (TEXTBOX (create TEXTBOX using GFILLEDELT TEXTBOXFILLING _ NEWFILLING)) (CLOSEDWIRE (create CLOSEDWIRE using GFILLEDELT CLOSEDWIREFILLING _ NEWFILLING)) (CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING _ NEWFILLING)) (SHOULDNT))) (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHFILLING) INDIVIDUALGLOBALPART _ NEWELT) OLDELT _ ELTWITHFILLING PROPERTY _ 'FILLING NEWVALUE _ NEWFILLING OLDVALUE _ FILLING]) (SK.BOX.TRANSLATEFN [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:46") (* * returns a curve element which has the box translated by DELTAPOS) (PROG ((GBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT))) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) INDIVIDUALGLOBALPART _ (create BOX using GBOXELT GLOBALREGION _ (REL.MOVE.REGION (fetch (BOX GLOBALREGION) of GBOXELT) (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS]) (SK.BOX.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "12-Jul-85 17:16") (* returns a copy of the global BOX element that has had each of its control  points transformed by transformfn. TRANSFORMDATA is arbitrary data that is  passed to tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (SK.BOX.CREATE (SK.TRANSFORM.REGION (fetch (BOX GLOBALREGION) of INDVPART) TRANSFORMFN TRANSFORMDATA) (SK.TRANSFORM.BRUSH (fetch (BOX BRUSH) of INDVPART) SCALEFACTOR) (fetch (BOX BOXDASHING) of INDVPART) (fetch (BOX BOXINITSCALE) of INDVPART) (fetch (BOX BOXFILLING) of INDVPART]) (SK.BOX.TRANSLATEPTSFN [LAMBDA (BOXELT SELPTS GDELTA WINDOW) (* rrb "12-Jul-85 17:55") (* returns a closed wire element which has the knots that are members of SELPTS  translated by the global amount GDELTA.) (PROG ((GBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of BOXELT)) OLDGLOBALREGION LLX LLY URX URY) (SETQ OLDGLOBALREGION (fetch (BOX GLOBALREGION) of GBOXELT)) [COND [(MEMBER (fetch (LOCALBOX BOXLL) of (fetch (SCREENELT LOCALPART) of BOXELT)) SELPTS) (* lower left point is moving.) (SETQ LLX (PLUS (fetch (REGION LEFT) of OLDGLOBALREGION) (fetch (POSITION XCOORD) of GDELTA))) (SETQ LLY (PLUS (fetch (REGION BOTTOM) of OLDGLOBALREGION) (fetch (POSITION YCOORD) of GDELTA] (T (SETQ LLX (fetch (REGION LEFT) of OLDGLOBALREGION)) (SETQ LLY (fetch (REGION BOTTOM) of OLDGLOBALREGION] [COND [(MEMBER (fetch (LOCALBOX BOXUR) of (fetch (SCREENELT LOCALPART) of BOXELT)) SELPTS) (* upper right point) (SETQ URX (PLUS (fetch (REGION PRIGHT) of OLDGLOBALREGION) (fetch (POSITION XCOORD) of GDELTA))) (SETQ URY (PLUS (fetch (REGION PTOP) of OLDGLOBALREGION) (fetch (POSITION YCOORD) of GDELTA] (T (SETQ URX (fetch (REGION PRIGHT) of OLDGLOBALREGION)) (SETQ URY (fetch (REGION PTOP) of OLDGLOBALREGION] (RETURN (SK.BOX.CREATE (CREATEREGION (MIN LLX URX) (MIN LLY URY) (ABS (DIFFERENCE LLX URX)) (ABS (DIFFERENCE LLY URY))) (fetch (BOX BRUSH) of GBOXELT) (fetch (BOX BOXDASHING) of GBOXELT) (fetch (BOX BOXINITSCALE) of GBOXELT) (fetch (BOX BOXFILLING) of GBOXELT]) (UNSCALE.REGION.TO.GRID [LAMBDA (REGION SCALE GRIDSIZE) (* rrb "25-Oct-84 12:53") (* scales a region from a window region to the larger coordinate space.) (PROG [(LFT (TIMES SCALE (fetch (REGION LEFT) of REGION))) (BTM (TIMES SCALE (fetch (REGION BOTTOM) of REGION))) (WDTH (TIMES SCALE (fetch (REGION WIDTH) of REGION))) (HGHT (TIMES SCALE (fetch (REGION HEIGHT) of REGION] [COND (GRIDSIZE (* move X and Y to nearest point on the grid) (SETQ LFT (NEAREST.ON.GRID LFT GRIDSIZE)) (SETQ BTM (NEAREST.ON.GRID BTM GRIDSIZE)) (SETQ WDTH (NEAREST.ON.GRID WDTH GRIDSIZE)) (SETQ HGHT (NEAREST.ON.GRID HGHT GRIDSIZE] (RETURN (CREATEREGION LFT BTM WDTH HGHT]) (INCREASEREGION [LAMBDA (REGION BYAMOUNT) (* rrb " 9-Sep-84 19:58") (* * increases a region by a fixed amount in all directions.) (CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of REGION) BYAMOUNT) (DIFFERENCE (fetch (REGION BOTTOM) of REGION) BYAMOUNT) (PLUS (fetch (REGION WIDTH) of REGION) (TIMES BYAMOUNT 2)) (PLUS (fetch (REGION HEIGHT) of REGION) (TIMES BYAMOUNT 2]) (INSUREREGIONSIZE [LAMBDA (REGION MINSIZE) (* rrb " 5-Dec-84 11:27") (* * makes sure the height and width of REGION are at least MINSIZE.) (PROG (X) (COND ((GREATERP MINSIZE (SETQ X (fetch (REGION WIDTH) of REGION))) (replace (REGION LEFT) of REGION with (DIFFERENCE (fetch (REGION LEFT) of REGION) (QUOTIENT (DIFFERENCE MINSIZE X) 2))) (replace (REGION WIDTH) of REGION with MINSIZE))) (COND ((GREATERP MINSIZE (SETQ X (fetch (REGION HEIGHT) of REGION))) (replace (REGION BOTTOM) of REGION with (DIFFERENCE (fetch (REGION BOTTOM) of REGION) (QUOTIENT (DIFFERENCE MINSIZE X) 2))) (replace (REGION HEIGHT) of REGION with MINSIZE))) (RETURN REGION]) (EXPANDREGION [LAMBDA (REGION BYFACTOR) (* rrb "30-Nov-84 10:43") (* * expands a region by a factor.) (PROG ((WIDTH (fetch (REGION WIDTH) of REGION)) (HEIGHT (fetch (REGION HEIGHT) of REGION)) NEWWIDTH NEWHEIGHT) (SETQ NEWWIDTH (TIMES WIDTH BYFACTOR)) (SETQ NEWHEIGHT (TIMES HEIGHT BYFACTOR)) (RETURN (CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of REGION) (QUOTIENT (IDIFFERENCE NEWWIDTH WIDTH) 2)) (DIFFERENCE (fetch (REGION BOTTOM) of REGION) (QUOTIENT (IDIFFERENCE NEWHEIGHT HEIGHT) 2)) NEWWIDTH NEWHEIGHT]) (REGION.FROM.COORDINATES [LAMBDA (X1 Y1 X2 Y2) (* rrb "11-Sep-84 16:27") (* * returns the region for which { X1 Y1 } and { X2 Y2} are the corners.) (CREATEREGION (MIN X1 X2) (MIN Y1 Y2) (ADD1 (ABS (IDIFFERENCE X2 X1))) (ADD1 (ABS (IDIFFERENCE Y2 Y1]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD BOX (GLOBALREGION BRUSH BOXDASHING BOXINITSCALE BOXFILLING)) (RECORD LOCALBOX ((BOXLL BOXUR) LOCALHOTREGION LOCALREGION LOCALBOXBRUSH LOCALBOXFILLING LOCALBOXDASHING)) ) ) (READVARS-FROM-STRINGS '(BOXICON) "({(READBITMAP)(20 12 %"@@@@@@@@%" %"GOOON@@@%" %"GOOON@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"GOOON@@@%" %"GOOON@@@%" %"@@@@@@@@%")}) ") (* ; "fns for the arc sketch element type") (DEFINEQ (SKETCH.CREATE.ARC [LAMBDA (CENTERPT RADIUSPT ANGLEPT BRUSH DASHING ARROWHEADS DIRECTION SCALE) (* rrb " 7-Jul-86 14:49") (* creates a sketch arc element.) (ARC.CREATE (SK.INSURE.POSITION CENTERPT) (SK.INSURE.POSITION RADIUSPT) (COND ((NUMBERP ANGLEPT) (SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE CENTERPT RADIUSPT ANGLEPT)) (T (SK.INSURE.POSITION ANGLEPT))) (SK.INSURE.BRUSH BRUSH) (SK.INSURE.DASHING DASHING) (OR (NUMBERP SCALE) 1.0) (SK.INSURE.ARROWHEADS ARROWHEADS) (SK.INSURE.DIRECTION DIRECTION]) (ARC.DRAWFN [LAMBDA (ARCELT WINDOW REGION) (* rrb "20-Jun-86 17:12") (* draws a arc from a arc element.) (PROG ((GARC (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT)) (LARC (fetch (SCREENELT LOCALPART) of ARCELT)) BRUSH DASHING LOCALPTS LOCALARROWPTS GARROWSPECS) (AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION ARCELT))) (RETURN)) (SETQ GARROWSPECS (fetch (ARC ARCARROWHEADS) of GARC)) (SETQ LOCALARROWPTS (fetch (LOCALARC LOCALARCARROWHEADPTS) of LARC)) (SETQ BRUSH (fetch (LOCALARC LOCALARCBRUSH) of LARC)) (SETQ DASHING (fetch (LOCALARC LOCALARCDASHING) of LARC)) (COND [(EQ T (fetch (ARC ARCANGLEPT) of GARC)) (* T means greater than 360) (PROG ((CPT (fetch (LOCALARC LOCALARCCENTERPT) of LARC)) (RPT (fetch (LOCALARC LOCALARCRADIUSPT) of LARC))) (RETURN (\CIRCLE.DRAWFN1 CPT RPT (DISTANCEBETWEEN CPT RPT) BRUSH DASHING WINDOW] (T (SETQ LOCALPTS (\SK.ADJUST.FOR.ARROWHEADS (fetch (LOCALARC LOCALARCKNOTS) of LARC) LOCALARROWPTS GARROWSPECS WINDOW)) (* draw the curve from the knots) (DRAWCURVE LOCALPTS NIL BRUSH DASHING WINDOW))) (DRAWARROWHEADS GARROWSPECS LOCALARROWPTS WINDOW BRUSH]) (ARC.EXPANDFN [LAMBDA (GARC SCALE) (* rrb "20-Jun-86 13:58") (* returns a screen elt that has a arc screen element calculated from the  global part.) (PROG ((INDGARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARC)) CENTER RADIUSPT ANGLEPT LOCALKNOTS LOCALARROWHEADS) (SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCCENTERPT) of INDGARC) SCALE)) (SETQ RADIUSPT (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCRADIUSPT) of INDGARC) SCALE)) (SETQ ANGLEPT (SK.SCALE.POSITION.INTO.VIEWER (\SK.GET.ARC.ANGLEPT INDGARC) SCALE)) (SETQ LOCALKNOTS (SK.COMPUTE.ARC.PTS CENTER RADIUSPT ANGLEPT (fetch (ARC ARCDIRECTION) of INDGARC))) (COND ((AND (fetch (ARC ARCARROWHEADS) of INDGARC) (NOT (fetch (ARC ARCARROWHEADPOINTS) of INDGARC))) (* check to make sure the global arrowhead points have been calculated.  Old form didn't have them.) (SET.ARC.ARROWHEAD.POINTS INDGARC))) (SETQ LOCALARROWHEADS (SK.EXPAND.ARROWHEADS (fetch (ARC ARCARROWHEADPOINTS) of INDGARC) SCALE)) (RETURN (create SCREENELT LOCALPART _ (create LOCALARC LOCALARCCENTERPT _ CENTER LOCALARCRADIUSPT _ RADIUSPT LOCALARCANGLEPT _ ANGLEPT LOCALARCARROWHEADPTS _ LOCALARROWHEADS LOCALARCBRUSH _ (SCALE.BRUSH (fetch (ARC ARCBRUSH) of INDGARC) (fetch (ARC ARCINITSCALE) of INDGARC) SCALE) LOCALARCKNOTS _ LOCALKNOTS LOCALARCDASHING _ (fetch (ARC ARCDASHING) of INDGARC)) GLOBALPART _ GARC]) (ARC.INPUTFN [LAMBDA (WINDOW) (* rrb "20-May-86 10:53") (* reads three points from the user and returns the arc figure element that it  represents.) (PROG [CENTER RADPT ANGLEPT DIRECTION (SKCONTEXT (WINDOWPROP WINDOW 'SKETCHCONTEXT] (SETQ DIRECTION (fetch (SKETCHCONTEXT SKETCHARCDIRECTION) of SKCONTEXT)) (STATUSPRINT WINDOW " " "Indicate center of the arc") (COND ((SETQ CENTER (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.CENTER NIL NIL NIL NIL SKETCH.USE.POSITION.PAD)) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) NIL WINDOW)) (T (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate end of the arc") (COND [(SETQ RADPT (SK.READ.CIRCLE.POINT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTER) (COND (DIRECTION (* use a cursor that shows the arc going in the correct direction.) CW.ARC.RADIUS.CURSOR) (T ARC.RADIUS.CURSOR] (T (* erase center pt on way out) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) NIL WINDOW) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (COND ((NEQ SKETCH.VERBOSE.FEEDBACK 'ALWAYS) (* if feedback in medium mode, put up  circle) (SK.INVERT.CIRCLE CENTER RADPT WINDOW)) (T (* if feedback is in very verbose mode, just put up the radius pt.) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT) NIL WINDOW))) (STATUSPRINT WINDOW " " "Indicate the angle of the arc") (SETQ ANGLEPT (SK.READ.ARC.ANGLE.POINT WINDOW (COND (DIRECTION CW.ARC.ANGLE.CURSOR) (T ARC.ANGLE.CURSOR)) (fetch (INPUTPT INPUT.POSITION) of CENTER) (fetch (INPUTPT INPUT.POSITION) of RADPT) DIRECTION)) (CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.) (COND ((NEQ SKETCH.VERBOSE.FEEDBACK 'ALWAYS) (* if feedback in medium mode, put up  circle) (SK.INVERT.CIRCLE CENTER RADPT WINDOW)) (T (* if feedback is in very verbose mode, just put up the radius pt.) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT) NIL WINDOW))) (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) NIL WINDOW) (OR ANGLEPT (RETURN NIL)) (* the list of knots passed to SK.ARROWHEAD.CREATE is only used to determine  right and left so don't bother to create a good one.  Actually this introduces a bug when the angle point is not on the same side of  the radius point as the end of the arc is.  should fix.) (RETURN (ARC.CREATE (SK.MAP.INPUT.PT.TO.GLOBAL CENTER WINDOW) (SK.MAP.INPUT.PT.TO.GLOBAL RADPT WINDOW) (SK.MAP.INPUT.PT.TO.GLOBAL ANGLEPT WINDOW) (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT) (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT) (SK.INPUT.SCALE WINDOW) (SK.ARROWHEAD.CREATE WINDOW (LIST RADPT ANGLEPT)) DIRECTION]) (SK.INVERT.CIRCLE [LAMBDA (CENTERIPT RADIUSIPT SKW) (* rrb "18-Nov-85 14:36") (* draws a circle as feedback while the user in inputting the angle point of an  arc.) (PROG ((PREVOP (DSPOPERATION 'INVERT SKW))) (RETURN (PROG1 (SK.SHOW.CIRCLE (fetch (POSITION XCOORD) of (fetch (INPUTPT INPUT.POSITION) of RADIUSIPT)) (fetch (POSITION YCOORD) of (fetch (INPUTPT INPUT.POSITION) of RADIUSIPT)) SKW (fetch (INPUTPT INPUT.POSITION) of CENTERIPT)) (DSPOPERATION PREVOP SKW]) (SK.READ.ARC.ANGLE.POINT [LAMBDA (WINDOW CURSOR CENTERPT RADIUSPT DIRECTION) (* rrb "20-May-86 10:48") (* reads a point from the user prompting them with an arc that follows the  cursor) (SK.READ.POINT.WITH.FEEDBACK WINDOW CURSOR (AND (EQ SKETCH.VERBOSE.FEEDBACK 'ALWAYS) (FUNCTION SK.SHOW.ARC)) (LIST CENTERPT RADIUSPT DIRECTION) 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.ARC [LAMBDA (X Y WINDOW ARCARGS) (* rrb "15-Nov-85 14:32") (* draws an arc as feedback for reading the angle point of an arc.) (* Mark the point too.) (SHOWSKETCHXY X Y WINDOW) (DRAWCURVE (SK.COMPUTE.ARC.PTS (CAR ARCARGS) (CADR ARCARGS) (create POSITION XCOORD _ X YCOORD _ Y) (CADDR ARCARGS)) NIL 1 NIL WINDOW]) (ARC.CREATE [LAMBDA (CENTERPT RADPT ANGLEPT BRUSH DASHING INITSCALE ARROWHEADS DIRECTION) (* rrb "19-Mar-86 17:19") (* creates a global arc element.) (PROG ((ARCANGLEPT (SK.COMPUTE.ARC.ANGLE.PT CENTERPT RADPT ANGLEPT))) (RETURN (SET.ARC.SCALES (create GLOBALPART INDIVIDUALGLOBALPART _ (SET.ARC.ARROWHEAD.POINTS (create ARC ARCCENTERPT _ CENTERPT ARCRADIUSPT _ RADPT ARCBRUSH _ BRUSH ARCDASHING _ DASHING ARCINITSCALE _ INITSCALE ARCARROWHEADS _ ARROWHEADS ARCANGLEPT _ ARCANGLEPT ARCDIRECTION _ DIRECTION]) (SK.UPDATE.ARC.AFTER.CHANGE [LAMBDA (GARCELT) (* rrb " 7-Dec-85 19:52") (* updates the dependent fields of a arc element when a field changes.) (replace (ARC ARCREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT) with NIL]) (ARC.MOVEFN [LAMBDA (ARCELT SELPOS NEWPOS WINDOW) (* rrb "15-Dec-86 15:19") (* returns a global arc element which has the part SELPOS moved to NEWPOS.) (PROG ((LOCALEL (fetch (SCREENELT LOCALPART) of ARCELT)) (GLOBALEL (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT)) CENTERPT ANGLEPT RADPT PTSCALE) (SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GLOBALEL)) (SETQ ANGLEPT (fetch (ARC ARCANGLEPT) of GLOBALEL)) (SETQ RADPT (fetch (ARC ARCRADIUSPT) of GLOBALEL)) (* find the point that has moved and  change it.) [COND ((EQUAL SELPOS (fetch (LOCALARC LOCALARCCENTERPT) of LOCALEL)) (SETQ CENTERPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW))) ((EQUAL SELPOS (fetch (LOCALARC LOCALARCANGLEPT) of LOCALEL)) (SETQ ANGLEPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW))) ((EQUAL SELPOS (fetch (LOCALARC LOCALARCRADIUSPT) of LOCALEL)) (SETQ RADPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW] (* return a new global elt because the orientation changes but is needed to  erase the one that is already on the screen.) (RETURN (SK.CREATE.ARC.USING CENTERPT RADPT ANGLEPT (fetch (SCREENELT GLOBALPART) of ARCELT]) (ARC.TRANSLATEPTS [LAMBDA (ARCELT SELPTS GLOBALDELTA WINDOW) (* rrb "15-Dec-86 15:19") (* returns a new global arc element which has the points on SELPTS moved by a  global distance.) (PROG ((LOCALEL (fetch (SCREENELT LOCALPART) of ARCELT)) (GLOBALEL (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT)) CENTERPT ANGLEPT RADPT PTSCALE) (SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GLOBALEL)) (SETQ ANGLEPT (fetch (ARC ARCANGLEPT) of GLOBALEL)) (SETQ RADPT (fetch (ARC ARCRADIUSPT) of GLOBALEL)) (* find the point that has moved and  change it.) [COND ((MEMBER (fetch (LOCALARC LOCALARCCENTERPT) of LOCALEL) SELPTS) (SETQ CENTERPT (PTPLUS CENTERPT GLOBALDELTA] [COND ((MEMBER (fetch (LOCALARC LOCALARCRADIUSPT) of LOCALEL) SELPTS) (SETQ RADPT (PTPLUS RADPT GLOBALDELTA] [COND ((MEMBER (fetch (LOCALARC LOCALARCANGLEPT) of LOCALEL) SELPTS) (COND [(EQ ANGLEPT T) (* user moved the point that is both the radius pt and the angle pt.  If it was the only point moved, don't move the angle pt, just the radius pt.) (COND ((NULL (CDR SELPTS)) (SETQ ANGLEPT (fetch (ARC ARCRADIUSPT) of GLOBALEL] (T (SETQ ANGLEPT (PTPLUS ANGLEPT GLOBALDELTA] (RETURN (SK.CREATE.ARC.USING CENTERPT RADPT ANGLEPT (fetch (SCREENELT GLOBALPART) of ARCELT]) (ARC.INSIDEFN [LAMBDA (GARC WREG) (* rrb "20-Jan-87 14:44") (* determines if the global arc GARC is inside of WREG.) (REGIONSINTERSECTP WREG (ARC.GLOBALREGIONFN GARC]) (ARC.REGIONFN [LAMBDA (ARCSCRELT) (* rrb "30-May-85 12:23") (* returns the region occuppied by an  arc.) (* uses the heuristic that the region containing the curve is not more than  10% larger than the knots. This was determined empirically on several curves.) (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (LOCALARC LOCALARCKNOTS) of (fetch (SCREENELT LOCALPART) of ARCSCRELT))) 1.1) (IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALARC LOCALARCBRUSH) of (fetch (SCREENELT LOCALPART) of ARCSCRELT] 2]) (ARC.GLOBALREGIONFN [LAMBDA (GARCELT) (* rrb "20-Jun-86 14:04") (* returns the global region occupied by a global arc element.) (OR (fetch (ARC ARCREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT)) (PROG ((INDVARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT)) REGION) (* uses the heuristic that the region containing the curve is not more than  10% larger than the knots. This was determined empirically on several curves.) [SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (SK.COMPUTE.ARC.PTS (fetch (ARC ARCCENTERPT ) of INDVARC) (fetch (ARC ARCRADIUSPT) of INDVARC) (\SK.GET.ARC.ANGLEPT INDVARC) (fetch (ARC ARCDIRECTION) of INDVARC))) 1.1) (SK.BRUSH.SIZE (fetch (ARC ARCBRUSH) of INDVARC] (replace (ARC ARCREGION) of INDVARC with REGION) (RETURN REGION]) (ARC.TRANSLATE [LAMBDA (GARCELT DELTAPOS) (* rrb "15-Dec-86 15:20") (* returns a global arc element which has the arc translated by DELTAPOS.) (PROG ((GLOBALEL (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT))) (RETURN (SK.CREATE.ARC.USING (PTPLUS (fetch (ARC ARCCENTERPT) of GLOBALEL) DELTAPOS) (PTPLUS (fetch (ARC ARCRADIUSPT) of GLOBALEL) DELTAPOS) (COND ((POSITIONP (fetch (ARC ARCANGLEPT) of GLOBALEL)) (PTPLUS (fetch (ARC ARCANGLEPT) of GLOBALEL) DELTAPOS)) (T (* T marks greater than 360) T)) GARCELT]) (ARC.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "15-Dec-86 15:20") (* returns a copy of the global element that has had each of its control points  transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to  tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) NEWGELT) (SETQ NEWGELT (SK.CREATE.ARC.USING (SK.TRANSFORM.POINT (fetch (ARC ARCCENTERPT) of INDVPART) TRANSFORMFN TRANSFORMDATA) (SK.TRANSFORM.POINT (fetch (ARC ARCRADIUSPT) of INDVPART) TRANSFORMFN TRANSFORMDATA) (COND ((POSITIONP (fetch (ARC ARCANGLEPT) of INDVPART)) (SK.TRANSFORM.POINT (fetch (ARC ARCANGLEPT) of INDVPART) TRANSFORMFN TRANSFORMDATA)) (T (* T marks greater than 360) T)) GELT)) (* update the brush too.) (replace (ARC ARCBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT) with (SK.TRANSFORM.BRUSH (fetch (ARC ARCBRUSH) of INDVPART) SCALEFACTOR)) (replace (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT) with (SK.TRANSFORM.ARROWHEADS (fetch (ARC ARCARROWHEADS) of INDVPART) SCALEFACTOR)) (SET.ARC.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)) [AND (EQ TRANSFORMFN 'SK.APPLY.AFFINE.TRANSFORM) (COND ([COND [(GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ax) of TRANSFORMDATA)) (* x coord is reflected, switch direction unless Y is reflected also.) (NOT (GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ey) of TRANSFORMDATA] (T (GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ey) TRANSFORMDATA] (* change the direction if the  transformation reflects.) (replace (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT) with (NOT (fetch (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART] (RETURN NEWGELT]) (ARC.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb "17-Dec-85 16:22") (* changefn for arcs) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Which aspect?" ITEMS _ (APPEND [COND ((SKETCHINCOLORP) '((Color 'BRUSHCOLOR "changes the color of the outline" ] '((Arrowheads 'ARROW "allows changing of arrow head charactistics." ) (Size 'SIZE "changes the size of the brush" ) (Angle 'ANGLE "changes the amount of angle in the arc." ) (Dashing 'DASHING "changes the dashing of the line." ) (Direction 'DIRECTION "changes which way around the circle the arc is drawn." ] (SIZE (READSIZECHANGE "Change size how?")) (ANGLE (READANGLE)) (ARROW (READ.ARROW.CHANGE SCRNELTS)) (DASHING (READ.DASHING.CHANGE)) (DIRECTION (READARCDIRECTION)) (BRUSHCOLOR [READ.COLOR.CHANGE "Change color how?" NIL (fetch (BRUSH BRUSHCOLOR) of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRNELTS)) 'BRUSH]) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) ) (DEFINEQ (SK.COMPUTE.ARC.ANGLE.PT [LAMBDA (CENTERPT RADPT ANGLEPT) (* rrb "26-Jun-86 17:04") (* computes the intersection of the line CENTERPT ANGLEPT with the circle with  center CENTERPT that goes through RADPT.) (COND ((EQ ANGLEPT T) (* used to mark more than 360.0) T) (T (PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADPT)) (ARCANGLE (SK.COMPUTE.SLOPE.OF.LINE CENTERPT ANGLEPT))) (RETURN (create POSITION XCOORD _ (PLUS (fetch (POSITION XCOORD) of CENTERPT) (TIMES RADIUS (COS ARCANGLE))) YCOORD _ (PLUS (fetch (POSITION YCOORD) of CENTERPT) (TIMES RADIUS (SIN ARCANGLE]) (SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE [LAMBDA (CENTERPT RADPT ANGLE) (* rrb " 7-Jul-86 14:49") (* computes the point on the circle with center CENTERPT that goes through  RADPT that is angle ANGLE from RADPT.) (COND ((OR (GEQ ANGLE 360.0) (LEQ ANGLE -360.0)) (* T denotes all the way around.) T) (T (PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADPT)) (DELTA (PLUS (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADPT) ANGLE))) (RETURN (create POSITION XCOORD _ (PLUS (fetch (POSITION XCOORD) of CENTERPT) (TIMES RADIUS (COS DELTA))) YCOORD _ (PLUS (fetch (POSITION YCOORD) of CENTERPT) (TIMES RADIUS (SIN DELTA]) (SK.COMPUTE.ARC.PTS [LAMBDA (CENTERPT RADIUSPT ARCPT DIRECTION) (* DECLARATIONS%: FLOATING) (* rrb " 5-May-86 14:11") (* computes a list of knots that a spline goes through to make an arc) (PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADIUSPT)) (ALPHA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT)) (OMEGA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT ARCPT)) (CENTERX (fetch (POSITION XCOORD) of CENTERPT)) (CENTERY (fetch (POSITION YCOORD) of CENTERPT)) PTLST ANGLEINCR DEGREESARC) [COND [DIRECTION (* if non-NIL go in a counterclockwise  direction.) (COND ((GREATERP OMEGA ALPHA) (SETQ OMEGA (DIFFERENCE OMEGA 360.0] (T (COND ((GREATERP ALPHA OMEGA) (* angle crosses angle change point,  correct.) (SETQ OMEGA (PLUS OMEGA 360.0] (* 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 (SETQ DEGREESARC (DIFFERENCE OMEGA ALPHA)) (IMIN (IMAX (ABS (FIX (FQUOTIENT DEGREESARC 10.0))) 5) (PROGN (* don't have more than a knot every 5  pts) (IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3 (QUOTIENT DEGREESARC 360.0)) 4))) 3] (* go from initial point to just past the last point.  The just past (PLUS OMEGA (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.) [SETQ PTLST (for ANGLE from ALPHA to (PLUS OMEGA (QUOTIENT ANGLEINCR 5.0)) by ANGLEINCR collect (create POSITION XCOORD _ (PLUS CENTERX (TIMES RADIUS (COS ANGLE))) YCOORD _ (PLUS CENTERY (TIMES RADIUS (SIN ANGLE] (* add first and last points exactly.  (CONS RADIUSPT (NCONC1 PTLST  (create POSITION XCOORD _  (FIXR (PLUS CENTERX (TIMES RADIUS  (COS OMEGA)))) YCOORD _  (FIXR (PLUS CENTERY (TIMES RADIUS  (SIN OMEGA)))))))) (RETURN PTLST]) (SK.SET.ARC.DIRECTION [LAMBDA (SKW NEWDIR) (* rrb "31-May-85 17:29") (* * reads a value of arc direction and makes it the default) (PROG [(LOCALNEWDIR (OR NEWDIR (READARCDIRECTION "Which way should new arcs go?"] (RETURN (AND LOCALNEWDIR (replace (SKETCHCONTEXT SKETCHARCDIRECTION) of (WINDOWPROP SKW 'SKETCHCONTEXT) with (EQ LOCALNEWDIR 'CLOCKWISE]) (SK.SET.ARC.DIRECTION.CW [LAMBDA (SKW) (* sets the default to clockwise) (SK.SET.ARC.DIRECTION SKW 'CLOCKWISE]) (SK.SET.ARC.DIRECTION.CCW [LAMBDA (SKW) (* sets the default direction of arcs  to counterclockwise) (SK.SET.ARC.DIRECTION SKW 'COUNTERCLOCKWISE]) (SK.COMPUTE.SLOPE.OF.LINE [LAMBDA (PT1 PT2) (* rrb "31-May-85 12:26") (* computes the angle of a line) (SK.COMPUTE.SLOPE (DIFFERENCE (fetch (POSITION XCOORD) of PT2) (fetch (POSITION XCOORD) of PT1)) (DIFFERENCE (fetch (POSITION YCOORD) of PT2) (fetch (POSITION YCOORD) of PT1]) (SK.CREATE.ARC.USING [LAMBDA (CENTERPT RADPT ANGLEPT GARCELT) (* rrb "15-Dec-86 15:20") (* creates an arc global element that is like another one but has different  positions.) (SET.ARC.SCALES (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of GARCELT)) INDIVIDUALGLOBALPART _ (SET.ARC.ARROWHEAD.POINTS (create ARC using (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GARCELT) ARCCENTERPT _ CENTERPT ARCRADIUSPT _ RADPT ARCANGLEPT _ (SK.COMPUTE.ARC.ANGLE.PT CENTERPT RADPT ANGLEPT) ARCREGION _ NIL]) (SET.ARC.SCALES [LAMBDA (GARCELT) (* rrb "30-May-85 11:33") (* updates the scale fields of an arc. Called upon creation and when a point is  moved.) (PROG [(RAD (DISTANCEBETWEEN (fetch (ARC ARCCENTERPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT)) (fetch (ARC ARCRADIUSPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT] (replace (GLOBALPART MAXSCALE) of GARCELT with RAD) (replace (GLOBALPART MINSCALE) of GARCELT with (QUOTIENT RAD 3000.0)) (RETURN GARCELT]) ) (DEFINEQ (SK.INSURE.DIRECTION [LAMBDA (DIR) (* rrb "16-Oct-85 16:11") (* decodes a DIRECTION spec which indicates whether an arc goes clockwise or  counterclockwise. T is CLOCKWISE. NIL is COUNTERCLOCKWISE.) (SELECTQ DIR ((NIL COUNTERCLOCKWISE) NIL) ((T CLOCKWISE) T) (\ILLEGAL.ARC DIR]) ) (RPAQ? SK.NUMBER.OF.POINTS.IN.ARC 8) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD ARC (ARCCENTERPT ARCRADIUSPT ARCBRUSH ARCDASHING ARCINITSCALE ARCARROWHEADS ARCANGLEPT ARCDIRECTION ARCREGION ARCARROWHEADPOINTS)) (RECORD LOCALARC ((LOCALARCCENTERPT LOCALARCRADIUSPT LOCALARCANGLEPT) LOCALHOTREGION LOCALARCARROWHEADPTS LOCALARCBRUSH LOCALARCKNOTS LOCALARCDASHING )) ) ) (RPAQ ARC.RADIUS.CURSOR (CURSORCREATE (QUOTE #*(16 16)@@@L@@@D@@@F@@@B@@@C@@LA@@OA@@CMOOOO@@CL@@O@@@L@@@@@@@@@@@@@@@@@ ) (QUOTE NIL) 15 7)) (RPAQ ARC.ANGLE.CURSOR (CURSORCREATE (QUOTE #*(16 16)@AN@@ACL@CHG@CHA@GL@@GL@@MF@@MF@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@ ) (QUOTE NIL) 7 15)) (RPAQ CW.ARC.ANGLE.CURSOR (CURSORCREATE (QUOTE #*(16 16)@O@@GI@@LCH@@CH@@GL@@GL@@MF@@MF@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@ ) (QUOTE NIL) 7 15)) (RPAQ CW.ARC.RADIUS.CURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@L@@@O@@@CLOOOO@@CM@@OA@@LC@@@B@@@F@@@L@@AH ) (QUOTE NIL) 15 7)) (READVARS-FROM-STRINGS '(ARCICON) "({(READBITMAP)(20 13 %"@@@@@@@@%" %"@AOH@@@@%" %"@COL@@@@%" %"@G@N@@@@%" %"@F@F@@@@%" %"@N@G@@@@%" %"@L@C@@@@%" %"@@@C@@@@%" %"@@@G@@@@%" %"@@@F@@@@%" %"@@@N@@@@%" %"@@@L@@@@%" %"@@@@@@@@%")}) ") (* ; "property getting and setting stuff") (DEFINEQ (GETSKETCHELEMENTPROP [LAMBDA (ELEMENT PROPERTY) (* rrb "26-Jun-86 14:16") (* gets the property from a sketch  element.) (* knows about and sets the system ones specially.  All others go to the elements property list.) (SELECTQ PROPERTY (TYPE (fetch (GLOBALPART GTYPE) of ELEMENT)) (SCALE (\SKELT.GET.SCALE ELEMENT)) (REGION (SK.ELEMENT.GLOBAL.REGION ELEMENT)) ((POSITION 1STCONTROLPT) (\SK.GET.1STCONTROLPT ELEMENT)) (2NDCONTROLPT (\SK.GET.2NDCONTROLPT ELEMENT)) (3RDCONTROLPT (\SK.GET.3RDCONTROLPT ELEMENT)) (DATA (\SKELT.GET.DATA ELEMENT)) (BRUSH (\SK.GET.BRUSH ELEMENT)) (FILLING (\SK.GET.FILLING ELEMENT)) (DASHING (\SK.GET.DASHING ELEMENT)) (ARROWHEADS (\SK.GET.ARROWHEADS ELEMENT)) (FONT (\SK.GET.FONT ELEMENT)) (JUSTIFICATION (\SK.GET.JUSTIFICATION ELEMENT)) (DIRECTION (\SK.GET.DIRECTION ELEMENT)) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT) PROPERTY]) (\SK.GET.ARC.ANGLEPT [LAMBDA (INDVARCELT) (* rrb "20-Jun-86 13:54") (* returns the arc point of an individual arc element.  Special because T is used to denote arcs of greater than 360 degrees.) (COND ((POSITIONP (fetch (ARC ARCANGLEPT) of INDVARCELT))) (T (* for arcs of greater than 360 degrees, the radiuspt is T and is marked as  being the same as the radius pt.) (fetch (ARC ARCRADIUSPT) of INDVARCELT]) (\GETSKETCHELEMENTPROP1 [LAMBDA (ELEMENT PROPERTY) (* * version of GETSKETCHELEMENTPROP that doesn't look for system properties.) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT) PROPERTY]) (\SK.GET.BRUSH [LAMBDA (GELT) (* rrb " 7-Dec-85 19:52") (* gets the brush field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX) (fetch (WIRE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((CIRCLE ARC) (fetch (CIRCLE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ELLIPSE (fetch (ELLIPSE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'BRUSH]) (\SK.GET.FILLING [LAMBDA (GELT) (* rrb " 7-Dec-85 18:58") (* gets the filling field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((CLOSEDWIRE CLOSEDCURVE BOX) (fetch (CLOSEDWIRE CLOSEDWIREFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (CIRCLE (fetch (CIRCLE CIRCLEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ELLIPSE (fetch (ELLIPSE ELLIPSEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'FILLING]) (\SK.GET.ARROWHEADS [LAMBDA (GELT) (* rrb " 7-Dec-85 19:17") (* gets the arrowhead field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (WIRE (fetch (WIRE WIREARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ARC (fetch (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'ARROWHEADS]) (\SK.GET.FONT [LAMBDA (GELT) (* rrb " 7-Dec-85 19:22") (* gets the font field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((TEXT TEXTBOX) (fetch (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'FONT]) (\SK.GET.JUSTIFICATION [LAMBDA (GELT) (* ; "Edited 8-Jan-87 19:46 by rrb") (* gets the justification field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((TEXT TEXTBOX) (fetch (TEXT TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'JUSTIFICATION]) (\SK.GET.DIRECTION [LAMBDA (GELT) (* rrb " 7-Dec-85 19:21") (* gets the direction field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (ARC (fetch (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'DIRECTION]) (\SK.GET.DASHING [LAMBDA (GELT) (* rrb " 7-Dec-85 20:05") (* gets the dashing field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((WIRE CIRCLE ARC) (fetch (WIRE OPENWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX) (fetch (CLOSEDWIRE CLOSEDWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ELLIPSE (fetch (ELLIPSE DASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (TEXTBOX (fetch (TEXTBOX TEXTBOXDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'DASHING]) (PUTSKETCHELEMENTPROP [LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb "26-Jun-86 16:46") (* puts the property from a sketch  element.) (* knows about and sets the system ones specially.  All others go to the elements property list.) (* mostly not implemented yet.) (PROG1 (GETSKETCHELEMENTPROP ELEMENT PROPERTY) (AND (SELECTQ PROPERTY (TYPE (ERROR "Can't change types")) (SCALE (\SKELT.PUT.SCALE ELEMENT VALUE) T) (REGION (ERROR "Not implemented yet")) ((POSITION 1STCONTROLPT) (\SK.PUT.1STCONTROLPT ELEMENT VALUE)) (2NDCONTROLPT (\SK.PUT.2NDCONTROLPT ELEMENT VALUE)) (3RDCONTROLPT (\SK.PUT.3RDCONTROLPT ELEMENT VALUE)) (DATA (\SKELT.PUT.DATA ELEMENT VALUE SKETCHTOUPDATE)) (BRUSH (\SK.PUT.BRUSH ELEMENT VALUE SKETCHTOUPDATE)) (FILLING (\SK.PUT.FILLING ELEMENT VALUE)) (DASHING (\SK.PUT.DASHING ELEMENT VALUE)) (ARROWHEADS (\SK.PUT.ARROWHEADS ELEMENT VALUE)) (FONT (\SK.PUT.FONT ELEMENT VALUE)) (JUSTIFICATION (\SK.PUT.JUSTIFICATION ELEMENT VALUE)) (DIRECTION (\SK.PUT.DIRECTION ELEMENT VALUE)) (PROG ((PLIST (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT))) [COND (PLIST (LISTPUT PLIST PROPERTY VALUE)) (T (replace (GLOBALPART SKELEMENTPROPLIST) of ELEMENT with (LIST PROPERTY VALUE] (* if it wasn't a system recognized property, return NIL so it won't be  redisplayed.) (RETURN NIL))) SKETCHTOUPDATE (SKETCH.UPDATE SKETCHTOUPDATE ELEMENT]) (\SK.PUT.FILLING [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:44") (* sets the filling field from a global sketch element instance.) (OR (SKFILLINGP NEWVALUE) (\ILLEGAL.ARG NEWVALUE)) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((CLOSEDWIRE CLOSEDCURVE BOX) (replace (CLOSEDWIRE CLOSEDWIREFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (CIRCLE (replace (CIRCLE CIRCLEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (ELLIPSE (replace (ELLIPSE ELLIPSEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (TEXTBOX (replace (TEXTBOX TEXTBOXFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'FILLING NEWVALUE)) T]) (ADDSKETCHELEMENTPROP [LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb "11-Dec-85 15:17") (* adds a value to the list of values for a property of a sketch element.) (PROG ((NOWVALUE (GETSKETCHELEMENTPROP ELEMENT PROPERTY))) (RETURN (PUTSKETCHELEMENTPROP ELEMENT PROPERTY [COND ((NULL NOWVALUE) (LIST VALUE)) ((NLISTP NOWVALUE) (LIST NOWVALUE VALUE)) (T (APPEND NOWVALUE (CONS VALUE] SKETCHTOUPDATE]) (REMOVESKETCHELEMENTPROP [LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb "11-Dec-85 15:17") (* removes a value to the list of values for a property of a sketch element.) (PROG ((NOWVALUE (GETSKETCHELEMENTPROP ELEMENT PROPERTY))) (RETURN (PUTSKETCHELEMENTPROP ELEMENT PROPERTY (COND ((EQ NOWVALUE VALUE) NIL) ((NLISTP NOWVALUE) NOWVALUE) (T (REMOVE VALUE NOWVALUE))) SKETCHTOUPDATE]) (\SK.PUT.FONT [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 17:04") (* sets the font field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (TEXT (replace (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with (SK.INSURE.TEXT NEWVALUE)) (SK.UPDATE.TEXT.AFTER.CHANGE GELT)) (TEXTBOX (replace (TEXTBOX FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with (SK.INSURE.TEXT NEWVALUE)) (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'FONT NEWVALUE)) T]) (\SK.PUT.JUSTIFICATION [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:45") (* sets the justification field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (TEXT (replace (TEXT TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with (SK.INSURE.STYLE NEWVALUE SK.DEFAULT.TEXT.ALIGNMENT)) (SK.UPDATE.TEXT.AFTER.CHANGE GELT)) (TEXTBOX (replace (TEXTBOX TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with (SK.INSURE.STYLE NEWVALUE SK.DEFAULT.TEXT.ALIGNMENT)) (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'JUSTIFICATION NEWVALUE)) T]) (\SK.PUT.DIRECTION [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:45") (* puts the direction field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (ARC (replace (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with (SK.INSURE.DIRECTION NEWVALUE)) (SK.UPDATE.ARC.AFTER.CHANGE GELT)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'DIRECTION NEWVALUE)) T]) (\SK.PUT.DASHING [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:44") (* sets the dashing field of a global  sketch element.) (OR (NULL NEWVALUE) (DASHINGP NEWVALUE) (\ILLEGAL.ARG NEWVALUE)) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((WIRE CIRCLE ARC) (replace (WIRE OPENWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) ((CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX) (replace (CLOSEDWIRE CLOSEDWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (ELLIPSE (replace (ELLIPSE DASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (TEXTBOX (replace (TEXTBOX TEXTBOXDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'DASHING NEWVALUE)) T]) (\SK.PUT.BRUSH [LAMBDA (GELT NEWVALUE SKETCHTOUPDATE) (* rrb "26-Jun-86 16:44") (* sets the brush field from a global sketch element instance.) (COND [(NUMBERP NEWVALUE) (SETQ NEWVALUE (create BRUSH BRUSHSIZE _ NEWVALUE BRUSHSHAPE _ 'ROUND] ((BRUSHP NEWVALUE)) (T (\ILLEGAL.ARG NEWVALUE))) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) (replace (WIRE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE ) (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) (BOX (replace (BOX BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) (CIRCLE (replace (CIRCLE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE) (SK.UPDATE.CIRCLE.AFTER.CHANGE GELT)) (ARC (replace (ARC ARCBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE) (SK.UPDATE.ARC.AFTER.CHANGE GELT)) (ELLIPSE (replace (ELLIPSE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE) (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) (TEXTBOX (AND SKETCHTOUPDATE (SKETCH.CLEANUP SKETCHTOUPDATE)) (replace (TEXTBOX TEXTBOXBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE) (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'BRUSH NEWVALUE)) T]) (\SK.PUT.ARROWHEADS [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:45") (* sets the arrowhead field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (WIRE (replace (WIRE WIREARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SK.INSURE.ARROWHEADS NEWVALUE))) (SET.WIRE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (OPENCURVE (replace (OPENCURVE CURVEARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SK.INSURE.ARROWHEADS NEWVALUE))) (SET.OPENCURVE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ARC (replace (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT with (SK.INSURE.ARROWHEADS NEWVALUE))) (SET.ARC.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'ARROWHEADS NEWVALUE)) T]) (SK.COPY.ELEMENT.PROPERTY.LIST [LAMBDA (ELEMENT OLDELEMENT) (* rrb " 6-May-86 11:01") (* copies the property list of an element from OLDELEMENT if it is given, from  itself otherwise.) (replace (GLOBALPART SKELEMENTPROPLIST) of ELEMENT with (APPEND (fetch (GLOBALPART SKELEMENTPROPLIST) of (OR OLDELEMENT ELEMENT]) (SKETCH.UPDATE [LAMBDA (SKETCH ELEMENTS) (* rrb " 6-Dec-85 14:40") (* updates all or part of a sketch.) (PROG ((SKSTRUC (INSURE.SKETCH SKETCH)) ALLVIEWERS) (SETQ ALLVIEWERS (ALL.SKETCH.VIEWERS SKSTRUC)) (COND ((NULL ELEMENTS) (for SKW in ALLVIEWERS do (SK.UPDATE.AFTER.SCALE.CHANGE SKW))) ((GLOBALELEMENTP ELEMENTS) (SKETCH.UPDATE1 ELEMENTS ALLVIEWERS)) ((LISTP ELEMENTS) (for ELT in ELEMENTS do (SKETCH.UPDATE1 ELT ALLVIEWERS))) (T (\ILLEGAL.ARG ELEMENTS]) (SKETCH.UPDATE1 [LAMBDA (GELT VIEWERS) (* rrb "26-Sep-86 14:49") (* updates the element GELT in the  sketch viewers VIEWERS.) (bind SELECTION for SKW in VIEWERS do (COND ((AND [SCREENELEMENTP (SETQ SELECTION (fetch (TEXTELTSELECTION SKTEXTELT) of (WINDOWPROP SKW 'SELECTION] (EQ GELT (fetch (SCREENELT GLOBALPART) of SELECTION))) (* if the element being updated is the current text selection, clear the  selection.) (SKED.CLEAR.SELECTION SKW))) (SK.UPDATE.ELEMENT1 GELT GELT SKW T]) (\SKELT.GET.SCALE [LAMBDA (GELT) (* rrb "29-Oct-85 13:44") (* gets the scale field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((TEXT TEXTBOX SKIMAGEOBJ BITMAPELT) (fetch (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((WIRE OPENCURVE CIRCLE ARC) (fetch (WIRE OPENWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((CLOSEDWIRE CLOSEDCURVE BOX) (fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ELLIPSE (fetch (ELLIPSE ELLIPSEINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) NIL]) (\SKELT.PUT.SCALE [LAMBDA (GELT NEWVALUE) (* rrb "16-Oct-85 21:24") (* sets the scale field of a global sketch element instance.) (COND ((NUMBERP NEWVALUE) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((TEXT TEXTBOX SKIMAGEOBJ BITMAPELT) (replace (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) ((WIRE OPENCURVE CIRCLE ARC) (replace (WIRE OPENWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) ((CLOSEDWIRE CLOSEDCURVE BOX) (replace (CLOSEDWIRE CLOSEDWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GELT) with NEWVALUE)) (ELLIPSE (replace (ELLIPSE ELLIPSEINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) NIL)) (T (\ILLEGAL.ARG NEWVALUE]) (\SKELT.PUT.DATA [LAMBDA (GELT NEWVALUE SKETCHTOUPDATE) (* rrb "26-Jun-86 16:40") (* changes the data of a sketch  element.) (* this is harder than it seems because all of the dependent fields must be  updated also -  lots of grubby details duplicated.) (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (GROUP (COND ([OR (NLISTP NEWVALUE) (NOT (EVERY NEWVALUE (FUNCTION GLOBALELEMENTP] (\ILLEGAL.ARG NEWVALUE))) (replace (GROUP LISTOFGLOBALELTS) of INDVELT with NEWVALUE) (SK.UPDATE.GROUP.AFTER.CHANGE GELT)) ((TEXT TEXTBOX) (* before changing the text element, make sure any interactive editing is  closed off.) (AND SKETCHTOUPDATE (SKETCH.CLEANUP SKETCHTOUPDATE)) (SK.REPLACE.TEXT.IN.ELEMENT GELT (SK.INSURE.TEXT NEWVALUE))) (BITMAPELT (replace (BITMAPELT SKBITMAP) of INDVELT with NEWVALUE)) (SKIMAGEOBJ (replace (SKIMAGEOBJ SKIMAGEOBJ) of INDVELT with NEWVALUE) (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE GELT)) ((WIRE OPENCURVE CLOSEDWIRE CLOSEDCURVE) (replace (WIRE LATLONKNOTS) of INDVELT with NEWVALUE) (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) (RETURN NIL)) (RETURN T]) (SK.REPLACE.TEXT.IN.ELEMENT [LAMBDA (GTEXTELT NEWSTRS) (* rrb "15-Dec-85 18:00") (* changes the characters in a text or  textbox element.) (SELECTQ (fetch (GLOBALPART GTYPE) of GTEXTELT) (TEXTBOX (replace (TEXTBOX LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT) with (OR NEWSTRS (CONS ""))) (SK.UPDATE.TEXTBOX.AFTER.CHANGE GTEXTELT)) (TEXT (replace (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT) with NEWSTRS) (SK.UPDATE.TEXT.AFTER.CHANGE GTEXTELT)) (\ILLEGAL.ARG GTEXTELT)) GTEXTELT]) (\SKELT.GET.DATA [LAMBDA (GELT) (* rrb " 6-Dec-85 14:52") (* changes the data of a sketch  element.) (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (GROUP (fetch (GROUP LISTOFGLOBALELTS) of INDVELT)) ((TEXT TEXTBOX) (fetch (TEXT LISTOFCHARACTERS) of INDVELT)) (BITMAPELT (fetch (BITMAPELT SKBITMAP) of INDVELT)) (SKIMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDVELT)) ((WIRE OPENCURVE CLOSEDWIRE CLOSEDCURVE) (fetch (WIRE LATLONKNOTS) of INDVELT)) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) 'DATA]) (\SK.GET.1STCONTROLPT [LAMBDA (GELT PROPERTY) (* rrb " 9-Dec-85 11:33") (* gets the first control point field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((TEXT CIRCLE ARC ELLIPSE) (fetch (TEXT LOCATIONLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((TEXTBOX BOX) (LOWERLEFTCORNER (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) ((BITMAPELT SKIMAGEOBJ) (LOWERLEFTCORNER (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GELT)))) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) (CAR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) (GROUP (fetch (GROUP GROUPCONTROLPOINT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) PROPERTY]) (\SK.PUT.1STCONTROLPT [LAMBDA (GELT NEWPOSITION) (* rrb "26-Jun-86 16:22") (* changes the first control point field from a global sketch element instance.) (OR (POSITIONP NEWPOSITION) (\ILLEGAL.ARG NEWPOSITION)) (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) X) (SELECTQ (CAR INDVELT) (TEXT (replace (TEXT LOCATIONLATLON) of INDVELT with NEWPOSITION) (SK.UPDATE.TEXT.AFTER.CHANGE GELT)) (CIRCLE (replace (CIRCLE CENTERLATLON) of INDVELT with NEWPOSITION) (SK.UPDATE.CIRCLE.AFTER.CHANGE GELT)) (ARC (replace (ARC ARCCENTERPT) of INDVELT with NEWPOSITION) (SK.UPDATE.ARC.AFTER.CHANGE GELT)) (ELLIPSE (replace (ELLIPSE ELLIPSECENTERLATLON) of INDVELT with NEWPOSITION) (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) (TEXTBOX (replace (TEXTBOX TEXTBOXREGION) of INDVELT with (create REGION using (fetch (BOX GLOBALREGION ) of INDVELT) LEFT _ (fetch (POSITION XCOORD) of NEWPOSITION) BOTTOM _ (fetch (POSITION YCOORD) of NEWPOSITION))) (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) (BOX (replace (BOX GLOBALREGION) of INDVELT with (create REGION using (fetch (BOX GLOBALREGION) of INDVELT) LEFT _ (fetch (POSITION XCOORD) of NEWPOSITION) BOTTOM _ (fetch (POSITION YCOORD) of NEWPOSITION))) (SK.UPDATE.BOX.AFTER.CHANGE GELT)) (SKIMAGEOBJ (replace (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of INDVELT with (create REGION using (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of INDVELT) LEFT _ (fetch (POSITION XCOORD) of NEWPOSITION ) BOTTOM _ (fetch (POSITION YCOORD) of NEWPOSITION ))) (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE GELT)) (BITMAPELT (replace (BITMAPELT SKBITMAPREGION) of INDVELT with (create REGION using (fetch (BITMAPELT SKBITMAPREGION) of INDVELT) LEFT _ (fetch (POSITION XCOORD) of NEWPOSITION) BOTTOM _ (fetch (POSITION YCOORD) of NEWPOSITION )))) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) [COND ((SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT)) (* there is at least one knot) (RPLACA X NEWPOSITION)) (T (replace (WIRE LATLONKNOTS) of INDVELT with (CONS NEWPOSITION] (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) (GROUP (* change the position of the control point without changing the group.) (replace (GROUP GROUPCONTROLPOINT) of INDVELT with NEWPOSITION)) (RETURN NIL)) (RETURN T]) (\SK.GET.2NDCONTROLPT [LAMBDA (GELT) (* rrb " 9-Dec-85 11:32") (* gets the second control point field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) ((CIRCLE ARC ELLIPSE) (fetch (CIRCLE RADIUSLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((TEXTBOX BOX) (UPPERRIGHTCORNER (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) (CADR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) '2NDCONTROLPT]) (\SK.PUT.2NDCONTROLPT [LAMBDA (GELT NEWPOSITION) (* rrb "26-Jun-86 16:38") (* changes the second control point field from a global sketch element  instance.) (OR (POSITIONP NEWPOSITION) (\ILLEGAL.ARG NEWPOSITION)) (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) X) (SELECTQ (CAR INDVELT) (CIRCLE (replace (CIRCLE RADIUSLATLON) of INDVELT with NEWPOSITION) (SK.UPDATE.CIRCLE.AFTER.CHANGE GELT)) (ARC (replace (ARC ARCRADIUSPT) of INDVELT with NEWPOSITION) (SK.UPDATE.ARC.AFTER.CHANGE GELT)) (ELLIPSE (replace (ELLIPSE SEMIMINORLATLON) of INDVELT with NEWPOSITION) (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) (BOX (SETQ X (fetch (BOX GLOBALREGION) of INDVELT)) [replace (BOX GLOBALREGION) of INDVELT with (create REGION using X WIDTH _ (DIFFERENCE (fetch (POSITION XCOORD) of NEWPOSITION) (fetch (REGION LEFT) of X)) HEIGHT _ (DIFFERENCE (fetch (POSITION YCOORD) of NEWPOSITION) (fetch (REGION BOTTOM) of X] (SK.UPDATE.BOX.AFTER.CHANGE GELT)) (TEXTBOX (SETQ X (fetch (TEXTBOX TEXTBOXREGION) of INDVELT)) [replace (TEXTBOX TEXTBOXREGION) of INDVELT with (create REGION using X WIDTH _ (DIFFERENCE (fetch (POSITION XCOORD) of NEWPOSITION) (fetch (REGION LEFT) of X)) HEIGHT _ (DIFFERENCE (fetch (POSITION YCOORD) of NEWPOSITION) (fetch (REGION BOTTOM) of X] (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) (COND ((NULL (SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT))) (* doesn't have a first knot, give it one at 0 . 0) (replace (WIRE LATLONKNOTS) of INDVELT with (LIST '(0 . 0) NEWPOSITION))) ((NULL (CDR X)) (replace (WIRE LATLONKNOTS) of INDVELT with (LIST (CAR X) NEWPOSITION))) (T (* there is at least one knot) (RPLACA (CDR X) NEWPOSITION))) (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) '2NDCONTROLPT NEWPOSITION)) (RETURN T]) (\SK.GET.3RDCONTROLPT [LAMBDA (GELT) (* rrb "20-Jun-86 13:55") (* gets the third control point field from a global sketch element instance.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (ELLIPSE (fetch (ELLIPSE SEMIMAJORLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (ARC (\SK.GET.ARC.ANGLEPT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) (CADDR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) '3RDCONTROLPT]) (\SK.PUT.3RDCONTROLPT [LAMBDA (GELT NEWPOSITION) (* rrb "10-Jul-86 11:15") (* changes the third control point field from a global sketch element instance.) (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) X) (RETURN (COND ((EQ (CAR INDVELT) 'ARC) (* handle ARC specially because it will convert the number of degrees to a  point.) (COND ((POSITIONP NEWPOSITION) (replace (ARC ARCANGLEPT) of INDVELT with (SK.COMPUTE.ARC.ANGLE.PT (fetch (ARC ARCCENTERPT) of INDVELT) (fetch (ARC ARCRADIUSPT) of INDVELT) NEWPOSITION))) ((NUMBERP NEWPOSITION) (replace (ARC ARCANGLEPT) of INDVELT with (  SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE (fetch (ARC ARCCENTERPT) of INDVELT) (fetch (ARC ARCRADIUSPT) of INDVELT) NEWPOSITION))) (T (\ILLEGAL.ARG NEWPOSITION))) (SK.UPDATE.ARC.AFTER.CHANGE GELT) T) (T (OR (POSITIONP NEWPOSITION) (\ILLEGAL.ARG NEWPOSITION)) (SELECTQ (CAR INDVELT) (ELLIPSE (replace (ELLIPSE SEMIMAJORLATLON) of INDVELT with NEWPOSITION) (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) (COND ((NULL (SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT))) (* doesn't have a first knot, give it one at 0 . 0) (replace (WIRE LATLONKNOTS) of INDVELT with (LIST '(0 . 0) '(0 . 0) NEWPOSITION))) ((NULL (CDR X)) (replace (WIRE LATLONKNOTS) of INDVELT with (LIST (CAR X) '(0 . 0) NEWPOSITION))) ((NULL (CDDR X)) (replace (WIRE LATLONKNOTS) of INDVELT with (LIST (CAR X) (CADR X) NEWPOSITION))) (T (* there is at least one knot) (RPLACA (CDDR X) NEWPOSITION))) (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) '3RDCONTROLPT NEWPOSITION)) T]) ) (DEFINEQ (LOWERLEFTCORNER [LAMBDA (REGION) (* returns a position which is the lower left corner of a region.) (CREATEPOSITION (FETCH (REGION LEFT) OF REGION) (FETCH (REGION BOTTOM) OF REGION]) (UPPERRIGHTCORNER [LAMBDA (REGION) (* rrb "16-Oct-85 21:10") (* returns a position which is the lower left corner of a region.) (CREATEPOSITION (fetch (REGION RIGHT) of REGION) (fetch (REGION TOP) of REGION]) ) (PUTPROPS SKETCHELEMENTS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (14348 24762 (INIT.SKETCH.ELEMENTS 14358 . 21921) (CREATE.SKETCH.ELEMENT.TYPE 21923 . 23449) (SKETCH.ELEMENT.TYPEP 23451 . 23839) (SKETCH.ELEMENT.NAMEP 23841 . 24104) ( \CURSOR.IN.MIDDLE.MENU 24106 . 24760)) (24803 25480 (SKETCHINCOLORP 24813 . 25133) (READ.COLOR.CHANGE 25135 . 25478)) (25989 28768 (SK.CREATE.DEFAULT.FILLING 25999 . 26300) (SKFILLINGP 26302 . 26935) ( SK.INSURE.FILLING 26937 . 28365) (SK.INSURE.COLOR 28367 . 28766)) (28769 34379 (SK.TRANSLATE.MODE 28779 . 29561) (SK.CHANGE.FILLING.MODE 29563 . 33146) (READ.FILLING.MODE 33148 . 34377)) (34380 65054 (SKETCH.CREATE.CIRCLE 34390 . 35202) (CIRCLE.EXPANDFN 35204 . 38576) (CIRCLE.DRAWFN 38578 . 41579) ( \CIRCLE.DRAWFN1 41581 . 44176) (CIRCLE.INPUTFN 44178 . 46027) (SK.UPDATE.CIRCLE.AFTER.CHANGE 46029 . 46388) (SK.READ.CIRCLE.POINT 46390 . 46861) (SK.SHOW.CIRCLE 46863 . 47509) (CIRCLE.INSIDEFN 47511 . 47776) (CIRCLE.REGIONFN 47778 . 49459) (CIRCLE.GLOBALREGIONFN 49461 . 50979) (CIRCLE.TRANSLATE 50981 . 52842) (CIRCLE.READCHANGEFN 52844 . 57460) (CIRCLE.TRANSFORMFN 57462 . 59315) (CIRCLE.TRANSLATEPTS 59317 . 60931) (SK.CIRCLE.CREATE 60933 . 61776) (SET.CIRCLE.SCALE 61778 . 62544) (SK.BRUSH.READCHANGE 62546 . 65052)) (65055 65784 (SK.INSURE.BRUSH 65065 . 65459) (SK.INSURE.DASHING 65461 . 65782)) (67036 96530 (SKETCH.CREATE.ELLIPSE 67046 . 67645) (ELLIPSE.EXPANDFN 67647 . 71259) (ELLIPSE.DRAWFN 71261 . 75438) (ELLIPSE.INPUTFN 75440 . 77880) (SK.READ.ELLIPSE.MAJOR.PT 77882 . 78461) ( SK.SHOW.ELLIPSE.MAJOR.RADIUS 78463 . 79218) (SK.READ.ELLIPSE.MINOR.PT 79220 . 79913) ( SK.SHOW.ELLIPSE.MINOR.RADIUS 79915 . 80747) (ELLIPSE.INSIDEFN 80749 . 81019) (ELLIPSE.CREATE 81021 . 82396) (SK.UPDATE.ELLIPSE.AFTER.CHANGE 82398 . 82766) (ELLIPSE.REGIONFN 82768 . 84968) ( ELLIPSE.GLOBALREGIONFN 84970 . 86783) (ELLIPSE.TRANSLATEFN 86785 . 89331) (ELLIPSE.TRANSFORMFN 89333 . 90610) (ELLIPSE.TRANSLATEPTS 90612 . 92653) (MARK.SPOT 92655 . 93906) (DISTANCEBETWEEN 93908 . 94503) (SK.DISTANCE.TO 94505 . 94890) (SQUARE 94892 . 94934) (COMPUTE.ELLIPSE.ORIENTATION 94936 . 95655) (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT 95657 . 96528)) (97655 138711 (SKETCH.CREATE.OPEN.CURVE 97665 . 98218) (OPENCURVE.INPUTFN 98220 . 99088) (SK.CURVE.CREATE 99090 . 100835) (MAXXEXTENT 100837 . 101696) (MAXYEXTENT 101698 . 102558) (KNOT.SET.SCALE.FIELD 102560 . 103362) (OPENCURVE.DRAWFN 103364 . 104495) (OPENCURVE.EXPANDFN 104497 . 107812) (OPENCURVE.READCHANGEFN 107814 . 111016) ( OPENCURVE.TRANSFORMFN 111018 . 113516) (OPENCURVE.TRANSLATEFN 113518 . 113940) ( OPENCURVE.TRANSLATEPTSFN 113942 . 115323) (SKETCH.CREATE.CLOSED.CURVE 115325 . 115831) ( CLOSEDCURVE.DRAWFN 115833 . 116617) (CLOSEDCURVE.EXPANDFN 116619 . 119732) (CLOSEDCURVE.REGIONFN 119734 . 120531) (CLOSEDCURVE.GLOBALREGIONFN 120533 . 121966) (READ.LIST.OF.POINTS 121968 . 123947) ( CLOSEDCURVE.INPUTFN 123949 . 124594) (CLOSEDCURVE.READCHANGEFN 124596 . 127491) ( CLOSEDCURVE.TRANSFORMFN 127493 . 129293) (CLOSEDCURVE.TRANSLATEPTSFN 129295 . 130640) (INVISIBLEPARTP 130642 . 130995) (SHOWSKETCHPOINT 130997 . 131302) (SHOWSKETCHXY 131304 . 131822) (KNOTS.REGIONFN 131824 . 132725) (OPENWIRE.GLOBALREGIONFN 132727 . 133591) (CURVE.REGIONFN 133593 . 134534) ( OPENCURVE.GLOBALREGIONFN 134536 . 135943) (KNOTS.TRANSLATEFN 135945 . 136988) (REGION.CONTAINING.PTS 136990 . 138709)) (138712 160988 (CHANGE.ELTS.BRUSH.SIZE 138722 . 139332) (CHANGE.ELTS.BRUSH 139334 . 139851) (CHANGE.ELTS.BRUSH.SHAPE 139853 . 140254) (SK.CHANGE.BRUSH.SHAPE 140256 . 143768) ( SK.CHANGE.BRUSH.COLOR 143770 . 148216) (SK.CHANGE.BRUSH.SIZE 148218 . 153176) (SK.CHANGE.ANGLE 153178 . 156158) (SK.CHANGE.ARC.DIRECTION 156160 . 158539) (SK.SET.DEFAULT.BRUSH.SIZE 158541 . 159240) ( READSIZECHANGE 159242 . 160986)) (160989 162608 (SK.CHANGE.ELEMENT.KNOTS 160999 . 162606)) (162609 163256 (SK.INSURE.POINT.LIST 162619 . 163072) (SK.INSURE.POSITION 163074 . 163254)) (164636 196959 ( SKETCH.CREATE.WIRE 164646 . 165136) (CLOSEDWIRE.EXPANDFN 165138 . 167826) (KNOTS.INSIDEFN 167828 . 168549) (OPEN.WIRE.DRAWFN 168551 . 169143) (WIRE.EXPANDFN 169145 . 172392) ( SK.UPDATE.WIRE.ELT.AFTER.CHANGE 172394 . 172915) (OPENWIRE.READCHANGEFN 172917 . 175410) ( OPENWIRE.TRANSFORMFN 175412 . 177535) (OPENWIRE.TRANSLATEFN 177537 . 177961) (OPENWIRE.TRANSLATEPTSFN 177963 . 179242) (WIRE.INPUTFN 179244 . 180875) (SK.READ.WIRE.POINTS 180877 . 181408) ( SK.READ.POINTS.WITH.FEEDBACK 181410 . 184177) (OPENWIRE.FEEDBACKFN 184179 . 184933) ( CLOSEDWIRE.FEEDBACKFN 184935 . 186291) (CLOSEDWIRE.REGIONFN 186293 . 187278) ( CLOSEDWIRE.GLOBALREGIONFN 187280 . 188332) (SK.WIRE.CREATE 188334 . 190097) (WIRE.ADD.POINT.TO.END 190099 . 191015) (READ.ARROW.CHANGE 191017 . 196493) (CHANGE.ELTS.ARROWHEADS 196495 . 196957)) (196960 207966 (SKETCH.CREATE.CLOSED.WIRE 196970 . 197531) (CLOSED.WIRE.INPUTFN 197533 . 197888) ( CLOSED.WIRE.DRAWFN 197890 . 199935) (CLOSEDWIRE.READCHANGEFN 199937 . 204842) (CLOSEDWIRE.TRANSFORMFN 204844 . 206638) (CLOSEDWIRE.TRANSLATEPTSFN 206640 . 207964)) (207967 260673 (SK.EXPAND.ARROWHEADS 207977 . 208327) (SK.COMPUTE.ARC.ARROWHEAD.POINTS 208329 . 209710) (ARC.ARROWHEAD.POINTS 209712 . 210935) (SET.ARC.ARROWHEAD.POINTS 210937 . 211918) (SET.OPENCURVE.ARROWHEAD.POINTS 211920 . 212821) ( SK.COMPUTE.CURVE.ARROWHEAD.POINTS 212823 . 214093) (SET.WIRE.ARROWHEAD.POINTS 214095 . 214848) ( SK.COMPUTE.WIRE.ARROWHEAD.POINTS 214850 . 216115) (SK.EXPAND.ARROWHEAD 216117 . 217300) (CHANGED.ARROW 217302 . 220474) (SK.CHANGE.ARROWHEAD 220476 . 220929) (SK.CHANGE.ARROWHEAD1 220931 . 226186) ( SK.CREATE.ARROWHEAD 226188 . 226708) (SK.ARROWHEAD.CREATE 226710 . 228284) (SK.ARROWHEAD.END.TEST 228286 . 229210) (READ.ARROWHEAD.END 229212 . 231237) (ARROW.HEAD.POSITIONS 231239 . 233079) ( ARROWHEAD.POINTS.LIST 233081 . 237053) (CURVE.ARROWHEAD.POINTS 237055 . 237918) (LEFT.MOST.IS.BEGINP 237920 . 238801) (WIRE.ARROWHEAD.POINTS 238803 . 240329) (DRAWARROWHEADS 240331 . 242701) ( \SK.DRAW.TRIANGLE.ARROWHEAD 242703 . 244363) (\SK.ENDPT.OF.ARROW 244365 . 246622) ( \SK.ADJUST.FOR.ARROWHEADS 246624 . 249129) (SK.SET.ARROWHEAD.LENGTH 249131 . 250275) ( SK.SET.ARROWHEAD.ANGLE 250277 . 251373) (SK.SET.ARROWHEAD.TYPE 251375 . 254664) (SK.SET.LINE.ARROWHEAD 254666 . 257079) (SK.UPDATE.ARROWHEAD.FORMAT 257081 . 259191) (SK.SET.LINE.LENGTH.MODE 259193 . 260671)) (260674 262475 (SK.INSURE.ARROWHEADS 260684 . 261866) (SK.ARROWHEADP 261868 . 262473)) ( 265279 327605 (SKETCH.CREATE.TEXT 265289 . 265803) (TEXT.CHANGEFN 265805 . 266197) (TEXT.READCHANGEFN 266199 . 274270) (\SK.READ.FONT.SIZE1 274272 . 276168) (SK.TEXT.ELT.WITH.SAME.FIELDS 276170 . 277810) (SK.READFONTFAMILY 277812 . 279358) (CLOSE.PROMPT.WINDOW 279360 . 279784) (TEXT.DRAWFN 279786 . 280507 ) (TEXT.DRAWFN1 280509 . 284011) (TEXT.INSIDEFN 284013 . 284402) (TEXT.EXPANDFN 284404 . 286529) ( SK.TEXT.LINE.REGIONS 286531 . 288405) (TEXT.UPDATE.GLOBAL.REGIONS 288407 . 289639) (REL.MOVE.REGION 289641 . 290178) (LTEXT.LINE.REGIONS 290180 . 293598) (TEXT.INPUTFN 293600 . 294110) (READ.TEXT 294112 . 294860) (TEXT.POSITION.AND.CREATE 294862 . 297173) (CREATE.TEXT.ELEMENT 297175 . 297993) ( SK.UPDATE.TEXT.AFTER.CHANGE 297995 . 298397) (SK.TEXT.FROM.TEXTBOX 298399 . 302205) ( TEXT.SET.GLOBAL.REGIONS 302207 . 303500) (TEXT.REGIONFN 303502 . 304272) (TEXT.GLOBALREGIONFN 304274 . 304962) (TEXT.TRANSLATEFN 304964 . 306279) (TEXT.TRANSFORMFN 306281 . 307404) (TEXT.TRANSLATEPTSFN 307406 . 307923) (TEXT.UPDATEFN 307925 . 312581) (SK.CHANGE.TEXT 312583 . 325671) (TEXT.SET.SCALES 325673 . 326641) (BREAK.AT.CARRIAGE.RETURNS 326643 . 327603)) (327606 343675 (ADD.KNOWN.SKETCH.FONT 327616 . 328493) (SK.PICK.FONT 328495 . 331877) (SK.CHOOSE.TEXT.FONT 331879 . 335636) (SK.NEXTSIZEFONT 335638 . 336905) (SK.DECREASING.FONT.LIST 336907 . 338780) (SK.GUESS.FONTSAVAILABLE 338782 . 343673)) (344107 358250 (SK.SET.FONT 344117 . 345684) (SK.SET.TEXT.FONT 345686 . 346688) (SK.SET.TEXT.SIZE 346690 . 347377) (SK.SET.TEXT.HORIZ.ALIGN 347379 . 348953) (SK.READFONTSIZE 348955 . 351185) ( SK.COLLECT.FONT.SIZES 351187 . 354105) (SK.SET.TEXT.VERT.ALIGN 354107 . 356149) (SK.SET.TEXT.LOOKS 356151 . 357608) (SK.SET.DEFAULT.TEXT.FACE 357610 . 358248)) (358251 358837 (CREATE.SKETCH.TERMTABLE 358261 . 358835)) (358838 360604 (SK.FONT.LIST 358848 . 359174) (SK.INSURE.FONT 359176 . 359698) ( SK.INSURE.STYLE 359700 . 360218) (SK.INSURE.TEXT 360220 . 360602)) (361174 418467 ( SKETCH.CREATE.TEXTBOX 361184 . 362826) (SK.COMPUTE.TEXTBOX.REGION.FOR.STRING 362828 . 364905) ( SK.BREAK.INTO.LINES 364907 . 376093) (SK.BRUSH.SIZE 376095 . 376476) (SK.TEXTBOX.CREATE 376478 . 377275) (SK.TEXTBOX.CREATE1 377277 . 378341) (SK.UPDATE.TEXTBOX.AFTER.CHANGE 378343 . 378883) ( SK.TEXTBOX.POSITION.IN.BOX 378885 . 380796) (TEXTBOX.CHANGEFN 380798 . 381272) (TEXTBOX.DRAWFN 381274 . 383310) (SK.TEXTURE.AROUND.REGIONS 383312 . 389385) (ALL.EMPTY.REGIONS 389387 . 389877) ( TEXTBOX.EXPANDFN 389879 . 397035) (TEXTBOX.INPUTFN 397037 . 398650) (TEXTBOX.INSIDEFN 398652 . 399065) (TEXTBOX.REGIONFN 399067 . 399921) (TEXTBOX.GLOBALREGIONFN 399923 . 400251) ( TEXTBOX.SET.GLOBAL.REGIONS 400253 . 401584) (TEXTBOX.TRANSLATEFN 401586 . 403427) ( TEXTBOX.TRANSLATEPTSFN 403429 . 406212) (TEXTBOX.TRANSFORMFN 406214 . 407882) (TEXTBOX.UPDATEFN 407884 . 409777) (TEXTBOX.READCHANGEFN 409779 . 414668) (SK.TEXTBOX.TEXT.POSITION 414670 . 415091) ( SK.TEXTBOX.FROM.TEXT 415093 . 417698) (ADD.EOLS 417700 . 418465)) (419035 422536 ( SK.SET.TEXTBOX.VERT.ALIGN 419045 . 420925) (SK.SET.TEXTBOX.HORIZ.ALIGN 420927 . 422534)) (422919 467394 (SKETCH.CREATE.BOX 422929 . 423412) (SK.BOX.DRAWFN 423414 . 424573) (BOX.DRAWFN1 424575 . 427414) (KNOTS.OF.REGION 427416 . 428650) (SK.DRAWAREABOX 428652 . 435253) (SK.DRAWBOX 435255 . 436444 ) (SK.BOX.EXPANDFN 436446 . 440194) (SK.BOX.GETREGIONFN 440196 . 441382) (BOX.SET.SCALES 441384 . 442624) (SK.BOX.INPUTFN 442626 . 444559) (SK.BOX.CREATE 444561 . 445262) (SK.UPDATE.BOX.AFTER.CHANGE 445264 . 445775) (SK.BOX.INSIDEFN 445777 . 446167) (SK.BOX.REGIONFN 446169 . 446882) ( SK.BOX.GLOBALREGIONFN 446884 . 447622) (SK.BOX.READCHANGEFN 447624 . 451345) (SK.CHANGE.FILLING 451347 . 455295) (SK.CHANGE.FILLING.COLOR 455297 . 458953) (SK.BOX.TRANSLATEFN 458955 . 460134) ( SK.BOX.TRANSFORMFN 460136 . 461081) (SK.BOX.TRANSLATEPTSFN 461083 . 463451) (UNSCALE.REGION.TO.GRID 463453 . 464378) (INCREASEREGION 464380 . 464971) (INSUREREGIONSIZE 464973 . 466144) (EXPANDREGION 466146 . 467026) (REGION.FROM.COORDINATES 467028 . 467392)) (467934 494289 (SKETCH.CREATE.ARC 467944 . 468753) (ARC.DRAWFN 468755 . 470482) (ARC.EXPANDFN 470484 . 472817) (ARC.INPUTFN 472819 . 477037) ( SK.INVERT.CIRCLE 477039 . 477899) (SK.READ.ARC.ANGLE.POINT 477901 . 478408) (SK.SHOW.ARC 478410 . 479020) (ARC.CREATE 479022 . 480377) (SK.UPDATE.ARC.AFTER.CHANGE 480379 . 480719) (ARC.MOVEFN 480721 . 482304) (ARC.TRANSLATEPTS 482306 . 484191) (ARC.INSIDEFN 484193 . 484443) (ARC.REGIONFN 484445 . 485581) (ARC.GLOBALREGIONFN 485583 . 487305) (ARC.TRANSLATE 487307 . 488289) (ARC.TRANSFORMFN 488291 . 491241) (ARC.READCHANGEFN 491243 . 494287)) (494290 503369 (SK.COMPUTE.ARC.ANGLE.PT 494300 . 495226 ) (SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE 495228 . 496221) (SK.COMPUTE.ARC.PTS 496223 . 499795) ( SK.SET.ARC.DIRECTION 499797 . 500371) (SK.SET.ARC.DIRECTION.CW 500373 . 500547) ( SK.SET.ARC.DIRECTION.CCW 500549 . 500822) (SK.COMPUTE.SLOPE.OF.LINE 500824 . 501316) ( SK.CREATE.ARC.USING 501318 . 502555) (SET.ARC.SCALES 502557 . 503367)) (503370 503815 ( SK.INSURE.DIRECTION 503380 . 503813)) (505217 550598 (GETSKETCHELEMENTPROP 505227 . 506535) ( \SK.GET.ARC.ANGLEPT 506537 . 507098) (\GETSKETCHELEMENTPROP1 507100 . 507354) (\SK.GET.BRUSH 507356 . 508280) (\SK.GET.FILLING 508282 . 509380) (\SK.GET.ARROWHEADS 509382 . 510161) (\SK.GET.FONT 510163 . 510643) (\SK.GET.JUSTIFICATION 510645 . 511169) (\SK.GET.DIRECTION 511171 . 511648) (\SK.GET.DASHING 511650 . 512669) (PUTSKETCHELEMENTPROP 512671 . 514940) (\SK.PUT.FILLING 514942 . 516212) ( ADDSKETCHELEMENTPROP 516214 . 517019) (REMOVESKETCHELEMENTPROP 517021 . 517810) (\SK.PUT.FONT 517812 . 518626) (\SK.PUT.JUSTIFICATION 518628 . 519639) (\SK.PUT.DIRECTION 519641 . 520248) ( \SK.PUT.DASHING 520250 . 521585) (\SK.PUT.BRUSH 521587 . 523506) (\SK.PUT.ARROWHEADS 523508 . 524996) (SK.COPY.ELEMENT.PROPERTY.LIST 524998 . 525574) (SKETCH.UPDATE 525576 . 526306) (SKETCH.UPDATE1 526308 . 527596) (\SKELT.GET.SCALE 527598 . 528586) (\SKELT.PUT.SCALE 528588 . 529895) (\SKELT.PUT.DATA 529897 . 531694) (SK.REPLACE.TEXT.IN.ELEMENT 531696 . 532649) (\SKELT.GET.DATA 532651 . 533718) ( \SK.GET.1STCONTROLPT 533720 . 535232) (\SK.PUT.1STCONTROLPT 535234 . 540707) (\SK.GET.2NDCONTROLPT 540709 . 541624) (\SK.PUT.2NDCONTROLPT 541626 . 545814) (\SK.GET.3RDCONTROLPT 545816 . 546694) ( \SK.PUT.3RDCONTROLPT 546696 . 550596)) (550599 551180 (LOWERLEFTCORNER 550609 . 550855) ( UPPERRIGHTCORNER 550857 . 551178))))) STOP \ No newline at end of file diff --git a/library/TABLEBROWSER.~1~ b/library/TABLEBROWSER.~1~ deleted file mode 100644 index 5199ad18..00000000 --- a/library/TABLEBROWSER.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "24-Aug-95 15:31:14" {DSK}library>TABLEBROWSER.;3 56660 changes to%: (VARS TABLEBROWSERCOMS) previous date%: "27-Sep-94 15:02:59" {DSK}library>TABLEBROWSER.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993, 1994, 1995 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TABLEBROWSERCOMS) (RPAQQ TABLEBROWSERCOMS ((COMS (* ; "Entries") (FNS TB.MAKE.BROWSER TB.REPLACE.ITEMS) (FNS TB.DELETE.ITEM TB.UNDELETE.ITEM TB.INSERT.ITEM TB.REMOVE.ITEM TB.NORMALIZE.ITEM TB.REDISPLAY.ITEMS TB.SELECT.ITEM TB.UNSELECT.ITEM TB.UNSELECT.ALL.ITEMS) (FNS TB.NUMBER.OF.ITEMS TB.NTH.ITEM TB.COLLECT.ITEMS TB.MAP.ITEMS TB.MAP.DELETED.ITEMS TB.MAP.SELECTED.ITEMS TB.FIND.ITEM TB.ITEM.SELECTED? TB.ITEM.DELETED?) (FNS TB.CLEAR.LINE TB.USERDATA TB.WINDOW)) (COMS (* ; "Display") (FNS TB.REPAINTFN TB.RESHAPEFN TB.SCROLLFN TB.DISPLAY.LINES TB.PRINT.LINE TB.FIRST.VISIBLE.ITEM# TB.LAST.VISIBLE.ITEM# TB.ITEM.VISIBLE? TB.ITEM.FROM.YCOORD TB.BOTTOM.OF.ITEM TB.SHOW.DELETION TB.SHOW.SELECTION TB.UPDATE.DISPLAY TB.ITEM.UPDATABLE?)) (COMS (* ; "Selection") (FNS TB.BUTTONEVENTFN TB.DO.UNLESS.BUSY TB.DO.ITEM.SELECTION TB.CONTIGUOUS.SELP TB.DECONSIDERRANGE TB.CONSIDERRANGE TB.DESELECTRANGE TB.RECONSIDERRANGE TB.SELECTRANGE TB.UNDOSELECTION TB.FIND.SELECTED.ITEM TB.REV.FIND.SELECTED.ITEM) (FNS TB.COPYBUTTONEVENTFN TB.SHOW.COPY.SELECTION)) (COMS (* ; "Misc state change") (FNS TB.BROWSER.BUSY TB.CLOSE/SHRINK TB.CLOSEFN TB.FINISH.CLOSE TB.FLUSH.WINDOW TB.SET.FONT TB.SHRINKFN TB.EXPANDFN TB.FIND.PREVIOUS.TAIL TB.RENUMBER.TAIL)) (COMS (* ; "Misc") (FNS TB.PROCESS) (INITVARS (TB.DELETEDLINEHEIGHT 1)) (VARS TB.SELECTION.BITMAP) (CURSORS TB.CROSSCURSOR) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TBDECLS) (CONSTANTS * TOCSTATES) (MACROS .COPYKEYDOWNP.) (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) (LOCALVARS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TB.USERDATA))) (INITRECORDS TABLEBROWSER TABLEITEM) (SYSRECORDS TABLEBROWSER TABLEITEM))) (* ; "Entries") (DEFINEQ (TB.MAKE.BROWSER (LAMBDA (ITEMS WINDOWSPEC PROPS) (* ; "Edited 28-Jan-88 04:37 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (PROG ((LINESPERITEM 1) FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA WINDOW USERPROPS BROWSER ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (DECLARE (SPECVARS FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS)) (* ; "For SET below") (for TAIL on PROPS by (CDDR TAIL) do (SELECTQ (CAR TAIL) ((FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (SET (CAR TAIL) (CADR TAIL))) (push USERPROPS (LIST (CAR TAIL) (CADR TAIL))))) (SETQ WINDOW (DECODE.WINDOW.ARG WINDOWSPEC NIL NIL TITLE)) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) (SETQ BROWSER (create TABLEBROWSER TBWINDOW _ WINDOW TBFONT _ FONT TBLOCK _ (CREATE.MONITORLOCK (OR (WINDOWPROP WINDOW (QUOTE TITLE)) "Table Browser")) TB#LINESPERITEM _ (OR LINESPERITEM 1) TBBASELINE _ (OR BASELINE 0) TBCOLUMNS _ COLUMNS TBPRINTFN _ PRINTFN TBCOPYFN _ COPYFN TBCLOSEFN _ CLOSEFN TBAFTERCLOSEFN _ AFTERCLOSEFN TBUSERDATA _ USERDATA TBHEADINGWINDOW _ HEADINGWINDOW TBLINETHICKNESS _ (OR LINETHICKNESS TB.DELETEDLINEHEIGHT)))) (if ITEMHEIGHT then (* ; "User explicitly controlling height variables.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with ITEMHEIGHT) (replace (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER with T)) (DSPLEFTMARGIN TB.LEFT.MARGIN WINDOW) (TB.REPLACE.ITEMS BROWSER ITEMS) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION TB.SCROLLFN)) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION TB.REPAINTFN)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION TB.COPYBUTTONEVENTFN)) (for PROP in (QUOTE (CLOSEFN SHRINKFN RESHAPEFN)) do (* ;; "This used to be (progn (windowaddprop window 'closefn (function tb.closefn)) (windowaddprop window 'shrinkfn (function tb.shrinkfn)) (windowaddprop window 'reshapefn (function tb.reshapefn))). However, we want to be careful to put our stuff on before any attached window stuff, so that we can reject a CLOSE, for example, before CLOSEATTACHEDWINDOWS has already closed them. Could always put on front, but it's probably better to put our functions after any the user might have explicitly put there already.") (LET ((OLDP (WINDOWPROP WINDOW PROP)) (FN (PACK* "TB." PROP))) (if (NULL OLDP) then (SETQ OLDP (LIST FN)) else (for TAIL on (OR (LISTP OLDP) (SETQ OLDP (LIST OLDP))) do (if (EQ (CAR TAIL) FN) then (* ; "Window already has our fn!") (RETURN) elseif (STRPOS "ATTACHED" (CAR TAIL)) then (* ; "Insert before this attached window hacker") (RETURN (ATTACH FN TAIL))) finally (* ; "Put at end") (NCONC1 OLDP FN))) (WINDOWPROP WINDOW PROP OLDP))) (replace (TABLEBROWSER TBREADY) of BROWSER with T) (RETURN BROWSER))) ) (TB.REPLACE.ITEMS (LAMBDA (BROWSER NEWITEMS) (* ; "Edited 27-Jan-88 16:27 by bvm") (* ;; "Completely replace the current items with the specified items") (LET ((N 0) FIRSTSEL) (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (for ITEM in NEWITEMS do (* ; "Number the items") (freplace TI# of (\DTEST ITEM (QUOTE TABLEITEM)) with (add N 1))) (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL) (freplace (TABLEBROWSER TBITEMS) of BROWSER with NEWITEMS) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with N) (freplace (TABLEBROWSER TB#DELETED) of BROWSER with (for ITEM in NEWITEMS count (ffetch TIDELETED of ITEM))) (COND ((SETQ FIRSTSEL (TB.FIND.SELECTED.ITEM BROWSER 1 N)) (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with FIRSTSEL) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL N))) (T (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with (ADD1 N)) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with 0))) (TB.SET.FONT BROWSER) (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)))) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) ) (DEFINEQ (TB.DELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((NOT (ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM)))) (freplace (TABLEITEM TIDELETED) of ITEM with T) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 1) (if (TB.ITEM.UPDATABLE? BROWSER ITEM T) then (TB.SHOW.DELETION BROWSER ITEM (ffetch (TABLEBROWSER TBWINDOW) of BROWSER) (QUOTE REPLACE)))))) ) (TB.UNDELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM))) (freplace (TABLEITEM TIDELETED) of ITEM with NIL) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) -1) (COND ((TB.ITEM.UPDATABLE? BROWSER ITEM T) (LET ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE ERASE)) (* ; "reprint the line sans deletion mark") (TB.PRINT.LINE BROWSER ITEM WINDOW (ffetch (TABLEBROWSER TBPRINTFN) of BROWSER)))))))) ) (TB.INSERT.ITEM (LAMBDA (BROWSER NEWITEM BEFOREITEM) (* ; "Edited 27-Jan-88 16:08 by bvm") (* ;;; "Inserts NEWITEM in TABLEBROWSER before item BEFOREITEM or at the end if BEFOREITEM is NIL") (LET ((LASTITEM# (ffetch (TABLEBROWSER TB#ITEMS) of (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))))) BEFORE# TAIL N) (SETQ NEWITEM (\DTEST NEWITEM (QUOTE TABLEITEM))) (if BEFOREITEM then (SETQ BEFORE# (OR (FIXP BEFOREITEM) (ffetch TI# of (\DTEST BEFOREITEM (QUOTE TABLEITEM))))) (COND ((OR (> BEFORE# LASTITEM#) (< BEFORE# 1)) (* ; "Check for bad values") (\ILLEGAL.ARG BEFOREITEM))) else (SETQ BEFORE# (ADD1 LASTITEM#))) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (if (EQ BEFORE# 1) then (* ; "Goes at the beginning (or at the end of a null list)") (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CONS NEWITEM (ffetch (TABLEBROWSER TBITEMS) of BROWSER)))) else (* ; "Somewhere else--find the tail") (SETQ TAIL (if (NULL BEFOREITEM) then (* ; "Insert at end") (FLAST (OR (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER) (ffetch (TABLEBROWSER TBITEMS) of BROWSER))) else (TB.FIND.PREVIOUS.TAIL BROWSER BEFORE#))) (RPLACD TAIL (SETQ TAIL (CONS NEWITEM (CDR TAIL))))) (* ;; "Now (CAR TAIL) is the new item") (TB.RENUMBER.TAIL BROWSER TAIL BEFORE#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (ADD1 LASTITEM#)) (COND ((ffetch TIDELETED of NEWITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) 1))) (* ;; "Update first & last selected item if they fall after the insertion, or if the new item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((ffetch TISELECTED of NEWITEM) BEFORE#) (T (ADD1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBLASTSELECTEDITEM of BROWSER with (ADD1 N))) ((ffetch TISELECTED of NEWITEM) (freplace TBLASTSELECTEDITEM of BROWSER with BEFORE#))) (TB.UPDATE.DISPLAY BROWSER BEFORE# (QUOTE INSERT)))) ) (TB.REMOVE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:09 by bvm") (* ;;; "Removes ITEM from TABLEBROWSER") (LET ((LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (ITEM# (ffetch TI# of (\DTEST ITEM (QUOTE TABLEITEM)))) N TAIL) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (COND ((EQ ITEM# 1) (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CDR (ffetch (TABLEBROWSER TBITEMS) of BROWSER))))) (T (RPLACD (SETQ TAIL (TB.FIND.PREVIOUS.TAIL BROWSER ITEM#)) (SETQ TAIL (CDDR TAIL))))) (TB.RENUMBER.TAIL BROWSER TAIL ITEM#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (SUB1 LASTITEM#)) (COND ((ffetch TIDELETED of ITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) -1))) (* ;; "Update first & last selected item if they fall after the deletion or if the old item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the first selected, so look for next one after it") (OR (TB.FIND.SELECTED.ITEM BROWSER ITEM#) LASTITEM#)) (T (* ; "Item numbers are decremented") (SUB1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBLASTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the last selected, so look for next one before it") (OR (TB.REV.FIND.SELECTED.ITEM BROWSER NIL (SUB1 ITEM#)) 0)) (T (SUB1 N)))))) (TB.UPDATE.DISPLAY BROWSER ITEM# (QUOTE REMOVE)))) ) (TB.NORMALIZE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:22 by bvm") (* ;; "Scroll, if necessary, so that ITEM is visible in browser.") (LET* ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM)) (CLIP (DSPCLIPPINGREGION NIL WINDOW))) (COND ((OR (> (fetch (REGION BOTTOM) of CLIP) BOT) (< (fetch (REGION PTOP) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (* ; "Scroll so that item's midline is at midline of window") (SCROLLBYREPAINTFN WINDOW 0 (- (+ (fetch (REGION BOTTOM) of CLIP) (IQUOTIENT (fetch (REGION HEIGHT) of CLIP) 2)) (+ BOT (IQUOTIENT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) 2)))))))) ) (TB.REDISPLAY.ITEMS (LAMBDA (BROWSER FIRSTITEM LASTITEM) (* ; "Edited 2-Feb-88 11:53 by bvm:") (* ;; "Force redisplay of all items from FIRSTITEM to LASTITEM, e.g., because their content or format changed. We'll only redisplay the visible ones, of course. Also, if browser isn't open, we'll save the change until browser is expanded") (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))))) (if (AND (NULL FIRSTITEM) (NULL LASTITEM)) then (* ; "We're being told to redisplay the whole browser, so recompute the extent while we're at it (it might have gotten smaller).") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0)) (SETQ FIRSTITEM (IMAX (COND ((NULL FIRSTITEM) 1) ((FIXP FIRSTITEM)) (T (ffetch TI# of (\DTEST FIRSTITEM (QUOTE TABLEITEM))))) (TB.FIRST.VISIBLE.ITEM# BROWSER REGION))) (SETQ LASTITEM (IMIN (COND ((NULL LASTITEM) (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) ((FIXP LASTITEM)) (T (ffetch TI# of (\DTEST LASTITEM (QUOTE TABLEITEM))))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (if (AND (>= LASTITEM FIRSTITEM) (TB.ITEM.UPDATABLE? BROWSER FIRSTITEM)) then (TB.DISPLAY.LINES BROWSER FIRSTITEM LASTITEM)))) ) (TB.SELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (LET ((N (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))) (TB.SELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N T) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE REPLACE))))) ) (TB.UNSELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:09 by bvm") (if (ffetch (TABLEITEM TISELECTED) of (\DTEST ITEM (QUOTE TABLEITEM))) then (LET ((N (ffetch (TABLEITEM TI#) of ITEM))) (TB.DESELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE ERASE)))))) ) (TB.UNSELECT.ALL.ITEMS (LAMBDA (BROWSER) (* ; "Edited 29-Jan-88 12:14 by bvm") (* ;; "User entry for unselecting all items in the browser. ") (LET ((START (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (END (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER))) (if (<= START END) then (for I from START to END bind (UPDATABLE _ (TB.ITEM.UPDATABLE? BROWSER START)) ITEM when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) do (freplace TISELECTED of ITEM with NIL) (if UPDATABLE then (TB.SHOW.SELECTION BROWSER I (QUOTE ERASE)))) (freplace TBFIRSTSELECTEDITEM of BROWSER with (ADD1 (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (freplace TBLASTSELECTEDITEM of BROWSER with 0)))) ) ) (DEFINEQ (TB.NUMBER.OF.ITEMS (LAMBDA (BROWSER TYPE) (* ; "Edited 27-Jan-88 16:16 by bvm") (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (SELECTQ TYPE (NIL (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (DELETED (ffetch (TABLEBROWSER TB#DELETED) of BROWSER)) (SELECTED (for I from (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER) to (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER) count (ffetch (TABLEITEM TISELECTED) of (TB.NTH.ITEM BROWSER I)))) (\ILLEGAL.ARG TYPE))) ) (TB.NTH.ITEM (LAMBDA (BROWSER N) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;; "Return the Nth item of BROWSER, or NIL if N is out of range.") (* ;; "Browser items are currently stored as a simple list. To make most accesses reasonable, we save a hint to a recent tail of the list to speed up the search.") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET (TAIL TAILN) (if (AND (> N 0) (OR (AND (SETQ TAIL (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER)) (>= N (SETQ TAILN (ffetch (TABLEITEM TI#) of (CAR TAIL))))) (PROG1 (SETQ TAIL (ffetch (TABLEBROWSER TBITEMS) of BROWSER)) (* ; "Item is not in hint tail, have to search whole list") (SETQ TAILN 1)))) then (while (< TAILN N) do (if (NULL (SETQ TAIL (CDR TAIL))) then (* ; "Greater than last item. I could have done a comparison against #items, but it is rare to ask for this (and we never do internally).") (RETURN NIL)) (add TAILN 1) finally (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL) (* ; "Store away the new hint. This makes ascending iterations constant time, rather than n^2.") (RETURN (CAR TAIL)))))) ) (TB.COLLECT.ITEMS (LAMBDA (BROWSER PREDFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) collect ITEM when (OR (NULL PREDFN) (CL:FUNCALL PREDFN BROWSER ITEM)))) ) (TB.MAP.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEMS (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (COND (ITEMS (for ITEM in ITEMS do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (CL:FUNCALL NULLFN BROWSER))))) ) (TB.MAP.DELETED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each deleted item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (COND ((NEQ (ffetch TB#DELETED of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 0) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of BROWSER) when (ffetch TIDELETED of ITEM) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing deleted") (CL:FUNCALL NULLFN BROWSER)))) ) (TB.MAP.SELECTED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:19 by bvm") (* ;;; "Apply MAPFN to each selected item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEM# (SUB1 (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (LASTITEM# (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER)) ITEM) (COND ((< ITEM# LASTITEM#) (until (> (add ITEM# 1) LASTITEM#) when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#))) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing selected") (CL:FUNCALL NULLFN BROWSER))))) ) (TB.FIND.ITEM (LAMBDA (BROWSER PREDFN FIRST# LAST# BACKWARDSFLG) (* ; "Edited 27-Jan-88 16:20 by bvm") (* ;;; "Returns the first item in the designated range satisfying (PREDFN browser item); range defaults to whole browser") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET ((LO (COND (FIRST# (IMAX FIRST# 1)) (T 1))) (HI (COND (LAST# (IMIN LAST# (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (T (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)))) I END INCREMENT ITEM) (COND ((<= LO HI) (COND (BACKWARDSFLG (SETQ I (ADD1 HI)) (SETQ END LO) (SETQ INCREMENT -1)) (T (SETQ I (SUB1 LO)) (SETQ END HI) (SETQ INCREMENT 1))) (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (when (CL:FUNCALL PREDFN BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER (add I INCREMENT)))) do (RETURN ITEM) repeatuntil (EQ I END)))))) ) (TB.ITEM.SELECTED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TISELECTED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) (TB.ITEM.DELETED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TIDELETED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) ) (DEFINEQ (TB.CLEAR.LINE (LAMBDA (BROWSER ITEM LEFT WIDTH) (* ; "Edited 22-Jan-88 16:06 by bvm") (* ;;; "Clears the contents of ITEM's line starting at xpos LEFT for width WIDTH. Defaults to whole line") (BLTSHADE WHITESHADE (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (OR LEFT 0) (TB.BOTTOM.OF.ITEM BROWSER ITEM) WIDTH (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (QUOTE REPLACE))) ) (TB.USERDATA (CL:LAMBDA (BROWSER &OPTIONAL (NEWDATA NIL NEWP)) (* ; "Edited 27-Jan-88 16:25 by bvm") (PROG1 (ffetch (TABLEBROWSER TBUSERDATA) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (COND (NEWP (freplace (TABLEBROWSER TBUSERDATA) of BROWSER with NEWDATA))))) ) (TB.WINDOW (LAMBDA (BROWSER) (* ; "Edited 27-Jan-88 16:25 by bvm") (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) ) ) (* ; "Display") (DEFINEQ (TB.REPAINTFN (LAMBDA (WINDOW REGION) (* bvm%: "10-Sep-85 13:00") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (AND (NEQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (T (TB.BROWSER.BUSY BROWSER))))))) ) (TB.RESHAPEFN (LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 22-Jan-88 10:21 by bvm") (RESETLST (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) ITEM#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (* ; "Browser is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) NIL T)) ((NOT (fetch (TABLEBROWSER TBREADY) of BROWSER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ ITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER REGION)) (TB.SET.FONT BROWSER) (WYOFFSET (TIMES (SUB1 ITEM#) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) WINDOW) (TB.DISPLAY.LINES BROWSER ITEM# (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) (TB.SCROLLFN (LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 22-Jan-88 17:32 by bvm") (* ;; "only scroll if can get the monitor lock") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HW) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG) (if (AND (EQ DY 0) (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER))) then (* ; "Horizontally scroll the header window together with it.") (SCROLLW HW DX DY CONTINUOUSFLG))) (T (TB.BROWSER.BUSY BROWSER)))))) ) (TB.DISPLAY.LINES (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 25-Jan-88 18:34 by bvm") (for ITEM# from (IMAX FIRST# 1) to (IMIN LAST# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) bind (WINDOW _ (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (MAXXPOS _ (fetch (TABLEBROWSER TBMAXXPOS) of BROWSER)) (PRINTFN _ (fetch (TABLEBROWSER TBPRINTFN) of BROWSER)) EXTENTCHANGED ITEM HERE EXTENT HWINDOW do (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#)) (TB.PRINT.LINE BROWSER ITEM WINDOW PRINTFN) (* ; "keep track of maximum width printed to, so window's EXTENT is always right") (COND ((< MAXXPOS (SETQ HERE (DSPXPOSITION NIL WINDOW))) (SETQ MAXXPOS HERE) (SETQ EXTENTCHANGED T))) finally (COND (EXTENTCHANGED (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with MAXXPOS) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) with MAXXPOS) (WINDOWPROP WINDOW (QUOTE EXTENT) EXTENT) (if (SETQ HWINDOW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Update heading window extent, too. Width has to account for the difference, if any, in borders.") (replace (REGION WIDTH) of (SETQ EXTENT (WINDOWPROP HWINDOW (QUOTE EXTENT))) with (+ MAXXPOS (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HWINDOW (QUOTE BORDER))))))))))) ) (TB.PRINT.LINE (LAMBDA (BROWSER ITEM WINDOW PRINTFN) (* ; "Edited 22-Jan-88 17:16 by bvm") (MOVETO TB.LEFT.MARGIN (+ (TB.BOTTOM.OF.ITEM BROWSER ITEM) (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) WINDOW) (* ; "Move to item's baseline") (POSITION WINDOW 0) (CL:FUNCALL PRINTFN BROWSER ITEM WINDOW) (TB.SHOW.SELECTION BROWSER ITEM (COND ((fetch (TABLEITEM TISELECTED) of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))) (COND ((fetch (TABLEITEM TIDELETED) of ITEM) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE REPLACE))))) ) (TB.FIRST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 16:59 by bvm") (* ;; "Computes number of the first item in TABLEBROWSER that is visible in REGION") (IMAX 1 (ADD1 (IQUOTIENT (- (ffetch (TABLEBROWSER TBORIGIN) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (fetch (REGION PTOP) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))))) ) (TB.LAST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 17:00 by bvm") (* ;; "Computes number of the last item in TABLEBROWSER that is visible in REGION") (IMIN (ffetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (CL:CEILING (- (ffetch (TABLEBROWSER TBORIGIN) of BROWSER) (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) ) (TB.ITEM.VISIBLE? (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:12 by bvm") (* ;;; "True if any part of ITEM is visible in window of BROWSER") (LET ((CLIP (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM))) (* ;; "Check bottom of line is below top, and top of line is above the bottom") (AND (< BOT (fetch (REGION PTOP) of CLIP)) (< (fetch (REGION BOTTOM) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))))) ) (TB.ITEM.FROM.YCOORD (LAMBDA (BROWSER YPOS) (* ; "Edited 22-Jan-88 16:41 by bvm") (LET ((N (CL:CEILING (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) YPOS) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (TB.NTH.ITEM BROWSER (COND ((<= N 0) 1) (T (IMIN N (fetch (TABLEBROWSER TB#ITEMS) of BROWSER))))))) ) (TB.BOTTOM.OF.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:11 by bvm") (* ;; "Returns the y position of the bottom of specified item (number or tableitem). Add the font descent to get the baseline of the first line.") (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) (TIMES (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (OR (FIXP ITEM) (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))))) ) (TB.SHOW.DELETION (LAMBDA (BROWSER ITEM WINDOW OPERATION) (* ; "Edited 27-Jan-88 17:00 by bvm") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that ITEM is deleted") (LET ((THICKNESS (fetch (TABLEBROWSER TBLINETHICKNESS) of BROWSER)) (BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER))) (BLTSHADE BLACKSHADE WINDOW TB.LEFT.MARGIN (PROGN (* ;; "Center the deletion line between the baseline and the top of the item") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE THICKNESS) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL THICKNESS OPERATION))) ) (TB.SHOW.SELECTION (LAMBDA (BROWSER ITEM OPERATION) (* ; "Edited 27-Jan-88 15:42 by bvm") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that ITEM is selected") (LET ((BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) (BM TB.SELECTION.BITMAP)) (BITBLT BM 0 0 (fetch (TABLEBROWSER TBWINDOW) of BROWSER) 0 (PROGN (* ;; "Center the selection bitmap between the baseline and the top of the item, rounding down slightly on the grounds that the top pixel of the line tends to be blank, so the center of gravity is lower than it might be.") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE (fetch BITMAPHEIGHT of BM)) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL NIL (QUOTE INPUT) OPERATION))) ) (TB.UPDATE.DISPLAY (LAMBDA (BROWSER FROMITEM# TYPE) (* ; "Edited 11-Feb-88 11:34 by bvm") (* ;;; "Updates the display window appropriately after a TYPE operation (REMOVE or INSERT) on TABLEBROWSER that affects items starting at FROMITEM#") (PROG ((WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) (LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (ITEMHEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) (ITEMBOTTOM (TB.BOTTOM.OF.ITEM BROWSER FROMITEM#)) DELTA HEIGHT LAST# CLIP WBOTTOM EXTENTBOTTOM) (* ; "YPOS is the bottom of the line corresponding to FROMITEM#") (add (fetch (REGION HEIGHT) of EXTENT) (SETQ DELTA (SELECTQ TYPE (REMOVE (- ITEMHEIGHT)) (INSERT ITEMHEIGHT) (SHOULDNT)))) (SETQ CLIP (DSPCLIPPINGREGION NIL WINDOW)) (COND ((>= ITEMBOTTOM (fetch (REGION PTOP) of CLIP)) (* ; "Changed item above top of window, so no visible change -- just cheat the origin appropriately") (add (fetch (TABLEBROWSER TBORIGIN) of BROWSER) DELTA)) (T (* ; "Changed item visible or below bottom of window, so bottom of extent changes") (replace (REGION BOTTOM) of EXTENT with (SETQ EXTENTBOTTOM (- (fetch (REGION BOTTOM) of EXTENT) DELTA))) (COND ((<= (+ ITEMBOTTOM ITEMHEIGHT) (SETQ WBOTTOM (fetch (REGION BOTTOM) of CLIP))) (* ; "Below bottom of window, so we're done")) ((TB.ITEM.UPDATABLE? BROWSER FROMITEM#) (* ; "If window is visible, update it now") (SELECTQ TYPE (INSERT (* ; "Push everything from line FROMITEM# down one line, then redisplay item FROMITEM#") (BITBLT WINDOW 0 (+ WBOTTOM ITEMHEIGHT) WINDOW 0 WBOTTOM NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER FROMITEM# FROMITEM#)) (REMOVE (* ; "Pull everything below line FROMITEM# up one line, then redisplay last visible item(s)") (BITBLT WINDOW 0 WBOTTOM WINDOW 0 (+ WBOTTOM ITEMHEIGHT) NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER (SETQ LAST# (+ FROMITEM# (IQUOTIENT (- ITEMBOTTOM WBOTTOM) ITEMHEIGHT))) (ADD1 LAST#)) (* ; "May have to display two lines if the bottom line of window was a half line") (COND ((> EXTENTBOTTOM WBOTTOM) (* ; "Clear everything below the extent") (BLTSHADE WHITESHADE WINDOW 0 WBOTTOM NIL (- EXTENTBOTTOM WBOTTOM) (QUOTE REPLACE))))) (SHOULDNT)))))))) ) (TB.ITEM.UPDATABLE? (LAMBDA (BROWSER ITEM ONLYIFVISIBLE) (* ; "Edited 29-Jan-88 12:08 by bvm") (* ;;; "True if window of BROWSER is open. If false, we update the TBUPDATEFROMHERE field, denoting that we should repaint window when it is opened. If ONLYIFVISIBLE is true, we do nothing and return NIL if the item is not currently visible.") (OR (FIXP ITEM) (SETQ ITEM (fetch TI# of ITEM))) (COND ((AND ONLYIFVISIBLE (NOT (TB.ITEM.VISIBLE? BROWSER ITEM))) (* ; "Item not visible, so no need to change display") NIL) ((OPENWP (fetch (TABLEBROWSER TBWINDOW) of BROWSER))) (T (LET ((OLDN (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER))) (COND ((OR (NULL OLDN) (< ITEM OLDN)) (* ; "Mark browser for display update after being unshrunk") (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with ITEM)))) NIL))) ) ) (* ; "Selection") (DEFINEQ (TB.BUTTONEVENTFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 15:23") (TOTOPW WINDOW) (LET (FN) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (TB.DO.UNLESS.BUSY WINDOW (FUNCTION TB.DO.ITEM.SELECTION))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((AND (LASTMOUSESTATE (ONLY MIDDLE)) (SETQ FN (fetch (TABLEBROWSER TBTITLEEVENTFN) of (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))))) (TB.DO.UNLESS.BUSY WINDOW FN))))) ) (TB.DO.UNLESS.BUSY (LAMBDA (WINDOW FN) (* ; "Edited 20-Jan-88 23:30 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (COND ((AND (fetch (TABLEBROWSER TBREADY) of BROWSER) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (CL:FUNCALL FN WINDOW BROWSER)))))) ) (TB.DO.ITEM.SELECTION (LAMBDA (WINDOW) (* ; "Edited 20-Jan-88 22:17 by bvm") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS) (SPECVARS SELECTIONSTATE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION FIRST# LAST# FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE NEWSELECTION OLDSELECTION SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS ITEM LASTX LASTY) (COND ((EQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch TBLASTSELECTEDITEM of BROWSER)) (SETQ FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER)) (SETQ FIRSTVISIBLE# (TB.FIRST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (SETQ LASTVISIBLE# (TB.LAST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (* ; "Forget what we were doing") (SETQ OLDSELECTION))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (AND OLDSELECTION (SETQ OLDSEL# (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.REPLACING (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (replace TISELECTED of OLDSELECTION with T) (replace TBFIRSTSELECTEDITEM of BROWSER with (replace TBLASTSELECTEDITEM of BROWSER with OLDSEL#))) (TS.ADDING (TB.SELECTRANGE BROWSER OLDSEL# OLDSEL# T)) (TS.REMOVING (TB.DESELECTRANGE BROWSER OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (TB.SELECTRANGE BROWSER (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (TB.SELECTRANGE BROWSER OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (TB.DESELECTRANGE BROWSER (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (TB.DESELECTRANGE BROWSER FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND NIL (* ; "In a special column")) (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (SETQ OLDSELECTION)))) ((OR (NEQ (SETQ NEWSELECTION (TB.ITEM.FROM.YCOORD BROWSER LASTY)) OLDSELECTION) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (* ; "Something changed") (COND ((AND (fetch TIUNSELECTABLE of NEWSELECTION) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Can't select that item, so revert to idle") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION)))) ((AND (LASTMOUSESTATE (OR LEFT MIDDLE)) (SHIFTDOWNP (QUOTE CTRL))) (* ; "Deselect this item") (SELECTC SELECTIONSTATE (TS.REMOVING (* ; "we were deselecting, so reselect that guy") (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE REPLACE))) (TS.IDLE (* ; "nothing going on")) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((fetch TISELECTED of NEWSELECTION) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single item") (COND ((EQ SELECTIONSTATE TS.REPLACING) (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (T (TB.DECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.REPLACING))) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this item to the selection") (SELECTC SELECTIONSTATE (TS.ADDING (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (TS.IDLE) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((NOT (fetch TISELECTED of NEWSELECTION)) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SETQ SEL# (fetch TI# of NEWSELECTION)) (SETQ OLDSEL# (AND OLDSELECTION (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (COND ((<= FIRST# LAST#) (* ; "Something is already selected, so we can think about extending.") (COND ((NEQ SELECTIONSTATE TS.IDLE) (* ; "Cancel any selection we were thinking about") (TB.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ SELECTIONSTATE (COND ((> SEL# LAST#) (TB.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (TB.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (* ; "we are closer to the high end, but inside. Shrink from the top, but only if we are pointing at a contigous selection") (if (TB.CONTIGUOUS.SELP BROWSER SEL# (SUB1 LAST#)) then (TB.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI else TS.IDLE)) (T (* ; "We are closer to the low end, so shrink from bottom") (if (TB.CONTIGUOUS.SELP BROWSER (ADD1 FIRST#) SEL#) then (TB.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO else TS.IDLE))))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSELECTION NEWSELECTION)))))) ) (TB.CONTIGUOUS.SELP (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:16 by bvm") (* ;; "true if all the elements of ITEMS from FIRST# to LAST# are selected (or deleted or unselectable)") (for I from FIRST# to LAST# bind ITEM always (OR (fetch TISELECTED of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) (fetch TIDELETED of ITEM) (fetch TIUNSELECTABLE of ITEM)))) ) (TB.DECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as unselected.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) do (TB.SHOW.SELECTION BROWSER (TB.NTH.ITEM BROWSER I) (QUOTE ERASE)))) ) (TB.CONSIDERRANGE (LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as selected. Deleted items are not selected unless EVENIFDELETED is true") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (TB.SHOW.SELECTION BROWSER ITEM (QUOTE REPLACE)))))) ) (TB.DESELECTRANGE (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as unselected. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified--use TB.UNSELECT.ALL.ITEMS to do both") (LET ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER))) (if (< FIRST# FIRSTSEL) then (SETQ FIRST# FIRSTSEL)) (if (> LAST# LASTSEL) then (SETQ LAST# LASTSEL)) (if (<= FIRST# LAST#) then (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (COND ((EQ FIRST# FIRSTSEL) (replace TBFIRSTSELECTEDITEM of BROWSER with (COND ((TB.FIND.SELECTED.ITEM BROWSER (ADD1 LAST#) LASTSEL)) (T (replace TBLASTSELECTEDITEM of BROWSER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)))))) ((EQ LAST# LASTSEL) (replace TBLASTSELECTEDITEM of BROWSER with (OR (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL (SUB1 FIRST#)) 1))))))) ) (TB.RECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (TB.SHOW.SELECTION BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((fetch TISELECTED of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) ) (TB.SELECTRANGE (LAMBDA (BROWSER FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:10 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified") (PROG ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER)) ITEM) (for I from FIRST# to LAST# do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (replace TISELECTED of ITEM with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER))) (replace TBFIRSTSELECTEDITEM of BROWSER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch TBLASTSELECTEDITEM of BROWSER))) (replace TBLASTSELECTEDITEM of BROWSER with LAST#))))) ) (TB.UNDOSELECTION (LAMBDA NIL (* bvm%: " 6-Sep-85 15:04") (* ;;; "Restore browser to state before any selections were attempted") (DECLARE (USEDFREE FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE)) (TB.RECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.IDLE)) ) (TB.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR FIRST# 1) to (OR LAST# (fetch TB#ITEMS of BROWSER)) suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) (TB.REV.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR LAST# (fetch TB#ITEMS of BROWSER)) to (OR FIRST# 1) by -1 suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) ) (DEFINEQ (TB.COPYBUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 22-Jan-88 12:08 by bvm") (* ;;; "copy select an item from the window.") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION COPYFN CURRENTITEM NEWITEM LASTX LASTY) (COND ((OR (NULL (SETQ COPYFN (fetch (TABLEBROWSER TBCOPYFN) of BROWSER))) (NULL (fetch (TABLEBROWSER TBITEMS) of BROWSER))) (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) LP (TOTOPW WINDOW) (COND ((AND (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (TB.ITEM.FROM.YCOORD BROWSER LASTY))) (fetch TIUNCOPYSELECTABLE of NEWITEM)) (SETQ NEWITEM NIL))) (COND ((NEQ CURRENTITEM NEWITEM) (COND (CURRENTITEM (* ; "turn off old selection.") (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))) (COND ((SETQ CURRENTITEM NEWITEM) (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))))) (* ; "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM) (CL:FUNCALL COPYFN BROWSER CURRENTITEM))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, no action") (GO LP2)) (T (GO LP))))) ) (TB.SHOW.COPY.SELECTION (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:38 by bvm") (* ;;; "underline this item in browser") (BLTSHADE GRAYSHADE (fetch (TABLEBROWSER TBWINDOW) of BROWSER) TB.LEFT.MARGIN (TB.BOTTOM.OF.ITEM BROWSER ITEM) NIL 2 (QUOTE INVERT))) ) ) (* ; "Misc state change") (DEFINEQ (TB.BROWSER.BUSY (LAMBDA (BROWSER) (* bvm%: " 8-Sep-85 16:42") (RESETFORM (CURSOR TB.CROSSCURSOR) (BLOCK 1000)))) (TB.CLOSE/SHRINK (LAMBDA (WINDOW FLG) (* ; "Edited 20-Jan-88 23:36 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (COND ((AND (SETQ HOW? (fetch (TABLEBROWSER TBCLOSEFN) of BROWSER)) (SETQ HOW? (CL:FUNCALL HOW? BROWSER WINDOW FLG))) (COND ((NEQ HOW? (QUOTE DON'T)) (TB.PROCESS (BQUOTE ((\, HOW?) (QUOTE (\, BROWSER)) (QUOTE (\, WINDOW)) (QUOTE (\, FLG)))) (QUOTE TB.UPDATE)))) (QUOTE DON'T)) (T (TB.FINISH.CLOSE BROWSER WINDOW FLG T) NIL))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) ) (TB.CLOSEFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:25") (TB.CLOSE/SHRINK WINDOW (QUOTE CLOSE)))) (TB.FINISH.CLOSE (LAMBDA (BROWSER WINDOW CLOSEFLG DONTCLOSE) (* bvm%: " 9-Sep-85 00:42") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge. DONTCLOSE is true if neither occurred, in which case we are being called directly from the CLOSEFN and should not close/shrink the window ourselves") (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (SELECTQ CLOSEFLG (CLOSE (SETQ WINDOW (TB.FLUSH.WINDOW BROWSER WINDOW)) (OR DONTCLOSE (CLOSEW WINDOW))) (SHRINK (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION TB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN)) (OR DONTCLOSE (SHRINKW WINDOW))) NIL))) ) (TB.FLUSH.WINDOW (LAMBDA (BROWSER WINDOW) (* ; "Edited 20-Jan-88 22:42 by bvm") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION TB.CLOSEFN)) (ERSETQ (LET ((FN (fetch (TABLEBROWSER TBAFTERCLOSEFN) of BROWSER))) (AND FN (CL:FUNCALL FN BROWSER WINDOW)))) (replace (TABLEBROWSER TBITEMS) of BROWSER with (replace (TABLEBROWSER TBWINDOW) of BROWSER with (replace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL))) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) NIL) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) ) (TB.SET.FONT (LAMBDA (BROWSER FONT) (* ; "Edited 10-Feb-88 11:07 by bvm:") (* ;;; "Sets/changes font of TABLEBROWSER to be FONT. Clears window. Caller is responsible for repainting window") (LET ((FONTGIVEN FONT) (WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) WIDTH HEIGHT ASCENT TOTALHEIGHT ORIGIN FN EXTENT HW) (CLEARW WINDOW) (SETQ FONT (FONTCREATE (OR FONT (fetch (TABLEBROWSER TBFONT) of BROWSER) (DSPFONT NIL WINDOW)))) (DSPFONT FONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH T WINDOW) (replace (TABLEBROWSER TBFONT) of BROWSER with FONT) (replace (TABLEBROWSER TBFONTHEIGHT) of BROWSER with (SETQ HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))) (if (NOT (fetch (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER)) then (* ; "Compute item heights. Don't do this if user gave an explicit height.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with (SETQ HEIGHT (TIMES HEIGHT (fetch (TABLEBROWSER TB#LINESPERITEM) of BROWSER)))) (replace (TABLEBROWSER TBFONTASCENT) of BROWSER with (SETQ ASCENT (FONTPROP FONT (QUOTE ASCENT)))) (replace (TABLEBROWSER TBBASELINE) of BROWSER with (- HEIGHT ASCENT)) else (SETQ HEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))) (replace (TABLEBROWSER TBORIGIN) of BROWSER with (SETQ ORIGIN (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOTALHEIGHT (TIMES (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (TABLEBROWSER TBEXTENT) of BROWSER with (create REGION LEFT _ 0 BOTTOM _ (- ORIGIN TOTALHEIGHT) WIDTH _ 0 HEIGHT _ TOTALHEIGHT))) (* ; "Let extent width be zero until we print something") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0) (if (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Fix extent of header window, too. Be sure to account for different size of borders, if any") (LET ((HWIDTH (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HW (QUOTE BORDER)))))) (if (SETQ EXTENT (WINDOWPROP HW (QUOTE EXTENT))) then (replace (REGION WIDTH) of EXTENT with HWIDTH) else (WINDOWPROP HW (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ HWIDTH HEIGHT _ -1))))) (COND ((AND FONTGIVEN (SETQ FN (fetch (TABLEBROWSER TBFONTCHANGEFN) of BROWSER))) (* ; "Notify application program of font change") (CL:FUNCALL FN BROWSER WINDOW))))) ) (TB.SHRINKFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:14") (TB.CLOSE/SHRINK WINDOW (QUOTE SHRINK)))) (TB.EXPANDFN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 16:53 by bvm") (* ;;; "If browser changed while it was shrunk, update display accordingly") (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (LET ((FIRSTCHANGEDITEM# (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER)) REGION FN) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN) T) (COND (FIRSTCHANGEDITEM# (* ; "Browser has changed since shrinking") (TB.DISPLAY.LINES BROWSER (IMAX FIRSTCHANGEDITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION)) (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with NIL))))))) ) (TB.FIND.PREVIOUS.TAIL (LAMBDA (BROWSER ITEM#) (* ; "Edited 20-Jan-88 23:23 by bvm") (* ;; "Return the tail of BROWSER's items whose CADR is ITEM#. Assumes ITEM# at least 2 and not greater than number of items") (LET (TAIL TAILN) (if (OR (NULL (SETQ TAIL (fetch (TABLEBROWSER TBTAILHINT) of BROWSER))) (< ITEM# (SETQ TAILN (ADD1 (fetch (TABLEITEM TI#) of (CAR TAIL)))))) then (* ; "Can't use the hint") (SETQ TAIL (fetch (TABLEBROWSER TBITEMS) of BROWSER)) (SETQ TAILN 2)) (* ;; "TAILN is the number of (CADR TAIL). Want to get TAIL pointing to one before the requested number") (while (< TAILN ITEM#) do (SETQ TAIL (CDR TAIL)) (add TAILN 1)) (if (OR (NULL TAIL) (NEQ TAILN ITEM#)) then (HELP "Failed to find item tail" ITEM#)) TAIL)) ) (TB.RENUMBER.TAIL (LAMBDA (BROWSER TAIL FIRST#) (* ; "Edited 20-Jan-88 23:22 by bvm") (* ;; "Renumbers all of BROWSER's items from TAIL onward, giving (CAR TAIL) the number FIRST#. Also updates tail hint.") (for ITEM in TAIL as I from FIRST# do (replace TI# of ITEM with I)) (replace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL)) ) ) (* ; "Misc") (DEFINEQ (TB.PROCESS (LAMBDA (FORM NAME ALLOWLOGOUT RESTARTABLE) (* bvm%: "25-Mar-84 17:16") (* ;;; "Creates a process running FORM which by default is not restartable and will not permit LOGOUT while it is running") (ADD.PROCESS FORM (QUOTE NAME) NAME (QUOTE RESTARTABLE) (OR RESTARTABLE (QUOTE NO)) (QUOTE BEFOREEXIT) (COND (ALLOWLOGOUT NIL) (T (QUOTE DON'T))))) ) ) (RPAQ? TB.DELETEDLINEHEIGHT 1) (RPAQQ TB.SELECTION.BITMAP #*(8 9)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@) (RPAQ TB.CROSSCURSOR (CURSORCREATE (QUOTE #*(16 16)L@@CN@@GG@@NCHALALCH@NG@@GN@@CL@@CL@@GN@@NG@ALCHCHALG@@NN@@GL@@C ) (QUOTE NIL) 8 8)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TBDECLS) (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .COPYKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TB.USERDATA) ) (/DECLAREDATATYPE 'TABLEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER)) '48) (/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD) '((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 (FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 0 POINTER) (TABLEITEM 2 (BITS . 15)) (TABLEITEM 3 (BITS . 15))) '4) (ADDTOVAR SYSTEMRECLST (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (NIL 6 FLAG) (TBITEMS POINTER) (TB#ITEMS WORD) (TB#DELETED WORD) (TB#LINESPERITEM WORD) (TBFIRSTSELECTEDITEM WORD) (TBLASTSELECTEDITEM WORD) (TBITEMHEIGHT WORD) (TBMAXXPOS WORD) (TBFONTHEIGHT WORD) (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (TBLOCK POINTER) (TBUSERDATA POINTER) (TBFONT POINTER) (TBEXTENT POINTER) (TBUPDATEFROMHERE POINTER) (TBCOLUMNS POINTER) (TBPRINTFN POINTER) (TBCOPYFN POINTER) (TBFONTCHANGEFN POINTER) (TBCLOSEFN POINTER) (TBAFTERCLOSEFN POINTER) (TBTITLEEVENTFN POINTER) (TBLINETHICKNESS POINTER) (TBORIGIN POINTER) (TBTAILHINT POINTER) (TBHEADINGWINDOW POINTER) (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))) ) (PUTPROPS TABLEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 1994 1995) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3140 7491 (TB.MAKE.BROWSER 3150 . 6266) (TB.REPLACE.ITEMS 6268 . 7489)) (7492 15382 ( TB.DELETE.ITEM 7502 . 7936) (TB.UNDELETE.ITEM 7938 . 8517) (TB.INSERT.ITEM 8519 . 10526) ( TB.REMOVE.ITEM 10528 . 12060) (TB.NORMALIZE.ITEM 12062 . 12775) (TB.REDISPLAY.ITEMS 12777 . 13967) ( TB.SELECT.ITEM 13969 . 14274) (TB.UNSELECT.ITEM 14276 . 14631) (TB.UNSELECT.ALL.ITEMS 14633 . 15380)) (15383 19909 (TB.NUMBER.OF.ITEMS 15393 . 15875) (TB.NTH.ITEM 15877 . 16951) (TB.COLLECT.ITEMS 16953 . 17324) (TB.MAP.ITEMS 17326 . 17690) (TB.MAP.DELETED.ITEMS 17692 . 18139) (TB.MAP.SELECTED.ITEMS 18141 . 18748) (TB.FIND.ITEM 18750 . 19623) (TB.ITEM.SELECTED? 19625 . 19766) (TB.ITEM.DELETED? 19768 . 19907)) (19910 20751 (TB.CLEAR.LINE 19920 . 20332) (TB.USERDATA 20334 . 20600) (TB.WINDOW 20602 . 20749)) (20776 31034 (TB.REPAINTFN 20786 . 21197) (TB.RESHAPEFN 21199 . 22037) (TB.SCROLLFN 22039 . 22590) (TB.DISPLAY.LINES 22592 . 23849) (TB.PRINT.LINE 23851 . 24371) (TB.FIRST.VISIBLE.ITEM# 24373 . 24810) (TB.LAST.VISIBLE.ITEM# 24812 . 25285) (TB.ITEM.VISIBLE? 25287 . 25807) (TB.ITEM.FROM.YCOORD 25809 . 26119) (TB.BOTTOM.OF.ITEM 26121 . 26534) (TB.SHOW.DELETION 26536 . 27158) (TB.SHOW.SELECTION 27160 . 27929) (TB.UPDATE.DISPLAY 27931 . 30216) (TB.ITEM.UPDATABLE? 30218 . 31032)) (31061 42474 ( TB.BUTTONEVENTFN 31071 . 31530) (TB.DO.UNLESS.BUSY 31532 . 31839) (TB.DO.ITEM.SELECTION 31841 . 37915) (TB.CONTIGUOUS.SELP 37917 . 38284) (TB.DECONSIDERRANGE 38286 . 38654) (TB.CONSIDERRANGE 38656 . 39227 ) (TB.DESELECTRANGE 39229 . 40291) (TB.RECONSIDERRANGE 40293 . 40791) (TB.SELECTRANGE 40793 . 41733) ( TB.UNDOSELECTION 41735 . 42012) (TB.FIND.SELECTED.ITEM 42014 . 42237) (TB.REV.FIND.SELECTED.ITEM 42239 . 42472)) (42475 43974 (TB.COPYBUTTONEVENTFN 42485 . 43705) (TB.SHOW.COPY.SELECTION 43707 . 43972)) ( 44009 50316 (TB.BROWSER.BUSY 44019 . 44136) (TB.CLOSE/SHRINK 44138 . 44770) (TB.CLOSEFN 44772 . 44873) (TB.FINISH.CLOSE 44875 . 45528) (TB.FLUSH.WINDOW 45530 . 46057) (TB.SET.FONT 46059 . 48357) ( TB.SHRINKFN 48359 . 48462) (TB.EXPANDFN 48464 . 49229) (TB.FIND.PREVIOUS.TAIL 49231 . 49973) ( TB.RENUMBER.TAIL 49975 . 50314)) (50338 50711 (TB.PROCESS 50348 . 50709))))) STOP \ No newline at end of file diff --git a/library/TABLEBROWSER.~2~ b/library/TABLEBROWSER.~2~ deleted file mode 100644 index d895c4db..00000000 --- a/library/TABLEBROWSER.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Jun-99 00:30:27" {DSK}medley3.5>library>TABLEBROWSER.;3 56000 previous date%: "24-Aug-95 15:31:14" {DSK}medley3.5>library>TABLEBROWSER.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993, 1994, 1995, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TABLEBROWSERCOMS) (RPAQQ TABLEBROWSERCOMS ((COMS (* ; "Entries") (FNS TB.MAKE.BROWSER TB.REPLACE.ITEMS) (FNS TB.DELETE.ITEM TB.UNDELETE.ITEM TB.INSERT.ITEM TB.REMOVE.ITEM TB.NORMALIZE.ITEM TB.REDISPLAY.ITEMS TB.SELECT.ITEM TB.UNSELECT.ITEM TB.UNSELECT.ALL.ITEMS) (FNS TB.NUMBER.OF.ITEMS TB.NTH.ITEM TB.COLLECT.ITEMS TB.MAP.ITEMS TB.MAP.DELETED.ITEMS TB.MAP.SELECTED.ITEMS TB.FIND.ITEM TB.ITEM.SELECTED? TB.ITEM.DELETED?) (FNS TB.CLEAR.LINE TB.USERDATA TB.WINDOW)) (COMS (* ; "Display") (FNS TB.REPAINTFN TB.RESHAPEFN TB.SCROLLFN TB.DISPLAY.LINES TB.PRINT.LINE TB.FIRST.VISIBLE.ITEM# TB.LAST.VISIBLE.ITEM# TB.ITEM.VISIBLE? TB.ITEM.FROM.YCOORD TB.BOTTOM.OF.ITEM TB.SHOW.DELETION TB.SHOW.SELECTION TB.UPDATE.DISPLAY TB.ITEM.UPDATABLE?)) (COMS (* ; "Selection") (FNS TB.BUTTONEVENTFN TB.DO.UNLESS.BUSY TB.DO.ITEM.SELECTION TB.CONTIGUOUS.SELP TB.DECONSIDERRANGE TB.CONSIDERRANGE TB.DESELECTRANGE TB.RECONSIDERRANGE TB.SELECTRANGE TB.UNDOSELECTION TB.FIND.SELECTED.ITEM TB.REV.FIND.SELECTED.ITEM) (FNS TB.COPYBUTTONEVENTFN TB.SHOW.COPY.SELECTION)) (COMS (* ; "Misc state change") (FNS TB.BROWSER.BUSY TB.CLOSE/SHRINK TB.CLOSEFN TB.FINISH.CLOSE TB.FLUSH.WINDOW TB.SET.FONT TB.SHRINKFN TB.EXPANDFN TB.FIND.PREVIOUS.TAIL TB.RENUMBER.TAIL)) (COMS (* ; "Misc") (FNS TB.PROCESS) (INITVARS (TB.DELETEDLINEHEIGHT 1)) (VARS TB.SELECTION.BITMAP) (CURSORS TB.CROSSCURSOR) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TBDECLS) (CONSTANTS * TOCSTATES) (MACROS .COPYKEYDOWNP.) (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) (LOCALVARS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TB.USERDATA))) (INITRECORDS TABLEBROWSER TABLEITEM) (SYSRECORDS TABLEBROWSER TABLEITEM))) (* ; "Entries") (DEFINEQ (TB.MAKE.BROWSER (LAMBDA (ITEMS WINDOWSPEC PROPS) (* ; "Edited 28-Jan-88 04:37 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (PROG ((LINESPERITEM 1) FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA WINDOW USERPROPS BROWSER ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (DECLARE (SPECVARS FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS)) (* ; "For SET below") (for TAIL on PROPS by (CDDR TAIL) do (SELECTQ (CAR TAIL) ((FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (SET (CAR TAIL) (CADR TAIL))) (push USERPROPS (LIST (CAR TAIL) (CADR TAIL))))) (SETQ WINDOW (DECODE.WINDOW.ARG WINDOWSPEC NIL NIL TITLE)) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) (SETQ BROWSER (create TABLEBROWSER TBWINDOW _ WINDOW TBFONT _ FONT TBLOCK _ (CREATE.MONITORLOCK (OR (WINDOWPROP WINDOW (QUOTE TITLE)) "Table Browser")) TB#LINESPERITEM _ (OR LINESPERITEM 1) TBBASELINE _ (OR BASELINE 0) TBCOLUMNS _ COLUMNS TBPRINTFN _ PRINTFN TBCOPYFN _ COPYFN TBCLOSEFN _ CLOSEFN TBAFTERCLOSEFN _ AFTERCLOSEFN TBUSERDATA _ USERDATA TBHEADINGWINDOW _ HEADINGWINDOW TBLINETHICKNESS _ (OR LINETHICKNESS TB.DELETEDLINEHEIGHT)))) (if ITEMHEIGHT then (* ; "User explicitly controlling height variables.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with ITEMHEIGHT) (replace (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER with T)) (DSPLEFTMARGIN TB.LEFT.MARGIN WINDOW) (TB.REPLACE.ITEMS BROWSER ITEMS) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION TB.SCROLLFN)) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION TB.REPAINTFN)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION TB.COPYBUTTONEVENTFN)) (for PROP in (QUOTE (CLOSEFN SHRINKFN RESHAPEFN)) do (* ;; "This used to be (progn (windowaddprop window 'closefn (function tb.closefn)) (windowaddprop window 'shrinkfn (function tb.shrinkfn)) (windowaddprop window 'reshapefn (function tb.reshapefn))). However, we want to be careful to put our stuff on before any attached window stuff, so that we can reject a CLOSE, for example, before CLOSEATTACHEDWINDOWS has already closed them. Could always put on front, but it's probably better to put our functions after any the user might have explicitly put there already.") (LET ((OLDP (WINDOWPROP WINDOW PROP)) (FN (PACK* "TB." PROP))) (if (NULL OLDP) then (SETQ OLDP (LIST FN)) else (for TAIL on (OR (LISTP OLDP) (SETQ OLDP (LIST OLDP))) do (if (EQ (CAR TAIL) FN) then (* ; "Window already has our fn!") (RETURN) elseif (STRPOS "ATTACHED" (CAR TAIL)) then (* ; "Insert before this attached window hacker") (RETURN (ATTACH FN TAIL))) finally (* ; "Put at end") (NCONC1 OLDP FN))) (WINDOWPROP WINDOW PROP OLDP))) (replace (TABLEBROWSER TBREADY) of BROWSER with T) (RETURN BROWSER))) ) (TB.REPLACE.ITEMS (LAMBDA (BROWSER NEWITEMS) (* ; "Edited 27-Jan-88 16:27 by bvm") (* ;; "Completely replace the current items with the specified items") (LET ((N 0) FIRSTSEL) (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (for ITEM in NEWITEMS do (* ; "Number the items") (freplace TI# of (\DTEST ITEM (QUOTE TABLEITEM)) with (add N 1))) (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL) (freplace (TABLEBROWSER TBITEMS) of BROWSER with NEWITEMS) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with N) (freplace (TABLEBROWSER TB#DELETED) of BROWSER with (for ITEM in NEWITEMS count (ffetch TIDELETED of ITEM))) (COND ((SETQ FIRSTSEL (TB.FIND.SELECTED.ITEM BROWSER 1 N)) (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with FIRSTSEL) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL N))) (T (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with (ADD1 N)) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with 0))) (TB.SET.FONT BROWSER) (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)))) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) ) (DEFINEQ (TB.DELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((NOT (ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM)))) (freplace (TABLEITEM TIDELETED) of ITEM with T) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 1) (if (TB.ITEM.UPDATABLE? BROWSER ITEM T) then (TB.SHOW.DELETION BROWSER ITEM (ffetch (TABLEBROWSER TBWINDOW) of BROWSER) (QUOTE REPLACE)))))) ) (TB.UNDELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM))) (freplace (TABLEITEM TIDELETED) of ITEM with NIL) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) -1) (COND ((TB.ITEM.UPDATABLE? BROWSER ITEM T) (LET ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE ERASE)) (* ; "reprint the line sans deletion mark") (TB.PRINT.LINE BROWSER ITEM WINDOW (ffetch (TABLEBROWSER TBPRINTFN) of BROWSER)))))))) ) (TB.INSERT.ITEM (LAMBDA (BROWSER NEWITEM BEFOREITEM) (* ; "Edited 27-Jan-88 16:08 by bvm") (* ;;; "Inserts NEWITEM in TABLEBROWSER before item BEFOREITEM or at the end if BEFOREITEM is NIL") (LET ((LASTITEM# (ffetch (TABLEBROWSER TB#ITEMS) of (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))))) BEFORE# TAIL N) (SETQ NEWITEM (\DTEST NEWITEM (QUOTE TABLEITEM))) (if BEFOREITEM then (SETQ BEFORE# (OR (FIXP BEFOREITEM) (ffetch TI# of (\DTEST BEFOREITEM (QUOTE TABLEITEM))))) (COND ((OR (> BEFORE# LASTITEM#) (< BEFORE# 1)) (* ; "Check for bad values") (\ILLEGAL.ARG BEFOREITEM))) else (SETQ BEFORE# (ADD1 LASTITEM#))) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (if (EQ BEFORE# 1) then (* ; "Goes at the beginning (or at the end of a null list)") (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CONS NEWITEM (ffetch (TABLEBROWSER TBITEMS) of BROWSER)))) else (* ; "Somewhere else--find the tail") (SETQ TAIL (if (NULL BEFOREITEM) then (* ; "Insert at end") (FLAST (OR (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER) (ffetch (TABLEBROWSER TBITEMS) of BROWSER))) else (TB.FIND.PREVIOUS.TAIL BROWSER BEFORE#))) (RPLACD TAIL (SETQ TAIL (CONS NEWITEM (CDR TAIL))))) (* ;; "Now (CAR TAIL) is the new item") (TB.RENUMBER.TAIL BROWSER TAIL BEFORE#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (ADD1 LASTITEM#)) (COND ((ffetch TIDELETED of NEWITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) 1))) (* ;; "Update first & last selected item if they fall after the insertion, or if the new item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((ffetch TISELECTED of NEWITEM) BEFORE#) (T (ADD1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBLASTSELECTEDITEM of BROWSER with (ADD1 N))) ((ffetch TISELECTED of NEWITEM) (freplace TBLASTSELECTEDITEM of BROWSER with BEFORE#))) (TB.UPDATE.DISPLAY BROWSER BEFORE# (QUOTE INSERT)))) ) (TB.REMOVE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:09 by bvm") (* ;;; "Removes ITEM from TABLEBROWSER") (LET ((LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (ITEM# (ffetch TI# of (\DTEST ITEM (QUOTE TABLEITEM)))) N TAIL) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (COND ((EQ ITEM# 1) (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CDR (ffetch (TABLEBROWSER TBITEMS) of BROWSER))))) (T (RPLACD (SETQ TAIL (TB.FIND.PREVIOUS.TAIL BROWSER ITEM#)) (SETQ TAIL (CDDR TAIL))))) (TB.RENUMBER.TAIL BROWSER TAIL ITEM#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (SUB1 LASTITEM#)) (COND ((ffetch TIDELETED of ITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) -1))) (* ;; "Update first & last selected item if they fall after the deletion or if the old item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the first selected, so look for next one after it") (OR (TB.FIND.SELECTED.ITEM BROWSER ITEM#) LASTITEM#)) (T (* ; "Item numbers are decremented") (SUB1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBLASTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the last selected, so look for next one before it") (OR (TB.REV.FIND.SELECTED.ITEM BROWSER NIL (SUB1 ITEM#)) 0)) (T (SUB1 N)))))) (TB.UPDATE.DISPLAY BROWSER ITEM# (QUOTE REMOVE)))) ) (TB.NORMALIZE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:22 by bvm") (* ;; "Scroll, if necessary, so that ITEM is visible in browser.") (LET* ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM)) (CLIP (DSPCLIPPINGREGION NIL WINDOW))) (COND ((OR (> (fetch (REGION BOTTOM) of CLIP) BOT) (< (fetch (REGION PTOP) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (* ; "Scroll so that item's midline is at midline of window") (SCROLLBYREPAINTFN WINDOW 0 (- (+ (fetch (REGION BOTTOM) of CLIP) (IQUOTIENT (fetch (REGION HEIGHT) of CLIP) 2)) (+ BOT (IQUOTIENT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) 2)))))))) ) (TB.REDISPLAY.ITEMS (LAMBDA (BROWSER FIRSTITEM LASTITEM) (* ; "Edited 2-Feb-88 11:53 by bvm:") (* ;; "Force redisplay of all items from FIRSTITEM to LASTITEM, e.g., because their content or format changed. We'll only redisplay the visible ones, of course. Also, if browser isn't open, we'll save the change until browser is expanded") (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))))) (if (AND (NULL FIRSTITEM) (NULL LASTITEM)) then (* ; "We're being told to redisplay the whole browser, so recompute the extent while we're at it (it might have gotten smaller).") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0)) (SETQ FIRSTITEM (IMAX (COND ((NULL FIRSTITEM) 1) ((FIXP FIRSTITEM)) (T (ffetch TI# of (\DTEST FIRSTITEM (QUOTE TABLEITEM))))) (TB.FIRST.VISIBLE.ITEM# BROWSER REGION))) (SETQ LASTITEM (IMIN (COND ((NULL LASTITEM) (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) ((FIXP LASTITEM)) (T (ffetch TI# of (\DTEST LASTITEM (QUOTE TABLEITEM))))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (if (AND (>= LASTITEM FIRSTITEM) (TB.ITEM.UPDATABLE? BROWSER FIRSTITEM)) then (TB.DISPLAY.LINES BROWSER FIRSTITEM LASTITEM)))) ) (TB.SELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (LET ((N (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))) (TB.SELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N T) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE REPLACE))))) ) (TB.UNSELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:09 by bvm") (if (ffetch (TABLEITEM TISELECTED) of (\DTEST ITEM (QUOTE TABLEITEM))) then (LET ((N (ffetch (TABLEITEM TI#) of ITEM))) (TB.DESELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE ERASE)))))) ) (TB.UNSELECT.ALL.ITEMS (LAMBDA (BROWSER) (* ; "Edited 29-Jan-88 12:14 by bvm") (* ;; "User entry for unselecting all items in the browser. ") (LET ((START (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (END (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER))) (if (<= START END) then (for I from START to END bind (UPDATABLE _ (TB.ITEM.UPDATABLE? BROWSER START)) ITEM when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) do (freplace TISELECTED of ITEM with NIL) (if UPDATABLE then (TB.SHOW.SELECTION BROWSER I (QUOTE ERASE)))) (freplace TBFIRSTSELECTEDITEM of BROWSER with (ADD1 (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (freplace TBLASTSELECTEDITEM of BROWSER with 0)))) ) ) (DEFINEQ (TB.NUMBER.OF.ITEMS (LAMBDA (BROWSER TYPE) (* ; "Edited 27-Jan-88 16:16 by bvm") (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (SELECTQ TYPE (NIL (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (DELETED (ffetch (TABLEBROWSER TB#DELETED) of BROWSER)) (SELECTED (for I from (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER) to (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER) count (ffetch (TABLEITEM TISELECTED) of (TB.NTH.ITEM BROWSER I)))) (\ILLEGAL.ARG TYPE))) ) (TB.NTH.ITEM (LAMBDA (BROWSER N) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;; "Return the Nth item of BROWSER, or NIL if N is out of range.") (* ;; "Browser items are currently stored as a simple list. To make most accesses reasonable, we save a hint to a recent tail of the list to speed up the search.") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET (TAIL TAILN) (if (AND (> N 0) (OR (AND (SETQ TAIL (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER)) (>= N (SETQ TAILN (ffetch (TABLEITEM TI#) of (CAR TAIL))))) (PROG1 (SETQ TAIL (ffetch (TABLEBROWSER TBITEMS) of BROWSER)) (* ; "Item is not in hint tail, have to search whole list") (SETQ TAILN 1)))) then (while (< TAILN N) do (if (NULL (SETQ TAIL (CDR TAIL))) then (* ; "Greater than last item. I could have done a comparison against #items, but it is rare to ask for this (and we never do internally).") (RETURN NIL)) (add TAILN 1) finally (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL) (* ; "Store away the new hint. This makes ascending iterations constant time, rather than n^2.") (RETURN (CAR TAIL)))))) ) (TB.COLLECT.ITEMS (LAMBDA (BROWSER PREDFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) collect ITEM when (OR (NULL PREDFN) (CL:FUNCALL PREDFN BROWSER ITEM)))) ) (TB.MAP.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEMS (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (COND (ITEMS (for ITEM in ITEMS do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (CL:FUNCALL NULLFN BROWSER))))) ) (TB.MAP.DELETED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each deleted item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (COND ((NEQ (ffetch TB#DELETED of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 0) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of BROWSER) when (ffetch TIDELETED of ITEM) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing deleted") (CL:FUNCALL NULLFN BROWSER)))) ) (TB.MAP.SELECTED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:19 by bvm") (* ;;; "Apply MAPFN to each selected item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEM# (SUB1 (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (LASTITEM# (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER)) ITEM) (COND ((< ITEM# LASTITEM#) (until (> (add ITEM# 1) LASTITEM#) when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#))) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing selected") (CL:FUNCALL NULLFN BROWSER))))) ) (TB.FIND.ITEM (LAMBDA (BROWSER PREDFN FIRST# LAST# BACKWARDSFLG) (* ; "Edited 27-Jan-88 16:20 by bvm") (* ;;; "Returns the first item in the designated range satisfying (PREDFN browser item); range defaults to whole browser") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET ((LO (COND (FIRST# (IMAX FIRST# 1)) (T 1))) (HI (COND (LAST# (IMIN LAST# (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (T (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)))) I END INCREMENT ITEM) (COND ((<= LO HI) (COND (BACKWARDSFLG (SETQ I (ADD1 HI)) (SETQ END LO) (SETQ INCREMENT -1)) (T (SETQ I (SUB1 LO)) (SETQ END HI) (SETQ INCREMENT 1))) (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (when (CL:FUNCALL PREDFN BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER (add I INCREMENT)))) do (RETURN ITEM) repeatuntil (EQ I END)))))) ) (TB.ITEM.SELECTED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TISELECTED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) (TB.ITEM.DELETED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TIDELETED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) ) (DEFINEQ (TB.CLEAR.LINE (LAMBDA (BROWSER ITEM LEFT WIDTH) (* ; "Edited 22-Jan-88 16:06 by bvm") (* ;;; "Clears the contents of ITEM's line starting at xpos LEFT for width WIDTH. Defaults to whole line") (BLTSHADE WHITESHADE (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (OR LEFT 0) (TB.BOTTOM.OF.ITEM BROWSER ITEM) WIDTH (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (QUOTE REPLACE))) ) (TB.USERDATA (CL:LAMBDA (BROWSER &OPTIONAL (NEWDATA NIL NEWP)) (* ; "Edited 27-Jan-88 16:25 by bvm") (PROG1 (ffetch (TABLEBROWSER TBUSERDATA) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (COND (NEWP (freplace (TABLEBROWSER TBUSERDATA) of BROWSER with NEWDATA))))) ) (TB.WINDOW (LAMBDA (BROWSER) (* ; "Edited 27-Jan-88 16:25 by bvm") (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) ) ) (* ; "Display") (DEFINEQ (TB.REPAINTFN (LAMBDA (WINDOW REGION) (* bvm%: "10-Sep-85 13:00") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (AND (NEQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (T (TB.BROWSER.BUSY BROWSER))))))) ) (TB.RESHAPEFN (LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 22-Jan-88 10:21 by bvm") (RESETLST (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) ITEM#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (* ; "Browser is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) NIL T)) ((NOT (fetch (TABLEBROWSER TBREADY) of BROWSER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ ITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER REGION)) (TB.SET.FONT BROWSER) (WYOFFSET (TIMES (SUB1 ITEM#) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) WINDOW) (TB.DISPLAY.LINES BROWSER ITEM# (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) (TB.SCROLLFN (LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 22-Jan-88 17:32 by bvm") (* ;; "only scroll if can get the monitor lock") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HW) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG) (if (AND (EQ DY 0) (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER))) then (* ; "Horizontally scroll the header window together with it.") (SCROLLW HW DX DY CONTINUOUSFLG))) (T (TB.BROWSER.BUSY BROWSER)))))) ) (TB.DISPLAY.LINES (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 25-Jan-88 18:34 by bvm") (for ITEM# from (IMAX FIRST# 1) to (IMIN LAST# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) bind (WINDOW _ (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (MAXXPOS _ (fetch (TABLEBROWSER TBMAXXPOS) of BROWSER)) (PRINTFN _ (fetch (TABLEBROWSER TBPRINTFN) of BROWSER)) EXTENTCHANGED ITEM HERE EXTENT HWINDOW do (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#)) (TB.PRINT.LINE BROWSER ITEM WINDOW PRINTFN) (* ; "keep track of maximum width printed to, so window's EXTENT is always right") (COND ((< MAXXPOS (SETQ HERE (DSPXPOSITION NIL WINDOW))) (SETQ MAXXPOS HERE) (SETQ EXTENTCHANGED T))) finally (COND (EXTENTCHANGED (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with MAXXPOS) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) with MAXXPOS) (WINDOWPROP WINDOW (QUOTE EXTENT) EXTENT) (if (SETQ HWINDOW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Update heading window extent, too. Width has to account for the difference, if any, in borders.") (replace (REGION WIDTH) of (SETQ EXTENT (WINDOWPROP HWINDOW (QUOTE EXTENT))) with (+ MAXXPOS (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HWINDOW (QUOTE BORDER))))))))))) ) (TB.PRINT.LINE (LAMBDA (BROWSER ITEM WINDOW PRINTFN) (* ; "Edited 22-Jan-88 17:16 by bvm") (MOVETO TB.LEFT.MARGIN (+ (TB.BOTTOM.OF.ITEM BROWSER ITEM) (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) WINDOW) (* ; "Move to item's baseline") (POSITION WINDOW 0) (CL:FUNCALL PRINTFN BROWSER ITEM WINDOW) (TB.SHOW.SELECTION BROWSER ITEM (COND ((fetch (TABLEITEM TISELECTED) of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))) (COND ((fetch (TABLEITEM TIDELETED) of ITEM) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE REPLACE))))) ) (TB.FIRST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 16:59 by bvm") (* ;; "Computes number of the first item in TABLEBROWSER that is visible in REGION") (IMAX 1 (ADD1 (IQUOTIENT (- (ffetch (TABLEBROWSER TBORIGIN) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (fetch (REGION PTOP) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))))) ) (TB.LAST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 17:00 by bvm") (* ;; "Computes number of the last item in TABLEBROWSER that is visible in REGION") (IMIN (ffetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (CL:CEILING (- (ffetch (TABLEBROWSER TBORIGIN) of BROWSER) (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) ) (TB.ITEM.VISIBLE? (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:12 by bvm") (* ;;; "True if any part of ITEM is visible in window of BROWSER") (LET ((CLIP (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM))) (* ;; "Check bottom of line is below top, and top of line is above the bottom") (AND (< BOT (fetch (REGION PTOP) of CLIP)) (< (fetch (REGION BOTTOM) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))))) ) (TB.ITEM.FROM.YCOORD (LAMBDA (BROWSER YPOS) (* ; "Edited 22-Jan-88 16:41 by bvm") (LET ((N (CL:CEILING (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) YPOS) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (TB.NTH.ITEM BROWSER (COND ((<= N 0) 1) (T (IMIN N (fetch (TABLEBROWSER TB#ITEMS) of BROWSER))))))) ) (TB.BOTTOM.OF.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:11 by bvm") (* ;; "Returns the y position of the bottom of specified item (number or tableitem). Add the font descent to get the baseline of the first line.") (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) (TIMES (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (OR (FIXP ITEM) (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))))) ) (TB.SHOW.DELETION (LAMBDA (BROWSER ITEM WINDOW OPERATION) (* ; "Edited 27-Jan-88 17:00 by bvm") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that ITEM is deleted") (LET ((THICKNESS (fetch (TABLEBROWSER TBLINETHICKNESS) of BROWSER)) (BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER))) (BLTSHADE BLACKSHADE WINDOW TB.LEFT.MARGIN (PROGN (* ;; "Center the deletion line between the baseline and the top of the item") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE THICKNESS) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL THICKNESS OPERATION))) ) (TB.SHOW.SELECTION (LAMBDA (BROWSER ITEM OPERATION) (* ; "Edited 27-Jan-88 15:42 by bvm") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that ITEM is selected") (LET ((BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) (BM TB.SELECTION.BITMAP)) (BITBLT BM 0 0 (fetch (TABLEBROWSER TBWINDOW) of BROWSER) 0 (PROGN (* ;; "Center the selection bitmap between the baseline and the top of the item, rounding down slightly on the grounds that the top pixel of the line tends to be blank, so the center of gravity is lower than it might be.") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE (fetch BITMAPHEIGHT of BM)) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL NIL (QUOTE INPUT) OPERATION))) ) (TB.UPDATE.DISPLAY (LAMBDA (BROWSER FROMITEM# TYPE) (* ; "Edited 11-Feb-88 11:34 by bvm") (* ;;; "Updates the display window appropriately after a TYPE operation (REMOVE or INSERT) on TABLEBROWSER that affects items starting at FROMITEM#") (PROG ((WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) (LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (ITEMHEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) (ITEMBOTTOM (TB.BOTTOM.OF.ITEM BROWSER FROMITEM#)) DELTA HEIGHT LAST# CLIP WBOTTOM EXTENTBOTTOM) (* ; "YPOS is the bottom of the line corresponding to FROMITEM#") (add (fetch (REGION HEIGHT) of EXTENT) (SETQ DELTA (SELECTQ TYPE (REMOVE (- ITEMHEIGHT)) (INSERT ITEMHEIGHT) (SHOULDNT)))) (SETQ CLIP (DSPCLIPPINGREGION NIL WINDOW)) (COND ((>= ITEMBOTTOM (fetch (REGION PTOP) of CLIP)) (* ; "Changed item above top of window, so no visible change -- just cheat the origin appropriately") (add (fetch (TABLEBROWSER TBORIGIN) of BROWSER) DELTA)) (T (* ; "Changed item visible or below bottom of window, so bottom of extent changes") (replace (REGION BOTTOM) of EXTENT with (SETQ EXTENTBOTTOM (- (fetch (REGION BOTTOM) of EXTENT) DELTA))) (COND ((<= (+ ITEMBOTTOM ITEMHEIGHT) (SETQ WBOTTOM (fetch (REGION BOTTOM) of CLIP))) (* ; "Below bottom of window, so we're done")) ((TB.ITEM.UPDATABLE? BROWSER FROMITEM#) (* ; "If window is visible, update it now") (SELECTQ TYPE (INSERT (* ; "Push everything from line FROMITEM# down one line, then redisplay item FROMITEM#") (BITBLT WINDOW 0 (+ WBOTTOM ITEMHEIGHT) WINDOW 0 WBOTTOM NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER FROMITEM# FROMITEM#)) (REMOVE (* ; "Pull everything below line FROMITEM# up one line, then redisplay last visible item(s)") (BITBLT WINDOW 0 WBOTTOM WINDOW 0 (+ WBOTTOM ITEMHEIGHT) NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER (SETQ LAST# (+ FROMITEM# (IQUOTIENT (- ITEMBOTTOM WBOTTOM) ITEMHEIGHT))) (ADD1 LAST#)) (* ; "May have to display two lines if the bottom line of window was a half line") (COND ((> EXTENTBOTTOM WBOTTOM) (* ; "Clear everything below the extent") (BLTSHADE WHITESHADE WINDOW 0 WBOTTOM NIL (- EXTENTBOTTOM WBOTTOM) (QUOTE REPLACE))))) (SHOULDNT)))))))) ) (TB.ITEM.UPDATABLE? (LAMBDA (BROWSER ITEM ONLYIFVISIBLE) (* ; "Edited 29-Jan-88 12:08 by bvm") (* ;;; "True if window of BROWSER is open. If false, we update the TBUPDATEFROMHERE field, denoting that we should repaint window when it is opened. If ONLYIFVISIBLE is true, we do nothing and return NIL if the item is not currently visible.") (OR (FIXP ITEM) (SETQ ITEM (fetch TI# of ITEM))) (COND ((AND ONLYIFVISIBLE (NOT (TB.ITEM.VISIBLE? BROWSER ITEM))) (* ; "Item not visible, so no need to change display") NIL) ((OPENWP (fetch (TABLEBROWSER TBWINDOW) of BROWSER))) (T (LET ((OLDN (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER))) (COND ((OR (NULL OLDN) (< ITEM OLDN)) (* ; "Mark browser for display update after being unshrunk") (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with ITEM)))) NIL))) ) ) (* ; "Selection") (DEFINEQ (TB.BUTTONEVENTFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 15:23") (TOTOPW WINDOW) (LET (FN) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (TB.DO.UNLESS.BUSY WINDOW (FUNCTION TB.DO.ITEM.SELECTION))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((AND (LASTMOUSESTATE (ONLY MIDDLE)) (SETQ FN (fetch (TABLEBROWSER TBTITLEEVENTFN) of (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))))) (TB.DO.UNLESS.BUSY WINDOW FN))))) ) (TB.DO.UNLESS.BUSY (LAMBDA (WINDOW FN) (* ; "Edited 20-Jan-88 23:30 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (COND ((AND (fetch (TABLEBROWSER TBREADY) of BROWSER) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (CL:FUNCALL FN WINDOW BROWSER)))))) ) (TB.DO.ITEM.SELECTION (LAMBDA (WINDOW) (* ; "Edited 20-Jan-88 22:17 by bvm") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS) (SPECVARS SELECTIONSTATE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION FIRST# LAST# FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE NEWSELECTION OLDSELECTION SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS ITEM LASTX LASTY) (COND ((EQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch TBLASTSELECTEDITEM of BROWSER)) (SETQ FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER)) (SETQ FIRSTVISIBLE# (TB.FIRST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (SETQ LASTVISIBLE# (TB.LAST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (* ; "Forget what we were doing") (SETQ OLDSELECTION))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (AND OLDSELECTION (SETQ OLDSEL# (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.REPLACING (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (replace TISELECTED of OLDSELECTION with T) (replace TBFIRSTSELECTEDITEM of BROWSER with (replace TBLASTSELECTEDITEM of BROWSER with OLDSEL#))) (TS.ADDING (TB.SELECTRANGE BROWSER OLDSEL# OLDSEL# T)) (TS.REMOVING (TB.DESELECTRANGE BROWSER OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (TB.SELECTRANGE BROWSER (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (TB.SELECTRANGE BROWSER OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (TB.DESELECTRANGE BROWSER (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (TB.DESELECTRANGE BROWSER FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND NIL (* ; "In a special column")) (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (SETQ OLDSELECTION)))) ((OR (NEQ (SETQ NEWSELECTION (TB.ITEM.FROM.YCOORD BROWSER LASTY)) OLDSELECTION) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (* ; "Something changed") (COND ((AND (fetch TIUNSELECTABLE of NEWSELECTION) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Can't select that item, so revert to idle") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION)))) ((AND (LASTMOUSESTATE (OR LEFT MIDDLE)) (SHIFTDOWNP (QUOTE CTRL))) (* ; "Deselect this item") (SELECTC SELECTIONSTATE (TS.REMOVING (* ; "we were deselecting, so reselect that guy") (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE REPLACE))) (TS.IDLE (* ; "nothing going on")) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((fetch TISELECTED of NEWSELECTION) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single item") (COND ((EQ SELECTIONSTATE TS.REPLACING) (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (T (TB.DECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.REPLACING))) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this item to the selection") (SELECTC SELECTIONSTATE (TS.ADDING (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (TS.IDLE) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((NOT (fetch TISELECTED of NEWSELECTION)) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SETQ SEL# (fetch TI# of NEWSELECTION)) (SETQ OLDSEL# (AND OLDSELECTION (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (COND ((<= FIRST# LAST#) (* ; "Something is already selected, so we can think about extending.") (COND ((NEQ SELECTIONSTATE TS.IDLE) (* ; "Cancel any selection we were thinking about") (TB.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ SELECTIONSTATE (COND ((> SEL# LAST#) (TB.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (TB.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (* ; "we are closer to the high end, but inside. Shrink from the top, but only if we are pointing at a contigous selection") (if (TB.CONTIGUOUS.SELP BROWSER SEL# (SUB1 LAST#)) then (TB.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI else TS.IDLE)) (T (* ; "We are closer to the low end, so shrink from bottom") (if (TB.CONTIGUOUS.SELP BROWSER (ADD1 FIRST#) SEL#) then (TB.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO else TS.IDLE))))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSELECTION NEWSELECTION)))))) ) (TB.CONTIGUOUS.SELP (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:16 by bvm") (* ;; "true if all the elements of ITEMS from FIRST# to LAST# are selected (or deleted or unselectable)") (for I from FIRST# to LAST# bind ITEM always (OR (fetch TISELECTED of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) (fetch TIDELETED of ITEM) (fetch TIUNSELECTABLE of ITEM)))) ) (TB.DECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as unselected.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) do (TB.SHOW.SELECTION BROWSER (TB.NTH.ITEM BROWSER I) (QUOTE ERASE)))) ) (TB.CONSIDERRANGE (LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as selected. Deleted items are not selected unless EVENIFDELETED is true") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (TB.SHOW.SELECTION BROWSER ITEM (QUOTE REPLACE)))))) ) (TB.DESELECTRANGE (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as unselected. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified--use TB.UNSELECT.ALL.ITEMS to do both") (LET ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER))) (if (< FIRST# FIRSTSEL) then (SETQ FIRST# FIRSTSEL)) (if (> LAST# LASTSEL) then (SETQ LAST# LASTSEL)) (if (<= FIRST# LAST#) then (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (COND ((EQ FIRST# FIRSTSEL) (replace TBFIRSTSELECTEDITEM of BROWSER with (COND ((TB.FIND.SELECTED.ITEM BROWSER (ADD1 LAST#) LASTSEL)) (T (replace TBLASTSELECTEDITEM of BROWSER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)))))) ((EQ LAST# LASTSEL) (replace TBLASTSELECTEDITEM of BROWSER with (OR (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL (SUB1 FIRST#)) 1))))))) ) (TB.RECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (TB.SHOW.SELECTION BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((fetch TISELECTED of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) ) (TB.SELECTRANGE (LAMBDA (BROWSER FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:10 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified") (PROG ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER)) ITEM) (for I from FIRST# to LAST# do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (replace TISELECTED of ITEM with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER))) (replace TBFIRSTSELECTEDITEM of BROWSER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch TBLASTSELECTEDITEM of BROWSER))) (replace TBLASTSELECTEDITEM of BROWSER with LAST#))))) ) (TB.UNDOSELECTION (LAMBDA NIL (* bvm%: " 6-Sep-85 15:04") (* ;;; "Restore browser to state before any selections were attempted") (DECLARE (USEDFREE FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE)) (TB.RECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.IDLE)) ) (TB.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR FIRST# 1) to (OR LAST# (fetch TB#ITEMS of BROWSER)) suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) (TB.REV.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR LAST# (fetch TB#ITEMS of BROWSER)) to (OR FIRST# 1) by -1 suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) ) (DEFINEQ (TB.COPYBUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 22-Jan-88 12:08 by bvm") (* ;;; "copy select an item from the window.") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION COPYFN CURRENTITEM NEWITEM LASTX LASTY) (COND ((OR (NULL (SETQ COPYFN (fetch (TABLEBROWSER TBCOPYFN) of BROWSER))) (NULL (fetch (TABLEBROWSER TBITEMS) of BROWSER))) (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) LP (TOTOPW WINDOW) (COND ((AND (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (TB.ITEM.FROM.YCOORD BROWSER LASTY))) (fetch TIUNCOPYSELECTABLE of NEWITEM)) (SETQ NEWITEM NIL))) (COND ((NEQ CURRENTITEM NEWITEM) (COND (CURRENTITEM (* ; "turn off old selection.") (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))) (COND ((SETQ CURRENTITEM NEWITEM) (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))))) (* ; "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM) (CL:FUNCALL COPYFN BROWSER CURRENTITEM))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, no action") (GO LP2)) (T (GO LP))))) ) (TB.SHOW.COPY.SELECTION (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:38 by bvm") (* ;;; "underline this item in browser") (BLTSHADE GRAYSHADE (fetch (TABLEBROWSER TBWINDOW) of BROWSER) TB.LEFT.MARGIN (TB.BOTTOM.OF.ITEM BROWSER ITEM) NIL 2 (QUOTE INVERT))) ) ) (* ; "Misc state change") (DEFINEQ (TB.BROWSER.BUSY (LAMBDA (BROWSER) (* bvm%: " 8-Sep-85 16:42") (RESETFORM (CURSOR TB.CROSSCURSOR) (BLOCK 1000)))) (TB.CLOSE/SHRINK (LAMBDA (WINDOW FLG) (* ; "Edited 20-Jan-88 23:36 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (COND ((AND (SETQ HOW? (fetch (TABLEBROWSER TBCLOSEFN) of BROWSER)) (SETQ HOW? (CL:FUNCALL HOW? BROWSER WINDOW FLG))) (COND ((NEQ HOW? (QUOTE DON'T)) (TB.PROCESS (BQUOTE ((\, HOW?) (QUOTE (\, BROWSER)) (QUOTE (\, WINDOW)) (QUOTE (\, FLG)))) (QUOTE TB.UPDATE)))) (QUOTE DON'T)) (T (TB.FINISH.CLOSE BROWSER WINDOW FLG T) NIL))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) ) (TB.CLOSEFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:25") (TB.CLOSE/SHRINK WINDOW (QUOTE CLOSE)))) (TB.FINISH.CLOSE (LAMBDA (BROWSER WINDOW CLOSEFLG DONTCLOSE) (* bvm%: " 9-Sep-85 00:42") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge. DONTCLOSE is true if neither occurred, in which case we are being called directly from the CLOSEFN and should not close/shrink the window ourselves") (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (SELECTQ CLOSEFLG (CLOSE (SETQ WINDOW (TB.FLUSH.WINDOW BROWSER WINDOW)) (OR DONTCLOSE (CLOSEW WINDOW))) (SHRINK (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION TB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN)) (OR DONTCLOSE (SHRINKW WINDOW))) NIL))) ) (TB.FLUSH.WINDOW (LAMBDA (BROWSER WINDOW) (* ; "Edited 20-Jan-88 22:42 by bvm") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION TB.CLOSEFN)) (ERSETQ (LET ((FN (fetch (TABLEBROWSER TBAFTERCLOSEFN) of BROWSER))) (AND FN (CL:FUNCALL FN BROWSER WINDOW)))) (replace (TABLEBROWSER TBITEMS) of BROWSER with (replace (TABLEBROWSER TBWINDOW) of BROWSER with (replace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL))) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) NIL) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) ) (TB.SET.FONT (LAMBDA (BROWSER FONT) (* ; "Edited 10-Feb-88 11:07 by bvm:") (* ;;; "Sets/changes font of TABLEBROWSER to be FONT. Clears window. Caller is responsible for repainting window") (LET ((FONTGIVEN FONT) (WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) WIDTH HEIGHT ASCENT TOTALHEIGHT ORIGIN FN EXTENT HW) (CLEARW WINDOW) (SETQ FONT (FONTCREATE (OR FONT (fetch (TABLEBROWSER TBFONT) of BROWSER) (DSPFONT NIL WINDOW)))) (DSPFONT FONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH T WINDOW) (replace (TABLEBROWSER TBFONT) of BROWSER with FONT) (replace (TABLEBROWSER TBFONTHEIGHT) of BROWSER with (SETQ HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))) (if (NOT (fetch (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER)) then (* ; "Compute item heights. Don't do this if user gave an explicit height.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with (SETQ HEIGHT (TIMES HEIGHT (fetch (TABLEBROWSER TB#LINESPERITEM) of BROWSER)))) (replace (TABLEBROWSER TBFONTASCENT) of BROWSER with (SETQ ASCENT (FONTPROP FONT (QUOTE ASCENT)))) (replace (TABLEBROWSER TBBASELINE) of BROWSER with (- HEIGHT ASCENT)) else (SETQ HEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))) (replace (TABLEBROWSER TBORIGIN) of BROWSER with (SETQ ORIGIN (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOTALHEIGHT (TIMES (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (TABLEBROWSER TBEXTENT) of BROWSER with (create REGION LEFT _ 0 BOTTOM _ (- ORIGIN TOTALHEIGHT) WIDTH _ 0 HEIGHT _ TOTALHEIGHT))) (* ; "Let extent width be zero until we print something") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0) (if (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Fix extent of header window, too. Be sure to account for different size of borders, if any") (LET ((HWIDTH (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HW (QUOTE BORDER)))))) (if (SETQ EXTENT (WINDOWPROP HW (QUOTE EXTENT))) then (replace (REGION WIDTH) of EXTENT with HWIDTH) else (WINDOWPROP HW (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ HWIDTH HEIGHT _ -1))))) (COND ((AND FONTGIVEN (SETQ FN (fetch (TABLEBROWSER TBFONTCHANGEFN) of BROWSER))) (* ; "Notify application program of font change") (CL:FUNCALL FN BROWSER WINDOW))))) ) (TB.SHRINKFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:14") (TB.CLOSE/SHRINK WINDOW (QUOTE SHRINK)))) (TB.EXPANDFN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 16:53 by bvm") (* ;;; "If browser changed while it was shrunk, update display accordingly") (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (LET ((FIRSTCHANGEDITEM# (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER)) REGION FN) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN) T) (COND (FIRSTCHANGEDITEM# (* ; "Browser has changed since shrinking") (TB.DISPLAY.LINES BROWSER (IMAX FIRSTCHANGEDITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION)) (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with NIL))))))) ) (TB.FIND.PREVIOUS.TAIL (LAMBDA (BROWSER ITEM#) (* ; "Edited 20-Jan-88 23:23 by bvm") (* ;; "Return the tail of BROWSER's items whose CADR is ITEM#. Assumes ITEM# at least 2 and not greater than number of items") (LET (TAIL TAILN) (if (OR (NULL (SETQ TAIL (fetch (TABLEBROWSER TBTAILHINT) of BROWSER))) (< ITEM# (SETQ TAILN (ADD1 (fetch (TABLEITEM TI#) of (CAR TAIL)))))) then (* ; "Can't use the hint") (SETQ TAIL (fetch (TABLEBROWSER TBITEMS) of BROWSER)) (SETQ TAILN 2)) (* ;; "TAILN is the number of (CADR TAIL). Want to get TAIL pointing to one before the requested number") (while (< TAILN ITEM#) do (SETQ TAIL (CDR TAIL)) (add TAILN 1)) (if (OR (NULL TAIL) (NEQ TAILN ITEM#)) then (HELP "Failed to find item tail" ITEM#)) TAIL)) ) (TB.RENUMBER.TAIL (LAMBDA (BROWSER TAIL FIRST#) (* ; "Edited 20-Jan-88 23:22 by bvm") (* ;; "Renumbers all of BROWSER's items from TAIL onward, giving (CAR TAIL) the number FIRST#. Also updates tail hint.") (for ITEM in TAIL as I from FIRST# do (replace TI# of ITEM with I)) (replace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL)) ) ) (* ; "Misc") (DEFINEQ (TB.PROCESS (LAMBDA (FORM NAME ALLOWLOGOUT RESTARTABLE) (* bvm%: "25-Mar-84 17:16") (* ;;; "Creates a process running FORM which by default is not restartable and will not permit LOGOUT while it is running") (ADD.PROCESS FORM (QUOTE NAME) NAME (QUOTE RESTARTABLE) (OR RESTARTABLE (QUOTE NO)) (QUOTE BEFOREEXIT) (COND (ALLOWLOGOUT NIL) (T (QUOTE DON'T))))) ) ) (RPAQ? TB.DELETEDLINEHEIGHT 1) (RPAQQ TB.SELECTION.BITMAP #*(8 9)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@) (RPAQ TB.CROSSCURSOR (CURSORCREATE (QUOTE #*(16 16)L@@CN@@GG@@NCHALALCH@NG@@GN@@CL@@CL@@GN@@NG@ALCHCHALG@@NN@@GL@@C ) (QUOTE NIL) 8 8)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TBDECLS) (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .COPYKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TB.USERDATA) ) (/DECLAREDATATYPE 'TABLEBROWSER '(FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER)) '48) (/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG POINTER WORD) '((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 2 POINTER) (TABLEITEM 1 (BITS . 15))) '4) (ADDTOVAR SYSTEMRECLST (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (TBITEMS POINTER) (TB#ITEMS WORD) (TB#DELETED WORD) (TB#LINESPERITEM WORD) (TBFIRSTSELECTEDITEM WORD) (TBLASTSELECTEDITEM WORD) (TBITEMHEIGHT WORD) (TBMAXXPOS WORD) (TBFONTHEIGHT WORD) (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (TBLOCK POINTER) (TBUSERDATA POINTER) (TBFONT POINTER) (TBEXTENT POINTER) (TBUPDATEFROMHERE POINTER) (TBCOLUMNS POINTER) (TBPRINTFN POINTER) (TBCOPYFN POINTER) (TBFONTCHANGEFN POINTER) (TBCLOSEFN POINTER) (TBAFTERCLOSEFN POINTER) (TBTITLEEVENTFN POINTER) (TBLINETHICKNESS POINTER) (TBORIGIN POINTER) (TBTAILHINT POINTER) (TBHEADINGWINDOW POINTER) (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (TIDATA POINTER) (TI# WORD))) ) (PUTPROPS TABLEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 1994 1995 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3119 7470 (TB.MAKE.BROWSER 3129 . 6245) (TB.REPLACE.ITEMS 6247 . 7468)) (7471 15361 ( TB.DELETE.ITEM 7481 . 7915) (TB.UNDELETE.ITEM 7917 . 8496) (TB.INSERT.ITEM 8498 . 10505) ( TB.REMOVE.ITEM 10507 . 12039) (TB.NORMALIZE.ITEM 12041 . 12754) (TB.REDISPLAY.ITEMS 12756 . 13946) ( TB.SELECT.ITEM 13948 . 14253) (TB.UNSELECT.ITEM 14255 . 14610) (TB.UNSELECT.ALL.ITEMS 14612 . 15359)) (15362 19888 (TB.NUMBER.OF.ITEMS 15372 . 15854) (TB.NTH.ITEM 15856 . 16930) (TB.COLLECT.ITEMS 16932 . 17303) (TB.MAP.ITEMS 17305 . 17669) (TB.MAP.DELETED.ITEMS 17671 . 18118) (TB.MAP.SELECTED.ITEMS 18120 . 18727) (TB.FIND.ITEM 18729 . 19602) (TB.ITEM.SELECTED? 19604 . 19745) (TB.ITEM.DELETED? 19747 . 19886)) (19889 20730 (TB.CLEAR.LINE 19899 . 20311) (TB.USERDATA 20313 . 20579) (TB.WINDOW 20581 . 20728)) (20755 31013 (TB.REPAINTFN 20765 . 21176) (TB.RESHAPEFN 21178 . 22016) (TB.SCROLLFN 22018 . 22569) (TB.DISPLAY.LINES 22571 . 23828) (TB.PRINT.LINE 23830 . 24350) (TB.FIRST.VISIBLE.ITEM# 24352 . 24789) (TB.LAST.VISIBLE.ITEM# 24791 . 25264) (TB.ITEM.VISIBLE? 25266 . 25786) (TB.ITEM.FROM.YCOORD 25788 . 26098) (TB.BOTTOM.OF.ITEM 26100 . 26513) (TB.SHOW.DELETION 26515 . 27137) (TB.SHOW.SELECTION 27139 . 27908) (TB.UPDATE.DISPLAY 27910 . 30195) (TB.ITEM.UPDATABLE? 30197 . 31011)) (31040 42453 ( TB.BUTTONEVENTFN 31050 . 31509) (TB.DO.UNLESS.BUSY 31511 . 31818) (TB.DO.ITEM.SELECTION 31820 . 37894) (TB.CONTIGUOUS.SELP 37896 . 38263) (TB.DECONSIDERRANGE 38265 . 38633) (TB.CONSIDERRANGE 38635 . 39206 ) (TB.DESELECTRANGE 39208 . 40270) (TB.RECONSIDERRANGE 40272 . 40770) (TB.SELECTRANGE 40772 . 41712) ( TB.UNDOSELECTION 41714 . 41991) (TB.FIND.SELECTED.ITEM 41993 . 42216) (TB.REV.FIND.SELECTED.ITEM 42218 . 42451)) (42454 43953 (TB.COPYBUTTONEVENTFN 42464 . 43684) (TB.SHOW.COPY.SELECTION 43686 . 43951)) ( 43988 50295 (TB.BROWSER.BUSY 43998 . 44115) (TB.CLOSE/SHRINK 44117 . 44749) (TB.CLOSEFN 44751 . 44852) (TB.FINISH.CLOSE 44854 . 45507) (TB.FLUSH.WINDOW 45509 . 46036) (TB.SET.FONT 46038 . 48336) ( TB.SHRINKFN 48338 . 48441) (TB.EXPANDFN 48443 . 49208) (TB.FIND.PREVIOUS.TAIL 49210 . 49952) ( TB.RENUMBER.TAIL 49954 . 50293)) (50317 50690 (TB.PROCESS 50327 . 50688))))) STOP \ No newline at end of file diff --git a/library/TEDIT.~1~ b/library/TEDIT.~1~ deleted file mode 100644 index 16440947..00000000 --- a/library/TEDIT.~1~ +++ /dev/null @@ -1,1655 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jun-99 20:00:16" {DSK}medley3.5>library>TEDIT.;3 140027 changes to%: (FNS COERCETEXTOBJ TEDIT \TEDIT.INSERT.PIECES) previous date%: "24-Apr-95 12:07:48" {DSK}medley3.5>library>TEDIT.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITCOMS) (RPAQQ TEDITCOMS [(FILES TEDITDECLS) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDECLS)) (FILES PCTREE TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS) (VARS (TEDIT.TERMSA.FONTS NIL) (TEDIT.TENTATIVE NIL) (TEDIT.DEFAULT.PROPS NIL) (TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP)) (TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU)) (* ;  "Original was (CREATE MENU ITEMS _ '(NewEditProcess)).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS) (FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE TEDIT.DO.BLUEPENDINGDELETE TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN \TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE \TEDIT.DIFFUSE.PARALOOKS \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1) (P (MOVD? 'NILL 'OBJECTOUTOFTEDIT)) (* ;  "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.") (COMS (FNS \CREATE.TEDIT.RESTART.MENU)) (* ;  "Added by yabu.fx, for SUNLOADUP without DWIM.") (COMS (* ; "Debugging functions") (FNS PLCHAIN PRINTLINE SEEFILE)) (COMS (* ; "Object-oriented editing") (FNS TEDIT.INSERT.OBJECT TEDIT.EDIT.OBJECT TEDIT.FIND.OBJECT TEDIT.FIND.OBJECT.SUBTREE TEDIT.PUT.OBJECT TEDIT.GET.OBJECT TEDIT.OBJECT.CHANGED)) (FILES TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS) (COMS (* ; "TEDIT Support information") (E (SETQ TEDITSYSTEMDATE (DATE))) (VARS TEDITSYSTEMDATE (TEDITSUPPORT "TEditSupport.PA")) (FNS MAKETEDITFORM) (P (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM "Report a problem with TEdit")) (SETQ LAFITEFORMSMENU NIL))) (COMS (* ;  "LISTFILES Interface, so the system can decide if a file is a TEdit file.") (ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1) (EXTENSION (TEDIT]) (FILESLOAD TEDITDECLS) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDECLS) ) (FILESLOAD PCTREE TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS) (RPAQQ TEDIT.TERMSA.FONTS NIL) (RPAQQ TEDIT.TENTATIVE NIL) (RPAQQ TEDIT.DEFAULT.PROPS NIL) (RPAQ TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP)) (RPAQ TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS) ) (DEFINEQ (\TEDIT2 - [LAMBDA (TEXT WINDOW UNSPAWNED) (* ; "Edited 12-Jun-90 17:51 by mitani") - - (* ;; "Does the actual editing work, once TEDIT has OPENTEXTSTREAMed the thing to be edited.") - - (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) - (* ; "Run the editing engine") - (CLOSEW WINDOW) (* ; "Close the edit window") - (\TEXTCLOSEF TEXT) (* ; "Close the underlying files") - (replace (STREAM ACCESSBITS) of TEXT with BothBits) - (* ; - "But leave the stream itself accessible") - (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'AFTERQUITFN) - (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'AFTERQUITFN) - WINDOW TEXT)) (* ; - "Apply any post-window-close (and post-QUIT) function") - (COND - (UNSPAWNED (* ; - "We're not a distinct process: Send back the edited text in some suitable form") - (COND - ((NEQ (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM - TEXTOBJ) - of TEXT)) - T) - (PROG1 (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM - TEXTOBJ) - of TEXT)) - (replace (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM - TEXTOBJ) - of TEXT) with - NIL))) - ((STRINGP (fetch (TEXTOBJ TXTFILE) of (fetch (TEXTSTREAM TEXTOBJ - ) of TEXT))) - (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'STRINGP)) - (T TEXT]) (COERCETEXTOBJ [LAMBDA (STREAM TYPE OUTPUTSTREAM) (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 13:58 by rmk:") (* ; "Edited 11-Jun-99 13:58 by rmk:") (* ; "Edited 18-Apr-93 23:42 by jds") (* ;; "Coerce the contents of the TEXOTBJ to be of the given type. This is for making a string from a textobj, e.g.") (PROG ((TEXTOBJ (COND ((type? STREAM STREAM) (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) (T STREAM))) OFILE FMTFILE) (OR (type? TEXTOBJ TEXTOBJ) (\ILLEGAL.ARG TEXTOBJ)) (* ;  "If we haven't got a TEXTOBJ, something is wrong.") (RETURN (SELECTQ TYPE ((STRINGP STRING) (AND (ILEQ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 65535) (PROG ((STR (ALLOCSTRING (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) PC (CH# 1) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (DELTA 0) PFILE) (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) 0)) [WHILE PC do (COND ((ATOM PC)(* ;  "It's the lastpiece atom -- do nothing.") (SETQ PC NIL)) ((fetch CLINVISIBLE of (fetch (PIECE PLOOKS) of PC)) (* ;; "If the characters are invisible, do nothing. HOWEVER, we have to shrink the final string to account for the characters we ignored.") (add DELTA (fetch (PIECE PLEN) of PC))) ((fetch (PIECE PSTR) of PC) [OR (ZEROP (fetch (PIECE PLEN) of PC)) (RPLSTRING STR CH# (SUBSTRING (fetch (PIECE PSTR) of PC) 1 (fetch (PIECE PLEN) of PC] (add CH# (fetch (PIECE PLEN) of PC))) ((SETQ PFILE (fetch (PIECE PFILE) of PC)) [COND ((NOT (OPENP PFILE)) (SETQ PFILE (\TEDIT.REOPEN.STREAM STREAM PFILE] (SETFILEPTR PFILE (fetch (PIECE PFPOS) of PC)) (for C from CH# as I from 1 to (fetch (PIECE PLEN) of PC) do (RPLCHARCODE STR C (BIN PFILE))) (add CH# (fetch (PIECE PLEN) of PC))) ((fetch (PIECE POBJ) of PC) (* ; "DO NOTHING FOR OBJECTS") (add CH# (fetch (PIECE PLEN) of PC)) (add DELTA (fetch (PIECE PLEN) of PC))) (T (ERROR "CANNOT GET TEXT FROM A 'PIECE.'" PC))) (AND PC (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC] [COND ((ZEROP DELTA) (* ;  "No change in the length; do nothing.") ) (T (* ;  "The string got shortened to account for invisible chars. Chop it off") (SETQ STR (SUBSTRING STR 1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) DELTA] (RETURN STR)))) (STREAM (COND ((type? STREAM (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) [OPENFILE (fetch (STREAM FULLNAME) of (fetch (TEXTOBJ TXTFILE ) of TEXTOBJ)) 'INPUT NIL '((TYPE TEXT] (replace (STREAM ACCESSBITS) of (fetch (TEXTOBJ TXTFILE) of TEXTOBJ) with ReadBit))) (\SETUPGETCH 1 TEXTOBJ) (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (FILE [SETQ OFILE (OR (AND OUTPUTSTREAM (OPENP OUTPUTSTREAM 'OUTPUT)) (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW] (TEDIT.PUT.PCTB TEXTOBJ OFILE) (OR OUTPUTSTREAM (CLOSEF OFILE)) OFILE) (SPLIT (* ;; "I.e., Return 2 files, one with plain text, one with formatting info, such that concatenating them will do the right thing.") (SETQ OFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW)) (SETQ FMTFILE (CAR (TEDIT.PUT.PCTB TEXTOBJ (\GETSTREAM OFILE 'BOTH) NIL T))) (CLOSEF OFILE) (CONS OFILE FMTFILE)) NIL]) (TEDIT [LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 11-Jun-99 14:14 by rmk:") (* ; "Edited 11-Jun-99 14:13 by rmk:") (* ; "Edited 11-Jun-99 14:08 by rmk:") (* ; "Edited 3-Jun-88 14:27 by jds") (* ;; "User entry to the text editor. Takes an optional window to be used for editing") (* ;; "DONTSPAWN => Don't try to create a new process for this edit.") (PROG (PROC TEDITCREATEDWINDOW) (* ;  "Include the default properties in the list.") [COND ((AND TEXT (ATOM TEXT)) (* ;  "Make sure the file exists before trying to open the window.") (SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD '((TYPE TEXT] (RESETLST [RESETSAVE NIL `(AND ,WINDOW (WINDOWPROP ,WINDOW 'TEXTOBJ NIL] (WITH.MONITOR TEDIT.STARTUP.MONITORLOCK (COND ((NOT WINDOW) (SETQ TEDITCREATEDWINDOW T) (SETQ WINDOW (COND [(OR (NOT TEDIT.DEFAULT.WINDOW) (\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW)) (TEDIT.CREATEW (COND ((AND TEXT (ATOM TEXT)) (CONCAT "Please specify an editing window for " TEXT)) (T "Please specify a region for the editing window." )) TEXT (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS] (T (\TEDIT.CREATEW.FROM.REGION (WINDOWPROP TEDIT.DEFAULT.WINDOW 'REGION) TEXT (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS))) (* ; "Replace the old title") TEDIT.DEFAULT.WINDOW))) (* ;;  "Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.") (* ;;  "mark that we created the window so that we know we can update the title, etc.") (WINDOWPROP WINDOW 'TEXTOBJ T))))) [SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL (APPEND PROPS '(BEING-EDITED T] (* ;  "Connect the editor to the window") (replace (TEXTOBJ TXTEDITING) of (TEXTOBJ TEXT) with T) (* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)") [COND (TEDITCREATEDWINDOW (TEXTPROP TEXT 'TEDITCREATEDWINDOW 'T] (COND (DONTSPAWN (* ;  "Either no processes running, or specifically not to spawn one.") (RETURN (\TEDIT2 TEXT WINDOW T))) (T (* ; "Spawn a process to do the edit.") [SETQ PROC (ADD.PROCESS (LIST '\TEDIT2 (KWOTE TEXT) WINDOW NIL) 'NAME 'TEdit 'RESTARTABLE 'HARDRESET 'RESTARTFORM (LIST '\TEDIT.RESTARTFN (KWOTE TEXT) WINDOW (KWOTE PROPS] (PROCESSPROP PROC 'WINDOW WINDOW) (COND ((NOT (LISTGET (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)) 'LEAVETTY)) (* ;  "Unless he asked us to leave the tty where it is, TEdit should get it.") (TTY.PROCESS PROC))) (RETURN PROC]) (TEDIT.CHARWIDTH - [LAMBDA (CH FONT TERMSA) (* jds "22-OCT-83 19:32") - - (* Returns the width of CH in FONT printed according to any special printing - instructions in CHARTABLE TERMSA) - - (COND - (TERMSA (* There IS a TERMTABLE to account for) - (SELECTC (fetch CCECHO of (\SYNCODE TERMSA CH)) - (INDICATE.CCE (IPLUS (COND - ((IGREATERP CH 127)(* META character) - (SETQ CH (LOGAND CH 127)) - (CHARWIDTH (CHARCODE %#) - FONT)) - (T 0)) - (COND - ((ILESSP CH 32) (* CONTROL character) - (SETQ CH (LOGOR CH 64)) - (CHARWIDTH (CHARCODE ^) - FONT)) - (T 0)) - (CHARWIDTH CH FONT))) - (SIMULATE.CCE (SELCHARQ CH - ((EOL CR LF) - (IMAX 6 (CHARWIDTH CH FONT))) - (ESCAPE (CHARWIDTH (CHARCODE $) - FONT)) - (BELL 0) - (TAB 36) - (CHARWIDTH CH FONT))) - (REAL.CCE (CHARWIDTH CH FONT)) - (IGNORE.CCE 0) - (SHOULDNT))) - (T (* The usual case is to treat every character as a graphic.) - (SELCHARQ CH - (CR (IMAX 6 (CHARWIDTH CH FONT))) - (TAB 36) - (CHARWIDTH CH FONT]) (TEDIT.COPY - [LAMBDA (FROM TO) (* ; "Edited 4-Jun-92 11:11 by jds") - (SETQ TEDIT.COPY.PENDING NIL) (* ; - "First, Turn off the global flag that got us here.") - (COND - ((NOT (AND FROM (fetch (SELECTION SET) of FROM))) - (* ; - "There MUST be a source selected first.") - (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of TO) - "Copy source selection hasn't been set yet." T)) - ((ZEROP (fetch (SELECTION DCH) of FROM)) (* ; - "The source is empty. Just turn off the selection hilite and ignore the request.") - (\SHOWSEL FROM NIL NIL)) - ((fetch (TEXTOBJ TXTREADONLY) of (fetch (SELECTION \TEXTOBJ) of TO)) - (* ; "The target is read-only. Don't do anything except turn off the selection highlighting and ignore the request.") - (\SHOWSEL FROM NIL NIL)) - (T (\SHOWSEL FROM NIL NIL) (* ; - "Before all else, make sure the copy source selection is turned off") - (replace (SELECTION SET) of FROM with NIL) - (COND - ((AND TO (fetch (SELECTION SET) of TO)) (* ; - "Can only do copy if there's a target selection") - (PROG ((TOOBJ (fetch (SELECTION \TEXTOBJ) of TO)) - (FROMOBJ (fetch (SELECTION \TEXTOBJ) of FROM)) - (CROSSCOPY (NEQ (fetch (SELECTION \TEXTOBJ) of FROM) - (fetch (SELECTION \TEXTOBJ) of TO))) - TOLEN LEN INSPC INSPC# PC NPC PCCH NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST - OBJ COPYFN UNDOCHAIN) - (SETQ PCLST (TEDIT.SELECTED.PIECES FROMOBJ FROM CROSSCOPY (FUNCTION - \TEDIT.COPY.PIECEMAPFN - ) - FROMOBJ TOOBJ)) (* ; - "Get the list of pieces to be copied") - (SETQ REPLACING (TEDIT.DO.BLUEPENDINGDELETE TO TOOBJ)) - (* ; "Do any blue-pending-delete") - (SETQ TOLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ)) - (\SHOWSEL TO NIL NIL) (* ; - "NOW turn off the target selection.") - [COND - ((EQ (fetch (SELECTION POINT) of TO) - 'LEFT) - (SETQ INSERTCH# (fetch (SELECTION CH#) of TO))) - (T (SETQ INSERTCH# (IMIN (fetch (SELECTION CHLIM) of TO) - (ADD1 TOLEN] (* ; - "Figure out where to do the insertion.") - (COND - ((AND (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ) - (NOT (fetch (TEXTOBJ FORMATTEDP) of TOOBJ))) - (* ; - "The source is formatted and the target isn't. Give the guy a choice.") - (* ; - "For now, convert the target file to formatted.") - (\TEDIT.CONVERT.TO.FORMATTED TOOBJ))) - (SETQ UNDOCHAIN (\TEDIT.INSERT.PIECES TOOBJ INSERTCH# PCLST - (SETQ LEN (IDIFFERENCE (fetch (SELECTION CHLIM) - of FROM) - (fetch (SELECTION CH#) of FROM))) - NIL NIL CROSSCOPY NIL T)) - (bind OBJ AFTERCOPYFN for PC in PCLST - when [AND (SETQ OBJ (fetch (PIECE POBJ) of PC)) - (SETQ AFTERCOPYFN (IMAGEOBJPROP OBJ 'AFTERCOPYFN] - do (APPLY* AFTERCOPYFN OBJ)) - (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TOOBJ)) - (\TEDIT.HISTORYADD TOOBJ - (create TEDITHISTORYEVENT - THACTION _ (COND - (REPLACING 'Replace) - (T 'Copy)) - THLEN _ LEN - THCH# _ INSERTCH# - THFIRSTPIECE _ UNDOCHAIN - THOLDINFO _ (AND REPLACING EVENT))) - (* ; - "Make a history-list entry for the COPY.") - (replace (TEXTOBJ \DIRTY) of TOOBJ with T) - (* ; "Mark the document changed") - (replace (TEXTOBJ TEXTLEN) of TOOBJ with (IPLUS LEN TOLEN)) - (* ; "Set the new length") - (\FIXILINES TOOBJ TO INSERTCH# LEN TOLEN)(* ; "Fix LINES and SELs") - [COND - ((EQ (fetch (TEXTOBJ FORMATTEDP) of TOOBJ) - (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ)) - (* ; - "Either both of the files are formatted or neither is. This case is OK") - ) - ((fetch (TEXTOBJ FORMATTEDP) of TOOBJ) - (* ; - "The source wasn't formatted, but the target is. Go convert the copied text.") - (\TEDIT.CONVERT.TO.FORMATTED TOOBJ INSERTCH# (IPLUS INSERTCH# LEN] - (TEDIT.UPDATE.SCREEN TOOBJ) (* ; "Refresh the display") - (replace (SELECTION CH#) of TO with INSERTCH#) - (* ; "Correct the target selection") - (replace (SELECTION CHLIM) of TO with (IPLUS INSERTCH# LEN)) - (replace (SELECTION DCH) of TO with LEN) - (replace (SELECTION DX) of TO with 0) - (replace (SELECTION POINT) of TO with 'RIGHT) - (* ; - "(replace CARETLOOKS of TOOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TOOBJ TO))") - (* ; - "Make any later type-in look like what we just copied.") - (replace (TEXTOBJ \INSERTPCVALID) of TOOBJ with NIL) - (* ; - "And make sure that the pieces copied never have their strings smashed by back spacing.") - (replace (TEXTOBJ \INSERTPCVALID) of FROMOBJ with NIL) - (\FIXSEL TO TOOBJ) - (\SHOWSEL TO NIL T))) - (T (* ; - "There is no target selection -- complain") - (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of FROM) - "Please select a destination for the copy first." T]) (TEDIT.DELETE - [LAMBDA (STREAM SEL LEN LEAVECARETLOOKS) (* ; "Edited 12-Jun-90 17:49 by mitani") - - (* ;; "DELETE THE CHARACTERS SPECIFIED FROM THE MAIN TEXT.") - - (* ;; "If LEAVECARETLOOKS is non-NIL, the selection will NOT be set up to do the right thing with type-in. This can save time in inner loops.") - - (PROG ((TEXTOBJ (TEXTOBJ STREAM))) - [COND - ((FIXP SEL) - (TEDIT.SETSEL STREAM SEL LEN NIL NIL LEAVECARETLOOKS) - (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ] - (OR SEL (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) - (\TEDIT.DELETE SEL TEXTOBJ]) (TEDIT.DO.BLUEPENDINGDELETE - [LAMBDA (SEL TEXTOBJ) (* ; "Edited 29-May-91 18:21 by jds") - (* Check for blue-pending-delete, - and do it if it's there.) - (* Return T if the deletion was - made. For people who need to know) - (COND - ((fetch (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ) - (* If he's in a Blue-pending-delete - state, delete the selection.) - (PROG1 (fetch (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ) - (COND - ((NOT (ZEROP (fetch (SELECTION DCH) of SEL))) - (* There really IS something to - delete.) - (\SHOWSEL SEL NIL NIL) (* Turn off the selection) - (\DELETECH (fetch (SELECTION CH#) of SEL) - (fetch (SELECTION CHLIM) of SEL) - (fetch (SELECTION DCH) of SEL) - TEXTOBJ) (* Delete the characters.) - (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) - SEL - (fetch (SELECTION CH#) of SEL) - (fetch (SELECTION CHLIM) of SEL) - TEXTOBJ) (* Fix up any line descriptors to - reflect the deletion.) - (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* Make it a normal selection again.) - (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) - of SEL)) - - (* Fix up the selection, so that it is 0 wide, where the old text used to be.) - - (replace (SELECTION DCH) of SEL with 0) - (replace (SELECTION POINT) of SEL with 'LEFT) - (\FIXSEL SEL TEXTOBJ) (* Make its line descriptors &c - reflect the new reality) - (\SHOWSEL SEL NIL T) (* And turn it back on.) - ) - (T (* Don't do it, since it's - zero-width. However, DO turn off the - blue-pendingness of it.) - (TEDIT.RESET.EXTEND.PENDING.DELETE SEL))))]) (TEDIT.INSERT - [LAMBDA (STREAM TEXT CH#ORSEL LOOKS DONTSCROLL) (* ; "Edited 29-May-91 18:21 by jds") - (* ; - "Insert TEXT (character, litatom or string) at the appropriate spot in the text.") - (SETQ STREAM (TEXTSTREAM STREAM)) - [COND - ((FIXP CH#ORSEL) (* ; - "He gave us a ch# to insert before") - (TEDIT.SETSEL STREAM CH#ORSEL 1 'LEFT] - [COND - ((LITATOM TEXT) - (SETQ TEXT (MKSTRING TEXT] - [OR (type? SELECTION CH#ORSEL) - (SETQ CH#ORSEL (fetch (TEXTOBJ SEL) of (fetch (TEXTSTREAM TEXTOBJ) - of STREAM] - (COND - ((AND (STRINGP TEXT) - (ZEROP (NCHARS TEXT))) (* ; - "Can't insert an empty string sensibly. It confuses the screen update code.") - NIL) - [(AND CH#ORSEL (fetch (SELECTION SET) of CH#ORSEL)) - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - CH# LINE XPOINT OTEXTLEN DS LINES CHARS BLANKSEEN CRSEEN) - (TEDIT.DO.BLUEPENDINGDELETE CH#ORSEL TEXTOBJ) - (* ; - "If the selected text was for pending delete, delete it before doing the insert.") - (COND - (LOOKS (* ; - "If looks for this insertion were specified, set them up.") - (TEDIT.CARETLOOKS STREAM LOOKS))) - (SETQ OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (* ; - "The PRE-INSERT text length, for starting the screen update process") - (COND - ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - - (* ;; "If this text is in a window, move it so the insertion point is on-screen, then turn off the selection highlight") - - (COND - ((NOT DONTSCROLL) (* ; - "If DONTSCROLL is T, then don't bother scrolling the window to show the change.") - (TEDIT.NORMALIZECARET TEXTOBJ CH#ORSEL))) - (\SHOWSEL CH#ORSEL NIL NIL))) - (SETQ CH# (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of CH#ORSEL) - (LEFT (fetch (SELECTION CH#) of CH#ORSEL)) - (RIGHT (IMIN (fetch (SELECTION CHLIM) of CH#ORSEL) - (ADD1 (fetch (TEXTOBJ TEXTLEN) of - TEXTOBJ - )))) - NIL))) - (SETQ XPOINT (SELECTQ (fetch (SELECTION POINT) of CH#ORSEL) - (LEFT (fetch (SELECTION X0) of CH#ORSEL)) - (RIGHT (fetch (SELECTION XLIM) of CH#ORSEL)) - NIL)) - [COND - [(type? STRINGP TEXT) (* ; - "It's a string: Count the characters and Insert them one by one into the text stream") - (SETQ CHARS (NCHARS TEXT)) - (for ACHAR instring TEXT as NCH# from CH# by 1 - do (SELCHARQ ACHAR - ((CR %#^M 1,CR) - (SETQ CRSEEN T) - (\INSERTCR ACHAR NCH# TEXTOBJ)) - (SPACE (SETQ BLANKSEEN T) - (\INSERTCH ACHAR NCH# TEXTOBJ)) - (\INSERTCH ACHAR NCH# TEXTOBJ] - (T (* ; - "It's a singe character. Just insert it.") - (SETQ CHARS 1) - (SELCHARQ TEXT - ((CR %#^M 1,CR) - (SETQ CRSEEN T) - (\INSERTCR TEXT CH# TEXTOBJ)) - (SPACE (SETQ BLANKSEEN T) - (\INSERTCH TEXT CH# TEXTOBJ)) - (\INSERTCH TEXT CH# TEXTOBJ] - (\FIXILINES TEXTOBJ CH#ORSEL CH# CHARS OTEXTLEN) - (* ; - "Fix up the line descriptors and the Selection.") - (COND - ((NOT (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ STREAM))) - (* ; "Update the edit window.") - (TEDIT.INSERT.UPDATESCREEN TEXT CH# CHARS XPOINT TEXTOBJ CH#ORSEL OTEXTLEN - BLANKSEEN CRSEEN DONTSCROLL] - ((NOT (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ STREAM))) - (TEDIT.PROMPTPRINT (TEXTOBJ STREAM) - "Please select a place for the insertion." T]) (TEDIT.KILL - [LAMBDA (STREAM) (* ; "Edited 12-Jun-90 17:49 by mitani") - (* Force the edit session supported - by STREAM to terminate, and to - return VALUE) - (COND - ((type? STREAM STREAM) (* If he gave us a textofd, get the - textobj) - (SETQ STREAM (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - [(WINDOWP STREAM) (* Take a window, and do the obvious - with it.) - (SETQ STREAM (WINDOWPROP STREAM 'TEXTOBJ] - ((type? TEXTOBJ STREAM) (* A Textobj is just fine) - ) - (T (* Anything else is ungood, - double-plus) - (\ILLEGAL.ARG STREAM))) - (replace (TEXTOBJ EDITFINISHEDFLG) of STREAM with T) - (PROG (TEDW TEDPROC) - (AND (SETQ TEDW (CAR (fetch (TEXTOBJ \WINDOW) of STREAM))) - [PROCESSP (SETQ TEDPROC (WINDOWPROP TEDW 'PROCESS] - (NEQ TEDPROC (THIS.PROCESS)) - (DEL.PROCESS TEDPROC) - (TEDIT.DEACTIVATE.WINDOW TEDW]) (TEDIT.MAPLINES - [LAMBDA (TEXTOBJ FN) (* ; "Edited 29-May-91 18:19 by jds") - - (* Go thru the visible lines in a textobj and call a mapping fn on them) - - (* FN has 2 args%: the LINEDESCRIPTOR, and a VISIBLEFLG to say if the line is - visible on the screen.) - - (bind (LINE _ (fetch (LINEDESCRIPTOR NEXTLINE) of (fetch (TEXTOBJ LINES) - of TEXTOBJ))) - (BOT _ (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) - [TOP _ (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION (\TEDIT.PRIMARYW TEXTOBJ] - while LINE do (COND - ((EQ (APPLY* FN LINE (AND (ILESSP (fetch (LINEDESCRIPTOR YBOT) - of LINE) - TOP) - (IGEQ (fetch (LINEDESCRIPTOR YBOT) - of LINE) - BOT))) - 'STOP) - (RETURN))) - (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE]) (TEDIT.MAPPIECES - [LAMBDA (TEXTOBJ FN FNARG) (* ; "Edited 22-Apr-93 16:02 by jds") - - (* ;; "Go thru all the pieces in a document, applying a function to them serially") - - (* ;; "FN is a function of 3 args (PIECE CH#-of-1st-char-in-piece PIECE# in table FNARG)") - - (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (CH# 1) - PCNODE PC) - (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) - 0)) - (OR (ATOM PC) - (RETURN (for I from 1 while PC - do [COND - ((EQ (APPLY* FN CH# PC I FNARG) - 'STOP) - (RETURN (LIST CH# PC I] - (add CH# (fetch (PIECE PLEN) of PC)) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) (TEDIT.MOVE - [LAMBDA (FROM TO) (* ; "Edited 29-May-91 18:21 by jds") - - (* ;; - "Move the text described by the selection FROM to the place described by the selection TO") - - (SETQ TEDIT.MOVE.PENDING NIL) (* ; - "First, Turn off the global flag that got us here.") - (COND - ((NOT (AND FROM (fetch (SELECTION SET) of FROM))) - (* ; - "There MUST be a source selected first.") - (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of TO) - "Move source selection hasn't been set yet." T)) - ((ZEROP (fetch (SELECTION DCH) of FROM)) (* ; - "The source selection is empty. Just turn it off.") - (\SHOWSEL FROM NIL NIL)) - ((fetch (TEXTOBJ TXTREADONLY) of (fetch (SELECTION \TEXTOBJ) of TO)) - (* ; - "The target is read-only. Skip it..") - (\SHOWSEL FROM NIL NIL)) - (T (\SHOWSEL FROM NIL NIL) (* ; - "Before all else, make sure the copy source selection is turned off") - (COND - ((AND TO (fetch (SELECTION SET) of TO)) (* ; - "Can only do copy if there's a target selection") - (PROG ((TOOBJ (fetch (SELECTION \TEXTOBJ) of TO)) - (FROMOBJ (fetch (SELECTION \TEXTOBJ) of FROM)) - (TOLEN (fetch (TEXTOBJ TEXTLEN) of (fetch (SELECTION \TEXTOBJ) - of TO))) - (TOPCTB (fetch (TEXTOBJ PCTB) of (fetch (SELECTION \TEXTOBJ) - of TO))) - (FROMPCTB (fetch (TEXTOBJ PCTB) of (fetch (SELECTION \TEXTOBJ) - of FROM))) - (CROSSCOPY (NEQ (fetch (SELECTION \TEXTOBJ) of FROM) - (fetch (SELECTION \TEXTOBJ) of TO))) - LEN INSPC INSPC# PC NPC PCCH NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST OBJ - COPYFN UNDOCHAIN) (* ; "Find the insertion point") - (SETQ PCLST (TEDIT.SELECTED.PIECES FROMOBJ FROM CROSSCOPY (FUNCTION - \TEDIT.MOVE.PIECEMAPFN - ) - FROMOBJ TOOBJ)) (* ; - "Grab the pieces that reflect the source selection") - (SETQ REPLACING (TEDIT.DO.BLUEPENDINGDELETE TO TOOBJ)) - (* ; "Do any blue-pending-delete") - (SETQ TOPCTB (fetch (TEXTOBJ PCTB) of TOOBJ)) - (* ; - "Get the new PCTB and text length") - (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TOOBJ)) - (SETQ LEN (IDIFFERENCE (fetch (SELECTION CHLIM) of FROM) - (fetch (SELECTION CH#) of FROM))) - (\DELETECH (fetch (SELECTION CH#) of FROM) - (fetch (SELECTION CHLIM) of FROM) - (fetch (SELECTION DCH) of FROM) - FROMOBJ) (* ; - "Now delete the text from its old place") - (\FIXDLINES (fetch (TEXTOBJ LINES) of FROMOBJ) - FROM - (fetch (SELECTION CH#) of FROM) - (fetch (SELECTION CHLIM) of FROM) - FROMOBJ) - (SETQ TOLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ)) - (\SHOWSEL TO NIL NIL) (* ; - "NOW turn off the target selection.") - (replace (SELECTION SET) of FROM with NIL) - [COND - ((EQ (fetch (SELECTION POINT) of TO) - 'LEFT) - (SETQ INSERTCH# (fetch (SELECTION CH#) of TO))) - (T (SETQ INSERTCH# (fetch (SELECTION CHLIM) of TO] - (* ; - "Figure out where to do the insertion.") - (\TEDIT.INSERT.PIECES TOOBJ INSERTCH# PCLST LEN NIL NIL CROSSCOPY) - (* ; - "Get the pieces that actually got inserted, so we can UNDO the move") - - (* ;; "Keep the target from sharing a piece with type-in by accident:") - - (replace (TEXTOBJ \INSERTPCVALID) of TOOBJ with NIL) - - (* ;; "Keep \DELETECH from playing clever games with the piece if it's new type-in: Don't let it be reclaimed by the deletion:") - - (replace (TEXTOBJ \INSERTPCVALID) of FROMOBJ with NIL) - (replace (TEXTOBJ \INSERTPC) of FROMOBJ with NIL) - (\TEDIT.HISTORYADD TOOBJ - (create TEDITHISTORYEVENT - THTEXTOBJ _ TOOBJ - THACTION _ (COND - (REPLACING 'ReplaceMove) - (T 'Move)) - THLEN _ LEN - THCH# _ INSERTCH# - THFIRSTPIECE _ PCLST - THAUXINFO _ FROMOBJ - THOLDINFO _ (fetch (SELECTION CH#) of FROM))) - (* ; - "Make a history-list entry for the COPY.") - (replace (TEXTOBJ \DIRTY) of TOOBJ with T) - (* ; "Mark the document changed") - (replace (TEXTOBJ TEXTLEN) of TOOBJ with (IPLUS LEN TOLEN)) - (* ; "Set the new length") - (\FIXILINES TOOBJ TO INSERTCH# LEN TOLEN)(* ; "Fix LINES and SELs") - (COND - ((EQ (fetch (TEXTOBJ FORMATTEDP) of TOOBJ) - (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ)) - (* ; - "Either both of the files are formatted or neither is. This case is OK") - ) - ((fetch (TEXTOBJ FORMATTEDP) of TOOBJ) - (* ; - "The source wasn't formatted, but the target is. Go convert the copied text.") - (\TEDIT.CONVERT.TO.FORMATTED TOOBJ INSERTCH# (IPLUS INSERTCH# LEN))) - (T (* ; - "The source is formatted and the target isn't. Give the guy a choice.") - (* ; - "For now, convert the target file to formatted.") - (\TEDIT.CONVERT.TO.FORMATTED TOOBJ))) - (TEDIT.UPDATE.SCREEN FROMOBJ) - (TEDIT.UPDATE.SCREEN TOOBJ) (* ; "Refresh the display") - (replace (SELECTION CH#) of TO with INSERTCH#) - (* ; "Correct the target selection") - (replace (SELECTION CHLIM) of TO with (IPLUS INSERTCH# LEN)) - (replace (SELECTION DCH) of TO with LEN) - (replace (SELECTION DX) of TO with 0) - (replace (SELECTION POINT) of TO with 'RIGHT) - (COND - ((NEQ TO FROM) - (\FIXSEL FROM FROMOBJ) - (\FIXSEL (fetch (TEXTOBJ SEL) of FROMOBJ) - FROMOBJ))) - (\FIXSEL TO TOOBJ) - (\SHOWSEL TO NIL T))) - (T (* ; - "There is no target selection -- complain") - (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of FROM) - "Please select a destination for the MOVE first." T]) (TEDIT.QUIT - [LAMBDA (STREAM VALUE) (* ; "Edited 12-Jun-90 17:49 by mitani") - - (* ;; "Force the edit session supported by STREAM to terminate, and to return VALUE") - - (COND - ((type? STREAM STREAM) (* ; - "If he gave us a textofd, get the textobj") - (SETQ STREAM (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - ((type? TEXTOBJ STREAM) (* ; "A Textobj is just fine") - ) - (T (* ; - "Anything else is ungood, double-plus") - (\ILLEGAL.ARG STREAM))) - (replace (TEXTOBJ EDITFINISHEDFLG) of STREAM with (OR VALUE T)) - (* ; - "tell the command loop to stop next time through") - (PROG (MAINW) - (COND - ([AND (fetch (TEXTOBJ \WINDOW) of STREAM) - (NEQ (SETQ MAINW (\TEDIT.PRIMARYW STREAM)) - (PROCESSPROP (TTY.PROCESS) - 'WINDOW] - - (* ;; "there is a main window of the stream, and it is not the window of the tty process, so give it the tty") - - (TTY.PROCESS (WINDOWPROP MAINW 'PROCESS)) - (AND (NEQ (TTY.PROCESS) - (THIS.PROCESS)) - (until [OR (NOT (WINDOWPROP MAINW 'PROCESS)) - (PROCESS.FINISHEDP (WINDOWPROP MAINW 'PROCESS] do - (* ; - "Wait until the Edit process has had a chance to go away before continuing here.") - (DISMISS]) (TEDIT.STRINGWIDTH - [LAMBDA (STR FONT TERMSA) (* jds "19-AUG-83 14:40") - (COND - (TERMSA - - (* We have a terminal table to take account of. - Do so.) - - (for CH instring STR sum (TEDIT.CHARWIDTH CH FONT TERMSA))) - (T (* Just use the native character - widths) - (for CH instring STR sum (SELCHARQ CH - (TAB 36) - (CHARWIDTH CH FONT]) (TEDIT.\INSERT - [LAMBDA (CH SEL STREAM) (* ; "Edited 29-May-91 18:22 by jds") - (* Insert the character CH at the - appropriate spot in the text.) - (DECLARE (LOCALVARS . T)) - (PROG [(TEXTOBJ (COND - ((type? STREAM STREAM) (* If we got a STREAM, change it - into a textobj) - (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - (T STREAM] - (COND - ((NOT (AND SEL (fetch (SELECTION SET) of SEL))) - (TEDIT.PROMPTPRINT TEXTOBJ "Please select a place for the insertion." T) - (RETURN))) - (COND - ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - - (* There is a window; make sure the insert point is on-screen, and turn off any - highlighted selection) - - (TEDIT.NORMALIZECARET TEXTOBJ SEL) - (\SHOWSEL SEL NIL NIL))) - (PROG ((CH# (TEDIT.GETPOINT STREAM SEL)) - (XPOINT (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (fetch (SELECTION X0) of SEL)) - (RIGHT (fetch (SELECTION XLIM) of SEL)) - NIL)) - (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) - (SELCHARQ CH - ((CR %#^M 1,CR) (* This was a CR. Go do the para - breaking as needed) - (\INSERTCR CH CH# TEXTOBJ)) - (\INSERTCH CH CH# TEXTOBJ)) - (\FIXILINES TEXTOBJ SEL CH# 1 OTEXTLEN) - (TEDIT.INSERT.UPDATESCREEN CH CH# 1 XPOINT TEXTOBJ SEL OTEXTLEN NIL NIL NIL T]) (TEXTOBJ - [LAMBDA (STREAM) (* jds "11-Jul-85 12:06") - (* Convert from a text stream to the - associated textobj) - (COND - ((type? TEXTOBJ STREAM) (* It's already a TEXTOBJ) - STREAM) - ((AND (type? STREAM STREAM) - (fetch (TEXTSTREAM TEXTOBJ) of STREAM) - (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - (* It's a TEXTSTREAM) - (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - ((AND (PROCESSP STREAM) - (PROCESS.WINDOW STREAM)) (* It's an edit PROCESS) - (WINDOWPROP (PROCESS.WINDOW STREAM) - 'TEXTOBJ)) - [(AND (WINDOWP STREAM) - (WINDOWPROP STREAM 'TEXTOBJ] - [(AND (DISPLAYSTREAMP STREAM) - (WINDOWPROP STREAM 'TEXTOBJ] - ((\ILLEGAL.ARG STREAM]) (TEXTSTREAM - [LAMBDA (STREAM) (* ; "Edited 12-Jun-90 17:50 by mitani") - (* Force a textobj or stream to be a - stream) - (COND - ((AND (type? STREAM STREAM) - (fetch (TEXTSTREAM TEXTOBJ) of STREAM) - (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - (* It's a stream, and is really a - TEXT stream. Just return it.) - STREAM) - ((type? TEXTOBJ STREAM) (* It's a TEXTOBJ, so grab the - stream hint field and return that.) - (fetch (TEXTOBJ STREAMHINT) of STREAM)) - ((AND (PROCESSP STREAM) - (PROCESS.WINDOW STREAM)) (* It's an edit process, so grab the - text stream from the edit window.) - (WINDOWPROP (PROCESS.WINDOW STREAM) - 'TEXTSTREAM)) - [(AND (WINDOWP STREAM) - (WINDOWPROP STREAM 'TEXTSTREAM] - [(AND (DISPLAYSTREAMP STREAM) - (WINDOWPROP STREAM 'TEXTSTREAM] - ((\ILLEGAL.ARG STREAM) (* Not a reasonable coercion to the - text stream. Punt.) - ]) (\TEDIT.INCLUDE - [LAMBDA (TEXTOBJ FILE START END) (* ; "Edited 29-May-91 18:22 by jds") - - (* A NATIVE text includer%: Includes part of a file, without checking to see if - it's a bravo file, a TEdit file or whatever.) - (* (PROG ((LEN (IDIFFERENCE - (OR END (GETEOFPTR FILE)) - (OR START 0))) (SEL - (fetch (TEXTOBJ SEL) of TEXTOBJ)) - NPC) (SETQ NPC (create PIECE PFILE _ - (\GETOFD FILE (QUOTE INPUT)) PFPOS _ - (OR START 0) PLEN _ LEN PLOOKS _ - (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ - SEL) PPARALOOKS _ NIL)) - (* Create a PIECE to describe the - text) (\TEDIT.INSERT.PIECES TEXTOBJ - (fetch (SELECTION CH#) of SEL) NPC - LEN) (* Insert it in the document) - (add (fetch (TEXTOBJ TEXTLEN) of - TEXTOBJ) LEN) (* And update the - document's length) - (\TEDIT.MARK.LINES.DIRTY TEXTOBJ - (fetch (SELECTION CH#) of SEL) - (IPLUS (fetch (SELECTION CH#) of SEL) - LEN)) (* Mark the screen dirty, so updating it will find something to do) (replace - (SELECTION CHLIM) of SEL with - (IPLUS (fetch (SELECTION CH#) of SEL) - LEN)) (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0) - (replace (SELECTION POINT) of SEL - with (QUOTE RIGHT)) - (replace (SELECTION SELKIND) of SEL - with (QUOTE CHAR)) - (replace (SELECTION SELOBJ) of SEL - with NIL) (COND ((fetch - (TEXTOBJ \WINDOW) of TEXTOBJ) - (\SHOWSEL SEL NIL NIL) - (TEDIT.UPDATE.SCREEN TEXTOBJ) - (\FIXSEL SEL TEXTOBJ) - (\SHOWSEL SEL NIL T))) - (* Update the screen) - (replace (TEXTOBJ \DIRTY) of TEXTOBJ - with T) (\SETUPGETCH - (fetch (SELECTION CH#) of SEL) - TEXTOBJ))) - (HELP]) (\TEDIT.INSERT.PIECES [LAMBDA (TEXTOBJ CH# FIRSTPIECE %#CHARS INSPC INSPC# CROSSCOPY DONTDIRTY COPYING) (* ; "Edited 11-Jun-99 14:03 by rmk:") (* ;  "Edited 24-Apr-95 12:04 by sybalsky:mv:envos") (* ;; "Inserts a series of pieces into TEXTOBJ in front of character CH#.") (* ;; "If FIRSTPIECE is a PIECE, this will follow the next-piece pointer chain; if FIRSTPIECE is a list, it is a list of pieces to insert.") (* ;; "If CROSSCOPY is non-NIL, the pieces' contents will be copied, to preserve text in case the original is deleted.") (* ;; "INSPC and INSPC# are accelerators for where in the PCTB the new pieces should go.") (* ;; "DONTDIRTY is T if this is a change not visible to the user--one that shouldn't %"dirty%" the document. This is used tor NS-character encoding recognition durint line formatting.") (* ;; "COPYING is T if these pieces are being inserted by a COPY operation. This lets us call the AFTERCOPYFN on image objects.") (* ;; "It is the CALLER'S RESPONSIBILITY to make sure the pieces to be inserted are 'safe' --that they are, if necessary, copies of the originals, and can safely be modified.") (* ;  "NB THAT THIS DOES NOT UPDATE TEXTLEN") (COND ((OR DONTDIRTY (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) (* ;; "Only do this if you're allowed to change the document, or it's a TEdit-intertnal fixup change, as for NS char recognition.") (LET ((TOLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (TOPCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (CURCH# CH#) LEN PC PREVPC NPC UNDOCHAIN PSTR SRCPFILE START-OF-PIECE) (* ;  "Get a handle on the piece we're to insert within or in front of") (* THIS USED TO WORK, BUT WITH NEW PCTREE CODE, IT CAUSES AN EMPTY PIECE AT  START OF DOC THAT'S NOT FORWARD-CONNECTED.  COND ((ZEROP (fetch (BTREENODE TOTLEN) of TOPCTB))  (* ; "PCTB is empty.") (\INSERT.FIRST.PIECE TEXTOBJ))) (SETQ INSPC (\CHTOPC CH# TOPCTB T)) (* ; "And the piece, itself. (Used to be (OR INSPC (\CH...)), but we MUST set START-OF-PIECE, so must make the call to \CHTOPC.") (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force later insertions to make new pieces.") [COND ((IGREATERP CH# TOLEN) (* ;  "We're inserting at end of file; leave the piece to insert before as LASTPIECE") ) ((IEQP CH# START-OF-PIECE) (* ;  "The insertion is IN FRONT of this piece; just continue on") ) (T (SETQ INSPC (\SPLITPIECE INSPC (- CH# START-OF-PIECE) TEXTOBJ] (* ;  "Nope, we're inserting INSIDE this piece. Split it in two.") (COND ((NEQ INSPC 'LASTPIECE) (* ;  "Not the last piece, so back up using the pointer.") (SETQ PREVPC (fetch (PIECE PREVPIECE) of INSPC))) ((NOT (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) (* ;  "If we are at the end, AND there is text before us, find it thru the pctb.") (SETQ PREVPC (\CHTOPC (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) TOPCTB))) (T (* ;  "Otherwise, there is no piece before where we're inserting.") (SETQ PREVPC NIL))) (* ; "For pushing para looks in") (bind [PC _ (create PIECE using (COND ((LISTP FIRSTPIECE) (pop FIRSTPIECE)) (T FIRSTPIECE] (LEN _ 0) (PCCOUNT _ 0) first (SETQ UNDOCHAIN PC) while (AND PC (OR (NOT %#CHARS) (ILESSP LEN %#CHARS))) do (* ;  "Now insert the copied pieces into the new place") (COND ((AND CROSSCOPY (SETQ SRCPFILE (fetch (PIECE PFILE) of PC))) (* ;; "If this is a cross-document copy, and the text comes from a file, we must REALLY make a copy of the text, lest the source file be deleted.") (* ;; "(replace PSTR of PC with (SETQ PSTR (ALLOCSTRING (fetch PLEN of PC) NIL NIL (fetch PFATP of PC))))") (replace (PIECE PFILE) of PC with (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) (* ; "Create the holding file") [COND ((NOT (OPENP SRCPFILE)) (* ;  "The source file was CLOSED -- reopen it, for our us") (replace (PIECE PFILE) of PC with (SETQ SRCPFILE (OPENSTREAM SRCPFILE 'INPUT 'OLD '((TYPE TEXT] (SETFILEPTR SRCPFILE (fetch (PIECE PFPOS) of PC)) [COPYCHARS SRCPFILE (fetch (PIECE PFILE) of PC) (fetch (PIECE PFPOS) of PC) (IPLUS (fetch (PIECE PFPOS) of PC) (COND ((fetch (PIECE PFATP) of PC) (LLSH (fetch (PIECE PLEN) of PC) 1)) (T (fetch (PIECE PLEN) of PC] (replace (PIECE PFPOS) of PC with 0))) (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ)) (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of PC) TEXTOBJ)) (* ;  "Assure that the new document knows about this piece's looks") [COND ((NULL FIRSTPIECE) (SETQ NPC NIL)) [(LISTP FIRSTPIECE) (* ;  "If the piece list really IS a list, grab the next piece from the front") (SETQ NPC (create PIECE using (pop FIRSTPIECE] (T (* ;  "Otherwise, follow the NEXTPIECE chain among pieces") (SETQ NPC (create PIECE using (fetch (PIECE NEXTPIECE) of PC] (\INSERTPIECE PC INSPC TEXTOBJ NIL) (* ;  "Insert the piece into the new document") [COND (COPYING (* ;; "For objects, call the optional AFTERCOPYFN.") (LET (OBJ AFTERFN) (AND (SETQ OBJ (ffetch (PIECE POBJ) of PC)) (SETQ AFTERFN (IMAGEOBJPROP OBJ 'AFTERCOPYFN)) (APPLY* AFTERFN OBJ PC CURCH#] (add CURCH# (fetch (PIECE PLEN) of PC)) (add LEN (fetch (PIECE PLEN) of PC)) (SETQ PC NPC)) (\TEDIT.DIFFUSE.PARALOOKS PREVPC INSPC) UNDOCHAIN]) (\TEDIT.MOVE.PIECEMAPFN - [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ) (* ; "Edited 12-Jun-90 17:50 by mitani") - (* Called by TEDIT.MOVE via - TEDIT.SELECTED.PIECES, to do the - move-operation processing on the - candidate pieces.) - (PROG (OBJ MOVEFN) - (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh - copy.) - [COND - [(fetch (PIECE POBJ) of PC) (* This piece describes an object) - (* Call its WHENMOVEDFN.) - (SETQ OBJ (fetch (PIECE POBJ) of PC)) - (COND - ((SETQ MOVEFN (IMAGEOBJPROP OBJ 'WHENMOVEDFN)) - (* If there's an eventfn for moving, - use it.) - (APPLY* MOVEFN OBJ (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ)) - (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) - (fetch (TEXTOBJ STREAMHINT) of TOOBJ] - ((fetch (PIECE PSTR) of PC) - - (* If the piece is a string, make our own copy of the string header, even tho - we share characters.) - - (replace (PIECE PSTR) of PC with (SUBSTRING (fetch (PIECE PSTR) - of PC) - 1 - (fetch (PIECE PLEN) - of PC] - (RETURN PC]) (\TEDIT.OBJECT.SHOWSEL - [LAMBDA (TEXTOBJ SEL ON SELWINDOW) (* ; "Edited 12-Jun-90 17:50 by mitani") - - (* ;; "We are hilighting (or dehilighting) a selected object. Let it know.") - - (LET ((X (fetch (SELECTION X0) of SEL)) - (Y (fetch (SELECTION Y0) of SEL)) - (FIRSTLINE (CAR (fetch (SELECTION L1) of SEL))) - (OBJ (fetch (SELECTION SELOBJ) of SEL)) - (WIDTH (fetch (SELECTION DX) of SEL)) - (XOFFSET (DSPXOFFSET NIL SELWINDOW)) - (YOFFSET (DSPYOFFSET NIL SELWINDOW)) - (IMAGEFN (IMAGEOBJPROP (fetch (SELECTION SELOBJ) of SEL) - 'WHENOPERATEDONFN)) - (WWIDTH (WINDOWPROP SELWINDOW 'WIDTH)) - (WHEIGHT (WINDOWPROP SELWINDOW 'HEIGHT)) - IMAGEBOX) - (COND - ((INSIDE? (CREATEREGION 0 0 WWIDTH WHEIGHT) - X Y) (* ; - "Only do this if teh selection is on-screen.") - (SETQ IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) - (APPLY* (IMAGEOBJPROP OBJ 'IMAGEBOXFN) - OBJ SELWINDOW))) - [COND - (FIRSTLINE - - (* ;; "There's really a line this selection is being displayed on, so we need to use the YBASE of the line- the object's descent, rather than the YBOT, which is what Y0 is.") - - (SETQ Y (- (fetch (LINEDESCRIPTOR YBASE) of FIRSTLINE) - (fetch (IMAGEBOX YDESC) of IMAGEBOX] - (RESETLST - [RESETSAVE (DSPXOFFSET (IDIFFERENCE (IPLUS X XOFFSET) - (fetch XKERN of IMAGEBOX)) - SELWINDOW) - (LIST (FUNCTION DSPXOFFSET) - XOFFSET - (WINDOWPROP SELWINDOW 'DSP] - (RESETSAVE (DSPYOFFSET (IPLUS Y YOFFSET) - SELWINDOW) - (LIST (FUNCTION DSPYOFFSET) - YOFFSET SELWINDOW)) - (RESETSAVE (DSPCLIPPINGREGION (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (IMIN WIDTH (IDIFFERENCE - (fetch (TEXTOBJ - WRIGHT) - of TEXTOBJ) - X)) - HEIGHT _ (fetch YSIZE of IMAGEBOX)) - SELWINDOW) - (LIST (FUNCTION DSPCLIPPINGREGION) - (DSPCLIPPINGREGION NIL SELWINDOW) - SELWINDOW)) - [AND IMAGEFN (ERSETQ (APPLY* IMAGEFN OBJ SELWINDOW (COND - (ON 'HIGHLIGHTED) - (T 'UNHIGHLIGHTED)) - SEL - (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ])]) (\TEDIT.RESTARTFN - [LAMBDA (TEXT WINDOW PROPS) (* ; "Edited 12-Jun-90 17:51 by mitani") - (* Restarts a TEdit session.) - (replace (TEXTOBJ \WINDOW) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - with NIL) (* Unattach the window, so we do a - redisplay.) - (PROG [(ODIRTY (fetch (TEXTOBJ \DIRTY) of (fetch (TEXTSTREAM TEXTOBJ) - of TEXT] - (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS)) - (replace (TEXTOBJ \DIRTY) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - with ODIRTY)) (* Now reconnect the world together - again) - (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) - (* Run the editing engine) - (CLOSEW WINDOW) (* Close the edit window) - (\TEXTCLOSEF TEXT) (* Close the underlying files) - (replace (STREAM ACCESSBITS) of TEXT with BothBits) - (* But leave the stream itself - accessible) - (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'AFTERQUITFN) - (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'AFTERQUITFN) - WINDOW TEXT)) (* Apply any post-window-close - (and post-QUIT) function) - ]) (\TEDIT.CHARDELETE - [LAMBDA (TEXTOBJ SCRATCHSTRING SEL) (* ; "Edited 19-Apr-93 10:50 by jds") - - (* ;; "Do character-backspace deletion for TEDIT") - - (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) - (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - TLEN INSCH# INSPC INSPC# TLOOKS START-OF-PIECE) - (COND - [NIL [NOT (ZEROP (SETQ TLEN (fetch (STRINGP OFFST) of SCRATCHSTRING] - (* ; - "If we didn't really insert the text yet, just remove from the text to be inserted") - (replace (STRINGP OFFST) of SCRATCHSTRING with (SUB1 TLEN)) - (replace (STRINGP LENGTH) of SCRATCHSTRING - with (ADD1 (fetch (STRINGP LENGTH) of SCRATCHSTRING] - (T (* ; - "Delete the character just before the current insertpoint.") - (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (SETQ INSCH# (SUB1 (fetch (SELECTION CH#) of SEL)))) - (RIGHT (SETQ INSCH# (SUB1 (fetch (SELECTION CHLIM) of SEL)))) - NIL) - (COND - ((ILEQ INSCH# 0) (* ; - "Can't backspace past start of document") - (RETURN))) - - (* ;; "(SETQ INSPC (\EDITELT PCTB (ADD1 (SETQ INSPC# (\CHTOPCNO INSCH# PCTB)))))") - - (SETQ INSPC (\CHTOPC INSCH# PCTB T)) - (SETQ TLOOKS (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of INSPC) - INSPC TEXTOBJ)) - [while (AND INSPC (fetch CLINVISIBLE of TLOOKS)) - do (* ; - "Back over any invisible text, which we're no allowed to delete.") - (SETQ INSPC (fetch (PIECE PREVPIECE) of INSPC)) - (SETQ INSCH# (SUB1 START-OF-PIECE)) - (add START-OF-PIECE (IMINUS (fetch (PIECE PLEN) of INSPC))) - (COND - (INSPC (SETQ TLOOKS (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) - of INSPC) - INSPC TEXTOBJ] - (COND - ((ILEQ INSCH# 0) (* ; - "We backed up to the start of the document. Can't go no further.") - (RETURN)) - ((NOT (fetch CLPROTECTED of TLOOKS)) - (* ; - "Can only backspace if the char to go isn't protected.") - (replace (SELECTION CHLIM) of SEL - with (ADD1 (replace (SELECTION CH#) of SEL with INSCH#))) - (* ; - "Set up the selection to point to the character which is to be deleted.") - (replace (SELECTION DCH) of SEL with 1) - (\SHOWSEL SEL NIL NIL) (* ; - "Turn off the underlining, if any, so there's no garbage.") - (\FIXSEL SEL TEXTOBJ) (* ; - "Fix the selection up so it points to the right line and all") - (\TEDIT.DELETE SEL TEXTOBJ T) (* ; "And delete it.") - ]) (\TEDIT.COPY.PIECEMAPFN - [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ) (* ; "Edited 12-Jun-90 17:50 by mitani") - (* Called by TEDIT.COPY via - TEDIT.SELECTED.PIECES, to do the - copy-operation processing on the - candidate pieces.) - (PROG (OBJ NEWOBJ COPYFN) - (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh - copy.) - [COND - ((fetch (PIECE POBJ) of PC) (* This piece describes an object) - (SETQ OBJ (fetch (PIECE POBJ) of PC)) - [COND - [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN)) - (SETQ NEWOBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) - (fetch (TEXTOBJ STREAMHINT) of TOOBJ))) - (COND - ((EQ NEWOBJ 'DON'T) (* He said not to copy this piece -- - abort the whole copy.) - (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T) - (RETFROM 'TEDIT.COPY)) - (NEWOBJ (replace (PIECE POBJ) of PC with NEWOBJ)) - (T (replace (PIECE POBJ) of PC with (COPYALL OBJ] - (OBJ (* No copy fn; just strike off a - copy of our own) - (replace (PIECE POBJ) of PC with (COPYALL OBJ] - (COND - ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN)) - (* If there's an eventfn for - copying, use it.) - (APPLY* COPYFN OBJ (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ)) - 'DSP) - (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) - (fetch (TEXTOBJ STREAMHINT) of TOOBJ] - [COND - ((fetch CLPROTECTED of (fetch (PIECE PLOOKS) of PC)) - (* The source text was protected; - unprotect the copy.) - (replace (PIECE PLOOKS) of PC - with (\TEDIT.UNIQUIFY.CHARLOOKS (create CHARLOOKS - using (fetch (PIECE PLOOKS) - of PC) - CLPROTECTED _ NIL CLSELHERE _ NIL) - TOOBJ] - (RETURN PC]) (\TEDIT.DELETE - [LAMBDA (SEL STREAM SELOFF) (* ; "Edited 29-May-91 18:22 by jds") - (* ; - "DELETE THE CHARACTERS SPECIFIED FROM THE MAIN TEXT.") - (* ; - "SELOFF => The selection is already turned off.") - (LET* - ((TEXTOBJ (TEXTOBJ STREAM)) - (CH# (fetch (SELECTION CH#) of SEL)) - (CHLIM (fetch (SELECTION CHLIM) of SEL)) - (LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) - (WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) - (HEIGHTCHANGED NIL) - (NLINE1 NIL) - (CRFLAG NIL) - (LINES\DELETED NIL) - OLINE1 OLINEN LEN NEXTLINE NL OLINE DX OCHLIM OXLIM OLHEIGHT OLASCENT OLDESCENT DY PREVLINE - TEXTLEN OCR\END SAVEWIDTH IMAGECACHE) - [SETQ LEN (COND - ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (* ; - "Past end of text, so don't delete any") - 0) - ((IGEQ CH# CHLIM) (* ; - "Start is past end, so don't delete any.") - 0) - ((ZEROP (fetch (SELECTION DCH) of SEL)) - (* ; - "Just a caret--no text really selected--so don't delete any") - 0) - ((ZEROP CHLIM) (* ; - "CHLIM is before start of text, so don't delete any") - 0) - (T (* ; "The normal case.") - (IDIFFERENCE CHLIM CH#] (* ; "# of characters to be deleted") - (COND - ((OR (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) - (NOT (fetch (SELECTION SET) of SEL)) - (ZEROP LEN)) (* ; "If the selection isn't set, OR the document is read-only, OR the selection contains no characters, don't do anything.") - ) - (T (AND WINDOW (TEDIT.NORMALIZECARET TEXTOBJ SEL)) (* ; - "If the text appears in a window, move the deletion point on-screen") - (SETQ OLINE1 (fetch (SELECTION L1) of SEL)) - (SETQ OLINEN (fetch (SELECTION LN) of SEL)) - (\TEDIT.SHOWSELS TEXTOBJ NIL NIL) (* ; - "Turn off the selection's highlighting") - (AND LINES (\FIXDLINES LINES SEL CH# CHLIM TEXTOBJ)) - (* ; - "Update the line descriptors to account for the deletion") - (\DELETECH CH# CHLIM LEN TEXTOBJ) (* ; - "Do the actual deletion of characters") - (replace THPOINT of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) - with (fetch (SELECTION POINT) of SEL)) - (* ; - "Remember which side of the selection we were on, in case it gets undone.") - (replace (SELECTION CH#) of SEL with (IMAX 1 CH#)) - (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) of - SEL)) - (replace (SELECTION POINT) of SEL with 'LEFT) - (replace (SELECTION DCH) of SEL with 0) - (COND - (WINDOW (* ; - "If there's no window to update, don't bother") - (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (* ; "The new text length") - (for OLINE1 inside (fetch (SELECTION L1) of SEL) as OLINEN - inside (fetch (SELECTION LN) of SEL) as TOPLINE - inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as THISW inside - WINDOW - do (SETQ LINES\DELETED - (\TEDIT.CLOSEUPLINES - TEXTOBJ - (OR (AND OLINE1 (COND - ((fetch (LINEDESCRIPTOR DELETED) of OLINE1) - (fetch (LINEDESCRIPTOR PREVLINE) of OLINE1)) - (T OLINE1))) - (COND - ([AND (fetch (LINEDESCRIPTOR NEXTLINE) of TOPLINE) - (OR (IGEQ (fetch (LINEDESCRIPTOR CHAR1) - of (fetch (LINEDESCRIPTOR NEXTLINE) - of TOPLINE)) - (fetch (SELECTION CHLIM) of SEL)) - (ILESSP (fetch (LINEDESCRIPTOR CHARLIM) - of (fetch (LINEDESCRIPTOR NEXTLINE) - of TOPLINE)) - (fetch (SELECTION CH#) of SEL] - (* ; - "The first line on the screen is already past where we're to delete. DON'T delete any lines") - NIL) - (T TOPLINE))) - (AND OLINEN (COND - ((fetch (LINEDESCRIPTOR DELETED) of OLINEN) - (fetch (LINEDESCRIPTOR NEXTLINE) of OLINEN)) - (T OLINEN))) - NIL THISW))) (* ; - "Remove any lines which were completely deleted.") - - (* ;; "This line must needs be reformatted the hard way--it isn't a left ragged line or one of the lines is off-screen.") - - (replace (SELECTION DX) of SEL with 0) - (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T) (* ; - "Correct the text that's displayed already") - (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) - TEXTOBJ) (* ; - "Then fix up the selection as needed.") - (\TEDIT.SHOWSELS TEXTOBJ NIL T]) (\TEDIT.DIFFUSE.PARALOOKS - [LAMBDA (PRIORPC SUCCEEDINGPC) (* ; "Edited 12-Jun-90 17:48 by mitani") - - (* Given a discontinuity in paragraph looks, caused by an insertion or by a - deletion%: Diffuse the existing paragraph looks across the discontinuity, so - that all the pieces in a single paragraph have consistent looks. - Give preference to diffusion toward the END of the document. - This means that if you delete a CR between paragraphs, the second para is - absorbed into the first.) - - (* PRIORPC and SUCCEEDINGPC are the PIECEs that bound the area of potential - discontinuity%: the change will occur at one boundary or the other....) - - [COND - ((AND PRIORPC (NOT (fetch (PIECE PPARALAST) of PRIORPC))) - (* The discontinuity is inside a - paragraph. Must copy para looks - forward into the text.) - (bind (PPLOOKS _ (fetch (PIECE PPARALOOKS) of PRIORPC)) - (PC _ (fetch (PIECE NEXTPIECE) of PRIORPC)) while PC - do (* Copy para looks info in from the - left, up the the first para break.) - (replace (PIECE PPARALOOKS) of PC with PPLOOKS) - (COND - ((fetch (PIECE PPARALAST) of PC) (* If this piece ends a paragraph, - we're done.) - (RETURN))) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC] - (COND - ((AND SUCCEEDINGPC (NEQ SUCCEEDINGPC 'LASTPIECE)) - - (* Only copy para looks in from the right if there is text to the right.) - - (bind (PPLOOKS _ (fetch (PIECE PPARALOOKS) of SUCCEEDINGPC)) - (PC _ (fetch (PIECE PREVPIECE) of SUCCEEDINGPC)) while (NEQ PC PRIORPC) - do (* Copy para looks in from the - right, up to the first para break) - (COND - ((fetch (PIECE PPARALAST) of PC) (* If this piece ends a paragraph, - we're done.) - (RETURN))) - (replace (PIECE PPARALOOKS) of PC with PPLOOKS) - (SETQ PC (fetch (PIECE PREVPIECE) of PC]) (\TEDIT.FOREIGN.COPY? - [LAMBDA (SEL) (* ; "Edited 21-Jan-93 11:46 by jds") - - (* ;; "IF the current process's window isn't a TEdit window, do a 'Copy' by BKSYSBUFing the selected text. Then turn off all the various indicators.") - - (PROG (PROCW (SOURCE.TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - CH STREAM DEST.TEDIT? DEST.TEXTOBJ) - [SETQ DEST.TEDIT? (AND (SETQ PROCW (PROCESSPROP (TTY.PROCESS) - 'WINDOW)) - (SETQ DEST.TEXTOBJ (WINDOWPROP PROCW 'TEXTOBJ)) - (NOT (TEXTPROP DEST.TEXTOBJ 'COPYBYBKSYSBUF] - (* ; "Treat the destination specially if (1) the recipient process has a window, and (2) it's a TEdit window, and (3) the TEdit isn't declining special treatment by having COPYBYBKSYSBUF set in its props.") - (COND - ((ZEROP (fetch (SELECTION DCH) of SEL)) (* ; - "Nothing to copy (0 characters in selection); don't bother.") - (SETQ TEDIT.COPY.PENDING NIL)) - ((IGREATERP (fetch (SELECTION CH#) of SEL) - (FETCH (TEXTOBJ TEXTLEN) OF SOURCE.TEXTOBJ)) - (* ; - "Trying to copy from beyond the end of the document; don't bother") - (SETQ TEDIT.COPY.PENDING NIL)) - ((OR (NOT DEST.TEDIT?) - (AND PROCW DEST.TEXTOBJ (NEQ SOURCE.TEXTOBJ DEST.TEXTOBJ) - (fetch (TEXTOBJ EDITOPACTIVE) of DEST.TEXTOBJ))) - (* ; - "OK -- receiver isn't TEdit. Do it the hard way.") - [COND - [(AND (WINDOWPROP [OR PROCW (WFROMDS (PROCESS.TTY (TTY.PROCESS] - 'COPYINSERTFN) - (PROGN (* ; - "This is the exit for looked-string objects") - (OBJECTOUTOFTEDIT SOURCE.TEXTOBJ SEL] - (T (* ; - "Old tedit method, run if OBJECTOUTOFTEDIT is NILL (ie., not installed yet)") - - (* ;; "Still used because COPYINSERT does (PRIN2 BKSYSBUF) if there's no insertfn, which cretes undesired string quotes.") - - (\SETUPGETCH (fetch (SELECTION CH#) of SEL) - SOURCE.TEXTOBJ) (* ; - "Go to the first character to be copied") - (SETQ STREAM (fetch (TEXTOBJ STREAMHINT) of SOURCE.TEXTOBJ)) - (for I from 1 to (fetch (SELECTION DCH) of SEL) - do - - (* ;; "Run thru the selected text, copying only those items that really ARE characters--IMAGEOBJs don't get copied by this route.") - - (COND - ((FIXP (SETQ CH (\BIN STREAM))) - (BKSYSBUF (CHARACTER CH))) - (T (COPYINSERT CH] - (\SHOWSEL SEL NIL NIL) (* ; - "Then reset the copy-pending flags.") - (SETQ TEDIT.COPY.PENDING NIL]) (\TEDIT.QUIT - [LAMBDA (W NOFORCE) (* ; "Edited 12-Jun-90 17:50 by mitani") - (* Called by the default - TEDIT.DEFAULT.MENUFN to perform the - QUIT command.) - (PROG* ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) - (QUITFNS (TEXTPROP TEXTOBJ 'QUITFN)) - QUITFLG RESP) - [for QUITFN inside QUITFNS while (AND (NEQ QUITFLG 'DON'T) - (NEQ QUITFLG T)) - do (COND - ((EQ QUITFN T) - (SETQ QUITFLG T)) - (T (AND QUITFN (NEQ QUITFN T) - (SETQ QUITFLG (APPLY* QUITFN W (fetch (TEXTOBJ STREAMHINT) - of TEXTOBJ) - TEXTOBJ - (fetch (TEXTOBJ EDITPROPS) of - TEXTOBJ - ] - (COND - ((EQ QUITFLG 'DON'T) - - (* The user supplied a QUITFN, and it returned "DON'T" %, so just ignore all - this Fooferaw and keep editing.) - - (RETURN)) - [(AND (fetch (TEXTOBJ \DIRTY) of TEXTOBJ) - (NOT (fetch (TEXTOBJ MENUFLG) of TEXTOBJ)) - (NEQ QUITFNS T) - (NEQ QUITFLG T)) - - (* If this document has changed, check with the user to make sure he really - wants to do it.) - - (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ - with (MOUSECONFIRM "Not saved yet; LEFT to Quit anyway." T (fetch - (TEXTOBJ - PROMPTWINDOW - ) - of TEXTOBJ] - (T (* Go ahead and quit the next time - we see the main command loop.) - (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ with T))) - [AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - (NOT NOFORCE) - (NEQ (\TEDIT.PRIMARYW TEXTOBJ) - (PROCESSPROP (TTY.PROCESS) - 'WINDOW)) - (TTY.PROCESS (WINDOWPROP (\TEDIT.PRIMARYW TEXTOBJ) - 'PROCESS] - (RETURN (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ]) (\TEDIT.WORDDELETE - [LAMBDA (TEXTOBJ) (* ; "Edited 29-May-91 18:22 by jds") - - (* ;; "Delete the word to the left of the caret.") - - (* ;; "Back word.") - - (* ;; "THIS FUNCTION IS FRAUGHT WITH FENCEPOST PROBLEM POTENTIAL, AND THE WHILE vs FOR LOGIC IS CONVOLUTED. CAUTION, CAUTION.") - - (LET* ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) - (READSA (fetch READSA of (OR (fetch (TEXTOBJ TXTWTBL) of TEXTOBJ) - TEDIT.WORDBOUND.READTABLE))) - (INSCH# (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (SUB1 (fetch (SELECTION CH#) of SEL))) - (RIGHT (SUB1 (fetch (SELECTION CHLIM) of SEL))) - NIL)) - CH CHNO) - - (* ;; "INSCH# is the final (i.e., highest-numbered) character to be deleted.") - - (COND - ((IGREATERP INSCH# 0) (* ; - "Don't try to back up past start of file.") - (\SETUPGETCH INSCH# TEXTOBJ) - (SETQ CH (\BIN STREAM)) - (for old CHNO from INSCH# to 1 by -1 - while [AND (SELECTC (COND - ((FIXP CH) - (\SYNCODE READSA CH)) - (T (* ; "It's an object!") - TEXT.TTC)) - (TEXT.TTC NIL) - T) - (NOT (fetch CLPROTECTED of (fetch (PIECE PLOOKS) - of (fetch (TEXTSTREAM - PIECE) - of STREAM] - do - - (* ;; "Skip over any initial separator characters") - - (SETQ CH (\GETCHB TEXTOBJ))) - - (* ;; "At this point, CH is the first non-separator character, and CHNO is the character number of the character BEFORE that one.") - - (for old CHNO from CHNO to 1 by -1 - while [AND (SELECTC (COND - ((FIXP CH) - (\SYNCODE READSA CH)) - (T (* ; "It's an object!") - TEXT.TTC)) - (TEXT.TTC T) - NIL) - (NOT (fetch CLPROTECTED of (fetch (PIECE PLOOKS) - of (fetch (TEXTSTREAM - PIECE) - of STREAM] - do - - (* ;; "Skip over the next group of non-separators (= a 'word')") - - (SETQ CH (\GETCHB TEXTOBJ))) - - (* ;; "At this point, CH is the first separator character you encountered, and CHNO is the character number of the character BEFORE the separator, or 0 if you hit the front of the document.") - - (\SHOWSEL SEL NIL NIL) - - (* ;; "First character to delete:") - - [replace (SELECTION CH#) of SEL with (COND - ((ILESSP CHNO 1) - (* ; - "Front of document, so start deleting at char # 1") - 1) - (T - (* ; -"Otherwise, we need to start 1 later than the separator we hit, which is 2 higher than CHNO is now.") - (IPLUS 2 CHNO] - (replace (SELECTION CHLIM) of SEL with (ADD1 INSCH#)) - (replace (SELECTION DCH) of SEL with (IDIFFERENCE INSCH# CHNO)) - (\FIXSEL SEL TEXTOBJ) - (\SHOWSEL SEL NIL T) - (\TEDIT.DELETE SEL TEXTOBJ]) (\TEDIT1 - [LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* ; "Edited 12-Jun-90 17:50 by mitani") - - (* Does the actual editing work, and re-coercion or process kill when done. - Called by TEDIT directly, or ADD.PROCESSed by it.) - - (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS)) (* Open the text for editing) - (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) - (* Run the editing engine) - (CLOSEW WINDOW) - (replace (TEXTOBJ \WINDOW) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - with NIL) - (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'AFTERQUITFN) - (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'AFTERQUITFN) - WINDOW TEXT)) (* Apply any post-window-close - (and post-QUIT) function) - (COND - (UNSPAWNED (* We're not a distinct process%: - Send back the edited text in some - suitable form) - (COND - ((NEQ (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM - TEXTOBJ) - of TEXT)) - T) - (PROG1 (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM - TEXTOBJ) - of TEXT)) - (replace (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM - TEXTOBJ) - of TEXT) with - NIL))) - ((STRINGP (fetch (TEXTOBJ TXTFILE) of (fetch (TEXTSTREAM TEXTOBJ - ) of TEXT))) - (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - 'STRINGP)) - (T TEXT]) ) (MOVD? 'NILL 'OBJECTOUTOFTEDIT) (* ; "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.") (DEFINEQ (\CREATE.TEDIT.RESTART.MENU - [LAMBDA NIL - (CREATE MENU - ITEMS _ '(NewEditProcess]) ) (* ; "Added by yabu.fx, for SUNLOADUP without DWIM.") (* ; "Debugging functions") (DEFINEQ (PLCHAIN - [LAMBDA (LN) (* ; "Edited 29-May-91 18:20 by jds") - (PRINTLINE LN) - (COND - ((fetch (LINEDESCRIPTOR NEXTLINE) of LN) - (PLCHAIN (fetch (LINEDESCRIPTOR NEXTLINE) of LN]) (PRINTLINE - [LAMBDA (LN) (* ; "Edited 29-May-91 18:20 by jds") - (* Print out a line descriptor in a - reasonable form.) - (printout T "-----" T LN " Bot: " (fetch (LINEDESCRIPTOR YBOT) of LN) - " Base: " - (fetch (LINEDESCRIPTOR YBASE) of LN) - " Height: " - (fetch (LINEDESCRIPTOR LHEIGHT) of LN) - " Ascent: " - (fetch (LINEDESCRIPTOR ASCENT) of LN) - " Descent: " - (fetch (LINEDESCRIPTOR DESCENT) of LN) - T "Char1: " (fetch (LINEDESCRIPTOR CHAR1) of LN) - " Lim: " - (fetch (LINEDESCRIPTOR CHARLIM) of LN) - " Top: " - (fetch (LINEDESCRIPTOR CHARTOP) of LN)) - (COND - ((fetch (LINEDESCRIPTOR DIRTY) of LN) - (PRIN1 " DIRTY"))) - (COND - ((fetch (LINEDESCRIPTOR CR\END) of LN) - (PRIN1 " CR-at-end"))) - (COND - ((fetch (LINEDESCRIPTOR DELETED) of LN) - (PRIN1 " DELETED"))) - (COND - ((fetch (LINEDESCRIPTOR LHASPROT) of LN) - (PRIN1 " [Protected text]"))) - (COND - ((fetch (LINEDESCRIPTOR LHASTABS) of LN) - (PRIN1 " Has Tabs"))) - (PRIN1 ". -") - (printout T "RMar: " (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LN) - " XLim: " - (fetch (LINEDESCRIPTOR LXLIM) of LN) - " Left: " - (fetch (LINEDESCRIPTOR SPACELEFT) of LN) - T "Prev: " (fetch (LINEDESCRIPTOR PREVLINE) of LN) - T "Next: " (fetch (LINEDESCRIPTOR NEXTLINE) of LN) - T) - (COND - ((AND (IGEQ (fetch (LINEDESCRIPTOR CHAR1) of LN) - 1) - (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LN) - (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) - (* The line is real -- - print it.) - (\SETUPGETCH (fetch (LINEDESCRIPTOR CHAR1) of LN) - TEXTOBJ) - (PRIN1 "|") - [bind CH for CHNO from (fetch (LINEDESCRIPTOR CHAR1) of LN) - to (IMIN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) - (fetch (LINEDESCRIPTOR CHARLIM) of LN)) - do (SETQ CH (\GETCH TEXTOBJ)) - (COND - ((SMALLP CH) - (PRIN1 (CHARACTER CH))) - (T (PRINT CH] - (PRIN1 "| -"]) (SEEFILE - [LAMBDA (FILE ST ND) (* jds " 4-NOV-83 20:21") - (PROG (CH) - [SETQ FILE (OR (OPENP FILE) - (OPENSTREAM FILE 'INPUT] - (SETFILEPTR FILE (OR ST 0)) - (for I from (OR ST 0) to (OR ND (SUB1 (GETEOFPTR FILE))) - do (printout T I 5 (SETQ CH (BIN FILE)) - 9 - (COND - [(ILEQ CH (CHARCODE ^Z)) - (CONCAT "^" (CHARACTER (IPLUS CH (CHARCODE @] - (T (CHARACTER CH))) - T]) ) (* ; "Object-oriented editing") (DEFINEQ (TEDIT.INSERT.OBJECT - [LAMBDA (OBJECT STREAM CH#) (* ; "Edited 21-Apr-93 00:52 by jds") - - (* ;; "Inserts the Image-object OBJECT into text STREAM in front of character CH.") - - (LET* ((TEXTOBJ (TEXTOBJ STREAM)) - (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - SUBSTREAM START-OF-PIECE) - (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (* ; - "Do the pending delete, if there is one.") - (COND - ((NULL CH#) (* ; - "Omitted CH# means put it at the current spot.") - (SETQ CH# SEL))) - [COND - ((type? SELECTION CH#) - - (* ;; "If the CH# passed in was a selection (or we set it because he defaulted CH#), then compute the REAL CH#.") - - (SETQ CH# (SELECTQ (fetch (SELECTION POINT) of CH#) - (LEFT (fetch (SELECTION CH#) of CH#)) - (RIGHT (fetch (SELECTION CHLIM) of CH#)) - (SHOULDNT] - (PROG ((PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ)) - TEXTLEN PC PCNO CHNO NEWPC PREVPC INSERTFN) - (COND - ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) - - (* ;; - "If no changes are allowed to this TEdit, bail out without doing anything.") - - (RETURN))) - (\SHOWSEL SEL NIL NIL) (* ; "Turn off the selection for now") - (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (SETQ CH# (IMIN CH# (ADD1 TEXTLEN))) (* ; - "CH# we're to insert these characters in front of") - (freplace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with -1) - [SETQ PC (COND - ((ILEQ CH# TEXTLEN) - (\CHTOPC CH# PCTB T)) - (T 'LASTPIECE] (* ; - "Piece we're to insert in front of or inside") - (SETQ NEWPC (create PIECE - PSTR _ NIL - PFILE _ NIL - POBJ _ OBJECT - PLEN _ 1)) (* ; "The new piece we're inserting") - [COND - ((SETQ SUBSTREAM (IMAGEOBJPROP OBJECT 'SUBSTREAM)) - (* ; - "If this is computed text in bulk, fix the length.") - (replace (PIECE PLEN) of NEWPC with (fetch (TEXTOBJ TEXTLEN) - of (fetch ( - TEXTSTREAM - TEXTOBJ) - of SUBSTREAM] - (COND - ((OR (IGREATERP CH# TEXTLEN) - (IEQP CH# START-OF-PIECE)) (* ; - "We're inserting on a piece boundary; do it, then remember the prior piece.") - (\INSERTPIECE NEWPC PC TEXTOBJ)) - (T (* ; - "Not on a piece boundary; split the piece we're inside of, then insert.") - (\INSERTPIECE NEWPC (\SPLITPIECE PC (IDIFFERENCE CH# START-OF-PIECE) - TEXTOBJ) - TEXTOBJ))) - (COND - ((SETQ INSERTFN (IMAGEOBJPROP OBJECT 'WHENINSERTEDFN)) - (* ; - "If there is a WHENINSERTEDFN, apply it.") - (APPLY* INSERTFN OBJECT (AND (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ - )) - (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) - of TEXTOBJ)) - 'DSP)) - NIL STREAM))) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (SETQ PREVPC (fetch (PIECE PREVPIECE) of NEWPC)) - (* ; "Fill in the para looks") - [COND - [PREVPC (COND - [(AND (fetch (PIECE PPARALAST) of PREVPC) - (fetch (PIECE NEXTPIECE) of NEWPC)) - (replace (PIECE PPARALOOKS) of NEWPC - with (fetch (PIECE PPARALOOKS) of (fetch - (PIECE NEXTPIECE) - of NEWPC] - (T (replace (PIECE PPARALOOKS) of NEWPC - with (fetch (PIECE PPARALOOKS) of PREVPC] - (T (COND - ((SETQ PREVPC (fetch (PIECE NEXTPIECE) of NEWPC)) - (replace (PIECE PPARALOOKS) of NEWPC with (fetch - (PIECE PPARALOOKS) - of PREVPC))) - (T (replace (PIECE PPARALOOKS) of NEWPC with (fetch - (TEXTOBJ - FMTSPEC) - of TEXTOBJ] - (replace (PIECE PLOOKS) of NEWPC with (fetch (TEXTOBJ CARETLOOKS) - of TEXTOBJ)) - (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT - THACTION _ 'Insert - THCH# _ CH# - THLEN _ 1 - THFIRSTPIECE _ NEWPC)) - (SETQ TEXTLEN (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ - with (IPLUS (fetch (PIECE PLEN) of NEWPC) - TEXTLEN))) - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "Since adding an IMAGEOBJ creates a new piece, the old insertion cache piece is no longer valid.") - (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) - (replace (THISLINE DESC) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ) - with NIL) - (replace (SELECTION SELKIND) of SEL with 'CHAR) - (COND - ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - (\FIXILINES TEXTOBJ SEL CH# (fetch (PIECE PLEN) of NEWPC) - (SUB1 TEXTLEN)) - (replace (SELECTION DCH) of SEL with 0) - (replace (SELECTION DX) of SEL with 0) - (TEDIT.UPDATE.SCREEN TEXTOBJ) - (\FIXSEL SEL TEXTOBJ) - (\SHOWSEL SEL NIL T)) - (T [replace (SELECTION CHLIM) of SEL - with (replace (SELECTION CH#) of SEL - with (IPLUS CH# (fetch (PIECE PLEN) of NEWPC] - (replace (SELECTION DCH) of SEL with 0) - (replace (SELECTION DX) of SEL with 0) - (replace (SELECTION POINT) of SEL with 'LEFT) - (replace (THISLINE DESC) of (fetch (TEXTOBJ THISLINE) - of TEXTOBJ) with NIL))) - (\COPYSEL SEL TEDIT.SELECTION]) (TEDIT.EDIT.OBJECT - [LAMBDA (STREAM OBJ) (* ; "Edited 29-May-91 18:23 by jds") - (PROG ([TEXTOBJ (COND - ((type? TEXTOBJ STREAM) - STREAM) - ((type? STREAM STREAM) - (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - ((SHOULDNT] - SEL LL CH# SELOBJ EDITFN) - [COND - [(AND OBJ (IMAGEOBJP OBJ)) - (SETQ CH# (TEDIT.FIND.OBJECT TEXTOBJ OBJ)) - (COND - (CH# (SETQ SEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - (replace (SELECTION CH#) of SEL with CH#) - (replace (SELECTION CHLIM) of SEL with (ADD1 CH#)) - (SETQ SELOBJ OBJ) - (replace (SELECTION DCH) of SEL with 1) - (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ) - (\FIXSEL SEL TEXTOBJ)) - (T (TEDIT.PROMPTPRINT TEXTOBJ "Can't find specified object." T] - (T (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (SETQ OBJ (fetch (SELECTION SELOBJ) of SEL] - (COND - [OBJ (* OK There's an object selected. - Edit it.) - (SETQ EDITFN (IMAGEOBJPROP OBJ 'EDITFN)) - (COND - ((AND EDITFN (APPLY* EDITFN OBJ)) (* If the editfn makes a change, - update the screen.) - (for LINE inside (fetch (SELECTION L1) of SEL) - do (replace (LINEDESCRIPTOR DIRTY) of LINE with T)) - (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with T) - (TEDIT.UPDATE.SCREEN TEXTOBJ] - (T (* No object selected.) - (TEDIT.PROMPTPRINT TEXTOBJ "Please select an editable object first." T]) (TEDIT.FIND.OBJECT - [LAMBDA (TEXTOBJ OBJ) (* ; "Edited 3-May-93 12:52 by jds") - (* ; - "Find OBJ, if it's in TEXTOBJ, and return CH#. Else return nil") - (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) - (LET ((PC (\GETBASEPTR (\FIRSTNODE (fetch PCTB of TEXTOBJ)) - 0)) - (CH 1)) - (while PC do (COND - ((AND (NOT (ATOM PC)) - (EQ (fetch (PIECE POBJ) of PC) - OBJ)) - (RETURN CH)) - (T (add CH (ffetch (PIECE PLEN) of PC)) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) (TEDIT.FIND.OBJECT.SUBTREE - [LAMBDA (PCTB OBJ) (* ; "Edited 12-Jun-90 17:52 by mitani") - (COND - ((NULL PCTB) - NIL) - ((ATOM (fetch (PCTNODE PCE) of PCTB)) - (OR (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE LO) of PCTB) - OBJ) - (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE HI) of PCTB) - OBJ))) - ((EQ (fetch (PIECE POBJ) of (fetch (PCTNODE PCE) of PCTB)) - OBJ) - (fetch (PCTNODE CHNUM) of PCTB)) - (T (OR (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE LO) of PCTB) - OBJ) - (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE HI) of PCTB) - OBJ]) (TEDIT.PUT.OBJECT - [LAMBDA (PIECE OFILE FONTFILE CURCH#) (* ; "Edited 12-Jun-90 17:49 by mitani") - (* Given a piece which describes an - object, put the object out there.) - (PROG ((OBJECT (fetch (PIECE POBJ) of PIECE)) - (FONTCH# (GETFILEPTR FONTFILE)) - TOFILE LEN) - (\DWOUT FONTFILE 0) (* Placeholder for length of the - object's description) - (\SMALLPOUT FONTFILE \PieceDescriptorOBJECT) (* Mark this as setting the piece's - looks) - (\ATMOUT FONTFILE (IMAGEOBJPROP OBJECT 'GETFN)) (* The FN to apply to reconstruct - the object) - (APPLY* (IMAGEOBJPROP OBJECT 'PUTFN) - OBJECT OFILE) - (SETFILEPTR FONTFILE FONTCH#) - - (* Now go back and fill in the length of the text description of the object.) - - [\DWOUT FONTFILE (SETQ LEN (ADD1 (IDIFFERENCE (GETEOFPTR OFILE) - CURCH#] - (SETFILEPTR FONTFILE -1) (* Make sure we're at the end of the - font file) - (AND (RANDACCESSP OFILE) - (SETFILEPTR OFILE -1)) (* And the text part of the file) - (RETURN LEN]) (TEDIT.GET.OBJECT - [LAMBDA (STREAM PIECE FILE CURCH#) (* ; "Edited 12-Jun-90 17:50 by mitani") - (* ; "Get an object from the file") - (* ; - "CURCH# = fileptr within the text section of the file where the object's text starts.") - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - FILEPTRSAVE NAMELEN GETFN OBJ NBYTES) - - (* ;; "rrb 10-AUG-87 --- calculate the length of the image object's data. This assumes that the file is currently pointed at the end of the data which is where the GETFN is written {I think}") - - (SETQ NBYTES (DIFFERENCE (GETFILEPTR FILE) - CURCH#)) - (SETQ GETFN (\ATMIN FILE)) (* ; - "The GETFN for this kind of IMAGEOBJ") - (SETQ FILEPTRSAVE (GETFILEPTR FILE)) (* ; - "Save our file location thru the building of the object") - (SETFILEPTR FILE CURCH#) - (SETQ OBJ (READIMAGEOBJ FILE GETFN NIL NBYTES)) - (COND - ((IMAGEOBJPROP OBJ 'UNKNOWNGETFN) (* ; - "If the object has an unknown getfn property, then it's an encapsulated object. Warn the user") - (TEDIT.PROMPTPRINT STREAM "WARNING: Document contains unknown image objects." T))) - (SETFILEPTR FILE FILEPTRSAVE) - (replace (PIECE POBJ) of PIECE with OBJ) - (replace (PIECE PFILE) of PIECE with NIL) - (replace (PIECE PSTR) of PIECE with NIL) - [replace (PIECE PLOOKS) of PIECE with (COND - ((fetch (PIECE PREVPIECE) - of PIECE) - (fetch (PIECE PLOOKS) - of (fetch (PIECE PREVPIECE - ) - of PIECE))) - (T (OR (fetch (TEXTOBJ - DEFAULTCHARLOOKS - ) - of TEXTOBJ) - (\TEDIT.UNIQUIFY.CHARLOOKS - (CHARLOOKS.FROM.FONT - DEFAULTFONT) - TEXTOBJ] - (RETURN (fetch (PIECE POBJ) of PIECE]) (TEDIT.OBJECT.CHANGED - [LAMBDA (STREAM OBJECT) (* ; "Edited 12-Jun-90 17:51 by mitani") - - (* Notify TEdit that an object has changed, and the display may need to be - updated.) - - (PROG ((TEXTOBJ (TEXTOBJ STREAM)) - (LINES (fetch (TEXTOBJ LINES) of (TEXTOBJ STREAM))) - PCINFO CHANGED CHANGEDCH#) - (SETQ PCINFO (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PC PCNO OBJ) - (AND (EQ OBJ (fetch (PIECE POBJ) - of PC)) - 'STOP] - OBJECT)) (* Find the piece containing this - object) - (OR PCINFO (HELP "Changed OBJECT not found!?")) - (SETQ CHANGEDCH# (CAR PCINFO)) (* Get the CH# of the changed object) - (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CHANGEDCH# CHANGEDCH#) - (* Mark affected lines) - (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) - (* And mark the document dirty.) - (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) - NIL NIL) - (TEDIT.UPDATE.SCREEN TEXTOBJ) - (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) - TEXTOBJ) - (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) - NIL T]) ) (FILESLOAD TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS) (* ; "TEDIT Support information") (RPAQQ TEDITSYSTEMDATE "21-Jun-99 20:00:25") (RPAQ TEDITSUPPORT "TEditSupport.PA") (DEFINEQ (MAKETEDITFORM - [LAMBDA NIL (* jds "12-Mar-85 04:00") - (* Builds a trouble-report form for - TEdit.) - (MAKEXXXSUPPORTFORM "TEdit" TEDITSUPPORT TEDITSYSTEMDATE]) ) (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM "Report a problem with TEdit")) (SETQ LAFITEFORMSMENU NIL) (* ; "LISTFILES Interface, so the system can decide if a file is a TEdit file.") (ADDTOVAR PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1) (EXTENSION (TEDIT)))) (PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1995 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4371 115205 (\TEDIT2 4381 . 7132) (COERCETEXTOBJ 7134 . 15910) (TEDIT 15912 . 20881) ( TEDIT.CHARWIDTH 20883 . 22907) (TEDIT.COPY 22909 . 31345) (TEDIT.DELETE 31347 . 32037) ( TEDIT.DO.BLUEPENDINGDELETE 32039 . 35106) (TEDIT.INSERT 35108 . 40638) (TEDIT.KILL 40640 . 42197) ( TEDIT.MAPLINES 42199 . 43598) (TEDIT.MAPPIECES 43600 . 44556) (TEDIT.MOVE 44558 . 54342) (TEDIT.QUIT 54344 . 56344) (TEDIT.STRINGWIDTH 56346 . 57017) (TEDIT.\INSERT 57019 . 59044) (TEXTOBJ 59046 . 60171) (TEXTSTREAM 60173 . 61788) (\TEDIT.INCLUDE 61790 . 65690) (\TEDIT.INSERT.PIECES 65692 . 75607) ( \TEDIT.MOVE.PIECEMAPFN 75609 . 77688) (\TEDIT.OBJECT.SHOWSEL 77690 . 81319) (\TEDIT.RESTARTFN 81321 . 83316) (\TEDIT.CHARDELETE 83318 . 87280) (\TEDIT.COPY.PIECEMAPFN 87282 . 90507) (\TEDIT.DELETE 90509 . 98027) (\TEDIT.DIFFUSE.PARALOOKS 98029 . 100793) (\TEDIT.FOREIGN.COPY? 100795 . 104522) ( \TEDIT.QUIT 104524 . 107670) (\TEDIT.WORDDELETE 107672 . 112505) (\TEDIT1 112507 . 115203)) (115319 115435 (\CREATE.TEDIT.RESTART.MENU 115329 . 115433)) (115534 119223 (PLCHAIN 115544 . 115818) ( PRINTLINE 115820 . 118584) (SEEFILE 118586 . 119221)) (119264 138907 (TEDIT.INSERT.OBJECT 119274 . 128351) (TEDIT.EDIT.OBJECT 128353 . 130609) (TEDIT.FIND.OBJECT 130611 . 131504) ( TEDIT.FIND.OBJECT.SUBTREE 131506 . 132312) (TEDIT.PUT.OBJECT 132314 . 133973) (TEDIT.GET.OBJECT 133975 . 137174) (TEDIT.OBJECT.CHANGED 137176 . 138905)) (139183 139546 (MAKETEDITFORM 139193 . 139544))))) STOP \ No newline at end of file diff --git a/library/TEDITABBREV.~1~ b/library/TEDITABBREV.~1~ deleted file mode 100644 index 698cccbb..00000000 --- a/library/TEDITABBREV.~1~ +++ /dev/null @@ -1,127 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Aug-94 10:52:43" {DSK}export>lispcore>library>TEDITABBREV.;3 10066 - - changes to%: (VARS TEDITABBREVCOMS) (FILES TEDITDCL) - - previous date%: "29-Mar-94 15:10:53" {DSK}export>lispcore>library>TEDITABBREV.;2) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITABBREVCOMS) - -(RPAQQ TEDITABBREVCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS \TEDIT.ABBREV.EXPAND \TEDIT.EXPAND.DATE \TEDIT.TRY.ABBREV) (GLOBALVARS TEDIT.ABBREVS) (VARS (TEDIT.ABBREVS (LIST (CONS "b" (ALLOCSTRING 1 (CHARCODE "357,146"))) (CONS "n" (ALLOCSTRING 1 (CHARCODE "357,44"))) (CONS "m" (ALLOCSTRING 1 (CHARCODE "357,45"))) (CONS "T" (ALLOCSTRING 1 (CHARCODE "357,57"))) (CONS "d" (ALLOCSTRING 1 (CHARCODE "357,60"))) (CONS "D" (ALLOCSTRING 1 (CHARCODE "357,61"))) (CONS "s" (ALLOCSTRING 1 (CHARCODE "0,247"))) (CONS "'" (ALLOCSTRING 1 (CHARCODE "0,271"))) (CONS "`" (ALLOCSTRING 1 (CHARCODE "0,251"))) (CONS "%"" (ALLOCSTRING 1 (CHARCODE "0,252"))) (CONS "~" (ALLOCSTRING 1 (CHARCODE "0,272"))) (CONS "1/4" (ALLOCSTRING 1 (CHARCODE "0,274"))) (CONS "1/2" (ALLOCSTRING 1 (CHARCODE "0,275"))) (CONS "3/4" (ALLOCSTRING 1 (CHARCODE "0,276"))) (CONS "1/3" (ALLOCSTRING 1 (CHARCODE "357,375"))) (CONS "2/3" (ALLOCSTRING 1 (CHARCODE "357,376"))) (CONS "c" (ALLOCSTRING 1 (CHARCODE "0,323"))) (CONS "c/o" (ALLOCSTRING 1 (CHARCODE "357,100"))) (CONS "%%" (ALLOCSTRING 1 (CHARCODE "357,100"))) (CONS "->" (ALLOCSTRING 1 (CHARCODE "0,256"))) (CONS "ra" (ALLOCSTRING 1 (CHARCODE "0,256"))) (CONS "|" (ALLOCSTRING 1 (CHARCODE "0,257"))) (CONS "da" (ALLOCSTRING 1 (CHARCODE "0,257"))) (CONS "^" (ALLOCSTRING 1 (CHARCODE "0,255"))) (CONS "ua" (ALLOCSTRING 1 (CHARCODE "0,255"))) (CONS "<-" (ALLOCSTRING 1 (CHARCODE "0,254"))) (CONS "la" (ALLOCSTRING 1 (CHARCODE "0,254"))) (CONS "_" (ALLOCSTRING 1 (CHARCODE "0,254"))) (CONS "L" (ALLOCSTRING 1 (CHARCODE "0,243"))) (CONS "o" (ALLOCSTRING 1 (CHARCODE "0,260"))) (CONS "Y" (ALLOCSTRING 1 (CHARCODE "0,245"))) (CONS "+" (ALLOCSTRING 1 (CHARCODE "0,261"))) (CONS "x" (ALLOCSTRING 1 (CHARCODE "0,264"))) (CONS "/" (ALLOCSTRING 1 (CHARCODE "0,270"))) (CONS "=" (ALLOCSTRING 1 (CHARCODE "357,121"))) (CONS "p" (ALLOCSTRING 1 (CHARCODE "0,266"))) (CONS "r" (ALLOCSTRING 1 (CHARCODE "0,322"))) (CONS "t" (ALLOCSTRING 1 (CHARCODE "0,324"))) (CONS "tm" (ALLOCSTRING 1 (CHARCODE "0,324"))) (CONS "box" (ALLOCSTRING 1 (CHARCODE "42,42"))) (CONS "cbox" (ALLOCSTRING 1 (CHARCODE "42,61"))) (CONS "-" (ALLOCSTRING 1 (CHARCODE "357,043"))) (CONS "=" (ALLOCSTRING 1 (CHARCODE "357,042"))) (CONS " " (ALLOCSTRING 1 (CHARCODE "357,041"))) (QUOTE ("DATE" . \TEDIT.EXPAND.DATE)) (QUOTE (">>DATE<<" . \TEDIT.EXPAND.DATE)))))) -) - -(FILESLOAD TEDITDCL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) TEDITDCL) -) -(DEFINEQ - -(\TEDIT.ABBREV.EXPAND - [LAMBDA (STREAM) (* ; "Edited 30-May-91 19:27 by jds") - (* ; "Expand an abbvreviation") - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - SEL CH# (CH NIL) - OLDLOOKS EXPANSION) - (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (SETQ CH# (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (SUB1 (fetch (SELECTION CH#) of SEL))) - (RIGHT (SUB1 (fetch (SELECTION CHLIM) of SEL))) - 0)) - [COND - ((ZEROP (fetch (SELECTION DCH) of SEL)) (* ; - "Point Selection, so use the character to the left") - (COND - ((ZEROP CH#) (* ; - "If we're off the front of the document, don't bother trying.") - (RETURN))) - (\SETUPGETCH CH# TEXTOBJ) - [SETQ CH (MKSTRING (CHARACTER (\BIN STREAM] - (TEDIT.SETSEL STREAM CH# 1 'RIGHT)) - (T (* ; - "We have a selection that isn't just a caret. Use it.") - (SETQ CH (TEDIT.SEL.AS.STRING STREAM] - (SETQ EXPANSION (\TEDIT.TRY.ABBREV CH STREAM)) (* ; "Find the abbreviation's expansion --first try it as-is, then try the upper-case version to be safe.") - (COND - (EXPANSION (* ; - "It exists, so insert it where the abbrev used to be") - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; "Force it to abandon caching") - (SETQ OLDLOOKS (TEDIT.GET.LOOKS TEXTOBJ)) - (TEDIT.DELETE TEXTOBJ SEL) (* ; - "First, delete the thing being expanded.") - (TEDIT.INSERT STREAM EXPANSION SEL OLDLOOKS]) - -(\TEDIT.EXPAND.DATE - [LAMBDA (STREAM CH) (* ; "Edited 23-Feb-88 10:41 by jds") - - (* ;; "Provide the date as the expansion for an abbreviation") - - (PROG* ((DATE (\UNPACKDATE)) - (YEAR (pop DATE)) - (MONTH (pop DATE)) - (DAY (pop DATE))) - (RETURN (CONCAT (CAR (NTH '("January" "February" "March" "April" "May" "June" "July" - "August" "September" "October" "November" "December") - (ADD1 MONTH))) - " " DAY ", " YEAR]) - -(\TEDIT.TRY.ABBREV - (LAMBDA (ABBREV STREAM) (* jds "11-Jul-85 12:46") - - (* Try expanding ABBREV as an abbreviation. - Return the expansion; NIL = no such abbreviation.) - - (PROG (SEL CH# (CH NIL) - EXPANSION) - (SETQ EXPANSION (OR (SASSOC ABBREV TEDIT.ABBREVS) - (SASSOC (U-CASE ABBREV) - TEDIT.ABBREVS))) - - (* Find the abbreviation's expansion --first try it as-is, then try the - upper-case version to be safe.) - - (RETURN (COND - (EXPANSION (* There's an expansion. - Turn it into an insertable string.) - (COND - ((OR (STRINGP (CDR EXPANSION)) - (NUMBERP (CDR EXPANSION))) - - (* The abbreviation expands to a string or a number - (charcode)%. Insert it.) - - (CDR EXPANSION)) - ((AND (LITATOM (CDR EXPANSION)) - (GETD (CDR EXPANSION))) (* It's a function to be called.) - (APPLY* (CDR EXPANSION) - STREAM CH)) - (T (* Anything else is a form to EVAL.) - (EVAL (CDR EXPANSION)))))))))) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.ABBREVS) -) - -(RPAQ TEDIT.ABBREVS (LIST (CONS "b" (ALLOCSTRING 1 (CHARCODE "357,146"))) (CONS "n" (ALLOCSTRING 1 (CHARCODE "357,44"))) (CONS "m" (ALLOCSTRING 1 (CHARCODE "357,45"))) (CONS "T" (ALLOCSTRING 1 (CHARCODE "357,57"))) (CONS "d" (ALLOCSTRING 1 (CHARCODE "357,60"))) (CONS "D" (ALLOCSTRING 1 (CHARCODE "357,61"))) (CONS "s" (ALLOCSTRING 1 (CHARCODE "0,247"))) (CONS "'" (ALLOCSTRING 1 (CHARCODE "0,271"))) (CONS "`" (ALLOCSTRING 1 (CHARCODE "0,251"))) (CONS "%"" (ALLOCSTRING 1 (CHARCODE "0,252"))) (CONS "~" (ALLOCSTRING 1 (CHARCODE "0,272"))) (CONS "1/4" (ALLOCSTRING 1 (CHARCODE "0,274"))) (CONS "1/2" (ALLOCSTRING 1 (CHARCODE "0,275"))) (CONS "3/4" (ALLOCSTRING 1 (CHARCODE "0,276"))) (CONS "1/3" (ALLOCSTRING 1 (CHARCODE "357,375"))) (CONS "2/3" (ALLOCSTRING 1 (CHARCODE "357,376"))) (CONS "c" (ALLOCSTRING 1 (CHARCODE "0,323"))) (CONS "c/o" (ALLOCSTRING 1 (CHARCODE "357,100"))) (CONS "%%" (ALLOCSTRING 1 (CHARCODE "357,100"))) (CONS "->" (ALLOCSTRING 1 (CHARCODE "0,256"))) (CONS "ra" (ALLOCSTRING 1 (CHARCODE "0,256"))) (CONS "|" (ALLOCSTRING 1 (CHARCODE "0,257"))) (CONS "da" (ALLOCSTRING 1 (CHARCODE "0,257"))) (CONS "^" (ALLOCSTRING 1 (CHARCODE "0,255"))) (CONS "ua" (ALLOCSTRING 1 (CHARCODE "0,255"))) (CONS "<-" (ALLOCSTRING 1 (CHARCODE "0,254"))) (CONS "la" (ALLOCSTRING 1 (CHARCODE "0,254"))) (CONS "_" (ALLOCSTRING 1 (CHARCODE "0,254"))) (CONS "L" (ALLOCSTRING 1 (CHARCODE "0,243"))) (CONS "o" (ALLOCSTRING 1 (CHARCODE "0,260"))) (CONS "Y" (ALLOCSTRING 1 (CHARCODE "0,245"))) (CONS "+" (ALLOCSTRING 1 (CHARCODE "0,261"))) (CONS "x" (ALLOCSTRING 1 (CHARCODE "0,264"))) (CONS "/" (ALLOCSTRING 1 (CHARCODE "0,270"))) (CONS "=" (ALLOCSTRING 1 (CHARCODE "357,121"))) (CONS "p" (ALLOCSTRING 1 (CHARCODE "0,266"))) (CONS "r" (ALLOCSTRING 1 (CHARCODE "0,322"))) (CONS "t" (ALLOCSTRING 1 (CHARCODE "0,324"))) (CONS "tm" (ALLOCSTRING 1 (CHARCODE "0,324"))) (CONS "box" (ALLOCSTRING 1 (CHARCODE "42,42"))) (CONS "cbox" (ALLOCSTRING 1 (CHARCODE "42,61"))) (CONS "-" (ALLOCSTRING 1 (CHARCODE "357,043"))) (CONS "=" (ALLOCSTRING 1 (CHARCODE "357,042"))) (CONS " " (ALLOCSTRING 1 (CHARCODE "357,041"))) (QUOTE ("DATE" . \TEDIT.EXPAND.DATE)) (QUOTE (">>DATE<<" . \TEDIT.EXPAND.DATE))) -) -(PUTPROPS TEDITABBREV COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 -1992 1993 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3095 7672 (\TEDIT.ABBREV.EXPAND 3105 . 5426) (\TEDIT.EXPAND.DATE 5428 . 6073) ( -\TEDIT.TRY.ABBREV 6075 . 7670))))) -STOP diff --git a/library/TEDITCOMMAND.~1~ b/library/TEDITCOMMAND.~1~ deleted file mode 100644 index 0931cafa..00000000 --- a/library/TEDITCOMMAND.~1~ +++ /dev/null @@ -1,105 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Aug-94 10:52:51" {DSK}export>lispcore>library>TEDITCOMMAND.;2 51809 - - changes to%: (VARS TEDITCOMMANDCOMS) (FILES TEDITDCL) - - previous date%: "22-May-92 15:14:24" {DSK}export>lispcore>library>TEDITCOMMAND.;1) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITCOMMANDCOMS) - -(RPAQQ TEDITCOMMANDCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS \TEDIT.INSERT.TTY.BUFFER \TEDIT.INTERRUPT.SETUP \TEDIT.MARKACTIVE \TEDIT.MARKINACTIVE \PNC \TEDIT.COMMAND.LOOP \TEDIT.COMMAND.RESET.SETUP) (INITVARS (TEDIT.INTERRUPTS (QUOTE ((2 BREAK) (5 ERROR) (7 HELP) (20 CONTROL-T))))) (VARS (TEDIT.COPY.PENDING NIL) (TEDIT.COPYLOOKS.PENDING NIL) (TEDIT.MOVE.PENDING NIL) (TEDIT.DEL.PENDING NIL) (TEDIT.BLUEPENDINGDELETE NIL)) (GLOBALVARS TEDIT.COPY.PENDING TEDIT.COPYLOOKS.PENDING TEDIT.MOVE.PENDING TEDIT.DEL.PENDING TEDIT.BLUEPENDINGDELETE TEDIT.INTERRUPTS) (COMS (* ; "Read-table Utilities") (FNS \TEDIT.READTABLE \TEDIT.WORDBOUND.READTABLE TEDIT.GETSYNTAX TEDIT.SETSYNTAX TEDIT.GETFUNCTION TEDIT.SETFUNCTION TEDIT.WORDGET TEDIT.WORDSET) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.READTABLE (\TEDIT.READTABLE)) (TEDIT.WORDBOUND.READTABLE (\TEDIT.WORDBOUND.READTABLE)))) (GLOBALVARS TEDIT.READTABLE TEDIT.WORDBOUND.READTABLE))) -) - -(FILESLOAD TEDITDCL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) TEDITDCL) -) -(DEFINEQ - -(\TEDIT.INSERT.TTY.BUFFER [LAMBDA (SCRATCH PASS TEXTOBJ SEL) (* ; "Edited 23-Feb-88 11:11 by jds") (* ;; "OBSOLETE 2/9/86 ?? JDS") (* ;; "(PROG ((TLEN (fetch (STRINGP OFFST) of SCRATCH))) (COND ((NOT (ZEROP TLEN)) (* If there are typed-ahead characters cached, insert them in the text object and clear the cache.) (replace (STRINGP OFFST) of SCRATCH with 0) (replace (STRINGP LENGTH) of SCRATCH with \SCRATCHLEN) (replace (STRINGP LENGTH) of PASS with TLEN) (TEDIT.\INSERT PASS SEL TEXTOBJ BLANKSEEN CRSEEN))))") (HELP]) - -(\TEDIT.INTERRUPT.SETUP (LAMBDA (PROC FORCEOFF) (* jds "12-Sep-84 15:36") (* Disarm any inconvenient interrupts, and save re-arming info on the window.) (PROG ((TEXTOBJ (AND (PROCESSPROP PROC 'WINDOW) (WINDOWPROP (PROCESSPROP PROC 'WINDOW) 'TEXTOBJ) (TEXTOBJ (PROCESSPROP PROC 'WINDOW))))) (UNINTERRUPTABLY (COND ((AND FORCEOFF (PROCESSPROP PROC 'TEDIT.INTERRUPTS)) (* There are disarmed interrupts;  re-arm them.) (RESET.INTERRUPTS (PROCESSPROP PROC 'TEDIT.INTERRUPTS)) (PROCESSPROP PROC 'TEDIT.INTERRUPTS NIL)) ((AND (NOT FORCEOFF) (NOT (PROCESSPROP PROC 'TEDIT.INTERRUPTS))) (* There aren't any interrupts  disarmed; go do it.) (PROCESSPROP PROC 'TEDIT.INTERRUPTS (RESET.INTERRUPTS (OR (AND TEXTOBJ (TEXTPROP TEXTOBJ 'INTERRUPTS)) TEDIT.INTERRUPTS) T)))))) PROC)) - -(\TEDIT.MARKACTIVE [LAMBDA (TEXTOBJ) (* ; "Edited 12-Jun-90 18:04 by mitani") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) TEXTOBJ]) - -(\TEDIT.MARKINACTIVE [LAMBDA (TEXTOBJ) (* ; "Edited 12-Jun-90 18:04 by mitani") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL) TEXTOBJ]) - -(\PNC (LAMBDA (CH STR) (* jds " 7-JUN-82 14:03") (PROG ((LEN (fetch (STRINGP LENGTH) of STR)) (OFFST (fetch (STRINGP OFFST) of STR))) (COND ((ZEROP LEN) (ERROR "NO ROOM LEFT IN STRING TO PUT CHARACTER")) (T (UNINTERRUPTABLY (\PUTBASEBYTE (fetch (STRINGP BASE) of STR) OFFST CH) (replace (STRINGP OFFST) of STR with (ADD1 OFFST)) (replace (STRINGP LENGTH) of STR with (SUB1 LEN)))))))) - -(\TEDIT.COMMAND.LOOP [LAMBDA (STREAM RTBL) (* ; "Edited 30-May-91 19:33 by jds") (* ;; "Main command loop for the TEDIT editor. Includes keyboard polling and command dispatch") (PROG ((TEXTOBJ (COND ((type? STREAM STREAM) (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) (T STREAM))) (ISCRSTRING (ALLOCSTRING \SCRATCHLEN " ")) SEL WINDOW LINES IPASSSTRING TTYWINDOW) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (SETQ WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) (SETQ IPASSSTRING (SUBSTRING ISCRSTRING 1)) (* ; "Used inside \INSERT\TTY\BUFFER") (SETQ RTBL (OR RTBL (fetch (TEXTOBJ TXTRTBL) of TEXTOBJ) TEDIT.READTABLE)) (* ;  "Used to derive command characters from type-in") (for WW inside WINDOW do (WINDOWPROP WW 'PROCESS (THIS.PROCESS))) (* ; "And the window to this process") (while (NOT (TTY.PROCESSP)) do (* ;  "Wait until we really have the TTY before proceeding.") (DISMISS 250)) (RESETLST (RESETSAVE (\TEDIT.COMMAND.RESET.SETUP (LIST TEXTOBJ WINDOW) T)) (PROG (CH FN TCH (DIRTY NIL) (BLANKSEEN NIL) INSCH# (CRSEEN NIL) TLEN CHNO (READSA (fetch READSA of %#CURRENTRDTBL#)) (TERMSA (OR (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ) \PRIMTERMSA)) (TEDITSA (fetch READSA of RTBL)) (TEDITFNHASH (fetch READMACRODEFS of RTBL)) (LOOPFN (TEXTPROP TEXTOBJ 'LOOPFN)) (CHARFN (TEXTPROP TEXTOBJ 'CHARFN)) COMMANDFN) (while (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) do [ERSETQ (while (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) do (PROGN (\WAITFORSYSBUFP 25) (* ; "Await type-in or mouse action") (while (OR TEDIT.SELPENDING (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ)) do (* ;  "Don't do anything while he's selecting or one of the lock-out ops is active.") [COND ((EQ TEDIT.SELPENDING TEXTOBJ) (* ;  "(OR (EQ TEDIT.SELPENDING TEXTOBJ) (fetch TCUP of (fetch CARET of TEXTOBJ)))") (* ;  "If this TEdit is the one being selected in, or the caret is explicitly visible, flash it") (TEDIT.FLASHCARET (fetch (TEXTOBJ CARET) of TEXTOBJ] (BLOCK)) [COND ((fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) (T (COND ((fetch (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ) (* ;  "We got here somehow with the window not in sync with the text. Run an update.") (\SHOWSEL SEL NIL NIL) (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (TEDIT.FLASHCARET (fetch (TEXTOBJ CARET) of TEXTOBJ)) (* ;  "Flash the caret periodically (BUT not while we're here only to cleanup and quit.)") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) (* ;  "Before starting to work, note that we're doing something.") (AND LOOPFN (ERSETQ (APPLY* LOOPFN STREAM))) (* ;  "If the guy wants control during the loop, give it to him.") (* ; "Process any pending selections") [COND (TEDIT.COPY.PENDING (* ;  "Have to copy the shifted SEL to caret.") (SETQ TEDIT.COPY.PENDING NIL) (\COPYSEL TEDIT.SHIFTEDSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) (ERSETQ (TEDIT.COPY (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ))) (replace (SELECTION SET) of TEDIT.SHIFTEDSELECTION with NIL) (replace (SELECTION L1) of TEDIT.SHIFTEDSELECTION with NIL) (replace (SELECTION LN) of TEDIT.SHIFTEDSELECTION with NIL) (\COPYSEL TEDIT.SHIFTEDSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (TEDIT.COPYLOOKS.PENDING (* ;  "Have to copy the shifted SEL to caret.") (SETQ TEDIT.COPYLOOKS.PENDING NIL) (\COPYSEL TEDIT.COPYLOOKSSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) [ERSETQ (COND ((EQ 'PARA (fetch (SELECTION SELKIND) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (* ;  "copy the paragraph looks, since the source selection type was paragraph") (TEDIT.COPY.PARALOOKS TEXTOBJ (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ ))) (T (* ; "copy the character looks") (TEDIT.COPY.LOOKS TEXTOBJ (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ] (\SHOWSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) NIL NIL) (replace (SELECTION SET) of TEDIT.COPYLOOKSSELECTION with NIL) (replace (SELECTION L1) of TEDIT.COPYLOOKSSELECTION with NIL) (replace (SELECTION LN) of TEDIT.COPYLOOKSSELECTION with NIL) (\COPYSEL TEDIT.COPYLOOKSSELECTION (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) (TEDIT.MOVE.PENDING (* ;  "Have to move the ctrl-shift SEL to caret.") (SETQ TEDIT.MOVE.PENDING NIL) (\COPYSEL TEDIT.MOVESELECTION (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (ERSETQ (TEDIT.MOVE (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ))) (replace (SELECTION SET) of TEDIT.MOVESELECTION with NIL) (replace (SELECTION L1) of TEDIT.MOVESELECTION with NIL) (replace (SELECTION LN) of TEDIT.MOVESELECTION with NIL) (\COPYSEL TEDIT.MOVESELECTION (fetch (TEXTOBJ MOVESEL) of TEXTOBJ))) (TEDIT.DEL.PENDING(* ; "Delete the current selection.") (SETQ TEDIT.DEL.PENDING NIL) (* ;  "Above all, reset the demand flag first") (ERSETQ (COND ((fetch (SELECTION SET) of TEDIT.DELETESELECTION ) (* ;  "Only try the deletion if he really set the selection.") (\SHOWSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) NIL NIL) (* ;  "Turn off the selection highlights") (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) with NIL) (\COPYSEL TEDIT.DELETESELECTION (fetch (TEXTOBJ SEL) of TEXTOBJ )) (\TEDIT.SET.SEL.LOOKS (fetch (TEXTOBJ SEL) of TEXTOBJ) 'NORMAL) (* ; "Grab the selection we're to use") (\TEDIT.DELETE (fetch (TEXTOBJ SEL) of TEXTOBJ) (fetch (SELECTION \TEXTOBJ) of (fetch (TEXTOBJ SEL) of TEXTOBJ)) NIL) (replace (SELECTION L1) of TEDIT.DELETESELECTION with NIL) (replace (SELECTION LN) of TEDIT.DELETESELECTION with NIL] (UNINTERRUPTABLY (replace (STRINGP OFFST) of ISCRSTRING with 0) (replace (STRINGP LENGTH) of ISCRSTRING with \SCRATCHLEN)) (while (\SYSBUFP) do (* ; "Handle user type-in") (SETQ CH (\GETKEY)) (COND (CHARFN (* ;  "Give the OEM user control for each character typed.") (SETQ TCH (APPLY* CHARFN STREAM CH)) (OR (EQ TCH T) (SETQ CH TCH)) (* ;  "And let him return one of NIL for 'ignore this char' , T for 'leave it be' or a new charcode.") )) (SELECTC (AND CH (\SYNCODE TEDITSA CH)) (CHARDELETE.TTC (* ;  "Backspace handler: Remove the character just before SEL:CH#.") (\TEDIT.CHARDELETE TEXTOBJ ISCRSTRING SEL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (WORDDELETE.TTC (\TEDIT.WORDDELETE TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (DELETE.TTC (* ;  "DEL Key handler: Delete the selected characters") (\TEDIT.DELETE SEL TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (UNDO.TTC (* ;  "He hit the CANCEL key, so go UNDO something") (TEDIT.UNDO TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (REDO.TTC (* ;  "He hit the REDO key, so go REDO something") (TEDIT.REDO TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (FUNCTIONCALL.TTC (* ;  "This is a special character -- it calls a function") (COND ((SETQ FN (GETHASH CH TEDITFNHASH)) (* ;  "There IS a command function to be called.") (APPLY* FN (fetch (TEXTOBJ STREAMHINT ) of TEXTOBJ) TEXTOBJ SEL) (* ; "do it") (\SHOWSEL SEL NIL NIL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* ;  "After a user function, no more blue-pending-delete") (\SHOWSEL SEL NIL T) (* ;  "And forget any pending deletion.") ))) (NEXT.TTC (* ;  "Move to the next blank to fill in. For now, blanks are delimited by >>...<<") (TEDIT.NEXT TEXTOBJ)) (EXPAND.TTC (* ; "EXPAND AN ABBREVIATION") (\TEDIT.ABBREV.EXPAND (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) (SELECTC (AND TERMSA CH (fetch TERMCLASS of (\SYNCODE TERMSA CH))) (CHARDELETE.TC (* ;  "Backspace handler: Remove the character just before SEL:CH#.") (\TEDIT.CHARDELETE TEXTOBJ ISCRSTRING SEL) ( TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (WORDDELETE.TC (* ; "Back-WORD handler") (\TEDIT.WORDDELETE TEXTOBJ) ( TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (LINEDELETE.TC (* ;  "DEL Key handler: Delete the selected characters") (\TEDIT.DELETE SEL TEXTOBJ) ( TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (COND (CH (* ;  "Any other key was hit: Just insert the character.") (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (* ;  "Handle blue pending delete, if there is one.") (TEDIT.\INSERT CH SEL TEXTOBJ BLANKSEEN CRSEEN] (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL] (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL))))]) - -(\TEDIT.COMMAND.RESET.SETUP [LAMBDA (TEXT&WIND STARTING) (* ; "Edited 12-Jun-90 18:04 by mitani") (* ;; "If STARTING is T, set up the reset-driven connections and values for editing; otherwise, break links and reset values for non-editing") (PROG ((TEXTOBJ (CAR TEXT&WIND)) (WINDOW (CADR TEXT&WIND)) (OTTYWINDOW (CADDR TEXT&WIND)) (OTTYENTRYFN (CADDDR TEXT&WIND)) (OTTYEXITFN (CAR (CDDDDR TEXT&WIND))) (OWINDOW (CADR (CDDDDR TEXT&WIND))) TTYWINDOW) [COND (STARTING (* ;  "We're going INTO the command loop. Set up all the stuff") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) (* ;  "Mark us busy until we're set up, so that nobody tries any funny stuff.") (SETQ OWINDOW (PROCESSPROP (THIS.PROCESS) 'WINDOW (CAR WINDOW))) (* ;  "Attach the process to this window.") (\TEDIT.INTERRUPT.SETUP (THIS.PROCESS)) (* ;  "Disarm all interrupt chars, re-arm them when we leave the edit") (SETQ OTTYEXITFN (PROCESSPROP (THIS.PROCESS) 'TTYEXITFN '\TEDIT.PROCEXITFN)) (* ;  "Set up functions for getting in and out of the edit process") (SETQ OTTYENTRYFN (PROCESSPROP (THIS.PROCESS) 'TTYENTRYFN '\TEDIT.PROCENTRYFN)) [COND ((NEQ (TEXTPROP TEXTOBJ 'TTYWINDOW) 'DON'T) (* ;  "He can suppress the ability to copy-select things into this window if he wants....") (SETQ TTYWINDOW (OR (TEXTPROP TEXTOBJ 'TTYWINDOW) (CREATEW DEFAULTTTYREGION "TTY Window for TEdit" NIL T))) (SETQ OTTYWINDOW (TTYDISPLAYSTREAM TTYWINDOW)) (PROCESSPROP (THIS.PROCESS) 'TEDITTTYWINDOW TTYWINDOW) (WINDOWPROP TTYWINDOW 'PROCESS NIL) [WINDOWPROP TTYWINDOW 'CLOSEFN (FUNCTION (LAMBDA (WW) (WINDOWPROP WW 'PROCESS NIL] (* ;  "So that there isn't a circularity in the PROCESS -> TTYWINDOW -> PROCESS") (WINDOWPROP TTYWINDOW 'COPYINSERTFN (FUNCTION \TEDIT.COPYINSERTFN)) (WINDOWPROP TTYWINDOW 'MAINWINDOW (CAR WINDOW] (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with T) (* ;  "Tell TEdit that this document is actively being edited.") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL) (* ;  "Mark us un-busy so life can go on.") ) (T (* ;  "Coming OUT OF the command loop -- reset everything") (PROCESSPROP (THIS.PROCESS) 'WINDOW (CAR WINDOW)) (* ;  "Detach the window from the edit process, to prevent circularity there") (WINDOWPROP (CAR WINDOW) 'PROCESS NIL) (\TEDIT.INTERRUPT.SETUP (THIS.PROCESS) T) (* ;  "Re-arm the interrupts we turned off coming in.") (COND ((AND (TXTFILE TEXTOBJ) (NOT (WINDOWPROP (CAR WINDOW) 'TEDIT-CLOSING-FILE T)))(* ;  "Remember to close the file we were editing (Only if the window function isn't closing it.)") (CLOSEF? (TXTFILE TEXTOBJ)) (WINDOWPROP (CAR WINDOW) 'TEDIT-CLOSING-FILE NIL) (* ;  "And let anyone else who wants to try closing the file do so.") )) (PROCESSPROP (THIS.PROCESS) 'TTYEXITFN OTTYEXITFN) (PROCESSPROP (THIS.PROCESS) 'TTYENTRYFN OTTYENTRYFN) (replace (TEXTOBJ TXTHISTORY) of TEXTOBJ with NIL) (* ;  "To prevent circularities arising from the need to remember textobjs in the history list.") (replace (TEXTOBJ SELWINDOW) of TEXTOBJ with NIL) (* ;  "To prevent a circularity thru the window back to the textobj.") (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with NIL) (* ;  "Tell TEdit that this document is NO LONGER actively being edited.") (COND ((NEQ (TEXTPROP TEXTOBJ 'TTYWINDOW) 'DON'T) (* ;  "He can suppress the ability to copy-select things into this window if he wants....") (TTYDISPLAYSTREAM OTTYWINDOW) (PROCESSPROP (THIS.PROCESS) 'TEDITTTYWINDOW NIL] (RETURN (LIST TEXTOBJ WINDOW OTTYWINDOW OTTYENTRYFN OTTYEXITFN OWINDOW]) -) - -(RPAQ? TEDIT.INTERRUPTS (QUOTE ((2 BREAK) (5 ERROR) (7 HELP) (20 CONTROL-T)))) - -(RPAQQ TEDIT.COPY.PENDING NIL) - -(RPAQQ TEDIT.COPYLOOKS.PENDING NIL) - -(RPAQQ TEDIT.MOVE.PENDING NIL) - -(RPAQQ TEDIT.DEL.PENDING NIL) - -(RPAQQ TEDIT.BLUEPENDINGDELETE NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.COPY.PENDING TEDIT.COPYLOOKS.PENDING TEDIT.MOVE.PENDING TEDIT.DEL.PENDING TEDIT.BLUEPENDINGDELETE TEDIT.INTERRUPTS) -) - - - -(* ; "Read-table Utilities") - -(DEFINEQ - -(\TEDIT.READTABLE (LAMBDA NIL (* jds "12-Sep-86 13:48") (* Create a TEdit read-table, to control which characters have what functions  and call which commands.) (PROG ((RTBL (create READTABLEP READMACRODEFS _ (HASHARRAY 50)))) (for CH in (CHARCODE (BS ^A ^W DEL %#A %#B %#C ESC)) as CL in (LIST CHARDELETE.TTC CHARDELETE.TTC WORDDELETE.TTC DELETE.TTC UNDO.TTC NEXT.TTC CMD.TTC REDO.TTC) do (* Set up the default syntax classes  for command characters) (\SETSYNCODE (fetch READSA of RTBL) CH CL)) (for CH in (CHARCODE (^X)) as FN in '(\TEDIT.ABBREV.EXPAND) do (* Set up the default function-calling  characters (^X to expand abbrevs for  now)) (\SETSYNCODE (fetch READSA of RTBL) CH FUNCTIONCALL.TTC) (PUTHASH CH FN (fetch READMACRODEFS of RTBL))) (TEDIT.SETFUNCTION (CHARCODE ^O) (FUNCTION GET.OBJ.FROM.USER) RTBL) (* And for image object capture) (RETURN RTBL)))) - -(\TEDIT.WORDBOUND.READTABLE [LAMBDA NIL (* ; "Edited 22-May-92 15:10 by jds") (* ;; "Create a readtable which will let TEdit find word boundaries. A word boundary is any point where the SYNCODE of the adjacent characters is different") (PROG [(RTBL (create READTABLEP READMACRODEFS _ (HARRAY 50] (for CH from 0 to 255 do (\SETSYNCODE (fetch READSA of RTBL) CH PUNCT.TTC)) (* ;; "By default, every character except those noted below is a punctuation character") (for CH from (CHARCODE A) to (CHARCODE Z) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (* ; "Upper case alpha") (for CH from (CHARCODE a) to (CHARCODE z) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (* ; "Lower case alpha") (for CH from (CHARCODE 0) to (CHARCODE 9) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (* ; "And digits are text characters") (* ;; "European chars and accents are text characters:") (for CH from (CHARCODE "361,41") to (CHARCODE "361,376") do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (for CH from (CHARCODE "0,301") to (CHARCODE "0,317") do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (for CH from (CHARCODE "0,341") to (CHARCODE "0,376") do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (for CH in (CHARCODE (CR SPACE TAB ^L)) do (\SETSYNCODE (fetch READSA of RTBL) CH WHITESPACE.TTC)) (* ; "And these are white space") (for CH in (LIST MSPACE NSPACE THINSPACE FIGSPACE) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (RETURN RTBL]) - -(TEDIT.GETSYNTAX [LAMBDA (CH TABLE) (* ; "Edited 31-Mar-87 10:01 by jds") (* ;  "Find TEdit's interpretation of a given character") (SELECTC (\SYNCODE [fetch READSA of (COND ((type? TEXTOBJ TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of TABLE) TEDIT.READTABLE)) ((type? STREAM TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of TABLE)) TEDIT.READTABLE)) (T (OR TABLE TEDIT.READTABLE] (COND ((LITATOM CH) (* ;  "Symbols are converted to numeric charcodes") (APPLY* 'CHARCODE CH)) ((STRINGP CH) (* ; "As are string char-names") (APPLY* 'CHARCODE CH)) (T CH))) (WORDDELETE.TTC 'WORDDELETE) (CHARDELETE.TTC 'CHARDELETE) (DELETE.TTC 'DELETE) (UNDO.TTC 'UNDO) (REDO.TTC 'REDO) (FUNCTIONCALL.TTC 'FN) (CMD.TTC 'CMD) (NEXT.TTC 'NEXT) (EXPAND.TTC 'EXPAND) NIL]) - -(TEDIT.SETSYNTAX [LAMBDA (CHAR CLASS TABLE) (* ; "Edited 31-Mar-87 10:00 by jds") (* ;  "SETS TEDIT-STYLE SYNTAX BITS IN A TERMTABLE") (PROG1 (TEDIT.GETSYNTAX (SETQ CHAR (COND ((LITATOM CHAR) (APPLY* 'CHARCODE CHAR)) ((STRINGP CHAR) (APPLY* 'CHARCODE CHAR)) (T CHAR))) TABLE) (\SETSYNCODE [fetch READSA of (COND ((type? TEXTOBJ TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of TABLE) TEDIT.READTABLE)) ((type? STREAM TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of TABLE)) TEDIT.READTABLE)) (T (OR TABLE TEDIT.READTABLE] CHAR (SELECTQ CLASS (CHARDELETE CHARDELETE.TTC) (WORDDELETE WORDDELETE.TTC) ((DELETE LINEDELETE) DELETE.TTC) (UNDO UNDO.TTC) (REDO REDO.TTC) (CMD CMD.TTC) (FN FUNCTIONCALL.TTC) (NEXT NEXT.TTC) (EXPAND EXPAND.TTC) NONE.TTC]) - -(TEDIT.GETFUNCTION (LAMBDA (CHARCODE TABLE) (* jds "19-Sep-85 17:06") (* Gets the FN that is called when CH is hit inside TEDIT.) (SETQ TABLE (COND ((type? TEXTOBJ TABLE) (* If given a TEXTOBJ in place of a read table, coerce it to the read table for  that edit session) (fetch (TEXTOBJ TXTRTBL) of TABLE)) ((type? STREAM TABLE) (* If given a TEXTOBJ in place of a read table, coerce it to the read table for  that edit session) (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of TABLE))) (T (OR TABLE TEDIT.READTABLE)))) (SETQ CHARCODE (COND ((LITATOM CHARCODE) (APPLY* 'CHARCODE CHARCODE)) (T CHARCODE))) (AND TABLE (type? READTABLEP TABLE) (IEQP FUNCTIONCALL.TTC (\SYNCODE (fetch READSA of TABLE) CHARCODE)) (fetch READMACRODEFS of TABLE) (GETHASH CHARCODE (fetch READMACRODEFS of TABLE))))) - -(TEDIT.SETFUNCTION [LAMBDA (CHARCODE FN RTBL) (* ; "Edited 31-Mar-87 10:58 by jds") (* ;  "Set TEDITs (read) table so that FN is called whenever CHARCODE is typed.") (* ;  "If FN is NIL, make the character be normal again.") [SETQ RTBL (COND ((type? TEXTOBJ RTBL) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (fetch (TEXTOBJ TXTRTBL) of RTBL)) ((type? STREAM RTBL) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of RTBL))) (T (OR RTBL TEDIT.READTABLE] (\SETSYNCODE (fetch READSA of RTBL) (SETQ CHARCODE (COND ((LITATOM CHARCODE) (APPLY* 'CHARCODE CHARCODE)) ((STRINGP CHARCODE) (APPLY* 'CHARCODE CHARCODE)) (T CHARCODE))) (COND (FN (* ;  "He gave us a function to call. Set up the syntax so it IS called.") FUNCTIONCALL.TTC) (T (* ;  "He gave us a function of NIL, meaning 'turn it off' . Cause this character to become normal.") NONE.TTC))) (* ;  "Mark the character as invoking a function") (OR (fetch READMACRODEFS of RTBL) (replace READMACRODEFS of RTBL with (HARRAY 50))) (* ;  "Make sure there's a hash table to store the function in.") (PUTHASH CHARCODE FN (fetch READMACRODEFS of RTBL]) - -(TEDIT.WORDGET (LAMBDA (CH TABLE) (* jds "27-MAY-83 13:24") (\SYNCODE (fetch READSA of (OR TABLE TEDIT.WORDBOUND.READTABLE)) (COND ((SMALLP CH)) (T (CHCON1 CH)))))) - -(TEDIT.WORDSET (LAMBDA (CHARCODE CLASS TABLE) (* jds " 1-JUN-83 12:23") (* SETS TEDIT-STYLE SYNTAX BITS IN A  TERMTABLE) (\SETSYNCODE (fetch READSA of (OR TABLE TEDIT.WORDBOUND.READTABLE)) (COND ((SMALLP CHARCODE)) (T (CHCON1 CHARCODE))) (COND ((FIXP CLASS)) (T (SELECTQ CLASS (PUNCTUATION PUNCT.TTC) (WHITESPACE WHITESPACE.TTC) (TEXT TEXT.TTC) TEXT.TTC)))))) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(RPAQ TEDIT.READTABLE (\TEDIT.READTABLE)) - -(RPAQ TEDIT.WORDBOUND.READTABLE (\TEDIT.WORDBOUND.READTABLE)) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.READTABLE TEDIT.WORDBOUND.READTABLE) -) -(PUTPROPS TEDITCOMMAND COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 -1992 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1694 37674 (\TEDIT.INSERT.TTY.BUFFER 1704 . 2314) (\TEDIT.INTERRUPT.SETUP 2316 . 3889) -(\TEDIT.MARKACTIVE 3891 . 4099) (\TEDIT.MARKINACTIVE 4101 . 4313) (\PNC 4315 . 4955) ( -\TEDIT.COMMAND.LOOP 4957 . 31094) (\TEDIT.COMMAND.RESET.SETUP 31096 . 37672)) (38157 51429 ( -\TEDIT.READTABLE 38167 . 39811) (\TEDIT.WORDBOUND.READTABLE 39813 . 42338) (TEDIT.GETSYNTAX 42340 . -44536) (TEDIT.SETSYNTAX 44538 . 46879) (TEDIT.GETFUNCTION 46881 . 48139) (TEDIT.SETFUNCTION 48141 . -50449) (TEDIT.WORDGET 50451 . 50720) (TEDIT.WORDSET 50722 . 51427))))) -STOP diff --git a/library/TEDITFILE.~1~ b/library/TEDITFILE.~1~ deleted file mode 100644 index dfc17cec..00000000 --- a/library/TEDITFILE.~1~ +++ /dev/null @@ -1,1636 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jun-99 20:00:50" {DSK}medley3.5>library>TEDITFILE.;3 245949 changes to%: (FNS TEDIT.BUILD.PCTB TEDIT.GET TEDIT.INCLUDE TEDIT.RAW.INCLUDE TEDIT.PUT TEDIT.PUT.PCTB TEDIT.PUT.PCTB2) previous date%: "25-Aug-94 10:53:27" {DSK}medley3.5>library>TEDITFILE.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITFILECOMS) (RPAQQ TEDITFILECOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "GETting a file") (FNS TEDIT.BUILD.PCTB \TEDIT.CONVERT.FOREIGN.FORMAT TEDIT.FORMATTEDFILEP TEDIT.GET TEDIT.PARSE.PAGEFRAMES1 \ARBIN \ATMIN \DWIN \STRINGIN \TEDIT.FORMATTEDP1 \TEDIT.SET.WINDOW)) (COMS (* ;; "INCLUDEing a file") (FNS TEDIT.INCLUDE TEDIT.RAW.INCLUDE)) (COMS (* ;; "PUTting a file:") (FNS TEDIT.PUT TEDIT.PUT.PCTB \TEDIT.PUTRESET TEDIT.PUT.PIECE.DESCRIPTOR \ARBOUT \ATMOUT \DWOUT \STRINGOUT \TEDIT-OPEN-FONT-FILE)) (FNS \TEDIT.GET.CHARLOOKS.LIST \TEDIT.GET.SINGLE.CHARLOOKS \TEDIT.PUT.CHARLOOKS.LIST \TEDIT.PUT.SINGLE.CHARLOOKS) (FNS \TEDIT.GET.PARALOOKS.LIST \TEDIT.GET.SINGLE.PARALOOKS \TEDIT.PUT.PARALOOKS.LIST \TEDIT.PUT.SINGLE.PARALOOKS) (GLOBALVARS TEDIT.INPUT.FORMATS *TEDIT-FILE-READTABLE*) (INITVARS (TEDIT.INPUT.FORMATS NIL) (*TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE)) (* ;  "For consistent reading and writing of info on TEdit files.") ) (COMS (* ;;  "For converting old incoming format. Cutover 5/22/85 to permit looks changes in the future.") (FNS TEDIT.BUILD.PCTB2 \TEDIT.GET.CHARLOOKS.LIST2 \TEDIT.GET.SINGLE.CHARLOOKS2 \TEDIT.PUT.SINGLE.PARALOOKS2 \TEDIT.PUT.SINGLE.CHARLOOKS2 \TEDIT.GET.PARALOOKS.LIST2 \TEDIT.GET.SINGLE.PARALOOKS2 TEDIT.PUT.PCTB2 \TEDIT.PUT.CHARLOOKS.LIST2 \TEDIT.PUT.PARALOOKS.LIST2)) (COMS (* ;; "For converting incoming old-format files (1/27/85 cutover)") (FNS TEDIT.BUILD.PCTB1 TEDIT.GET.PAGEFRAMES1 \TEDIT.GET.CHARLOOKS1 \TEDIT.GET.PARALOOKS1 TEDIT.GET.OBJECT1)) (COMS (* ;; "VERSION 0 Compatibility reading functions") (FNS TEDIT.BUILD.PCTB0 TEDIT.GET.CHARLOOKS0 TEDIT.GET.OBJECT0 TEDIT.GET.PARALOOKS0)))) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (* ;; "GETting a file") (DEFINEQ (TEDIT.BUILD.PCTB [LAMBDA (TEXT TEXTOBJ START END DEFAULTLOOKS DEFAULTPARALOOKS CLEARGET?) (* ; "Edited 11-Jun-99 14:51 by rmk:") (* ; "Edited 11-Jun-99 14:37 by rmk:") (* ; "Edited 19-Apr-93 13:46 by jds") (* ;  "START = 1st char of file to read from, if specified") (* ;  "END = use this as eofptr of file. For use in reading files within files.") (PROG (SEL LINES PCTB PC OLDPC PCCOUNT TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK EXISTINGFMTSPECS (*READTABLE* *TEDIT-FILE-READTABLE*) (*PRINT-BASE* 10) (CURFILECH# (OR START 0)) (CURCH# 1) (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) LOOKSHASH PARAHASH) [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) (T (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC ] (* ;  "Set the default paragraph formatting for filling in piece PPARALOOKS fields") (COND (TEXTOBJ (* ;  "If there's a TEXTOBJ behind this, set its TXTFILE field to point to the right place.") (replace (TEXTOBJ TXTFILE) of TEXTOBJ with TEXT))) (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))) (* ;  "Set the default CHARLOOKS, for filling in pieces' PLOOKS fields") (SETQ TEXT (\CREATEPIECEORSTREAM TEXT DEFAULTLOOKS DEFAULTPARALOOKS START END)) (* ;  "Grab the file, or a single piece (if the text is a string, or such simple cases)") (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL)) (* ;  "Start by assuming no page formatting") (COND ((STREAMP TEXT) (* ;  "OK, it wasn't a string, so check for cases where we have to cache the file locally.") (AND TEXTOBJ (replace (TEXTOBJ TXTFILE) of TEXTOBJ with TEXT)) (COND ((OR [AND TEXTOBJ (SETQ CACHE? (TEXTPROP TEXTOBJ 'CACHE] (NOT (RANDACCESSP TEXT))) (* ;  "If the file device isn't rancom access, cache the file locally.") (* ;  "Also do this if he asks for a local cache.") [SETQ CACHE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ; "The cache file") (COND ((OR START END) (COPYBYTES TEXT CACHE (OR START 0) (OR END -1))) (T (COPYBYTES TEXT CACHE))) (* ; "Copy the text there") (SETQ CACHE? T) (* ; "Remember that we cached it!") (* ;; "COPYBYTES can only have start/end args of NIL if the file is not random access. So it's impossible to grab out of the middle of a file on an NS server. Sorry.") (COND (CACHE? (* ;; "for the folx who don't trust the connections, since all their pcs will point to core, we can close the txtfile connection") (CLOSEF TEXT))) (replace (STREAM EOLCONVENTION) of CACHE with (fetch (STREAM EOLCONVENTION ) of TEXT)) (* ;  "Remember the EOL convention from the original file, so that we can do a copychars if need be.") (SETQ TEXT CACHE) (* ;  "And pretend the cache IS the real file from here on") (SETQ START (SETQ END NIL)) (* ;; "Since we only copied the relevant part of the file into the cache, we don't need to remember the limits of interest.") )) (SETQ PCCOUNT (\TEDIT.FORMATTEDP1 TEXT END)) (COND ((AND (NOT PCCOUNT) (NEQ (fetch (STREAM EOLCONVENTION) of TEXT) CR.EOLC)) (* ;; "This is an UNFORMATTED file, and it has a foreign EOL convention. Convert it, and save the converted copy locally.") [SETQ CACHE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ; "Build a cache file") (COND ((OR START END) (COPYCHARS TEXT CACHE (OR START 0) (OR END -1)) (* ;; "mcf: just like before, we have all the relevant portion") (SETQ START (SETQ END NIL))) (T (COPYCHARS TEXT CACHE))) (* ;  "Copy the text, converting from the foreign EOL convention into CR as end of line.") (SETQ TEXT CACHE) (* ;; "And think of THIS as the cache. At this point, we may have cached twice in succession--no need to clip off START and END.") (SETQ CACHE? T) (* ;  "Remember that we cached the file!") )) (* ;  "Check to see if this is a formatted file, and find out how may pieces we should allocate for it.") )) (AND TEXTOBJ (TEXTPROP TEXTOBJ 'CACHE CACHE?)) (* ;  "REMEMBER THAT THIS TEXT WAS CACHED, SO THAT LATER PUTS DON'T INVALIDATE THE CACHE.") [COND [(type? PIECE TEXT) (* ;  "If this isn't a text stream, build a piece table with the one piece in it.") (COND ((EQ (fetch (PIECE PLEN) of TEXT) 0) (* ;  "I hate piece whose length is zero.") (SETQ PCTB (\MAKEPCTB (SETQ TEXT NIL))) (* INSERT-BRT (CREATEPCNODE 1  (QUOTE LASTPIECE)) PCTB) ) (T (SETQ PCTB (\MAKEPCTB TEXT)) (* INSERT-BRT (CREATEPCNODE  (ADD1 (fetch (PIECE PLEN) of TEXT))  (QUOTE LASTPIECE)) PCTB) (replace (PIECE PLOOKS) of TEXT with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of TEXT) TEXTOBJ)) (* ;  "And note the CHARLOOKS and PARALOOKS of this text--as well as filling them in.") (replace (PIECE PPARALOOKS) of TEXT with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of TEXT) TEXTOBJ] (CLEARGET? (* ;; "If the user wants an uninterpreted stream onto the file , build a piece table with the one piece in it.") (SETQ TEXT (create PIECE PFILE _ TEXT PFPOS _ (COND (START START) (T 0)) PLEN _ (IDIFFERENCE (OR END (GETEOFPTR TEXT)) (COND (START START) (T 0))) PREVPIECE _ NIL PLOOKS _ DEFAULTLOOKS PPARALAST _ NIL PPARALOOKS _ DEFAULTPARALOOKS)) (* ;  "A single piece to describe the whole file") (SETQ PCTB (\MAKEPCTB TEXT)) (replace (PIECE PLOOKS) of TEXT with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of TEXT) TEXTOBJ)) (* ;  "And note the CHARLOOKS and PARALOOKS for later saving. Keep those caches consistent.") (replace (PIECE PPARALOOKS) of TEXT with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of TEXT) TEXTOBJ)) (* INSERT-BRT (CREATEPCNODE  (ADD1 (fetch (PIECE PLEN) of TEXT))  (QUOTE LASTPIECE)) PCTB) ) [(NOT PCCOUNT) (* ; "This is an unformatted file") (COND [(SETQ USERFILEFORMAT (for FILETYPE in TEDIT.INPUT.FORMATS when (SETQ USERTEMP (APPLY* (CAR FILETYPE) TEXT)) do (RETURN FILETYPE))) (* ;  "The input file is in a user-sensible format, which he is willing to convert for TEdit's use.") (* ; "See if there are Bravo headers") (SETQ PCTB (\TEDIT.CONVERT.FOREIGN.FORMAT (CADR USERFILEFORMAT) TEXT USERTEMP TEXTOBJ DEFAULTLOOKS DEFAULTPARALOOKS)) (* ;  "Convert the foreign format file, and grab its PCTB") (bind (PC _ (\GETBASEPTR (\FIRSTNODE PCTB) 0)) while [AND PC (NOT (EQ PC 'LASTPIECE] do (* ;  "Run thru the converted pieces, noting their CHARLOOKS and PARALOOKS for the get/put caches.") (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ)) (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS) of PC) TEXTOBJ)) (SETQ PC (fetch (PIECE NEXTPIECE) of PC] (T (* ;  "Nope--it's straight unformatted text") [SETQ PCTB (\MAKEPCTB (create PIECE PFILE _ TEXT PFPOS _ CURFILECH# PLEN _ (IDIFFERENCE (OR END (GETEOFPTR TEXT)) CURFILECH#) PREVPIECE _ NIL PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS DEFAULTLOOKS TEXTOBJ) PPARALAST _ NIL PPARALOOKS _ (\TEDIT.UNIQUIFY.PARALOOKS DEFAULTPARALOOKS TEXTOBJ] (* ;  "So create a single piece to describe its contents") (* INSERT-BRT (CREATEPCNODE  (ADD1 (IDIFFERENCE  (OR END (GETEOFPTR TEXT)) CURFILECH#))  (QUOTE LASTPIECE)) PCTB) (* ; "Insert LASTPIECE here") ] [(LISTP PCCOUNT) (* ;  "This is an obsolete version of the TEdit file format.") (SELECTQ (CAR PCCOUNT) (0 (* ; "VERSION 0") (SETQ PCTB (TEDIT.BUILD.PCTB0 TEXT TEXTOBJ (CDR PCCOUNT) START END))) (1 (* ;  "Version 1; obsoleted at INTERMEZZO release 2/85") (SETQ PCTB (TEDIT.BUILD.PCTB1 TEXT TEXTOBJ (CDR PCCOUNT) START END))) (2 (* ; "Version 2; obsoleted 5/22/85") (SETQ PCTB (TEDIT.BUILD.PCTB2 TEXT TEXTOBJ (CDR PCCOUNT) START END))) (SHOULDNT "File format version incompatible with this version of TEdit.")) (bind (PC _ (\GETBASEPTR (\FIRSTNODE PCTB) 0)) while [AND PC (NOT (EQ PC 'LASTPIECE] do (* ;  "Run thru the converted pieces, noting CHARLOOKS and PARALOOKS for the caches.") (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ)) (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of PC) TEXTOBJ)) (SETQ PC (fetch (PIECE NEXTPIECE) of PC] (T (* ;  "This IS a TEdit-format file, so read in all the parts.") (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB) (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) 8)) (SETQ PIECEINFOCH# (\DWIN TEXT)) (SETFILEPTR TEXT PIECEINFOCH#) (bind (OLDPC _ NIL) (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN from 1 do (SETQ PC NIL) (* ;  "This loop may not really read a piece, so we have to distinguish that case.") (SETQ PCLEN (\DWIN TEXT)) (SETQ TYPECODE (\SMALLPIN TEXT)) (* ; "What kind of piece is it?") [SELECTC TYPECODE (\PieceDescriptorPAGEFRAME (* ;  "This is page layout info for the file") (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with (TEDIT.GET.PAGEFRAMES TEXT))) (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") ) (\PieceDescriptorCHARLOOKSLIST (* ;  "This is the list of CHARLOOKSs used in this document.") (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ with (\TEDIT.GET.CHARLOOKS.LIST TEXT)) (* ;  "Read the list of looks used in this document.") [SETQ LOOKSHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (* ;  "Build an array of the looks, so the reader can index them.") (for I from 1 as LOOKS in (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ) do (SETA LOOKSHASH I LOOKS)) (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") (add I -1)) (\PieceDescriptorPARALOOKSLIST (* ;  "This is the list of PARALOOKSs used in this document.") (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ with (\TEDIT.GET.PARALOOKS.LIST TEXT TEXTOBJ)) (* ;  "Read the list of looks used in this document.") [SETQ PARAHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ] (* ;  "Build an array of the looks, so the reader can index them.") (for I from 1 as LOOKS in (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ) do (SETA PARAHASH I LOOKS)) (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") (add I -1)) (\PieceDescriptorPARA (* ;  "Reading a new set of paragraph looks.") (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T)) (* ;  "Mark the end of the preceding paragraph.") (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS TEXT PARAHASH)) (* ;  "Get the new set of looks, for use by later pieces.") (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ with T)) (* ;  "Mark the document as containing paragraph formatting info") (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") ) (\PieceDescriptorLOOKS (* ;  "New character looks. Build a piece to describe those characters.") (SETQ PC (create PIECE PFILE _ TEXT PFPOS _ CURFILECH# PLEN _ PCLEN PREVPIECE _ OLDPC PPARALOOKS _ OLDPARALOOKS)) (* ; "Build the new piece") (\TEDIT.GET.CHARLOOKS PC TEXT LOOKSHASH OLDPC) (* ;  "Read the character looks for this guy.") (COND (OLDPC (* ;  "If there's a prior piece, hook this one on the chain.") (replace (PIECE NEXTPIECE) of OLDPC with PC))) (add CURFILECH# PCLEN) (* ;  "And note the passing of characters.") ) (\PieceDescriptorOBJECT (* ;  "It describes an object. Read that, and perhaps some description of the charlooks to go with it.") (SETQ PC (create PIECE PFILE _ TEXT PFPOS _ CURFILECH# PLEN _ PCLEN PREVPIECE _ OLDPC PPARALOOKS _ OLDPARALOOKS)) (COND (OLDPC (* ;  "If there's a prior piece, hook this one on the chain.") (replace (PIECE NEXTPIECE) of OLDPC with PC))) (TEDIT.GET.OBJECT TEXTSTREAM PC TEXT CURFILECH#) (add CURFILECH# (fetch (PIECE PLEN) of PC)) [COND ((NOT (ZEROP (\BIN TEXT))) (* ;  "There are new character looks for this object. Read them in.") (replace (PIECE PLOOKS) of PC with (  \TEDIT.GET.SINGLE.CHARLOOKS TEXT))) (T (* ;  "No new looks; steal them from the prior piece.") (replace (PIECE PLOOKS) of PC with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC)) DEFAULTLOOKS] (replace (PIECE PLEN) of PC with 1) (* ;  "OBJECTs are officially one character long.") ) (PROGN (TEDIT.PROMPTPRINT TEXTOBJ "WARNING: Unknown-type piece skipped." T) (SETFILEPTR TEXT (IPLUS (GETFILEPTR TEXT) (\SMALLPIN TEXT] (COND (PC (\INSERTPIECE PC 'LASTPIECE TEXTOBJ) (* ;  "If we created a piece, save it in the table.") (add CURCH# (fetch (PIECE PLEN) of PC)) (SETQ OLDPC PC))) finally (* ;; "(\\editseta pctb pcn curch#)") (* ;;  " (\\editseta pctb (add1 pcn) 'lastpiece)") (* ;;  "(\\editseta pctb |\\PCTBLastPieceOffset| (add1 pcn)) ") (* ;;  "(\\editseta pctb |\\PCTBFreePieces| 0)") (* INSERT-BRT (CREATEPCNODE CURCH#  (QUOTE LASTPIECE)) PCTB) ] (AND (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) TEXTOBJ)) (* ;  "And make sure that the default and caret looks are reflected in that list.") (AND (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ)) (AND DEFAULTLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS DEFAULTLOOKS TEXTOBJ)) (* ;  "And the default looks we used in this function...") (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) TEXTOBJ) (* ;  "And make sure the default paralooks are reflected in that list.") [AND TEXT (bind (CHARLOOKSLIST _ (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ)) (PARALOOKSLIST _ (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) for (PC _ (\GETBASEPTR (\FIRSTNODE PCTB) 0)) by (fetch (PIECE NEXTPIECE) of PC) while [AND PC (NOT (EQ PC 'LASTPIECE] do (* ;  "Look at every piece, and assure that its CHARLOOKS and PARALOOKS are in the cache.") [COND ((FMEMB (fetch (PIECE PLOOKS) of PC) CHARLOOKSLIST) (* ;  "This piece's CHARLOOKS are known in the cache already. Don't bother doing anything else.") ) (T (* ;  "Nope; add these looks to the cache") (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ] (COND ((FMEMB (fetch (PIECE PPARALOOKS) of PC) PARALOOKSLIST) (* ;  "This piece's PARALOOKS are known in the cache already. Don't bother doing anything else.") ) (T (* ;  "Nope; add these looks to the cache") (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of PC) TEXTOBJ] (RETURN PCTB]) (\TEDIT.CONVERT.FOREIGN.FORMAT - [LAMBDA (CONVERSIONFN FILE PREDICATERESULT TEXTOBJ DEFAULTLOOKS DEFAULTPARALOOKS) - (* ; "Edited 12-Jun-90 18:16 by mitani") - - (* Perform the conversion from a foreign file format into TEdit-internal form - as an open TextStream.) - - (PROG (TSTREAM TTEXTOBJ SEL WORKINGSTREAM) (* See if there are Bravo headers) - (SETQ WORKINGSTREAM (OPENTEXTSTREAM "")) - (RESETLST - (RESETSAVE (\TEDIT.SET.WINDOW (CONS (TEXTOBJ WORKINGSTREAM) - NIL))) - (SETQ TSTREAM (APPLY* CONVERSIONFN FILE PREDICATERESULT WORKINGSTREAM))) - (COND - (TEXTOBJ - - (* If we're filling in an existing TEXTOBJ, there are fields that need to be - copied.) - - [OR (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) - (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ - with (fetch (TEXTOBJ TXTPAGEFRAMES) of (TEXTOBJ TSTREAM] - (* Such as the page formatting, - which the converter may well set.) - )) - (RETURN (fetch (TEXTOBJ PCTB) of (TEXTOBJ TSTREAM]) (TEDIT.FORMATTEDFILEP - [LAMBDA (STREAM) (* ; "Edited 19-Apr-93 11:57 by jds") - (* ; - "Test to see if this stream's text would need a TEdit-format file (T) or is just plain text (NIL)") - (PROG ((TEXTOBJ (TEXTOBJ STREAM)) - (FONTFILE 0) - OLDPARALOOKS PC OLDLOOKS PREVPC TENTATIVE) - (SETQ OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) - (SETQ TENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) - (* ; "If edits are to be shown") - (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - 0)) (* ; "First piece in the document") - (COND - ((ATOM PC) (* ; "Empty document") - (RETURN NIL))) - (SETQ OLDLOOKS (OR (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) - TEDIT.DEFAULT.CHARLOOKS)) - (while PC do [COND - ((fetch (PIECE POBJ) of PC) - (* ; - "OBJECTS require the special format") - (SETQ FONTFILE 4)) - ([AND (OR (NOT PREVPC) - (fetch (PIECE PPARALAST) of PREVPC)) - (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) - (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] - (* ; "We just hit a paragraph break.") - (SETQ FONTFILE (IMAX FONTFILE 3))) - ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of - PC))) - (AND TENTATIVE (OR (AND PREVPC (NEQ (fetch (PIECE PNEW) - of PREVPC) - (fetch (PIECE PNEW) - of PC))) - (AND (NOT PREVPC) - (fetch (PIECE PNEW) of PC)) - (AND PREVPC (NEQ (fetch (PIECE PFATP) - of PREVPC) - (fetch (PIECE PFATP) - of PC] - (* ; "Change in font, size, etc.") - (SETQ FONTFILE (IMAX FONTFILE 2))) - ((fetch (PIECE PFATP) of PC) - (* ; "NS Chars in the piece.") - (SETQ FONTFILE (IMAX FONTFILE 1] - (SETQ PREVPC PC) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) - (RETURN (SELECTQ FONTFILE - (0 NIL) - (1 'NSCHARS) - (2 'CHARLOOKS) - (3 'PARALOOKS) - (4 'IMAGEOBJ) - NIL]) (TEDIT.GET [LAMBDA (TEXTOBJ FILE UNFORMATTED?) (* ; "Edited 11-Jun-99 15:23 by rmk:") (* ; "Edited 19-Apr-93 13:12 by jds") (* ;; "Get a new file (overwriting the one being edited.)") (PROG ((TEXTOBJ (TEXTOBJ TEXTOBJ)) OFILE OCURSOR LINES USER.CMFILE RESP TITLE FILENAME MENUSTREAM (GETFN (TEXTPROP TEXTOBJ 'GETFN)) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (TEDIT.GET.FINISHEDFORMS NIL)) (COND ([AND (fetch (TEXTOBJ \DIRTY) of TEXTOBJ) (PROGN (AND (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ) (FRESHLINE (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ))) (NOT (MOUSECONFIRM "Not saved yet; LEFT go Get anyway." T (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ] (* ;; "Only do the GET if he knows he'll zorch himself.") (RETURN))) [SETQ OFILE (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to GET: " (OR (TEXTPROP TEXTOBJ 'LASTGETFILENAME) (\TEXTSTREAM.FILENAME TEXTOBJ] (TEXTPROP TEXTOBJ 'LASTGETFILENAME OFILE) (COND [(AND OFILE (OR (OPENP FILE) (INFILEP OFILE))) (* ;  "Only if there's a file to load and the file exists.") (COND ((AND GETFN (EQ (APPLY* GETFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (FULLNAME OFILE) 'BEFORE) 'DON'T)) (* ;  "He doesn't want this document put. Bail out.") (RETURN))) (TEXTPROP TEXTOBJ 'LASTGETFILENAME NIL) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM (OR (AND (NEQ (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ) 'DON'T) (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ)) PROMPTWINDOW))) (RESETSAVE (CURSOR WAITINGCURSOR)) (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL NIL) (\TEXTCLOSEF (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (* ; "CLOSE the old files") [OR (AND (STREAMP FILE) (OPENP FILE)) (SETQ OFILE (OPENSTREAM OFILE 'INPUT NIL '((TYPE TEXT] (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) do (* ;  "Remove the previous hardcopyfile") (WINDOWPROP WINDOW 'HARDCOPYFILE NIL)) (* ;; "Open the new one.") (SETQ PCTB (replace (TEXTOBJ PCTB) of TEXTOBJ with (TEDIT.BUILD.PCTB OFILE TEXTOBJ NIL NIL (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) UNFORMATTED?))) (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM)) (* ;  "Do any necessary cleanup for outside packages") (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL) (for FIRSTLINE inside LINES do (replace (LINEDESCRIPTOR NEXTLINE) of FIRSTLINE with NIL)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;; "The old cached piece is no longer valid--keep people from stepping on it, to prevent lost type-in and smashing other docuemnts to which it has been moved...") (* ;; "(replace TEXTLEN of TEXTOBJ with (SUB1 (\EDITELT PCTB (SUB1 (\EDITELT PCTB \PCTBLastPieceOffset)))))") (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN ) of PCTB)) (replace (SELECTION CH#) of SEL with (replace (SELECTION CHLIM) of SEL with 1)) (replace (SELECTION DCH) of SEL with 0) (replace (SELECTION POINT) of SEL with 'LEFT) (replace (SELECTION SET) of SEL with T) (replace (SELECTION SET) of (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) with NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) with NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) with NIL) (replace (SELECTION SET) of TEDIT.SELECTION with NIL) (replace (SELECTION SET) of TEDIT.SHIFTEDSELECTION with NIL) (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with ( \TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) as LINE inside LINES do (* ;  "Fill the edit window (s) with the new text") (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) LINE TEXTOBJ NIL WINDOW)) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T) (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ)) (* ; "find and set the title") (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL)) (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ)) (COND ((AND MENUSTREAM (type? LITATOM TITLE)) (* ;  "if we have a filename then put it in the GET and PUT fields of the menu") (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE)) (MBUTTON.SET.FIELD MENUSTREAM 'Get FILENAME) (MBUTTON.SET.FIELD MENUSTREAM 'Put FILENAME))) (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ (\TEDIT.PRIMARYW TEXTOBJ)) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Get))) (AND GETFN (APPLY* GETFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (FULLNAME (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) 'AFTER] (OFILE (TEDIT.PROMPTPRINT TEXTOBJ "[File not found.]") (TEXTPROP TEXTOBJ 'LASTGETFILENAME OFILE)(* ;  "Remember the file name he tried for, so we offer it next time.") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "[Get aborted.]" T]) (TEDIT.PARSE.PAGEFRAMES1 - [LAMBDA (PAGELIST PARENT) (* ; "Edited 2-Jan-87 12:21 by jds") - (* Take an external pageframe and - internalize it.) - (PROG (FRAMETYPE PAGEFRAME) - (COND - ((type? PAGEREGION PAGELIST) - (RETURN PAGELIST)) - ((NEQ 'LIST (SETQ FRAMETYPE (pop PAGELIST))) - [SETQ PAGEFRAME (create PAGEREGION - REGIONFILLMETHOD _ FRAMETYPE - REGIONTYPE _ (pop PAGELIST) - REGIONLOCALINFO _ (pop PAGELIST) - REGIONSPEC _ (for VAL - in (OR (pop PAGELIST) - (LIST 0 0 0 0)) - collect (\TEDIT.SCALE VAL - (CONSTANT (FQUOTIENT 1 35.27778] - (replace REGIONSUBBOXES of PAGEFRAME with (for ALIST in (pop PAGELIST) - collect (TEDIT.PARSE.PAGEFRAMES1 ALIST - PAGEFRAME))) - (RETURN PAGEFRAME)) - (T (RETURN (for FRAMESPEC in (CAR PAGELIST) collect (TEDIT.PARSE.PAGEFRAMES1 FRAMESPEC - NIL]) (\ARBIN - [LAMBDA (STREAM) (* jds "13-Nov-86 20:21") - (* ; - "Read an arbitrary object from a file, parse it, and return it.") - - (PROG ((LEN (\SMALLPIN STREAM)) - USERSTR) - (COND - ((NOT (ZEROP LEN)) - (SETQ USERSTR (OPENSTRINGSTREAM (\STRINGIN STREAM LEN) - 'INPUT)) - (RETURN (PROG1 (READ USERSTR *TEDIT-FILE-READTABLE*) - (CLOSEF? USERSTR]) (\ATMIN - [LAMBDA (STREAM) (* jds " 3-Apr-84 10:41") - (PROG ((LEN (\SMALLPIN STREAM))) - (RETURN (COND - ((ZEROP LEN) - NIL) - (T (PACK (for I from 1 to LEN collect (CHARACTER (\BIN STREAM]) (\DWIN - [LAMBDA (FILE) (* jds " 3-JAN-83 16:08") - (IPLUS (LLSH (\BIN FILE) - 24) - (LLSH (\BIN FILE) - 16) - (LLSH (\BIN FILE) - 8) - (\BIN FILE]) (\STRINGIN - [LAMBDA (STREAM SETLEN) (* ; "Edited 20-Apr-88 19:54 by jds") - (* Read a string in length-contents form%: One word for the length, and one - byte per character contained. However, the length may be specified by the - caller instead of being read from the file.) - (PROG ((LEN (OR SETLEN (\SMALLPIN STREAM))) - STR) - (SETQ STR (ALLOCSTRING LEN)) - [OR (ZEROP LEN) - (for I from 1 to LEN do (RPLCHARCODE STR I (READCCODE STREAM] - (RETURN STR]) (\TEDIT.FORMATTEDP1 - [LAMBDA (FILE LEN) (* ; "Edited 12-Feb-88 11:43 by jds") - (* ; - "Checks for a version-1 formatted file") - - (* ;; "Returns NIL if it isn't a formatted file, or the # of pieces needed if it is; leaves file at start of text or of piece descriptions, resp.") - - (SETQ LEN (OR LEN (GETEOFPTR FILE))) - (PROG (DESCPTR NPIECES PASSWORD) - (COND - ((ILEQ LEN 8) (* ; "Too short to be formatted.") - - (RETURN NIL)) - (T (SETFILEPTR FILE (IDIFFERENCE LEN 8)) (* ; - "Move to start of FILEPTR to descriptions") - - (SETQ DESCPTR (\DWIN FILE)) (* ; - "Read the file pos of the descriptions") - - (SETQ NPIECES (\SMALLPIN FILE)) - (SETQ PASSWORD (\SMALLPIN FILE)) - (COND - ((IEQP PASSWORD 31418) (* ; - "Version 3 TEdit format; instituted on 5/22/85") - - (SETFILEPTR FILE DESCPTR) - (RETURN NPIECES)) - ((IEQP PASSWORD 31417) - - (* ;; "Version 2 format. Obsoleted 5/22/85 to permit revision of looks in the future without loss of compatibility") - - (SETFILEPTR FILE DESCPTR) - (RETURN (CONS 2 NPIECES))) - ((IEQP PASSWORD 31416) (* ; "VERSION 1 TEDIT FORMAT") - - (SETFILEPTR FILE DESCPTR) - (RETURN (CONS 1 NPIECES))) - ((IEQP PASSWORD 31415) (* ; "VERSION 0 TEDIT FORMAT") - - (SETFILEPTR FILE DESCPTR) - (RETURN (CONS 0 NPIECES))) - (T (* ; "NOT A FORMATTED FILE") - - (SETFILEPTR FILE 0) - (RETURN NIL]) (\TEDIT.SET.WINDOW - [LAMBDA (TOWIND) (* ; "Edited 12-Jun-90 18:16 by mitani") - (* USED IN RESETSAVES TO NULL OUT A - TEXTSTREAM'S WINDOW BRIEFLY.) - (PROG1 (CONS (CAR TOWIND) - (fetch (TEXTOBJ \WINDOW) of (CAR TOWIND))) - (replace (TEXTOBJ \WINDOW) of (CAR TOWIND) with (CDR TOWIND)))]) ) (* ;; "INCLUDEing a file") (DEFINEQ (TEDIT.INCLUDE [LAMBDA (STREAM FILE START END SAFE) (* ; "Edited 11-Jun-99 15:11 by rmk:") (* ; "Edited 11-Jun-99 15:11 by rmk:") (* ; "Edited 11-Jun-99 15:03 by rmk:") (* ; "Edited 11-Jun-99 15:03 by rmk:") (* ; "Edited 11-Jun-99 14:28 by rmk:") (* ;  "Edited 1-Jun-93 11:31 by sybalsky:mv:envos") (* ;; "Obtain a file name, and include that file's contents at the place where the caret is.") (* ;; "Returns T if the insertion happened, NIL if there was no place to put it.") (SETQ STREAM (TEXTOBJ STREAM)) (PROG ((SEL (fetch (TEXTOBJ SEL) of STREAM)) PCTB TEXTLEN NFILE NNFILE INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN PCCOUNT NSTREAM START-OF-PIECE) (DECLARE (SPECVARS START-OF-PIECE)) (COND ((fetch (TEXTOBJ TXTREADONLY) of STREAM)(* ; "This is read-only.") ) ((fetch (SELECTION SET) of SEL) (* ;  "There is a place to do the include.") [SETQ NFILE (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT STREAM "Name of the file to load: "] (COND ((NOT NFILE) (* ;  "If no file was given, don't bother INCLUDEing.") (TEDIT.PROMPTPRINT STREAM "[Include aborted.]" T) (RETURN)) ((STREAMP NFILE)) ((NOT (INFILEP NFILE)) (* ;  "Can't find the file. Put out a message.") (TEDIT.PROMPTPRINT STREAM "[File not found.]") (RETURN))) (COND ((NOT SAFE) (* ;; "If the caller sets SAFE, we don't need to do any of this copying, because he's guaranteeing that the files'll be there until we don't need 'em any more.") [SETQ NNFILE (OPENSTREAM '{NODIRCORE} 'OUTPUT 'NEW '((TYPE TEXT] (* ; "Create the holding file") [SETQ NFILE (COND ((OPENP NFILE) (SETQ WASOPEN T) NFILE) (T (* ;  "Wasn't open -- need to open it for input...") (OPENFILE NFILE 'INPUT NIL '((TYPE TEXT] (* ;  "And copy the file-section into it.") [COPYCHARS NFILE NNFILE (OR START 0) (OR END (GETFILEINFO NFILE 'LENGTH] (* ; "Have to explicitly fill in 0 and EOFPTR, because if the file was open already, NILs would only copy from current fileptr to EOF.") (OR WASOPEN (CLOSEF NFILE)) (* ;  "If the file didn't come to use open, close it.") (CLOSEF NNFILE) (SETQ NFILE NNFILE) (SETQ START (SETQ END NIL)) (* ; "Then pretend nothing happened.") )) (TEDIT.DO.BLUEPENDINGDELETE SEL STREAM) (* ; "Delete any text, if need be") (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of STREAM)) (* ;  "We need the POST-deletion text length for later, so this must come after the b-p-d.") (\SHOWSEL SEL NIL NIL) (* ;  "Turn off SELs before we go any further") [SETQ NFILE (TEXTOBJ (SETQ NSTREAM (OPENTEXTSTREAM [OPENSTREAM NFILE 'INPUT NIL '((TYPE TEXT] NIL NIL NIL (LIST 'FONT ( \TEDIT.GET.INSERT.CHARLOOKS STREAM SEL) 'PARALOOKS (fetch (TEXTOBJ FMTSPEC ) of STREAM] (* ;; "Get a textobj to describe the include source file (need NSTREAM so that if we have to convert it to formatted, we won't have lost the textstream--and thus smash the free list.)") (COND ((AND (fetch (TEXTOBJ FORMATTEDP) of NFILE) (NOT (fetch (TEXTOBJ FORMATTEDP) of STREAM))) (* ;  "If the includED text is formatted but this file isn't, let's format it!") (\TEDIT.CONVERT.TO.FORMATTED STREAM)) ((AND (fetch (TEXTOBJ FORMATTEDP) of STREAM) (NOT (fetch (TEXTOBJ FORMATTEDP) of NFILE))) (* ;; "The TARGET document is formatted, but the INCLUDEd text isn't. Better format it before completing the include.") (\TEDIT.CONVERT.TO.FORMATTED NFILE))) (SETQ PCTB (fetch (TEXTOBJ PCTB) of STREAM)) (* ;  "HERE, because the conversion to formatted will lengthen the pctb") [SETQ INSERTCH# (COND ((EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (fetch (SELECTION CH#) of SEL)) (T (fetch (SELECTION CHLIM) of SEL] (* ;  "Find the place to make the insertion.") (SETQ INSPC (\CHTOPC INSERTCH# PCTB T)) (* ;  "The piece to make the insertion in") [COND ((NEQ INSPC 'LASTPIECE) (COND ((IGREATERP INSERTCH# START-OF-PIECE) (* ; "Must split the piece.") (SETQ INSPC (\SPLITPIECE INSPC INSERTCH# STREAM INSPC#)) (SETQ PCTB (fetch (TEXTOBJ PCTB) of STREAM)) (* ;  "Refresh the PCTB in case it grew.") ] (SETQ PCLST (fetch (TEXTOBJ PCTB) of NFILE)) (* ;  "A temporary pctb, holding the pieces which describe the INCLUDEd text") (SETQ LEN (fetch (BTREENODE TOTLEN) of PCLST)) (\TEDIT.INSERT.PIECES STREAM INSERTCH# (SETQ PCLST (\GETBASEPTR (\FIRSTNODE PCLST) 0)) LEN INSPC INSPC# NIL) [COND ((AND (fetch (TEXTOBJ FORMATTEDP) of STREAM) (NOT (fetch (TEXTOBJ FORMATTEDP) of NFILE))) (* ;  "If the includED text is formatted but this file isn't, let's format it!") (\TEDIT.CONVERT.TO.FORMATTED STREAM INSERTCH# (IPLUS INSERTCH# LEN] (\TEDIT.HISTORYADD STREAM (create TEDITHISTORYEVENT THACTION _ 'Include THCH# _ INSERTCH# THLEN _ LEN THFIRSTPIECE _ PCLST)) (* ;  "Remember that we did this, so it can be undone.") (replace (TEXTOBJ TEXTLEN) of STREAM with (IPLUS TEXTLEN LEN)) (* ;  "Inserting the pieces didn't fix up things like the length of the document, so do it now.") (AND (fetch (TEXTOBJ \WINDOW) of STREAM) (\FIXILINES STREAM SEL INSERTCH# LEN TEXTLEN)) (* ; "Mark any changed lines dirty.") (replace (SELECTION CHLIM) of SEL with (IPLUS (replace (SELECTION CH#) of SEL with INSERTCH# ) LEN)) (* ;  "Now fix up the selection to be the included text, point_left, character selection grain.") (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0) (replace (SELECTION POINT) of SEL with 'RIGHT) (* ;  "So that several things INCLUDED in sequence fall in sequence.") (replace (SELECTION SELKIND) of SEL with 'CHAR) (replace (SELECTION SELOBJ) of SEL with NIL) (COND ((fetch (TEXTOBJ \WINDOW) of STREAM)(* ;  "We're displaying; update the display and the selection's line references") (TEDIT.UPDATE.SCREEN STREAM) (\FIXSEL SEL STREAM) (\SHOWSEL SEL NIL T))) (replace (TEXTOBJ \DIRTY) of STREAM with T) (* ; "Mark the document changed") (\SETUPGETCH (IPLUS -1 INSERTCH# LEN) STREAM) (* ;  "Set the fileptr to the end of the insertion.") T) (T (TEDIT.PROMPTPRINT STREAM "Please choose the place for the INCLUDE first." T]) (TEDIT.RAW.INCLUDE [LAMBDA (STREAM INFILE START END) (* ; "Edited 11-Jun-99 15:05 by rmk:") (* ; "Edited 11-Jun-99 15:05 by rmk:") (* ; "Edited 11-Jun-99 14:49 by rmk:") (* ; "Edited 11-Jun-99 14:41 by rmk:") (* ;  "Edited 27-May-93 16:36 by sybalsky:mv:envos") (* ;; "takes a text stream and an OPEN stream to include. Note: Start and End are inclusive ptrs, unlike in copybytes and friends") (* ;;  "no interpretation (alternate file type e.g. Bravo) takes place. Simply include the characters") (* ;; "Default character and paragraph looks are applied") (LET* ((TEXTOBJ (TEXTOBJ STREAM)) (START START) (END END) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) [HOLDING.FILE (OR (fetch (TEXTOBJ TXTRAWINCLUDESTREAM) of TEXTOBJ) (replace (TEXTOBJ TXTRAWINCLUDESTREAM) of TEXTOBJ with (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] PCTB TEXTLEN INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN HOLDSTART HOLDLEN START-OF-PIECE ) (COND ((NOT (fetch (SELECTION SET) of SEL)) (SHOULDNT "\TEDIT.RAW.INCLUDE called with no selection set")) ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) (* ; "Not allowed to change it.") NIL) (T (* ;  "There is a place to do the include.") (\SHOWSEL SEL NIL NIL) (* ;  "Turn any pre-existing selection off") (COND (END (* ;; "This is the copy-part-of-a-file case, with file liable to be volatile. Copy it to core for protection") [SETQ INFILE (COND ((OPENP INFILE) (SETQ WASOPEN T) INFILE) (T (OPENSTREAM INFILE 'INPUT NIL '((TYPE TEXT] (* ;  "And copy the file-section into it.") (SETFILEPTR HOLDING.FILE (SETQ HOLDSTART (GETEOFPTR HOLDING.FILE))) (* ;  "Move to the end of the pre-existing part of the file.") (COPYBYTES INFILE HOLDING.FILE START END) (* ;  "must be copychars to respect eol conventions") (SETQ HOLDLEN (IDIFFERENCE (OR END (GETEOFPTR INFILE)) START)) (COND ((NOT WASOPEN) (* ;  "Close the input file if it wasn't open when we got here.") (CLOSEF INFILE))) (SETQ INFILE HOLDING.FILE) (SETQ START (SETQ END NIL)) (* ; "Then pretend nothing happened.") )) (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (SETQ INSERTCH# (TEDIT.GETPOINT NIL SEL)) (* ;  "Find the place to make the insertion.") (SETQ INSPC (OR (\CHTOPC INSERTCH# PCTB T) (LASTPIECE PCTB))) (* ;  "The piece to make the insertion in") [COND ((NEQ INSPC 'LASTPIECE) (COND ((IGREATERP INSERTCH# START-OF-PIECE) (* ; "Must split the piece.") (SETQ INSPC (\SPLITPIECE INSPC (- INSERTCH# START-OF-PIECE) TEXTOBJ INSPC#)) (add INSPC# 1) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (* ;  "Refresh the PCTB in case it grew.") ] (SETQ PCLST (create PIECE PFILE _ INFILE PFPOS _ (OR HOLDSTART START 0) PLEN _ [OR HOLDLEN (IDIFFERENCE [COND (END END) (T (* ; "get the eof pointer") (COND ((OPENP INFILE) (GETEOFPTR INFILE)) (T [OPENSTREAM INFILE 'INPUT NIL '((TYPE TEXT] (PROG1 (GETEOFPTR INFILE) (CLOSEF INFILE] (COND (START START) (T 0] PREVPIECE _ NIL NEXTPIECE _ NIL PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT) TEXTOBJ) PPARALAST _ NIL PPARALOOKS _ (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC)) ) (SETQ LEN (fetch (PIECE PLEN) of PCLST)) (\TEDIT.INSERT.PIECES TEXTOBJ INSERTCH# PCLST LEN INSPC INSPC# NIL) (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS TEXTLEN LEN)) (AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (\FIXILINES TEXTOBJ SEL INSERTCH# LEN TEXTLEN)) (replace (SELECTION CHLIM) of SEL with (IPLUS (replace (SELECTION CH#) of SEL with INSERTCH#) LEN)) (* ;  "Now fix up the selection to be the included text, point_left, character selection grain.") (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0) (replace (SELECTION POINT) of SEL with 'RIGHT) (* ;  "So that several things INCLUDED in sequence fall in sequence.") (replace (SELECTION SELKIND) of SEL with 'CHAR) (replace (SELECTION SELOBJ) of SEL with NIL) (COND ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (TEDIT.UPDATE.SCREEN TEXTOBJ) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) (* ; "Mark the document changed") (\SETUPGETCH (create EDITMARK PC _ INSPC PCOFF _ 0 PCNO _ NIL) TEXTOBJ) (* ;  "Set the fileptr to the end of the insertion.") T]) ) (* ;; "PUTting a file:") (DEFINEQ (TEDIT.PUT [LAMBDA (STREAM FILE FORCENEW UNFORMATTED? OLDFORMAT?) (* ; "Edited 21-Jun-99 19:02 by rmk:") (* ; "Edited 21-Jun-99 18:58 by rmk:") (* ; "Edited 11-Jun-99 15:05 by rmk:") (* ; "Edited 19-Apr-93 13:04 by jds") (* ;; "If the guy was editing a file, make a new updated version; else, ask for a file name") (* ;; "If FILE is specd, it's used; else the user must give us one") (* ;; "Returns an open stream on the file you PUT to.") (PROG ((TEXTOBJ (TEXTOBJ STREAM)) (TEDIT.PUT.FINISHEDFORMS NIL) (TEDIT.GET.FINISHEDFORMS NIL) (OUTPUT.FILE.WRITTEN NIL) OCURSOR OFILE FONTFILEUSED PROPS WINDOW PUTFN CACHE MENUSTREAM FILENAME TITLE CH#S PC) [COND (FILE (* ; "We were given a file to use.") (SETQ OFILE FILE)) [FORCENEW (* ;  "He insists on a new file. (without giving us one NIL)") (SETQ OFILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to PUT to: "] (T (* ; "Get a file to put the text into") (SETQ OFILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to PUT to: " (\TEXTSTREAM.FILENAME TEXTOBJ] (SETQ PUTFN (TEXTPROP TEXTOBJ 'PUTFN)) (SETQ CACHE (TEXTPROP TEXTOBJ 'CACHE)) (COND ((NOT OFILE) (* ;  "There's no file to put to; don't bother.") (RETURN)) ((AND PUTFN (EQ (APPLY* PUTFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (FULLNAME OFILE) 'BEFORE) 'DON'T)) (* ;  "He doesn't want this document put. Bail out.") (RETURN))) (RESETLST [RESETSAVE [SETQ OFILE (OPENSTREAM OFILE 'OUTPUT 'NEW (COND [UNFORMATTED? (* ;  "If the user forced no formatting, respect his wish.") '((TYPE TEXT] [(TEDIT.FORMATTEDFILEP TEXTOBJ) (* ;  "If this file has objects, para looks, or font changes, then we need a binary file.") '((TYPE BINARY] [(AND NIL (EQL (U-CASE (FILENAMEFIELD OFILE 'EXTENSION)) 'TEDIT)) (* ; "If file extension is TEDIT, then we presume that it really is a tedit file, thus making it a binary file. BUT: rmk we really prefer TYPE TEXT even for a file with extension tedit.") '((TYPE BINARY] (T (* ;  "Otherwise, we can get by with a text file") '((TYPE TEXT] '(AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE] [RESETSAVE (\TEDIT.PUTRESET (CONS (THIS.PROCESS) 'DON'T] (replace DESC of (fetch (TEXTOBJ THISLINE) of TEXTOBJ) with NIL) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "PUTting file " (fetch (STREAM FULLNAME) of OFILE) "...") T) [COND ((IGREATERP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 0) (SETQ FONTFILEUSED (COND (OLDFORMAT? (TEDIT.PUT.PCTB2 TEXTOBJ OFILE UNFORMATTED?)) (T (TEDIT.PUT.PCTB TEXTOBJ OFILE UNFORMATTED?] (CLOSEF OFILE) (* ;  "Close the file, to free it up. And re-open it for INPUT only") [COND ((NOT CACHE) (* ;  "CSLI if caching do not need to reopen the output file anyway") (* ;; "Declare as type text, even if it hasn't been specified as a binary file--could simply be an unformatted stream.") (SETQ OFILE (OPENSTREAM (fetch (STREAM FULLFILENAME) of OFILE) 'INPUT NIL '((TYPE TEXT](* ;  "changed TEMPORary for ns filing with caching. may not work in general") (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) (* ; "Close the old text file") (replace (TEXTOBJ TXTFILE) of TEXTOBJ with OFILE) (* ;  "And remember the new one for next time.") (* ;  "We can safely QUIT now without losing anything.") (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL)) (SETQ CH#S (REVERSE (CDR FONTFILEUSED))) (* ;  "The true filepos's of the pieces in the output file.") [COND ((AND (NOT CACHE) (RANDACCESSP OFILE) (EQ CR.EOLC (fetch (STREAM EOLCONVENTION) of OFILE))) (* ;; "If we've cached this file, DON'T go thru and fill in the real file's location, because the EOL convention may well be wrong.") (* ;; "(SETQ PC (ELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset)))") (UNINTERRUPTABLY (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ)) 0)) (while (AND PC CH#S) do (* ;;  "Run thru the pieces in the PCTB, pointing them to the new file and their new locations.") (COND ((fetch (PIECE POBJ) of PC)) (T (replace (PIECE PFPOS) of PC with (pop CH#S)) (CLOSEF? (fetch (PIECE PFILE) of PC)) (* ;  "If this is a piece on an open file, close it, since we're never going to read from it again.") (replace (PIECE PFILE) of PC with OFILE) (replace (PIECE PSTR) of PC with NIL))) (SETQ PC (fetch (PIECE NEXTPIECE) of PC))))] (TEDIT.PROMPTPRINT TEXTOBJ "done.") (* ; "Tell him we're finished.") (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ)) (* ; "find and set the title") (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL)) (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ)) (COND ((AND MENUSTREAM (type? LITATOM TITLE)) (* ;  "if we have a filename then put it in the GET and PUT fields of the menu") (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE)) (MBUTTON.SET.FIELD MENUSTREAM 'Get FILENAME) (MBUTTON.SET.FIELD MENUSTREAM 'Put FILENAME))) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ; "Make sure any new insertions happen for real, and not as appends. Since all the pieces now point to the file rather than the strings.") (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with NIL) (* ;; "make sure that TEDIT doesn't try to just add to the \INSERTPC since it will now have a pfile property") (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Put THCH# _ 0 THLEN _ 0 THFIRSTPIECE _ NIL)) (* ; "Remember we did this.") (AND PUTFN (APPLY* PUTFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (fetch (STREAM FULLNAME) of (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) 'AFTER)) (* ;  "CSLI changed to not presume ofile is the txtfile anymore") (RETURN OFILE]) (TEDIT.PUT.PCTB [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT) (* ; "Edited 11-Jun-99 15:55 by rmk:") (* ; "Edited 19-May-99 21:58 by rmk:") (* ;  "Edited 27-May-93 16:00 by sybalsky:mv:envos") (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks. UNFORMATTED? means write no font or formatting info.") (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) (*READTABLE* *TEDIT-FILE-READTABLE*) (*PRINT-BASE* 10) OLDCH# CURCH# PREVPC FONTFILE (PCCOUNT 0) TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL) (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) (PARALOOKSSEEN NIL) (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ)) (CACHE (TEXTPROP TEXTOBJ 'CACHE)) CH#S PREVFATP PARAHASH LOOKSHASH PREVPREVPC) (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP) (* ;  "Prevent spurious carriage-returns in the piece descriptions.") (* ;; "(SETQ PC (\EDITELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset)))") (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ)) 0)) (* ; "First piece in the document") (SETQ OLDLOOKS (OR (AND (type? PIECE PC) (fetch (PIECE PLOOKS) of PC)) (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) TEDIT.DEFAULT.CHARLOOKS)) (* ; "Starting looks") (COND ((NEQ (fetch (STREAM EOLCONVENTION) of OFILE) CR.EOLC) (* ;  "This file is on a non-CR host; make a note to cache it") (SETQ TRUEFILE OFILE) (* ;  "Remember where the file should wind up.") [SETQ OFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "And open a temp file to write it to.") (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP) (* ;  "Prevent spurious carriage-returns in the piece descriptions.") )) [SETQ CURCH# (SETQ OLDCH# (ADD1 (GETFILEPTR OFILE] (COND ((fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) (* ;  "There is layout info for this file. Save it") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (TEDIT.PUT.PAGEFRAMES FONTFILE (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)) (add PCCOUNT 1))) (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC) (* ;  "Run thru the lists of char & para looks and remove any that aren't in use") (COND ([AND (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ) (OR (IGREATERP (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) 1) (NOT (EQFMTSPEC (CAR (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) TEDIT.DEFAULT.FMTSPEC] (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (SETQ PARAHASH (\TEDIT.PUT.PARALOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ))) (SETQ PARALOOKSSEEN T))) [COND ((OR PARALOOKSSEEN FORMATTINGLEVEL) (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] [while PC do (COND ([AND (NOT (ZEROP (fetch (PIECE PLEN) of PC))) (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ ] (* ;  "The last piece ended a paragraph, so send out new para looks") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (COND ((NEQ CURCH# OLDCH#) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (\TEDIT.PUT.PARALOOKS FONTFILE PC PARAHASH) (SETQ PARALOOKSSEEN T) (* ;  "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries") (add PCCOUNT 1))) (COND [(fetch (PIECE POBJ) of PC) (* ;  "It's an object -- go use its PUTFN") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (COND ((AND (NEQ CURCH# OLDCH#) PREVPC) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (* ;  "If the prior thing was text, send along its descriptor.") (* ; "Send out the object") (IF UNFORMATTED? THEN (CL:WHEN (AND PREVPC (fetch (PIECE PFATP) of PREVPC)) (* ;; "Last piece was FAT, but object doesn't know that. Start it out thin. The stream must also be thin after the PRIN1 of the object's preprint string. Setting PREVPC to NIL means that no comparisons will be done (which asserts THIN among other things), but that's OK because we aren't doing formatting anyway.") (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 2) (SETQ PREVPC NIL)) (LET [(FN (IMAGEOBJPROP (fetch (PIECE POBJ) of PC) 'PREPRINTFN] (PRIN1 (IF FN THEN (PROG1 (APPLY* FN (fetch (PIECE POBJ) of PC)) (* ;; "Insure thin") (CHARSET OFILE 0)) ELSE "[UNPRINTABLE OBJECT]") OFILE) (add CURCH# 1 (IDIFFERENCE (GETEOFPTR OFILE) CURCH#))) ELSE (add CURCH# (TEDIT.PUT.OBJECT PC OFILE FONTFILE CURCH#))) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (COND ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (NEQ (fetch (PIECE PFATP) of PC) (AND PREVPC (fetch (PIECE PFATP) of PREVPC))) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ;  "The OBJECT has different ooks from before") (\BOUT FONTFILE 1) (\TEDIT.PUT.SINGLE.CHARLOOKS FONTFILE (fetch (PIECE PLOOKS) of PC)) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (T (* ;  "No differences. Don't write any charlooks, and mark that fact") (\BOUT FONTFILE 0) (* ;  "MAKE BLOODY SURE THAT THE NEXT RUN OF CHARACTERS GETS ITS OWN LOOKS") ] ((NOT (ZEROP (fetch (PIECE PLEN) of PC))) (* ; "It's not an object.") (* ;; "For 0-length pieces, don't even acknowledge their existence!!") (* ;; "So only do this processing if there's text in the piece.") [COND ([OR [NEQ (fetch (PIECE PFATP) of PC) (SETQ PREVFATP (AND PREVPC (fetch (PIECE PFATP) of PREVPC ] (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ; "We have a piece with new looks.") (* ;  "The PREVFATP clause needs to come first, so that PREVFATP gets set for later use.") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (COND ((NOT (IEQP OLDCH# CURCH#)) (* ;  "If there were looks past, and if the run was not empty, save a piece for its looks") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1))) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC)) (SETQ OLDCH# CURCH#) (COND [PREVFATP (COND ((fetch (PIECE PFATP) of PC)) (T (* ; "Switching from FAT to thin") (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 2] ((fetch (PIECE PFATP) of PC) (* ; "Switching from thin to fat") (BOUT OFILE 255) (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 3] (* ;  "Now dump out the non-object contents of the piece.") [COND [(SETQ PFILE (fetch (PIECE PFILE) of PC)) (* ; "It's on a file. Copy it.") [OR (OPENP PFILE) (replace (PIECE PFILE) of PC with (SETQ PFILE (\TEDIT.REOPEN.STREAM TEXTOBJ PFILE] (* ; "Make sure the file is open.") (COPYBYTES PFILE OFILE (fetch (PIECE PFPOS) of PC) (IPLUS (fetch (PIECE PFPOS) of PC) (COND ((fetch (PIECE PFATP) of PC) (* ;  "For fat file pieces, copy twice as many bytes as characters.") (UNFOLD (fetch (PIECE PLEN) of PC) 2)) (T (fetch (PIECE PLEN) of PC] ((SETQ PSTR (fetch (PIECE PSTR) of PC)) (* ;  "It's in a string. Just print it.") (COND [(fetch (PIECE PFATP) of PC) (* ;  "The string is fat: Copy twice as many bytes as chars.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE (\CHARSET CH)) (\BOUT OFILE (\CHAR8CODE CH] (T (* ;  "The string is thin. Just copy it to the file.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE CH] [COND ((AND (NOT CACHE) (RANDACCESSP OFILE)) (* ; "CSLI leave the pieces and the pctb alone and just write the file if its cached or not randomaccess") (push CH#S (SUB1 CURCH#] [COND ((fetch (PIECE PFATP) of PC) (add CURCH# (UNFOLD (fetch (PIECE PLEN) of PC) 2))) (T (add CURCH# (fetch (PIECE PLEN) of PC] (* ;  "Keep running track of where in the file we are.") )) (COND ((NOT (ZEROP (fetch (PIECE PLEN) of PC))) (* ;; "Only remember this piece if it's not zero-length!") (SETQ PREVPREVPC PREVPC) (SETQ PREVPC PC))) (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (* ;  "Put out a piece describing the last characters in the file.") (COND ((AND FONTFILE (NEQ OLDCH# CURCH#)) (* ;  "Only if there WERE characters, and only if there's a need for font information") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVPREVPC) (* ;  "Put out a description of the characters") (add PCCOUNT 1))) (COND ((AND PARALOOKSSEEN (fetch (PIECE PPARALAST) of PREVPC)) (* ;  "The last piece contained the end of a paragraph. Make sure it gets noted.") (\TEDIT.PUT.PARALOOKS FONTFILE PREVPC PARAHASH) (* ;; "Write out a dummy paragraph-looks piece, so that we protect the PPARALAST of the final piece in the document.") (\DWOUT FONTFILE 0) (\SMALLPOUT FONTFILE \PieceDescriptorPARA) (\SMALLPOUT FONTFILE 1) (* ;; "This adds a total of 2 pieces to the file:") (add PCCOUNT 2] (for FORM in TEDIT.PUT.FINISHEDFORMS do (EVAL FORM)) (* ; "Do any user-specific cleanup") (COND (TRUEFILE (* ;  "This file needs to be converted to the right convention") (COND ((AND FONTFILE (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;  "Formatted file: Copy without converting.") (COPYBYTES OFILE TRUEFILE 0 -1)) (T (* ;  "Go ahead and convert the EOLCONVENTION, this is a plain-text file") (COPYCHARS OFILE TRUEFILE 0 -1))) (SETQ OFILE TRUEFILE))) [COND ((AND (OPENP OFILE) FONTFILE) (* ; "We need to write format info.") (\DWOUT FONTFILE (GETFILEPTR OFILE)) (* ;  "So remember the end of the plain-text part of the file") (\SMALLPOUT FONTFILE PCCOUNT) (* ;  "# OF PIECES WE'' NEED TO RECONSTRUCT THIS FILE") (\SMALLPOUT FONTFILE 31418) (* ;  "Now the password for NEW format files: 31416") (COND ((AND (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;; "Only write fmtg info at the end if we want it there--not if we want plain text or want it kept separate.") (COPYBYTES FONTFILE OFILE 0 (GETEOFPTR FONTFILE)) (* ;  "Copy the font information to the file trailer") ) (T)) (CLOSEF FONTFILE) (COND ((NOT SEPARATEFORMAT) (* ;  "Unless we want the formatting info separately, delete the file") (* ;  "(since FONTFILE is a stream, we should not need to delete it at all) (DELFILE FONTFILE)") ] (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS ) of TEXTOBJ) TEXTOBJ)) (* ;  "Re-add the default and caret looks's to the lists, since they may not have been really saved.") (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ)) (replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) TEXTOBJ)) (RETURN (CONS (COND (UNFORMATTED? NIL) (T FONTFILE)) CH#S]) (\TEDIT.PUTRESET - [LAMBDA (PROC&VALUE) (* jds "15-May-85 16:38") - (CONS (CAR PROC&VALUE) - (PROCESSPROP (CAR PROC&VALUE) - 'BEFOREEXIT - (CDR PROC&VALUE]) (TEDIT.PUT.PIECE.DESCRIPTOR - [LAMBDA (FILE CH1 CHLIM LOOKS) (* ; "Edited 30-May-91 20:25 by jds") - (* Put a description of LOOKS into - FILE. LOOKS apply to characters CH1 - thru CHLIM-1) - (* (PROG ((FONT (fetch - (CHARLOOKS CLFONT) of LOOKS)) STR) - (SETQ STR (CONCAT "(FONTCREATE " - (KWOTE (FONTPROP FONT - (QUOTE FAMILY))) " " - (FONTPROP FONT (QUOTE SIZE)) " " - (KWOTE (FONTPROP FONT - (QUOTE FACE))) " )")) - (\DWOUT FILE (IDIFFERENCE CHLIM CH1)) - (* The length of this run of looks) - (\SMALLPOUT FILE (NCHARS STR)) - (* The length of the description - which follows) (PRIN1 STR FILE) - (* Print the form which can EVAL to - re-create the font information) - (\BOUT FILE (LOGOR - (COND ((fetch (CHARLOOKS CLPROTECTED) - of LOOKS) 8) (T 0)) (COND ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) NIL 4) (T 0)) - (COND ((fetch (CHARLOOKS CLSELHERE) - of LOOKS) 2) (T 0)) - (COND ((fetch (CHARLOOKS CLCANCOPY) - of LOOKS) 1) (T 0)))))) - (HELP]) (\ARBOUT - [LAMBDA (STREAM ITEM) (* ; "Edited 20-Apr-88 19:55 by jds") - (* ; - "Write an arbitrary MKSTRING-able thing in length-contents form.") - (LET ((SIZE (AND ITEM (NCHARS ITEM T *TEDIT-FILE-READTABLE*))) - (FPTR) - (END-FPTR)) - (\SMALLPOUT STREAM (OR SIZE 0)) - (SETQ FPTR (GETFILEPTR STREAM)) - (OR (NOT ITEM) - (ZEROP SIZE) - (PRIN2 ITEM STREAM *TEDIT-FILE-READTABLE*)) - (* ;; "Because of NS chars, you gotta back up and really count bytes.") - (* (SETQ END-FPTR (GETFILEPTR STREAM)) - (SETFILEPTR STREAM FPTR) - (\SMALLPOUT STREAM - (- - END-FPTR FPTR)) (SETFILEPTR STREAM - END-FPTR)) - NIL]) (\ATMOUT - [LAMBDA (STREAM ATOM) (* jds "30-Jan-85 14:46") - (* Write an atom's characters in - length-contents form.) - (\SMALLPOUT STREAM (COND - (ATOM (NCHARS ATOM)) - (T 0))) - (OR (NOT ATOM) - (ZEROP (NCHARS ATOM)) - (for CH inatom ATOM do (\BOUT STREAM CH]) (\DWOUT - [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]) (\STRINGOUT - [LAMBDA (STREAM STRING LEN) (* jds " 1-May-84 11:58") - - (* Write a string on a file in length-contents form; - one word for the length, and one byte per character contained.) - - (SETQ LEN (OR LEN (NCHARS STRING))) - (\SMALLPOUT STREAM LEN) - (OR (ZEROP LEN) - (for CH instring STRING as I from 1 to LEN do (\BOUT STREAM CH]) (\TEDIT-OPEN-FONT-FILE - [LAMBDA (EXISTING-FONTFILE-IF-ANY) (* ; "Edited 23-Sep-87 12:31 by jds") - - (* ;; " Open a font-information file for TEDIT PUT operation, if one doesn't exist already. Also set its linelength to effective infinity, so that we don't get spurious CRs in the middle of formatting info.") - - (* ;; - "The calling form must be (SETQ FOO (\TEDIT-OPEN-FONT-FILE FOO)), to preserve information.") - - (COND - ((NOT EXISTING-FONTFILE-IF-ANY) (* ; - "Create the font-info file if it doesn't exist yet") - - (SETQ EXISTING-FONTFILE-IF-ANY (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) - (replace (STREAM LINELENGTH) of EXISTING-FONTFILE-IF-ANY with MAX.SMALLP) - (* ; - "Prevent spurious carriage-returns in the piece descriptions.") - - )) - EXISTING-FONTFILE-IF-ANY]) ) (DEFINEQ (\TEDIT.GET.CHARLOOKS.LIST - [LAMBDA (FILE) (* jds "28-Jan-85 17:50") - (* Read the list of CHARLOOKSs from - the file.) - (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.CHARLOOKS FILE]) (\TEDIT.GET.SINGLE.CHARLOOKS - [LAMBDA (FILE) (* ; "Edited 30-May-91 20:25 by jds") - (* Read a set of CHARLOOKS from FILE) - (PROG* ((LOOKS (create CHARLOOKS)) - (FILEPOS (GETFILEPTR FILE)) - (LOOKSLEN (\SMALLPIN FILE)) - FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR) - (SETQ NAME (\ARBIN FILE)) (* The font name) - (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) - (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) - (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE) - 0)) - (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE)) - (SETQ PROPS (\SMALLPIN FILE)) - (with CHARLOOKS LOOKS [SETQ CLLEADER (NOT (ZEROP (LOGAND 2048 PROPS] - [SETQ CLINVERTED (NOT (ZEROP (LOGAND 1024 PROPS] - [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] - [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] - [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] - [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] - [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] - [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] - [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] - [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] - [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] - [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] - (SETQ CLSIZE SIZE) - (SETQ CLOFFSET SUPER)) - [replace (CHARLOOKS CLFONT) of LOOKS - with (COND - ((LISTP NAME) (* This was a font class. - Restore it.) - (FONTCLASS (pop NAME) - NAME)) - ((AND NAME (NOT (ZEROP SIZE))) - (FONTCREATE NAME SIZE (COND - ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) - (fetch (CHARLOOKS CLITAL) of LOOKS) - ) - 'BOLDITALIC) - ((fetch (CHARLOOKS CLBOLD) of LOOKS) - 'BOLD) - ((fetch (CHARLOOKS CLITAL) of LOOKS) - 'ITALIC] - (SETFILEPTR FILE (IPLUS FILEPOS LOOKSLEN)) - (RETURN LOOKS]) (\TEDIT.PUT.CHARLOOKS.LIST - [LAMBDA (FILE LOOKSLIST) (* jds " 5-Mar-85 15:58") - (* Write the list of CHARLOOKSs into - the font file.) - - (* Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' - position in the list we wrote on the file. - Those position numbers are then written in the individual looks descriptions, - and are used to reconstruct the piece looks when the file is read back in.) - - (PROG ((LOOKSHASH (HASHARRAY 50))) - (\DWOUT FILE 0) (* No characters are described by this - pseudo-piece entry.) - (\SMALLPOUT FILE \PieceDescriptorCHARLOOKSLIST) (* Mark it as containing the list of - CHARLOOKSs) - (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) (* How many CHARLOOKSs there are in - the list) - (for I from 1 as LOOKS in LOOKSLIST do - - (* Write each charlooks, in the order they appear in the list.) - - (\TEDIT.PUT.SINGLE.CHARLOOKS FILE LOOKS) - (* Write out the description) - (PUTHASH LOOKS I LOOKSHASH) - - (* And save it in the hash table so people can find its index.) -) - (RETURN LOOKSHASH]) (\TEDIT.PUT.SINGLE.CHARLOOKS - [LAMBDA (FILE LOOKS) (* ; "Edited 30-May-91 20:26 by jds") - (* Put out a single CHARLOOKS - description.) - (PROG ((FILEPOS (GETFILEPTR FILE)) - (FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) - STR LEN) - (\SMALLPOUT FILE 0) (* Reserve space for the length of - this looks) - [COND - ((type? FONTCLASS FONT) (* For font classes, we need to save - a list of device-FD sets) - (\ARBOUT FILE (FONTCLASSUNPARSE FONT))) - (T (* For FONTDESCRIPTORs, do it the - easy way) - (\ATMOUT FILE (FONTPROP FONT 'FAMILY] (* The font family) - (\SMALLPOUT FILE (OR (FONTPROP FONT 'SIZE) - 0)) (* Size of the type, in points) - (\SMALLPOUT FILE (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS) - 0)) (* Super/subscripting distance) - (COND - ([AND (fetch (CHARLOOKS CLSTYLE) of LOOKS) - (NOT (ZEROP (fetch (CHARLOOKS CLSTYLE) of LOOKS] - (\ARBOUT FILE (fetch (CHARLOOKS CLSTYLE) of LOOKS))) - (T (\SMALLPOUT FILE 0))) - (COND - ((fetch (CHARLOOKS CLUSERINFO) of LOOKS) - (\ARBOUT FILE (fetch (CHARLOOKS CLUSERINFO) of LOOKS))) - (T (\SMALLPOUT FILE 0))) - [\SMALLPOUT FILE (LOGOR (COND - ((fetch (CHARLOOKS CLLEADER) of LOOKS) - (* Dotted-leader; relevant only to - TABs) - 2048) - (T 0)) - (COND - ((fetch (CHARLOOKS CLINVERTED) of LOOKS) - (* Inverse-video) - 1024) - (T 0)) - (COND - ((fetch (CHARLOOKS CLBOLD) of LOOKS) - 512) - (T 0)) - (COND - ((fetch (CHARLOOKS CLITAL) of LOOKS) - 256) - (T 0)) - (COND - ((fetch (CHARLOOKS CLULINE) of LOOKS) - 128) - (T 0)) - (COND - ((fetch (CHARLOOKS CLOLINE) of LOOKS) - 64) - (T 0)) - (COND - ((fetch (CHARLOOKS CLSTRIKE) of LOOKS) - 32) - (T 0)) - (COND - ((fetch (CHARLOOKS CLSMALLCAP) of LOOKS) - 16) - (T 0)) - (COND - ((fetch (CHARLOOKS CLPROTECTED) of LOOKS) - 8) - (T 0)) - (COND - ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) - NIL 4) - (T 0)) - (COND - ((fetch (CHARLOOKS CLSELHERE) of LOOKS) - 2) - (T 0)) - (COND - ((fetch (CHARLOOKS CLCANCOPY) of LOOKS) - 1) - (T 0] - - (* * Now go fill in the length field at the front of the LOOKS. - (ALL looks info should be written out BEFORE this comment.)) - - (SETQ LEN (IDIFFERENCE (GETFILEPTR FILE) - FILEPOS)) (* The length of this set of looks) - (SETFILEPTR FILE FILEPOS) (* Go write the length field) - (\SMALLPOUT FILE LEN) - (SETFILEPTR FILE -1) (* And back to the end of the file) - ]) ) (DEFINEQ (\TEDIT.GET.PARALOOKS.LIST - [LAMBDA (FILE TEXTOBJ) (* jds "13-Jun-85 11:14") - (* Read the list of CHARLOOKSs from - the file.) - (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.PARALOOKS FILE TEXTOBJ]) (\TEDIT.GET.SINGLE.PARALOOKS - [LAMBDA (FILE TEXTOBJ) (* ; - "Edited 2-Jul-93 21:31 by sybalskY:MV:ENVOS") - (* ; - "Read a paragraph format spec from the FILE, and return it for later use.") - (PROG ((LOOKS (create FMTSPEC)) - (FILEPOS (GETFILEPTR FILE)) - (LOOKSLEN (\SMALLPIN FILE)) - TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC TABTYPE QUAD) - (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* ; - "Left margin for the first line of the paragraph") - (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* ; - "Left margin for the rest of the paragraph") - (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) - (* ; "Right margin for the paragraph") - (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) - (* ; "Leading before the paragraph") - (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) - (* ; "Lead after the paragraph") - (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) - (* ; "inter-line leading") - (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) - (* ; "Will be tab specs") - (SETQ TABFLG (\BIN FILE)) - (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (SETQ QUAD (\BIN FILE)) - (1 'LEFT) - (2 'RIGHT) - (3 'CENTERED) - (4 'JUSTIFIED) - (SHOULDNT))) - (COND - ((NOT (ZEROP (LOGAND TABFLG 1))) (* ; "There are tabs to read") - (SETQ DEFAULTTAB (\SMALLPIN FILE)) - (SETQ TABCOUNT (\BIN FILE)) - [SETQ TABS (for TAB# from 1 to TABCOUNT - collect (create TAB - TABX _ (\SMALLPIN FILE) - TABKIND _ (SELECTQ (SETQ TABTYPE (\BIN FILE)) - (0 'LEFT) - (1 'RIGHT) - (2 'CENTERED) - (3 'DECIMAL) - (4 'DOTTEDLEFT) - (5 'DOTTEDRIGHT) - (6 'DOTTEDCENTERED) - (7 'DOTTEDDECIMAL) - (SHOULDNT] - (OR (ZEROP DEFAULTTAB) - (RPLACA TABSPEC DEFAULTTAB)) - (RPLACD TABSPEC TABS))) - [COND - ((NOT (ZEROP (LOGAND TABFLG 2))) (* ; - "There are other paragraph parameters to be read.") - (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE)) - (* ; - "Special X location on page for this paragraph") - (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE)) - (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE)) - (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE)) - (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTHEADINGKEEP) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTKEEP) of LOOKS with (\ARBIN FILE)) - [COND - ((ILESSP (GETFILEPTR FILE) - (IPLUS FILEPOS LOOKSLEN)) - (replace (FMTSPEC FMTBASETOBASE) of LOOKS with (\ARBIN FILE] - [COND - ((ILESSP (GETFILEPTR FILE) - (IPLUS FILEPOS LOOKSLEN)) - (replace (FMTSPEC FMTREVISED) of LOOKS with (\ARBIN FILE] - [COND - ((ILESSP (GETFILEPTR FILE) - (IPLUS FILEPOS LOOKSLEN)) - (replace (FMTSPEC FMTCOLUMN) of LOOKS with (\ARBIN FILE] - (COND - ((ILESSP (GETFILEPTR FILE) - (IPLUS FILEPOS LOOKSLEN)) - (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE] - [COND - ((ILESSP (GETFILEPTR FILE) - (IPLUS FILEPOS LOOKSLEN)) (* ; - "There is more PARALOOKS info in this piece -- we probably lost data.") - (TEDIT.PROMPTPRINT TEXTOBJ "WARNING: Newer file version; you lost PARALOOKS info" T) - (SETFILEPTR FILE (IPLUS FILEPOS LOOKSLEN] - (RETURN LOOKS]) (\TEDIT.PUT.PARALOOKS.LIST - [LAMBDA (FILE LOOKSLIST) (* ; "Edited 1-Sep-87 20:34 by jds") - (* ; - "Write the list of FMTSPECs into the font file.") - - (PROG ((LOOKSHASH (HASHARRAY 50))) - (\DWOUT FILE 0) - (\SMALLPOUT FILE \PieceDescriptorPARALOOKSLIST) - (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) - (for I from 1 as LOOKS in LOOKSLIST do (\TEDIT.PUT.SINGLE.PARALOOKS FILE LOOKS) - (* ; "Write out the description") - - (PUTHASH LOOKS I LOOKSHASH) - (* ; - "And save it in the hash table so people can find its index.") -) - (RETURN LOOKSHASH]) (\TEDIT.PUT.SINGLE.PARALOOKS - [LAMBDA (FILE LOOKS) (* ; - "Edited 2-Jul-93 21:30 by sybalskY:MV:ENVOS") - - (* ;; "Put a description of LOOKS into FILE.") - - (PROG ((FILEPOS (GETFILEPTR FILE)) - DEFAULTTAB TABSPECS OUTPUTFORMAT LEN) - (\SMALLPOUT FILE 0) (* ; - "Reserve space for the length of this looks") - (\SMALLPOUT FILE (fetch (FMTSPEC 1STLEFTMAR) of LOOKS)) - (* ; - "Left margin for the first line of the paragraph") - (\SMALLPOUT FILE (fetch (FMTSPEC LEFTMAR) of LOOKS)) - (* ; - "Left margin for the rest of the paragraph") - (\SMALLPOUT FILE (fetch (FMTSPEC RIGHTMAR) of LOOKS)) - (* ; "Right margin for the paragraph") - (\SMALLPOUT FILE (fetch (FMTSPEC LEADBEFORE) of LOOKS)) - (* ; "Leading before the paragraph") - (\SMALLPOUT FILE (fetch (FMTSPEC LEADAFTER) of LOOKS)) - (* ; "Lead after the paragraph") - (\SMALLPOUT FILE (fetch (FMTSPEC LINELEAD) of LOOKS)) - (* ; "inter-line leading") - (SETQ DEFAULTTAB (CAR (fetch (FMTSPEC TABSPEC) of LOOKS))) - (SETQ TABSPECS (CDR (fetch (FMTSPEC TABSPEC) of LOOKS))) - (COND - ((AND (fetch (FMTSPEC TABSPEC) of LOOKS) - (OR DEFAULTTAB TABSPECS)) (* ; - "There are tab specs to save, or there is a default tab setting to save") - (\BOUT FILE 3)) - (T (* ; - "There are no tab looks. Just let him go.") - (\BOUT FILE 2))) - (\BOUT FILE (SELECTQ (fetch (FMTSPEC QUAD) of LOOKS) - (LEFT 1) - (RIGHT 2) - ((CENTER CENTERED) - 3) - ((JUST JUSTIFIED) - 4) - (SHOULDNT))) - [COND - ((OR TABSPECS DEFAULTTAB) (* ; "There are tab specs to save.") - (COND - (DEFAULTTAB (\SMALLPOUT FILE DEFAULTTAB)) - (T (\SMALLPOUT FILE 0))) - (COND - ((IGREATERP (LENGTH TABSPECS) - 255) - (SHOULDNT "Paragraph has more than 255 TABs set--can't be saved."))) - (\BOUT FILE (LENGTH TABSPECS)) - (COND - (TABSPECS (* ; "# of tab settings <256!") - (for TAB in TABSPECS do (\SMALLPOUT FILE (fetch TABX - of TAB)) - (* ; "And setting.") - (\BOUT FILE (SELECTQ (fetch TABKIND - of TAB) - (LEFT 0) - (RIGHT 1) - (CENTERED 2) - (DECIMAL 3) - (DOTTEDLEFT 4) - (DOTTEDRIGHT 5) - (DOTTEDCENTERED - 6) - (DOTTEDDECIMAL 7) - (SHOULDNT))) - (* ; "Tab type")] - (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALX) of LOOKS) - 0)) - (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALY) of LOOKS) - 0)) - (\ARBOUT FILE (fetch (FMTSPEC FMTUSERINFO) of LOOKS)) - (\ATMOUT FILE (fetch (FMTSPEC FMTPARATYPE) of LOOKS)) - (\ATMOUT FILE (fetch (FMTSPEC FMTPARASUBTYPE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTSTYLE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEAFTER) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTHEADINGKEEP) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTKEEP) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTBASETOBASE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTREVISED) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTCOLUMN) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS)) - -(* ;;; "Now go fill in the length field at the front of the LOOKS. (ALL looks info should be written out BEFORE this comment.)") - - (SETQ LEN (IDIFFERENCE (GETFILEPTR FILE) - FILEPOS)) (* ; "The length of this set of looks") - (SETFILEPTR FILE FILEPOS) (* ; "Go write the length field") - (\SMALLPOUT FILE LEN) - (SETFILEPTR FILE -1) (* ; "And back to the end of the file") - ]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.INPUT.FORMATS *TEDIT-FILE-READTABLE*) ) (RPAQ? TEDIT.INPUT.FORMATS NIL) (RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE)) (* ;; "For converting old incoming format. Cutover 5/22/85 to permit looks changes in the future.") (DEFINEQ (TEDIT.BUILD.PCTB2 - [LAMBDA (TEXT TEXTOBJ PCCOUNT START END DEFAULTLOOKS) (* ; "Edited 4-May-93 16:27 by jds") - - (* ;; "READ OBSOLETE FORMATS OF TEDIT FILE") - - (* ;; "START = 1st char of file to read from, if specified") - - (* ;; "END = use this as eofptr of file. For use in reading files within files.") - - (PROG (SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE - CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK - EXISTINGFMTSPECS (CURFILECH# (OR START 0)) - (CURCH# 1) - (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) - LOOKSHASH PARAHASH) (* ; - "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL") - [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND - (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) - of TEXTOBJ)) - (T (create FMTSPEC using - TEDIT.DEFAULT.FMTSPEC - ] - (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))) - (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL)) - (* ; - "Start by assuming no page formatting") - (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) - (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB) - (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) - 8)) - (SETQ PIECEINFOCH# (\DWIN TEXT)) - (SETFILEPTR TEXT PIECEINFOCH#) - (bind (OLDPC _ NIL) - (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN - from \FirstPieceOffset by \EltsPerPiece - do (SETQ PC NIL) (* ; - "This loop may not really read a piece, so we have to distinguish that case.") - (SETQ PCLEN (\DWIN TEXT)) - (SETQ TYPECODE (\SMALLPIN TEXT)) (* ; "What kind of piece is it?") - (SELECTC TYPECODE - (\PieceDescriptorPAGEFRAME (* ; - "This is page layout info for the file") - (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ - with (TEDIT.GET.PAGEFRAMES TEXT))) - (add PCN (IMINUS \EltsPerPiece)) - (* ; - "This didn't create a piece -- don't count it in the PCTB placement.") - ) - (\PieceDescriptorCHARLOOKSLIST (* ; - "This is the list of CHARLOOKSs used in this document.") - (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ - with (\TEDIT.GET.CHARLOOKS.LIST2 TEXT)) - (* ; - "Read the list of looks used in this document.") - [SETQ LOOKSHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTCHARLOOKSLIST) - of TEXTOBJ] - (* ; - "Build an array of the looks, so the reader can index them.") - (for I from 1 as LOOKS in (fetch (TEXTOBJ - TXTCHARLOOKSLIST - ) - of TEXTOBJ) - do (SETA LOOKSHASH I LOOKS)) - (add PCN (IMINUS \EltsPerPiece)) - (* ; - "This didn't create a piece -- don't count it in the PCTB placement.") - (add I -1)) - (\PieceDescriptorPARALOOKSLIST (* ; - "This is the list of PARALOOKSs used in this document.") - (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ - with (\TEDIT.GET.PARALOOKS.LIST2 TEXT)) - (* ; - "Read the list of looks used in this document.") - [SETQ PARAHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) - of TEXTOBJ] - (* ; - "Build an array of the looks, so the reader can index them.") - (for I from 1 as LOOKS in (fetch (TEXTOBJ - TXTPARALOOKSLIST - ) - of TEXTOBJ) - do (SETA PARAHASH I LOOKS)) - (add PCN (IMINUS \EltsPerPiece)) - (* ; - "This didn't create a piece -- don't count it in the PCTB placement.") - (add I -1)) - (\PieceDescriptorPARA (* ; - "Reading a new set of paragraph looks.") - (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T)) - (* ; - "Mark the end of the preceding paragraph.") - (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS TEXT PARAHASH)) - (* ; - "Get the new set of looks, for use by later pieces.") - (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ - with T)) (* ; - "Mark the document as containing paragraph formatting info") - (add PCN (IMINUS \EltsPerPiece)) - (* ; - "This didn't create a piece -- don't count it in the PCTB placement.") - ) - (\PieceDescriptorLOOKS (* ; - "New character looks. Build a piece to describe those characters.") - (SETQ PC - (create PIECE - PFILE _ TEXT - PFPOS _ CURFILECH# - PLEN _ PCLEN - PREVPIECE _ OLDPC - PPARALOOKS _ OLDPARALOOKS)) - (* ; "Build the new piece") - (\TEDIT.GET.CHARLOOKS PC TEXT LOOKSHASH OLDPC) - (* ; - "Read the character looks for this guy.") - (COND - [OLDPC (* ; - "If there's a prior piece, hook this one on the chain.") - (replace (PIECE NEXTPIECE) of OLDPC with PC) - (COND - ((AND (fetch (PIECE PFATP) of PC) - (NOT (fetch (PIECE PFATP) of OLDPC))) - (* ; - "Switching from not-fat to fat. Add 3 bytes for the 255-255-0") - (add (fetch (PIECE PFPOS) of PC) - 3) - (add CURFILECH# -3)) - ((AND (fetch (PIECE PFATP) of OLDPC) - (NOT (fetch (PIECE PFATP) of PC))) - (* ; - "Switching from fat to not-fat. Add 3 bytes for the 255-0") - (add (fetch (PIECE PFPOS) of PC) - 2] - ((fetch (PIECE PFATP) of PC) - (* ; - "Switching from not-fat to fat. Add 3 bytes for the 255-255-0") - (add (fetch (PIECE PFPOS) of PC) - 3) - (add CURFILECH# -3))) - (add CURFILECH# PCLEN) (* ; - "And note the passing of characters.") - ) - (\PieceDescriptorOBJECT (* ; - "It describes an object. Read that, and perhaps some description of the charlooks to go with it.") - (SETQ PC - (create PIECE - PFILE _ TEXT - PFPOS _ CURFILECH# - PLEN _ PCLEN - PREVPIECE _ OLDPC - PPARALOOKS _ OLDPARALOOKS)) - (COND - (OLDPC (* ; - "If there's a prior piece, hook this one on the chain.") - (replace (PIECE NEXTPIECE) of OLDPC with PC))) - (TEDIT.GET.OBJECT TEXTSTREAM PC TEXT CURFILECH#) - (add CURFILECH# (fetch (PIECE PLEN) of PC)) - [COND - ((NOT (ZEROP (\BIN TEXT))) (* ; - "There are new character looks for this object. Read them in.") - (replace (PIECE PLOOKS) of PC with ( - \TEDIT.GET.SINGLE.CHARLOOKS2 - TEXT))) - (T (* ; - "No new looks; steal them from the prior piece.") - (replace (PIECE PLOOKS) of PC - with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC)) - DEFAULTLOOKS] - (replace (PIECE PLEN) of PC with 1) - (* ; - "OBJECTs are officially one character long.") - ) - (SHOULDNT "Impossible piece-type code in BUILD.PCTB")) - (COND - (PC (* ; - "If we created a piece, save it in the table.") - (\INSERTPIECE PC 'LASTPIECE TEXTOBJ) - (add CURCH# (fetch (PIECE PLEN) of PC)) - (SETQ OLDPC PC))) finally (* INSERT-BRT (CREATEPCNODE CURCH# - (QUOTE LASTPIECE)) PCTB)) - (RETURN PCTB]) (\TEDIT.GET.CHARLOOKS.LIST2 - [LAMBDA (FILE) (* jds "22-May-85 14:28") - (* Read the list of CHARLOOKSs from - the file.) - (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.CHARLOOKS2 FILE]) (\TEDIT.GET.SINGLE.CHARLOOKS2 - [LAMBDA (FILE) (* ; "Edited 30-May-91 20:26 by jds") - (* Read a set of CHARLOOKS from FILE) - (PROG* ((LOOKS (create CHARLOOKS)) - FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR) - (SETQ NAME (\ARBIN FILE)) (* The font name) - (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) - (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) - (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE) - 0)) - (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE)) - (SETQ PROPS (\SMALLPIN FILE)) - (with CHARLOOKS LOOKS [SETQ CLLEADER (NOT (ZEROP (LOGAND 2048 PROPS] - [SETQ CLINVERTED (NOT (ZEROP (LOGAND 1024 PROPS] - [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] - [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] - [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] - [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] - [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] - [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] - [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] - [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] - [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] - [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] - (SETQ CLSIZE SIZE) - (SETQ CLOFFSET SUPER)) - [replace (CHARLOOKS CLFONT) of LOOKS - with (COND - ((LISTP NAME) (* This was a font class. - Restore it.) - (FONTCLASS (pop NAME) - NAME)) - ((AND NAME (NOT (ZEROP SIZE))) - (FONTCREATE NAME SIZE (COND - ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) - (fetch (CHARLOOKS CLITAL) of LOOKS) - ) - 'BOLDITALIC) - ((fetch (CHARLOOKS CLBOLD) of LOOKS) - 'BOLD) - ((fetch (CHARLOOKS CLITAL) of LOOKS) - 'ITALIC] - (RETURN LOOKS]) (\TEDIT.PUT.SINGLE.PARALOOKS2 - [LAMBDA (FILE LOOKS) (* ; "Edited 30-May-91 20:33 by jds") - (* Put a description of LOOKS into - FILE. LOOKS apply to characters CH1 - thru CHLIM-1) - (PROG (DEFAULTTAB TABSPECS OUTPUTFORMAT LEN) - (\SMALLPOUT FILE (fetch (FMTSPEC 1STLEFTMAR) of LOOKS)) - (* Left margin for the first line of - the paragraph) - (\SMALLPOUT FILE (fetch (FMTSPEC LEFTMAR) of LOOKS)) - (* Left margin for the rest of the - paragraph) - (\SMALLPOUT FILE (fetch (FMTSPEC RIGHTMAR) of LOOKS)) - (* Right margin for the paragraph) - (\SMALLPOUT FILE (fetch (FMTSPEC LEADBEFORE) of LOOKS)) - (* Leading before the paragraph) - (\SMALLPOUT FILE (fetch (FMTSPEC LEADAFTER) of LOOKS)) - (* Lead after the paragraph) - (\SMALLPOUT FILE (fetch (FMTSPEC LINELEAD) of LOOKS)) - (* inter-line leading) - (SETQ DEFAULTTAB (CAR (fetch (FMTSPEC TABSPEC) of LOOKS))) - (SETQ TABSPECS (CDR (fetch (FMTSPEC TABSPEC) of LOOKS))) - (COND - ((AND (fetch (FMTSPEC TABSPEC) of LOOKS) - (OR DEFAULTTAB TABSPECS)) - - (* There are tab specs to save, or there is a default tab setting to save) - - (\BOUT FILE 3)) - (T (* There are no tab looks. - Just let him go.) - (\BOUT FILE 2))) - (\BOUT FILE (SELECTQ (fetch (FMTSPEC QUAD) of LOOKS) - (LEFT 1) - (RIGHT 2) - ((CENTER CENTERED) - 3) - ((JUST JUSTIFIED) - 4) - (SHOULDNT))) - [COND - ((OR TABSPECS DEFAULTTAB) (* There are tab specs to save.) - (COND - (DEFAULTTAB (\SMALLPOUT FILE DEFAULTTAB)) - (T (\SMALLPOUT FILE 0))) - (\BOUT FILE (LENGTH TABSPECS)) - (COND - (TABSPECS (* %# of tab settings <256!) - (for TAB in TABSPECS do (\SMALLPOUT FILE (fetch TABX - of TAB)) - (* And setting.) - (\BOUT FILE (SELECTQ (fetch TABKIND - of TAB) - (LEFT 0) - (RIGHT 1) - (CENTERED 2) - (DECIMAL 3) - (SHOULDNT))) - (* Tab type)] - (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALX) of LOOKS) - 0)) - (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALY) of LOOKS) - 0)) - (\ARBOUT FILE (fetch (FMTSPEC FMTUSERINFO) of LOOKS)) - (\ATMOUT FILE (fetch (FMTSPEC FMTPARATYPE) of LOOKS)) - (\ATMOUT FILE (fetch (FMTSPEC FMTPARASUBTYPE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTSTYLE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS)) - (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEAFTER) of LOOKS]) (\TEDIT.PUT.SINGLE.CHARLOOKS2 - [LAMBDA (FILE LOOKS) (* ; "Edited 30-May-91 20:26 by jds") - (* Put out a single CHARLOOKS - description.) - (PROG ((FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) - STR LEN) - [COND - ((type? FONTCLASS FONT) (* For font classes, we need to save - a list of device-FD sets) - (\ARBOUT FILE (FONTCLASSUNPARSE FONT))) - (T (* For FONTDESCRIPTORs, do it the - easy way) - (\ATMOUT FILE (FONTPROP FONT 'FAMILY] (* The font family) - (\SMALLPOUT FILE (OR (FONTPROP FONT 'SIZE) - 0)) (* Size of the type, in points) - (\SMALLPOUT FILE (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS) - 0)) (* Super/subscripting distance) - (COND - ([AND (fetch (CHARLOOKS CLSTYLE) of LOOKS) - (NOT (ZEROP (fetch (CHARLOOKS CLSTYLE) of LOOKS] - (\ARBOUT FILE (fetch (CHARLOOKS CLSTYLE) of LOOKS))) - (T (\SMALLPOUT FILE 0))) - (COND - ((fetch (CHARLOOKS CLUSERINFO) of LOOKS) - (\ARBOUT FILE (fetch (CHARLOOKS CLUSERINFO) of LOOKS))) - (T (\SMALLPOUT FILE 0))) - (\SMALLPOUT FILE (LOGOR (COND - ((fetch (CHARLOOKS CLLEADER) of LOOKS) - (* Dotted-leader; relevant only to - TABs) - 2048) - (T 0)) - (COND - ((fetch (CHARLOOKS CLINVERTED) of LOOKS) - (* Inverse-video) - 1024) - (T 0)) - (COND - ((fetch (CHARLOOKS CLBOLD) of LOOKS) - 512) - (T 0)) - (COND - ((fetch (CHARLOOKS CLITAL) of LOOKS) - 256) - (T 0)) - (COND - ((fetch (CHARLOOKS CLULINE) of LOOKS) - 128) - (T 0)) - (COND - ((fetch (CHARLOOKS CLOLINE) of LOOKS) - 64) - (T 0)) - (COND - ((fetch (CHARLOOKS CLSTRIKE) of LOOKS) - 32) - (T 0)) - (COND - ((fetch (CHARLOOKS CLSMALLCAP) of LOOKS) - 16) - (T 0)) - (COND - ((fetch (CHARLOOKS CLPROTECTED) of LOOKS) - 8) - (T 0)) - (COND - ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) - NIL 4) - (T 0)) - (COND - ((fetch (CHARLOOKS CLSELHERE) of LOOKS) - 2) - (T 0)) - (COND - ((fetch (CHARLOOKS CLCANCOPY) of LOOKS) - 1) - (T 0]) (\TEDIT.GET.PARALOOKS.LIST2 - [LAMBDA (FILE) (* jds "22-May-85 14:28") - (* Read the list of CHARLOOKSs from - the file.) - (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.PARALOOKS2 FILE]) (\TEDIT.GET.SINGLE.PARALOOKS2 - [LAMBDA (FILE) (* ; "Edited 30-May-91 20:33 by jds") - (* Read a paragraph format spec from - the FILE, and return it for later - use.) - (PROG ((LOOKS (create FMTSPEC)) - TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC) - (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Left margin for the first line of - the paragraph) - (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Left margin for the rest of the - paragraph) - (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Right margin for the paragraph) - (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) - (* Leading before the paragraph) - (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) - (* Lead after the paragraph) - (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) - (* inter-line leading) - (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) - (* Will be tab specs) - (SETQ TABFLG (\BIN FILE)) - (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE) - (1 'LEFT) - (2 'RIGHT) - (3 'CENTERED) - (4 'JUSTIFIED) - (SHOULDNT))) - (COND - ((NOT (ZEROP (LOGAND TABFLG 1))) (* There are tabs to read) - (SETQ DEFAULTTAB (\SMALLPIN FILE)) - (SETQ TABCOUNT (\BIN FILE)) - [SETQ TABS (for TAB# from 1 to TABCOUNT - collect (create TAB - TABX _ (\SMALLPIN FILE) - TABKIND _ (SELECTQ (\BIN FILE) - (0 'LEFT) - (1 'RIGHT) - (2 'CENTERED) - (3 'DECIMAL) - (SHOULDNT] - (OR (ZEROP DEFAULTTAB) - (RPLACA TABSPEC DEFAULTTAB)) - (RPLACD TABSPEC TABS))) - [COND - ((NOT (ZEROP (LOGAND TABFLG 2))) (* There are other paragraph - parameters to be read.) - (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE)) - (* Special X location on page for - this paragraph) - (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE)) - (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE)) - (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE)) - (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE] - (RETURN LOOKS]) (TEDIT.PUT.PCTB2 [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT) (* ; "Edited 11-Jun-99 15:03 by rmk:") (* ; "Edited 11-Jun-99 15:03 by rmk:") (* ; "Edited 11-Jun-99 14:31 by rmk:") (* ; "Edited 11-Jun-99 14:29 by rmk:") (* ; "Edited 30-May-91 20:24 by jds") (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks. UNFORMATTED? means write no font or formatting info.") (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) OLDCH# CURCH# PREVPC (FONTFILE NIL) (PCCOUNT 0) TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL) (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) (PARALOOKSSEEN NIL) (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ)) (CACHE (TEXTPROP TEXTOBJ 'CACHE)) CH#S PREVFATP PREVPREVPC LOOKSHASH PARAHASH) (SETQ PC (\EDITELT (fetch (TEXTOBJ PCTB) of TEXTOBJ) (ADD1 \FirstPieceOffset))) (* ; "First piece in the document") (SETQ OLDLOOKS (OR (AND (type? PIECE PC) (fetch (PIECE PLOOKS) of PC)) (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) TEDIT.DEFAULT.CHARLOOKS)) (* ; "Starting looks") (COND ((NEQ (fetch (STREAM EOLCONVENTION) of OFILE) CR.EOLC) (* ;  "This file is on a non-CR host; make a note to cache it") (SETQ TRUEFILE OFILE) (* ;  "Remember where the file should wind up.") [SETQ OFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "And open a temp file to write it to.") )) [SETQ CURCH# (SETQ OLDCH# (ADD1 (GETFILEPTR OFILE] (COND ((fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) (* ;  "There is layout info for this file. Save it") [SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (TEDIT.PUT.PAGEFRAMES FONTFILE (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)) (add PCCOUNT 1))) (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC) (* ;  "Run thru the lists of char & para looks and remove any that aren't in use") (COND ([AND (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ) (OR (IGREATERP (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) 1) (NOT (EQFMTSPEC (CAR (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) TEDIT.DEFAULT.FMTSPEC] (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "Create the font-info file if it doesn't exist yet") (SETQ PARAHASH (\TEDIT.PUT.PARALOOKS.LIST2 FONTFILE (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ))) (SETQ PARALOOKSSEEN T))) [COND ((OR PARALOOKSSEEN FORMATTINGLEVEL) (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST2 FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] [while PC do (COND ([AND (NOT (ZEROP (fetch (PIECE PLEN) of PC))) (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS ) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ;  "The last piece ended a paragraph, so send out new para looks") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "Create the formatting-info file, if it didn't exist before.") (COND ((NEQ CURCH# OLDCH#) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (\TEDIT.PUT.PARALOOKS FONTFILE PC PARAHASH) (SETQ PARALOOKSSEEN T) (* ;  "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries") (add PCCOUNT 1))) (COND [(fetch (PIECE POBJ) of PC) (* ;  "It's an object -- go use its PUTFN") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "Create the font-info file, if need be.") (COND ((AND (NEQ CURCH# OLDCH#) PREVPC) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (* ;  "If the prior thing was text, send along its descriptor.") (add CURCH# (TEDIT.PUT.OBJECT PC OFILE FONTFILE CURCH#)) (* ; "Send out the object") (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (COND ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (NEQ (fetch (PIECE PFATP) of PC) (AND PREVPC (fetch (PIECE PFATP) of PREVPC))) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ ] (* ;  "The OBJECT has different ooks from before") (\BOUT FONTFILE 1) (\TEDIT.PUT.SINGLE.CHARLOOKS FONTFILE (fetch (PIECE PLOOKS) of PC)) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (T (* ;  "No differences. Don't write any charlooks, and mark that fact") (\BOUT FONTFILE 0) (* ;  "MAKE BLOODY SURE THAT THE NEXT RUN OF CHARACTERS GETS ITS OWN LOOKS") ] (T (* ; "It's not an object.") [COND ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (NEQ (fetch (PIECE PFATP) of PC) (AND PREVPC (fetch (PIECE PFATP) of PREVPC)) ) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ; "We have a piece with new looks.") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (COND ((NOT (IEQP OLDCH# CURCH#)) (* ;  "If there were looks past, and if the run was not empty, save a piece for its looks") [OR LOOKSHASH (SETQ LOOKSHASH (  \TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1))) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC)) (SETQ OLDCH# CURCH#) (COND [PREVFATP (COND ((fetch (PIECE PFATP) of PC)) (T (* ; "Switching from FAT to thin") (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 2] ((fetch (PIECE PFATP) of PC) (* ; "Switching from thin to fat") (BOUT OFILE 255) (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 3))) (SETQ PREVFATP (fetch (PIECE PFATP) of PC] (* ;  "Now dump out the non-object contents of the piece.") [COND [(SETQ PFILE (fetch (PIECE PFILE) of PC)) (* ; "It's on a file. Copy it.") [OR (OPENP PFILE) (replace (PIECE PFILE) of PC with (SETQ PFILE (OPENSTREAM (fetch (STREAM FULLNAME) of PFILE) 'INPUT NIL '((TYPE TEXT] (* ; "Make sure the file is open.") (COPYBYTES PFILE OFILE (fetch (PIECE PFPOS) of PC) (IPLUS (fetch (PIECE PFPOS) of PC) (COND ((fetch (PIECE PFATP) of PC) (* ;  "For fat file pieces, copy twice as many bytes as characters.") (UNFOLD (fetch (PIECE PLEN) of PC) 2)) (T (fetch (PIECE PLEN) of PC] ((SETQ PSTR (fetch (PIECE PSTR) of PC)) (* ;  "It's in a string. Just print it.") (COND [(fetch (PIECE PFATP) of PC) (* ;  "The string is fat: Copy twice as many bytes as chars.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE (\CHARSET CH)) (\BOUT OFILE (\CHAR8CODE CH] (T (* ;  "The string is thin. Just copy it to the file.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE CH] [COND ((AND (NOT CACHE) (RANDACCESSP OFILE)) (* ; "CSLI leave the pieces and the pctb alone and just write the file if its cached or not randomaccess") (push CH#S (SUB1 CURCH#] [COND ((fetch (PIECE PFATP) of PC) (add CURCH# (UNFOLD (fetch (PIECE PLEN) of PC) 2))) (T (add CURCH# (fetch (PIECE PLEN) of PC] (* ;  "Keep running track of where in the file we are.") )) (SETQ PREVPREVPC PREVPC) (SETQ PREVPC PC) (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (* ;  "Put out a piece describing the last characters in the file.") (COND ((AND FONTFILE (NEQ OLDCH# CURCH#)) (* ;  "Only if there WERE characters, and only if there's a need for font information") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVPREVPC) (* ;  "Put out a description of the characters") (add PCCOUNT 1))) (COND ((AND PARALOOKSSEEN (fetch (PIECE PPARALAST) of PREVPC)) (* ;  "The last piece contained the end of a paragraph. Make sure it gets noted.") (\TEDIT.PUT.PARALOOKS FONTFILE PREVPC PARAHASH) (add PCCOUNT 1] (for FORM in TEDIT.PUT.FINISHEDFORMS do (EVAL FORM)) (* ; "Do any user-specific cleanup") (COND (TRUEFILE (* ;  "This file needs to be converted to the right convention") (COND ((AND FONTFILE (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;  "Formatted file: Copy without converting.") (COPYBYTES OFILE TRUEFILE 0 -1)) (T (* ;  "Go ahead and convert the EOLCONVENTION, this is a plain-text file") (COPYCHARS OFILE TRUEFILE 0 -1))) (SETQ OFILE TRUEFILE))) [COND ((AND (OPENP OFILE) FONTFILE) (* ; "We need to write format info.") (\DWOUT FONTFILE (GETEOFPTR OFILE)) (* ;  "So remember the end of the plain-text part of the file") (\SMALLPOUT FONTFILE PCCOUNT) (* ;  "# OF PIECES WE'' NEED TO RECONSTRUCT THIS FILE") (\SMALLPOUT FONTFILE 31417) (* ;  "Now the password for NEW format files: 31416") (COND ((AND (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;; "Only write fmtg info at the end if we want it there--not if we want plain text or want it kept separate.") (COPYBYTES FONTFILE OFILE 0 (GETEOFPTR FONTFILE)) (* ;  "Copy the font information to the file trailer") ) (T)) (CLOSEF FONTFILE) (COND ((NOT SEPARATEFORMAT) (* ;  "Unless we want the formatting info separately, delete the file") (* ;  "(since FONTFILE is a stream, we should not need to delete it at all) (DELFILE FONTFILE)") ] (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS ) of TEXTOBJ) TEXTOBJ)) (* ;  "Re-add the default and caret looks's to the lists, since they may not have been really saved.") (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ)) (replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) TEXTOBJ)) (RETURN (CONS (COND (UNFORMATTED? NIL) (T FONTFILE)) CH#S]) (\TEDIT.PUT.CHARLOOKS.LIST2 - [LAMBDA (FILE LOOKSLIST) (* jds "22-May-85 15:12") - (* Write the list of CHARLOOKSs into - the font file.) - - (* Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' - position in the list we wrote on the file. - Those position numbers are then written in the individual looks descriptions, - and are used to reconstruct the piece looks when the file is read back in.) - - (PROG ((LOOKSHASH (HASHARRAY 50))) - (\DWOUT FILE 0) (* No characters are described by this - pseudo-piece entry.) - (\SMALLPOUT FILE \PieceDescriptorCHARLOOKSLIST) (* Mark it as containing the list of - CHARLOOKSs) - (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) (* How many CHARLOOKSs there are in - the list) - (for I from 1 as LOOKS in LOOKSLIST do - - (* Write each charlooks, in the order they appear in the list.) - - (\TEDIT.PUT.SINGLE.CHARLOOKS2 FILE LOOKS) - (* Write out the description) - (PUTHASH LOOKS I LOOKSHASH) - - (* And save it in the hash table so people can find its index.) -) - (RETURN LOOKSHASH]) (\TEDIT.PUT.PARALOOKS.LIST2 - [LAMBDA (FILE LOOKSLIST) (* jds "22-May-85 15:09") - (* Write the list of FMTSPECs into the - font file.) - (PROG ((LOOKSHASH (HASHARRAY 50))) - (\DWOUT FILE 0) - (\SMALLPOUT FILE \PieceDescriptorPARALOOKSLIST) - (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) - (for I from 1 as LOOKS in LOOKSLIST do (\TEDIT.PUT.SINGLE.PARALOOKS2 FILE LOOKS) - (* Write out the description) - (PUTHASH LOOKS I LOOKSHASH) - - (* And save it in the hash table so people can find its index.) -) - (RETURN LOOKSHASH]) ) (* ;; "For converting incoming old-format files (1/27/85 cutover)") (DEFINEQ (TEDIT.BUILD.PCTB1 - [LAMBDA (TEXT TEXTOBJ PCCOUNT START END DEFAULTLOOKS) (* ; "Edited 22-May-92 18:00 by jds") - -(* ;;; "READ OBSOLETE FORMATS OF TEDIT FILE") - - (* ;; "START = 1st char of file to read from, if specified") - - (* ;; "END = use this as eofptr of file. For use in reading files within files.") - - (PROG [SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE - CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK - EXISTINGFMTSPECS (CURFILECH# (OR START 0)) - (CURCH# 1) - (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ] - - (* ;; "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL") - - [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND - (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) - of TEXTOBJ)) - (T (create FMTSPEC using - TEDIT.DEFAULT.FMTSPEC - ] - (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))) - (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL)) - (* ; - "Start by assuming no page formatting") - (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) - (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) - 8)) - (SETQ PIECEINFOCH# (\DWIN TEXT)) - (SETFILEPTR TEXT PIECEINFOCH#) - (bind (OLDPC _ NIL) - (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN - from \FirstPieceOffset by \EltsPerPiece - do (SETQ PC NIL) (* ; - "This loop may not really read a piece, so we have to distinguish that case.") - (SETQ PCLEN (\DWIN TEXT)) - (SETQ TYPECODE (\SMALLPIN TEXT)) (* ; "What kind of piece is it?") - (SELECTC TYPECODE - (\PieceDescriptorPAGEFRAME (* ; - "This is page layout info for the file") - (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ - with (TEDIT.GET.PAGEFRAMES1 TEXT))) - (add PCN (IMINUS \EltsPerPiece)) - (* ; - "This didn't create a piece -- don't count it in the PCTB placement.") - ) - (\PieceDescriptorPARA (* ; - "Reading a new set of paragraph looks.") - (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T)) - (* ; - "Mark the end of the preceding paragraph.") - (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS1 TEXT)) - (* ; - "Get the new set of looks, for use by later pieces.") - (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ - with T)) (* ; - "Mark the document as containing paragraph formatting info") - (add PCN (IMINUS \EltsPerPiece)) - (* ; - "This didn't create a piece -- don't count it in the PCTB placement.") - ) - (\PieceDescriptorLOOKS (* ; - "New character looks. Build a piece to describe those characters.") - (SETQ PC - (create PIECE - PFILE _ TEXT - PFPOS _ CURFILECH# - PLEN _ PCLEN - PREVPIECE _ OLDPC - PPARALOOKS _ OLDPARALOOKS)) - (* ; "Build the new piece") - (COND - (OLDPC (* ; - "If there's a prior piece, hook this one on the chain.") - (replace (PIECE NEXTPIECE) of OLDPC with PC))) - (\TEDIT.GET.CHARLOOKS1 PC TEXT) - (* ; - "Read the character looks for this guy.") - (add CURFILECH# (fetch (PIECE PLEN) of PC)) - (* ; - "And note the passing of characters.") - ) - (\PieceDescriptorOBJECT (* ; - "It describes an object. Read that, and perhaps some description of the charlooks to go with it.") - (SETQ PC - (create PIECE - PFILE _ TEXT - PFPOS _ CURFILECH# - PLEN _ PCLEN - PREVPIECE _ OLDPC - PPARALOOKS _ OLDPARALOOKS)) - (COND - (OLDPC (* ; - "If there's a prior piece, hook this one on the chain.") - (replace (PIECE NEXTPIECE) of OLDPC with PC))) - (TEDIT.GET.OBJECT1 TEXTSTREAM PC TEXT CURFILECH#) - (add CURFILECH# (fetch (PIECE PLEN) of PC)) - [COND - ((NOT (ZEROP (\BIN TEXT))) (* ; - "There are new character looks for this object. Read them in.") - (\DWIN TEXT) - (\WIN TEXT) (* ; - "Skip over the piece-type code we know has to be here.") - (\TEDIT.GET.CHARLOOKS1 PC TEXT)) - (T (* ; - "No new looks; steal them from the prior piece.") - (replace (PIECE PLOOKS) of PC - with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC)) - DEFAULTLOOKS] - (replace (PIECE PLEN) of PC with 1) - (* ; - "OBJECTs are officially one character long.") - ) - (SHOULDNT "Impossible piece-type code in BUILD.PCTB")) - (COND - (PC (* ; - "If we created a piece, save it in the table.") - [COND - ((SETQ EXLOOK (for LOOK in EXISTINGCHARLOOKS - thereis (EQCLOOKS (fetch (PIECE PLOOKS) - of PC) - LOOK))) - (* ; - "These charlooks are a duplicate of pre-existing ones. Re-use the old one.") - (replace (PIECE PLOOKS) of PC with EXLOOK)) - (T (push EXISTINGCHARLOOKS (fetch (PIECE PLOOKS) of PC] - [COND - ((SETQ EXLOOK (for LOOK in EXISTINGFMTSPECS - thereis (EQFMTSPEC (fetch (PIECE PPARALOOKS) - of PC) - LOOK))) - (* ; - "These paralooks are a duplicate of pre-existing ones. Re-use the old one.") - (replace (PIECE PPARALOOKS) of PC with EXLOOK)) - (T (push EXISTINGFMTSPECS (fetch (PIECE PPARALOOKS) of - PC] - (INSERT-BRT (CREATEPCNODE CURCH# PC) - PCTB) - (add CURCH# (fetch (PIECE PLEN) of PC)) - (SETQ OLDPC PC))) finally (INSERT-BRT (CREATEPCNODE CURCH# 'LASTPIECE) - PCTB)) - (RETURN PCTB]) (TEDIT.GET.PAGEFRAMES1 - [LAMBDA (FILE) (* jds " 1-Feb-85 14:55") - - (* Read a bunch of page frames from the file, and return it.) - - (TEDIT.PARSE.PAGEFRAMES1 (READ FILE]) (\TEDIT.GET.CHARLOOKS1 - [LAMBDA (PC FILE) (* ; "Edited 30-May-91 20:26 by jds") - (* Read a description of PC's - CHARLOOKS from FILE.) - (PROG (FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR (LOOKS (create CHARLOOKS)) - ) - (replace (PIECE PLOOKS) of PC with LOOKS) - (SETQ NAME (\ARBIN FILE)) (* The font name) - (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) - (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) - (SETQ SUB (\SMALLPIN FILE)) (* former Subscripting distance) - (OR (ZEROP SUB) - (SETQ SUPER (IMINUS SUB))) - - (* If this is an old file, it'll have a subscript value not zero. - Let those past and do the right thing.) - - (COND - ((NOT (ZEROP (\BIN FILE))) (* This text is NEW. - Mark it so.) - (replace (PIECE PNEW) of PC with T))) - [COND - ((NOT (ZEROP (\BIN FILE))) (* There is style or user - information to be read) - (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE) - 0)) - (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE] - (SETQ PROPS (\SMALLPIN FILE)) - (with CHARLOOKS LOOKS [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] - [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] - [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] - [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] - [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] - [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] - [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] - [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] - [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] - [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] - (SETQ CLSIZE SIZE) - (SETQ CLOFFSET SUPER)) - (replace (CHARLOOKS CLFONT) of LOOKS - with (COND - ((LISTP NAME) (* This was a font class. - Restore it.) - (FONTCLASS (pop NAME) - NAME)) - ((AND NAME (NOT (ZEROP SIZE))) - (FONTCREATE NAME SIZE (COND - ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) - (fetch (CHARLOOKS CLITAL) of LOOKS)) - 'BOLDITALIC) - ((fetch (CHARLOOKS CLBOLD) of LOOKS) - 'BOLD) - ((fetch (CHARLOOKS CLITAL) of LOOKS) - 'ITALIC]) (\TEDIT.GET.PARALOOKS1 - [LAMBDA (FILE) (* ; "Edited 30-May-91 20:34 by jds") - (* Read a paragraph format spec from - the FILE, and return it for later - use.) - (PROG ((LOOKS (create FMTSPEC)) - TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC) - (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Left margin for the first line of - the paragraph) - (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Left margin for the rest of the - paragraph) - (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Right margin for the paragraph) - (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) - (* Leading before the paragraph) - (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) - (* Lead after the paragraph) - (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) - (* inter-line leading) - (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) - (* Will be tab specs) - (SETQ TABFLG (\BIN FILE)) - (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE) - (1 'LEFT) - (2 'RIGHT) - (3 'CENTERED) - (4 'JUSTIFIED) - (SHOULDNT))) - (COND - ((NOT (ZEROP (LOGAND TABFLG 1))) (* There are tabs to read) - (SETQ DEFAULTTAB (\SMALLPIN FILE)) - (SETQ TABCOUNT (\BIN FILE)) - [SETQ TABS (for TAB# from 1 to TABCOUNT - collect (create TAB - TABX _ (\SMALLPIN FILE) - TABKIND _ (SELECTQ (\BIN FILE) - (0 'LEFT) - (1 'RIGHT) - (2 'CENTERED) - (3 'DECIMAL) - (SHOULDNT] - (OR (ZEROP DEFAULTTAB) - (RPLACA TABSPEC DEFAULTTAB)) - (RPLACD TABSPEC TABS))) - [COND - ((NOT (ZEROP (LOGAND TABFLG 2))) (* There are other paragraph - parameters to be read.) - (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE)) - (* Special X location on page for - this paragraph) - (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE)) - (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE)) - (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE)) - (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE)) - (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE] - (RETURN LOOKS]) (TEDIT.GET.OBJECT1 - [LAMBDA (STREAM PIECE FILE CURCH#) (* ; "Edited 12-Jun-90 18:17 by mitani") - (* Get an object from the file) - - (* CURCH# = fileptr within the text section of the file where the object's text - starts.) - - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - FILEPTRSAVE NAMELEN GETFN OBJ) - (SETQ GETFN (\ATMIN FILE)) (* The GETFN for this kind of - IMAGEOBJ) - (SETQ FILEPTRSAVE (GETFILEPTR FILE)) (* Save our file location thru the - building of the object) - (SETFILEPTR FILE CURCH#) - (SETQ OBJ (READIMAGEOBJ FILE GETFN)) - (SETFILEPTR FILE FILEPTRSAVE) - (replace (PIECE POBJ) of PIECE with OBJ) - (replace (PIECE PFILE) of PIECE with NIL) - (replace (PIECE PSTR) of PIECE with NIL) - [replace (PIECE PLOOKS) of PIECE with (COND - ((fetch (PIECE PREVPIECE) - of PIECE) - (fetch (PIECE PLOOKS) - of (fetch (PIECE PREVPIECE - ) - of PIECE))) - (T (OR (fetch (TEXTOBJ - DEFAULTCHARLOOKS - ) - of TEXTOBJ) - (\TEDIT.UNIQUIFY.CHARLOOKS - (CHARLOOKS.FROM.FONT - DEFAULTFONT) - TEXTOBJ] - (RETURN (fetch (PIECE POBJ) of PIECE]) ) (* ;; "VERSION 0 Compatibility reading functions") (DEFINEQ (TEDIT.BUILD.PCTB0 - [LAMBDA (TEXT TEXTOBJ PCCOUNT START END) (* ; "Edited 22-May-92 18:01 by jds") - -(* ;;; "READ OBSOLETE FORMATS OF TEDIT FILE") - - (PROG [SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE - TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP (CURFILECH# (OR START 0)) - (CURCH# 1) - (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ] - (* ; - "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL") - [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND - (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) - of TEXTOBJ)) - (T (create FMTSPEC using - TEDIT.DEFAULT.FMTSPEC - ] - (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) - (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) - 8)) - (SETQ PIECEINFOCH# (\DWIN TEXT)) - (SETFILEPTR TEXT PIECEINFOCH#) - (bind (OLDPC _ NIL) for I from 1 to PCCOUNT as PCN from - \FirstPieceOffset - by \EltsPerPiece do (SETQ PC (create PIECE - PFILE _ TEXT - PFPOS _ CURFILECH# - PLEN _ (SETQ PCLEN (\DWIN TEXT)) - PREVPIECE _ OLDPC - PPARALOOKS _ DEFAULTPARALOOKS)) - [COND - (OLDPC (replace (PIECE NEXTPIECE) of OLDPC - with PC) - (replace (PIECE PPARALOOKS) of PC - with (fetch (PIECE PPARALOOKS) - of OLDPC] - (SETQ TYPECODE (\SMALLPIN TEXT)) - (SELECTC TYPECODE - (\PieceDescriptorLOOKS - (TEDIT.GET.CHARLOOKS0 PC TEXT) - (add CURFILECH# (fetch (PIECE PLEN) - of PC))) - (\PieceDescriptorOBJECT - (TEDIT.GET.OBJECT0 TEXTSTREAM PC TEXT CURFILECH# - ) - (add CURFILECH# (fetch (PIECE PLEN) - of PC)) - (replace (PIECE PLEN) of PC with 1) - (* ; - "Only object--can't be followed by either ot the others.") - ) - (\PieceDescriptorPARA - (AND OLDPC (replace (PIECE PPARALAST) - of OLDPC with T)) - (TEDIT.GET.PARALOOKS0 PC TEXT) - (replace (PIECE PLEN) of PC - with (\DWIN TEXT)) - (* ; - "Set this piece's length from the character looks.") - (\SMALLPIN TEXT) - (* ; - "Skip the piece-type code, since we know what's next") - (TEDIT.GET.CHARLOOKS0 PC TEXT) - (* ; "This document is 'formatted' .") - (add CURFILECH# (fetch (PIECE PLEN) - of PC)) - (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) - of TEXTOBJ with T))) - (SHOULDNT "Impossible piece-type code in BUILD.PCTB")) - (SETQ OLDPC PC) - (INSERT-BRT (CREATEPCNODE CURCH# PC) - PCTB) - (add CURCH# (fetch (PIECE PLEN) of PC)) - finally (INSERT-BRT (CREATEPCNODE CURCH# 'LASTPIECE) - PCTB)) - (RETURN PCTB]) (TEDIT.GET.CHARLOOKS0 - [LAMBDA (PC FILE) (* ; "Edited 30-May-91 20:26 by jds") - (* Put a description of LOOKS into - FILE. LOOKS apply to characters CH1 - thru CHLIM-1) - (PROG (FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR (LOOKS (create CHARLOOKS)) - ) - (replace (PIECE PLOOKS) of PC with LOOKS) - (SETQ NAMELEN (\SMALLPIN FILE)) (* The length of the description - which follows) - [SETQ NAME (PACK (for I from 1 to NAMELEN collect (CHARACTER (\BIN FILE] - (* The font name) - (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) - (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) - (SETQ SUB (\SMALLPIN FILE)) (* former Subscripting distance) - (OR (ZEROP SUB) - (SETQ SUPER (IMINUS SUB))) - - (* If this is an old file, it'll have a subscript value not zero. - Let those past and do the right thing.) - - (COND - ((NOT (ZEROP (\BIN FILE))) (* This text is NEW. - Mark it so.) - (replace (PIECE PNEW) of PC with T))) - [COND - ((NOT (ZEROP (\BIN FILE))) (* There is style or user - information to be read) - (SETQ STYLESTR (\STRINGIN FILE)) - (SETQ USERSTR (\STRINGIN FILE)) - (COND - ((NOT (ZEROP (NCHARS STYLESTR))) (* There IS style info) - (replace (CHARLOOKS CLSTYLE) of LOOKS with (READ STYLESTR))) - (T (replace (CHARLOOKS CLSTYLE) of LOOKS with 0))) - (COND - ((NOT (ZEROP (NCHARS USERSTR))) (* There IS user info) - (replace (CHARLOOKS CLUSERINFO) of LOOKS with (READ USERSTR] - (SETQ PROPS (\SMALLPIN FILE)) - (with CHARLOOKS LOOKS [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] - [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] - [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] - [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] - [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] - [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] - [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] - [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] - [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] - [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] - (SETQ CLSIZE SIZE) - (SETQ CLOFFSET SUPER)) - (replace (CHARLOOKS CLFONT) of LOOKS - with (AND NAME (NOT (ZEROP SIZE)) - (FONTCREATE NAME SIZE (COND - ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) - (fetch (CHARLOOKS CLITAL) of LOOKS) - ) - 'BOLDITALIC) - ((fetch (CHARLOOKS CLBOLD) of LOOKS) - 'BOLD) - ((fetch (CHARLOOKS CLITAL) of LOOKS) - 'ITALIC]) (TEDIT.GET.OBJECT0 - [LAMBDA (STREAM PIECE FILE CURCH#) (* ; "Edited 12-Jun-90 18:17 by mitani") - (* Get an object from the file) - - (* CURCH# = fileptr within the text section of the file where the object's text - starts.) - - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - FILEPTRSAVE NAMELEN GETFN OBJ) - (SETQ GETFN (\ATMIN FILE)) (* The GETFN for this kind of - IMAGEOBJ) - (SETQ FILEPTRSAVE (GETFILEPTR FILE)) (* Save our file location thru the - building of the object) - (SETFILEPTR FILE CURCH#) - (SETQ OBJ (READIMAGEOBJ FILE GETFN)) - (SETFILEPTR FILE FILEPTRSAVE) - (replace (PIECE POBJ) of PIECE with OBJ) - (replace (PIECE PFILE) of PIECE with NIL) - (replace (PIECE PSTR) of PIECE with NIL) - [replace (PIECE PLOOKS) of PIECE with (COND - ((fetch (PIECE PREVPIECE) - of PIECE) - (fetch (PIECE PLOOKS) - of (fetch (PIECE PREVPIECE - ) - of PIECE))) - (T (OR (fetch (TEXTOBJ - DEFAULTCHARLOOKS - ) - of TEXTOBJ) - (\TEDIT.UNIQUIFY.CHARLOOKS - (CHARLOOKS.FROM.FONT - DEFAULTFONT) - TEXTOBJ] - (RETURN (fetch (PIECE POBJ) of PIECE]) (TEDIT.GET.PARALOOKS0 - [LAMBDA (PC FILE) (* ; "Edited 30-May-91 20:34 by jds") - (* Put a description of LOOKS into - FILE. LOOKS apply to characters CH1 - thru CHLIM-1) - (PROG ((LOOKS (create FMTSPEC)) - TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC) - (replace (PIECE PPARALOOKS) of PC with LOOKS) - (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Left margin for the first line of - the paragraph) - (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Left margin for the rest of the - paragraph) - (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) - (* Right margin for the paragraph) - (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) - (* Leading before the paragraph) - (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) - (* Lead after the paragraph) - (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) - (* inter-line leading) - (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) - (* Will be tab specs) - (SETQ TABFLG (\BIN FILE)) - (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE) - (1 'LEFT) - (2 'RIGHT) - (3 'CENTERED) - (4 'JUSTIFIED) - (SHOULDNT))) - (COND - ((NOT (ZEROP TABFLG)) (* There are tabs to read) - (SETQ DEFAULTTAB (\SMALLPIN FILE)) - (SETQ TABCOUNT (\BIN FILE)) - [SETQ TABS (for TAB# from 1 to TABCOUNT - collect (create TAB - TABX _ (\SMALLPIN FILE) - TABKIND _ (SELECTQ (\BIN FILE) - (0 'LEFT) - (1 'RIGHT) - (2 'CENTERED) - (3 'DECIMAL) - (SHOULDNT] - (OR (ZEROP DEFAULTTAB) - (RPLACA TABSPEC DEFAULTTAB)) - (RPLACD TABSPEC TABS]) ) (PUTPROPS TEDITFILE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3185 58014 (TEDIT.BUILD.PCTB 3195 . 37569) (\TEDIT.CONVERT.FOREIGN.FORMAT 37571 . 39012 ) (TEDIT.FORMATTEDFILEP 39014 . 42878) (TEDIT.GET 42880 . 51698) (TEDIT.PARSE.PAGEFRAMES1 51700 . 53406) (\ARBIN 53408 . 54029) (\ATMIN 54031 . 54360) (\DWIN 54362 . 54640) (\STRINGIN 54642 . 55239) ( \TEDIT.FORMATTEDP1 55241 . 57505) (\TEDIT.SET.WINDOW 57507 . 58012)) (58050 78863 (TEDIT.INCLUDE 58060 . 69732) (TEDIT.RAW.INCLUDE 69734 . 78861)) (78897 122470 (TEDIT.PUT 78907 . 89280) (TEDIT.PUT.PCTB 89282 . 116206) (\TEDIT.PUTRESET 116208 . 116454) (TEDIT.PUT.PIECE.DESCRIPTOR 116456 . 118919) ( \ARBOUT 118921 . 120121) (\ATMOUT 120123 . 120638) (\DWOUT 120640 . 120923) (\STRINGOUT 120925 . 121377) (\TEDIT-OPEN-FONT-FILE 121379 . 122468)) (122471 132983 (\TEDIT.GET.CHARLOOKS.LIST 122481 . 122886) (\TEDIT.GET.SINGLE.CHARLOOKS 122888 . 125933) (\TEDIT.PUT.CHARLOOKS.LIST 125935 . 127730) ( \TEDIT.PUT.SINGLE.CHARLOOKS 127732 . 132981)) (132984 147263 (\TEDIT.GET.PARALOOKS.LIST 132994 . 133407) (\TEDIT.GET.SINGLE.PARALOOKS 133409 . 139803) (\TEDIT.PUT.PARALOOKS.LIST 139805 . 140799) ( \TEDIT.PUT.SINGLE.PARALOOKS 140801 . 147261)) (147571 208832 (TEDIT.BUILD.PCTB2 147581 . 160937) ( \TEDIT.GET.CHARLOOKS.LIST2 160939 . 161346) (\TEDIT.GET.SINGLE.CHARLOOKS2 161348 . 164260) ( \TEDIT.PUT.SINGLE.PARALOOKS2 164262 . 168976) (\TEDIT.PUT.SINGLE.CHARLOOKS2 168978 . 173474) ( \TEDIT.GET.PARALOOKS.LIST2 173476 . 173883) (\TEDIT.GET.SINGLE.PARALOOKS2 173885 . 178473) ( TEDIT.PUT.PCTB2 178475 . 206136) (\TEDIT.PUT.CHARLOOKS.LIST2 206138 . 207935) ( \TEDIT.PUT.PARALOOKS.LIST2 207937 . 208830)) (208909 230033 (TEDIT.BUILD.PCTB1 208919 . 219109) ( TEDIT.GET.PAGEFRAMES1 219111 . 219366) (\TEDIT.GET.CHARLOOKS1 219368 . 222918) (\TEDIT.GET.PARALOOKS1 222920 . 227501) (TEDIT.GET.OBJECT1 227503 . 230031)) (230093 245799 (TEDIT.BUILD.PCTB0 230103 . 235810) (TEDIT.GET.CHARLOOKS0 235812 . 239831) (TEDIT.GET.OBJECT0 239833 . 242361) ( TEDIT.GET.PARALOOKS0 242363 . 245797))))) STOP \ No newline at end of file diff --git a/library/TEDITFIND.~1~ b/library/TEDITFIND.~1~ deleted file mode 100644 index cff22679..00000000 --- a/library/TEDITFIND.~1~ +++ /dev/null @@ -1,632 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Aug-94 10:53:52" {DSK}export>lispcore>library>TEDITFIND.;3 39584 - - changes to%: (VARS TEDITFINDCOMS) (FILES TEDITDCL) - - previous date%: "30-Mar-94 16:15:41" {DSK}export>lispcore>library>TEDITFIND.;2) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITFINDCOMS) - -(RPAQQ TEDITFINDCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.SEARCH.CODETABLE (\TEDIT.SEARCH.CODETABLE)))) (COMS (* Read-table Utilities) (FNS \TEDIT.SEARCH.CODETABLE) (GLOBALVARS TEDIT.SEARCH.CODETABLE)) (FNS \TEDIT.BASICFIND TEDIT.FIND TEDIT.NEW.FIND TEDIT.NEXT \TEDIT.FIND.WC \TEDIT.FIND.WC1 \TEDIT.PACK.TARGETLIST \TEDIT.PARSE.SEARCHSTRING \TEDIT.SUBST.FN1 \TEDIT.SUBST.FN2 TEDIT.SUBSTITUTE)) -) - -(FILESLOAD TEDITDCL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) TEDITDCL) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(RPAQ TEDIT.SEARCH.CODETABLE (\TEDIT.SEARCH.CODETABLE)) -) - - - -(* Read-table Utilities) - -(DEFINEQ - -(\TEDIT.SEARCH.CODETABLE - (LAMBDA NIL (* jds "23-OCT-83 00:58") - (* Build the 16-bit-item "syntax class" - table for searching) - (PROG ((CODETBL (ARRAY 256 'SMALLP 0 0))) - (for I from 0 to 255 do (SETA CODETBL I I)) - - (* Default is that a char maps to itself, and is punctuation.) - - (for CH - in (CHARCODE (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)) - do (SETA CODETBL CH (IPLUS \AlphaNumericFlag \AlphaFlag CH))) - (for CH in (CHARCODE (0 1 2 3 4 5 6 7 8 9)) do (SETA CODETBL CH (IPLUS \AlphaNumericFlag CH - ))) - (for CH in (CHARCODE (%# * @ ! & ~ { })) as CODE - in (LIST \OneCharPattern \AnyStringPattern \OneAlphaPattern \OneNonAlphaPattern - \AnyAlphaPattern \AnyNonAlphaPattern \LeftBracketPattern \RightBracketPattern) - do (SETA CODETBL CH CODE)) - (RETURN CODETBL)))) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.SEARCH.CODETABLE) -) -(DEFINEQ - -(\TEDIT.BASICFIND - [LAMBDA (TEXTOBJ STRING CH# CHLIM) (* ; "Edited 30-May-91 20:56 by jds") - - (* ;; "Search thru TEXTOBJ, starting where the caret is, for the string STRING, exact match only for now. (Optionally, start the search at character ch#.)") - - (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - [TEXTLIM (OR CHLIM (ADD1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) - (NCHARS STRING] - (TEXTSTREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) - (FOUND NIL) - (CH#1 (NTHCHARCODE STRING 1)) - CH1 ANCHOR PCH# OANCHOR CH) - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "2/12/85 JDS: I don't understand WHY this is here, but I'll assume it's right for now.") - (* ; - "Prohibit future insertions in the current piece.") - (COND - ((OR CH# (fetch (SELECTION SET) of SEL))(* ; - "There must be a well-defined starting point.") - (RETURN (PROG NIL - (SETQ CH1 (OR CH# (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (fetch (SELECTION CH#) of SEL)) - (RIGHT (fetch (SELECTION CHLIM) of SEL)) - NIL))) (* ; - "Find the starting point for the search") - (* ; "DO THE SEARCH") - (COND - ((IGREATERP CH1 TEXTLIM) (* ; - "Starting the search past the last possible starting point. Just punt.") - (RETURN NIL))) - (SETQ ANCHOR (SUB1 CH1)) - RETRY - (\SETUPGETCH (ADD1 ANCHOR) - TEXTOBJ) - [for old ANCHOR from (ADD1 ANCHOR) to TEXTLIM - do (SETQ CH (\BIN TEXTSTREAM)) - (COND - ((EQ CH CH#1) - (RETURN] - (COND - ((IGREATERP ANCHOR TEXTLIM) - (RETURN NIL))) (* ; - "No starting character found before end of string") - (SETQ OANCHOR ANCHOR) - (SETQ FOUND T) - [for old CH1 from (ADD1 ANCHOR) to TEXTLIM as PCH# - from 2 to (NCHARS STRING) - do (SETQ CH (\BIN TEXTSTREAM)) - (COND - ((NEQ CH (NTHCHARCODE STRING PCH#)) - (SETQ FOUND NIL) - (RETURN] - (COND - (FOUND (RETURN ANCHOR)) - (T (GO RETRY]) - -(TEDIT.FIND - [LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* ; "Edited 30-May-91 20:56 by jds") - - (* ;; "If WILDCARDS? is NIL then TEDIT.FIND is the old TEDIT.FIND. Else, it returns a list of (SEL.START# SEL.END#) which is the start and end char positions of the selection") - - (LET* - [(TEXTOBJ (TEXTOBJ TEXTOBJ)) - (TEDIT.WILDCARD.CHARACTERS '("#" "*")) - (REAL-END# (OR END# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ] - (AND TARGETSTRING (NOT (STRINGP TARGETSTRING)) - (SETQ TARGETSTRING (MKSTRING TARGETSTRING))) - (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT - THACTION _ 'Find - THAUXINFO _ TARGETSTRING)) - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "Any FIND invalidates the type-in cache.") - (COND - [WILDCARDS? (* ; - "will return a list of start and end of selection or nil if not found") - (PROG (TARGETLIST SEL RESULT RESULT1) - (RETURN (COND - ((OR START# (AND (fetch (SELECTION SET) of (SETQ SEL - (fetch (TEXTOBJ - SEL) - of TEXTOBJ))) - (LEQ (SETQ START# (SELECTQ (fetch (SELECTION POINT) - of SEL) - (LEFT (fetch (SELECTION CH#) - of SEL)) - (RIGHT (fetch (SELECTION CHLIM) - of SEL)) - NIL)) - REAL-END#))) (* ; "START# better be >= to END#") - (COND - ((AND (for X in [SETQ TARGETLIST - (\TEDIT.PARSE.SEARCHSTRING - (for X in (CHCON TARGETSTRING) - collect (MKSTRING (CHARACTER X] - collect X when (LITATOM X)) - (SETQ RESULT1 (\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST START# - REAL-END#))) - (* ; - "If there are atoms, they are tedit wildcard chars") - (\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 REAL-END#)) - (T (* ; "no wildcards but bounded search") - (COND - ((SETQ RESULT (TEDIT.FIND TEXTOBJ (CAR TARGETLIST) - START# REAL-END# NIL)) - (LIST RESULT (SUB1 (IPLUS RESULT (NCHARS (CAR TARGETLIST] - (T (* ; - "will return just the number of the start char or nil if not found") - (LET ((RESULT (\TEDIT.BASICFIND TEXTOBJ TARGETSTRING START# REAL-END#))) - (COND - ((NULL REAL-END#) - RESULT) - ((OR (NULL RESULT) - (GREATERP (IPLUS RESULT (SUB1 (NCHARS TARGETSTRING))) - REAL-END#)) - NIL) - (T RESULT]) - -(TEDIT.NEW.FIND - [LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* ; "Edited 23-Feb-88 11:13 by jds") - - (* ;; "If WILDCARDS? is NIL then TEDIT.NEW.FIND is the old TEDIT.FIND. Else, it returns a list of (SEL.START# SEL.END#) which is the start and end char positions of the selection") - - (* ;; "(PROG ((TEXTSTREAM (fetch STREAMHINT of TEXTOBJ)) PATTERN FIRSTPAT PATTERNSTACK POSNSTACK FIRSTCHAR1 FIRSTCHAR2 FIRSTPATNORMAL PATTERNLEN FOUND PATTERNPOS TEXTPOS) (AND TARGETSTRING (NOT (STRINGP TARGETSTRING)) (SETQ TARGETSTRING (MKSTRING TARGETSTRING))) (SETQ PATTERN (\TEDIT.NEW.PARSE.SEARCHSTRING TARGETSTRING)) (OR PATTERN (RETURN)) (SETQ PATTERNLEN (FLENGTH PATTERN)) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ (QUOTE Find) THAUXINFO _ TARGETSTRING)) (COND ((ZEROP (LOGAND \SpecialPattern (SETQ FIRSTPAT (CAR PATTERN)))) (* The pattern starts with an easy first character) (SETQ FIRSTPATNORMAL T) (SETQ FIRSTCHAR1 (LOGAND \CHARMASK FIRSTPAT)) (COND ((ZEROP (LOGAND \AlphaFlag FIRSTPAT)) (* Not alphabetic) (SETQ FIRSTCHAR2 FIRSTCHAR1)) (T (* Is alphabetic) (SETQ FIRSTCHAR2 (LOGAND FIRSTCHAR1 223)))))) (bind (CH# _ START#) while (ILEQ CH# END#) first (\SETUPGETCH START# TEXTOBJ) do (COND (FIRSTPATNORMAL (* The pattern starts with an easy first character) (COND ((AND (NEQ (SETQ CH (\BIN TEXTSTREAM)) FIRSTCHAR1) (NEW CH FIRSTCHAR2)) (GO $$ITERATE))) (SETQ PATTERNPOS 1) (SETQ CH (\BIN TEXTSTREAM))) (T (SETQ PATTERNPOS 0))) (SETQ TEXTPOS (\TEXTMARK TEXTOBJ)) (COND ((IGEQ PATTERNPOS PATTERNLEN) (SETQ FOUND T) (RETURN)))))") - - (HELP]) - -(TEDIT.NEXT - [LAMBDA (STREAM) (* ; "Edited 30-May-91 20:57 by jds") - (PROG ((TEXTOBJ (TEXTOBJ STREAM)) - TARGET SEL OPTION FIELDSEL) - (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (SETQ TARGET (TEDIT.FIND TEXTOBJ ">>*<<" NIL NIL T)) - (* find the first >>delimited<< - field) - (SETQ FIELDSEL (MBUTTON.FIND.NEXT.FIELD TEXTOBJ (fetch (SELECTION CH#) of SEL))) - (* find the first menu-type - insertion field, usually delimited - with {}) - [SETQ OPTION (COND - [(AND TARGET FIELDSEL) (* take the first one) - (COND - ((IGREATERP (CAR TARGET) - (fetch (SELECTION CH#) of FIELDSEL)) - (* use the {} selection) - 'FIELD) - (T 'TARGET] - (TARGET 'TARGET) - (FIELDSEL 'FIELD) - (T 'NEITHER] - (SELECTQ OPTION - (TARGET (* Found another fill-in) - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION CH#) of SEL with (CAR TARGET)) - (* Set up SELECTION to be the found - text) - (replace (SELECTION CHLIM) of SEL with (ADD1 (CADR TARGET))) - (replace (SELECTION DCH) of SEL with (IDIFFERENCE - (ADD1 (CADR TARGET)) - (CAR TARGET))) - (replace (SELECTION POINT) of SEL with 'RIGHT) - (\TEDIT.SET.SEL.LOOKS SEL 'PENDINGDEL) (* Always selected normally) - (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T) - (* And never pending a deletion.) - (\FIXSEL SEL TEXTOBJ) - (TEDIT.NORMALIZECARET TEXTOBJ) - (\SHOWSEL SEL NIL T) (* And get it into the window) - ) - (FIELD (* Replace the selection for this - textobj with the scratch sel - returned from - MBUTTON.FIND.NEXT.FIELD) - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION CH#) of SEL with (fetch (SELECTION CH#) - of FIELDSEL)) - (* Set up SELECTION to be the found - text) - (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CHLIM) - of FIELDSEL)) - (replace (SELECTION DCH) of SEL with (fetch (SELECTION DCH) - of FIELDSEL)) - (replace (SELECTION POINT) of SEL with 'LEFT) - (\TEDIT.SET.SEL.LOOKS SEL 'PENDINGDEL) - (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T) - (\FIXSEL SEL TEXTOBJ) - (TEDIT.NORMALIZECARET TEXTOBJ) - (\SHOWSEL SEL NIL T) (* And get it into the window) - ) - (NEITHER (TEDIT.PROMPTPRINT TEXTOBJ "No more blanks to fill in." T) - (SETQ SEL NIL)) - (SHOULDNT "No legal value found in selectq in TEDIT.NEXT")) - (COND - (SEL - - (* There really IS a selection made here, so set up the charlooks for it - properly.) - - (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with ( - \TEDIT.GET.INSERT.CHARLOOKS - TEXTOBJ SEL]) - -(\TEDIT.FIND.WC - [LAMBDA (TEXTOBJ TARGETLIST START# END#) (* ; "Edited 9-Dec-88 09:56 by jds") - (* ; - "\TEDIT.FIND.WC returns the end char # of the TARGETLIST which may contain wildcards") - (PROG (RESULT RESULT1) - (RETURN (COND - ((SETQ RESULT (\TEDIT.FIND.WC1 TEXTOBJ TARGETLIST START# END#)) - - (* ;; "SUB1 because NEWFIND.WC2 takes that arg as the Lastchar of the selection so far and so will start on the next char after this") - (* ; "DONE!") - (LIST START# (IMAX START# RESULT))) - (T (AND (SETQ RESULT1 (\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST (ADD1 START#) - END#)) - (\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 END#]) - -(\TEDIT.FIND.WC1 - [LAMBDA (TEXTOBJ TARGETLIST TRIALEND# END#) (* ; "Edited 9-Dec-88 09:52 by jds") - (* ; - "TRIALEND# is where the next char string should go") - (* ; - "\TEDIT.FIND.WC1 should return the lastchar# of selection") - (PROG (RESULT RESULT1) - (RETURN (COND - ((NULL TARGETLIST) (* ; "DONE!") - (SUB1 TRIALEND#)) - [(STRINGP (CAR TARGETLIST)) - (COND - ((SETQ RESULT (TEDIT.FIND TEXTOBJ (CAR TARGETLIST) - TRIALEND# END# NIL)) - (* ; "NOT null") - (\TEDIT.FIND.WC1 TEXTOBJ (CDR TARGETLIST) - (IPLUS RESULT (NCHARS (CAR TARGETLIST))) - END#] - ((LITATOM (CAR TARGETLIST)) - (COND - [(MEMBER (CAR TARGETLIST) - '(%#)) (* ; "fixed width wildcard") - (COND - ((OR (NULL (CDR TARGETLIST)) - (EQUAL (CAR (TEDIT.FIND TEXTOBJ (CONCATLIST ( - \TEDIT.PACK.TARGETLIST - (CDR TARGETLIST))) - (ADD1 TRIALEND#) - END# T)) - (ADD1 TRIALEND#))) (* ; - "If the next start after a fixed char is the char after it, OK. else return nil") - (\TEDIT.FIND.WC1 TEXTOBJ (CDR TARGETLIST) - (ADD1 TRIALEND#) - END#] - (T (* ; "variable width wildcard") - (COND - ((CDR TARGETLIST) - (SETQ RESULT1 (TEDIT.FIND TEXTOBJ (CONCATLIST ( - \TEDIT.PACK.TARGETLIST - (CDR TARGETLIST))) - TRIALEND# END# T)) - (AND RESULT1 (CADR RESULT1))) - (T (* ; "last element of search") - (SUB1 TRIALEND#]) - -(\TEDIT.PACK.TARGETLIST - [LAMBDA (TARGETLIST) (* ; "Edited 24-Sep-87 09:54 by jds") - - (COND - ((NULL TARGETLIST) - NIL) - [(MEMBER (CAR TARGETLIST) - '("#" "*")) - (CONS (CONCAT (CAR TARGETLIST) - (CAR TARGETLIST)) - (\TEDIT.PACK.TARGETLIST (CDR TARGETLIST] - [(STRINGP (CAR TARGETLIST)) - (CONS (CAR TARGETLIST) - (\TEDIT.PACK.TARGETLIST (CDR TARGETLIST] - (T (* ; "wildcard") - - (CONS (MKSTRING (CAR TARGETLIST)) - (\TEDIT.PACK.TARGETLIST (CDR TARGETLIST]) - -(\TEDIT.PARSE.SEARCHSTRING - (LAMBDA (LST RESULT) (* jds "31-Jan-84 13:26") - (PROG ((TEDIT.WILDCARD.CHARACTERS '("#" "*"))) - (RETURN (COND - ((NULL LST) - (COND - (RESULT (LIST RESULT)))) - ((MEMBER (CAR LST) - TEDIT.WILDCARD.CHARACTERS) - (COND - ((NULL RESULT) - (CONS (MKATOM (CAR LST)) - (\TEDIT.PARSE.SEARCHSTRING (CDR LST)))) - (T (APPEND (LIST RESULT (MKATOM (CAR LST))) - (\TEDIT.PARSE.SEARCHSTRING (CDR LST)))))) - ((AND (EQUAL (CAR LST) - "'") - (LISTP (CDR LST)) - (MEMBER (CADR LST) - TEDIT.WILDCARD.CHARACTERS))(* quoting something a wildcard char) - (\TEDIT.PARSE.SEARCHSTRING (CDDR LST) - (COND - ((NULL RESULT) - (MKSTRING (CADR LST))) - (T (CONCAT RESULT (MKSTRING (CADR LST))))))) - (T (\TEDIT.PARSE.SEARCHSTRING (CDR LST) - (COND - ((NULL RESULT) - (CAR LST)) - (T (CONCAT RESULT (CAR LST))))))))))) - -(\TEDIT.SUBST.FN1 - [LAMBDA (TEXTOBJ TARGETLIST START# END#) (* ; "Edited 3-Sep-87 11:38 by jds") - (* ; - "returns the char location that would match the beginning element of a targetlist") - - (PROG (RESULT) - (SETQ RESULT (\TEDIT.SUBST.FN2 TEXTOBJ TARGETLIST START# END#)) - (RETURN (AND RESULT (IGEQ RESULT START#) - RESULT]) - -(\TEDIT.SUBST.FN2 - [LAMBDA (TEXTOBJ TARGETLIST TRIALSTART# END#) (* ; "Edited 9-Dec-88 09:54 by jds") - - (* ;; - "will return the start char of a wildcarded selection. returns NIL if selection is beyond bounds") - - (* ;; "TARGETLIST is (what)?") - - (LET (SUB-FIND-RESULT) - (COND - ((NULL TARGETLIST) - TRIALSTART#) - ((IGREATERP TRIALSTART# END#) - NIL) - [(LITATOM (CAR TARGETLIST)) - (COND - ((EQ (CAR TARGETLIST) - '%#) (* ; "fixed width wildcard") - (AND (SETQ SUB-FIND-RESULT (\TEDIT.SUBST.FN1 TEXTOBJ (CDR TARGETLIST) - (ADD1 TRIALSTART#) - END#)) - (SUB1 SUB-FIND-RESULT))) - (T (* ; - "variable width wildcard, so forget them") - (\TEDIT.SUBST.FN2 TEXTOBJ (CDR TARGETLIST) - TRIALSTART# END#] - (T (* ; "it's a string") - (TEDIT.FIND TEXTOBJ (CAR TARGETLIST) - TRIALSTART# END# NIL]) - -(TEDIT.SUBSTITUTE - [LAMBDA (TEXTSTREAM PATTERN REPLACEMENT CONFIRM?) (* ; "Edited 30-Mar-94 16:04 by jds") - - (* ;; "Replace all instances of PATTERN with REPLACEMENT. If CONFIRM? is non-NIL, ask before each replacement.") - - (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) - (REPLACEDFLG 0) - (YESLIST '("Y" "y" "yes" "YES" "T" "Yes")) - SEARCHSTRING REPLACESTRING ABORTFLG OUTOFRANGEFLG BEGINCHAR# ENDCHAR# STARTCHAR# RANGE - CONFIRMFLG SEL PC# SELCH# SELCHLIM SELPOINT CRSEEN REPLACE-LEN) - (COND - ([NULL (SETQ SEARCHSTRING (OR PATTERN (TEDIT.GETINPUT TEXTOBJ "Search string:" - (TEXTPROP TEXTOBJ - 'TEDIT.LAST.SUBSTITUTE.STRING) - (CHARCODE (EOL LF ESC] - (* ; - "If the search pattern is empty, bail out.") - (TEDIT.PROMPTPRINT TEXTOBJ "[Aborted]") - (RETURN))) - [SETQ REPLACESTRING (OR REPLACEMENT (TEDIT.GETINPUT TEXTOBJ "Replace string:" - (TEXTPROP TEXTOBJ - 'TEDIT.LAST.REPLACEMENT.STRING) - (CHARCODE (EOL LF ESC] - [COND - ((STRINGP REPLACESTRING) - (SETQ REPLACE-LEN (NCHARS REPLACESTRING))) - ((LISTP REPLACESTRING) (* ; - "It's a list of pieces, meaning insert these pieces as the replacement.") - (SETQ REPLACE-LEN (for PC in REPLACESTRING sum (fetch (PIECE PLEN) - of PC] - (SETQ CRSEEN (AND REPLACESTRING (STRINGP REPLACESTRING) - (STRPOS (CHARACTER (CHARCODE CR)) - REPLACESTRING))) - [COND - (PATTERN (* ; - "If a pattern is specd in the call, use the caller's confirm flag.") - (SETQ CONFIRMFLG CONFIRM?)) - (T (* ; "Otherwise, ask for one.") - (SETQ CONFIRMFLG (MEMBER (TEDIT.GETINPUT TEXTOBJ "Ask before each replace?" "No" - (CHARCODE (EOL SPACE ESCAPE LF TAB))) - YESLIST] - (TEDIT.PROMPTPRINT TEXTOBJ "Substituting..." T) - (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))(* ; - "STARTCHAR# and ENDCHAR# are the bound of the search") - (\SHOWSEL SEL NIL NIL) - (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* ; - "Turn off any blue pending delete") - (SETQ BEGINCHAR# (SETQ STARTCHAR# (fetch (SELECTION CH#) of SEL))) - [SETQ ENDCHAR# (IPLUS STARTCHAR# (SUB1 (fetch (SELECTION DCH) of SEL] - (while (AND (SETQ RANGE (TEDIT.FIND TEXTOBJ SEARCHSTRING STARTCHAR# ENDCHAR# T)) - (NOT ABORTFLG)) - do [PROG (PENDING.SEL CHOICE) - (COND - [CONFIRMFLG (SETQ PENDING.SEL (TEDIT.SETSEL TEXTSTREAM (CAR RANGE) - (IDIFFERENCE (CADR RANGE) - (SUB1 (CAR RANGE))) - 'RIGHT T)) - (\SHOWSEL PENDING.SEL NIL NIL) - (TEDIT.NORMALIZECARET TEXTOBJ PENDING.SEL) - (\SHOWSEL PENDING.SEL NIL T) - [SETQ CHOICE (TEDIT.GETINPUT TEXTOBJ "OK to replace? ['q' quits]" - "Yes" (CHARCODE (EOL SPACE ESCAPE LF TAB] - (COND - ((MEMBER CHOICE '("Q" "q")) - (SETQ ABORTFLG T) - (GO L1)) - ((NOT (MEMBER CHOICE YESLIST)) - (* ; "turn off selection") - (TEDIT.SHOWSEL TEXTSTREAM NIL PENDING.SEL) - (GO L1)) - (T (* ; "OK to replace") - (TEDIT.DELETE TEXTSTREAM PENDING.SEL) - (* ; "make the replacement") - -(* ;;;; "This is just wrong in this clause: (COND ((AND REPLACESTRING (NOT (EQUAL REPLACESTRING %"%"))) (* ; %"If the replacestring is nothing, why bother to add nothing%") (TEDIT.INSERT TEXTSTREAM REPLACESTRING (CAR RANGE)) (SETQ ENDCHAR# (IPLUS ENDCHAR# (IDIFFERENCE (NCHARS REPLACESTRING) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE)))))) (add REPLACEDFLG 1)))") - - [AND REPLACESTRING - (OR (IEQP REPLACE-LEN 0) - (COND - ((LISTP REPLACESTRING) - (* ; "INSERT A RUN OF PIECES") - (\TEDIT.INSERT.PIECES - TEXTOBJ - (CAR RANGE) - (for PC in REPLACESTRING - collect (\TEDIT.COPY.PIECEMAPFN PC - TEXTOBJ TEXTOBJ TEXTOBJ - )) - REPLACE-LEN NIL NIL T NIL T) - (add (fetch (TEXTOBJ TEXTLEN) - of TEXTOBJ) - REPLACE-LEN)) - (T (TEDIT.INSERT TEXTSTREAM REPLACESTRING - (CAR RANGE] - [SETQ ENDCHAR# (IPLUS ENDCHAR# - (IDIFFERENCE - (OR (AND REPLACESTRING REPLACE-LEN) - 0) - (IDIFFERENCE (CADR RANGE) - (SUB1 (CAR RANGE] - (add REPLACEDFLG 1] - (T (* ; - "No confirmation required. Do the substitutions without showing intermediate work") - [replace (TEXTOBJ CARETLOOKS) of TEXTOBJ - with (fetch (PIECE PLOOKS) - of (\CHTOPC (CAR RANGE) - (fetch (TEXTOBJ PCTB) of TEXTOBJ - ] - (SETQ PC# (\DELETECH (CAR RANGE) - (ADD1 (CADR RANGE)) - (ADD1 (IDIFFERENCE (CADR RANGE) - (CAR RANGE))) - TEXTOBJ)) - (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) - SEL - (CAR RANGE) - (ADD1 (CADR RANGE)) - TEXTOBJ) - [SETQ ENDCHAR# (IDIFFERENCE ENDCHAR# (IDIFFERENCE (CADR RANGE) - (SUB1 (CAR RANGE] - (* ; - "Take the length of what we're removing off the end-location, so we don't search too far.") - (COND - ((AND REPLACESTRING (NOT (EQUAL REPLACESTRING ""))) - (* ; - "If the replacestring is nothing, why bother to add nothing") - (\FIXILINES TEXTOBJ SEL (CAR RANGE) - REPLACE-LEN - (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (COND - [CRSEEN (for ACHAR instring REPLACESTRING as - NCH# - from (CAR RANGE) by 1 - do (SELCHARQ ACHAR - (CR (\INSERTCR ACHAR NCH# TEXTOBJ)) - (\INSERTCH ACHAR NCH# TEXTOBJ] - ((LISTP REPLACESTRING)(* ; "INSERT A RUN OF PIECES") - (\TEDIT.INSERT.PIECES TEXTOBJ (CAR RANGE) - (for PC in REPLACESTRING - collect (\TEDIT.COPY.PIECEMAPFN PC TEXTOBJ - TEXTOBJ TEXTOBJ)) - REPLACE-LEN NIL NIL T NIL T) - (add (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) - REPLACE-LEN)) - (T (\INSERTCH REPLACESTRING (CAR RANGE) - TEXTOBJ))) - (SETQ ENDCHAR# (IPLUS ENDCHAR# REPLACE-LEN)) - (* ; - "Now add the length of the replacement string into the ending position, so we go far enough.") - )) - (add REPLACEDFLG 1))) - [SETQ STARTCHAR# (COND - (REPLACESTRING (IPLUS (CAR RANGE) - REPLACE-LEN)) - (T (CAR RANGE] - (RETURN) - L1 - - (* ;; - "12/12/88 Should only look at REPLACESTRING when there has been a replacement.") - - (SETQ STARTCHAR# (ADD1 (CAR RANGE] (* ; - "start looking where you left off")) - - (* ;; "Save the search & replacement strings to offer for next time:") - - (TEXTPROP TEXTOBJ 'TEDIT.LAST.SUBSTITUTE.STRING SEARCHSTRING) - (TEXTPROP TEXTOBJ 'TEDIT.LAST.REPLACEMENT.STRING REPLACESTRING) - - (* ;; "Print the message that says how many substitutions got made:") - - (COND - ((ZEROP REPLACEDFLG) - (TEDIT.PROMPTPRINT TEXTOBJ "No replacements made." T)) - ((EQUAL REPLACEDFLG 1) - (TEDIT.PROMPTPRINT TEXTOBJ "1 Replacement made." T)) - (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (MKSTRING REPLACEDFLG) - " Replacements made.") - T))) - - (* ;; "Update the current selection:") - - (COND - ((AND (NOT CONFIRMFLG) - (NOT (ZEROP REPLACEDFLG))) (* ; - "There WERE replacements, and they were not confirmed.") - (replace (SELECTION CHLIM) of SEL with (ADD1 ENDCHAR#)) - (* ; - "account for the changes in selection length due to replacements") - (replace (SELECTION CH#) of SEL with BEGINCHAR#) - (* ; "And remember where it started") - (replace (SELECTION DCH) of SEL with (IDIFFERENCE (fetch (SELECTION - CHLIM) - of SEL) - (fetch (SELECTION CH#) - of SEL))) - (\TEDIT.MARK.LINES.DIRTY TEXTOBJ (fetch (SELECTION CH#) of SEL) - (fetch (SELECTION CHLIM) of SEL)) - (TEDIT.UPDATE.SCREEN TEXTOBJ) - (\FIXSEL SEL TEXTOBJ) - (\SHOWSEL SEL NIL T))) - (RETURN REPLACEDFLG]) -) -(PUTPROPS TEDITFIND COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 -1991 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1314 2661 (\TEDIT.SEARCH.CODETABLE 1324 . 2659)) (2736 39449 (\TEDIT.BASICFIND 2746 . -6327) (TEDIT.FIND 6329 . 10573) (TEDIT.NEW.FIND 10575 . 12205) (TEDIT.NEXT 12207 . 17204) ( -\TEDIT.FIND.WC 17206 . 18181) (\TEDIT.FIND.WC1 18183 . 21162) (\TEDIT.PACK.TARGETLIST 21164 . 21859) ( -\TEDIT.PARSE.SEARCHSTRING 21861 . 23438) (\TEDIT.SUBST.FN1 23440 . 23927) (\TEDIT.SUBST.FN2 23929 . -25305) (TEDIT.SUBSTITUTE 25307 . 39447))))) -STOP diff --git a/library/TEDITFNKEYS.~2~ b/library/TEDITFNKEYS.~2~ deleted file mode 100644 index 8d0b269a..00000000 --- a/library/TEDITFNKEYS.~2~ +++ /dev/null @@ -1,162 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Aug-94 10:53:59" {DSK}export>lispcore>library>TEDITFNKEYS.;2 26541 - - changes to%: (VARS TEDITFNKEYSCOMS) (FILES TEDITDCL) - - previous date%: "30-May-91 21:11:34" {DSK}export>lispcore>library>TEDITFNKEYS.;1) - - -(* ; " -Copyright (c) 1985, 1986, 1987, 1990, 1991, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITFNKEYSCOMS) - -(RPAQQ TEDITFNKEYSCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "Functions that actually implement the commands for the function keys:") (FNS \TEDIT.BOLD.SEL.OFF \TEDIT.BOLD.SEL.ON \TEDIT.CENTER.SEL \TEDIT.CENTER.SEL.REV \TEDIT.DEFAULTS.CARET \TEDIT.DEFAULTSSEL \TEDIT.SETDEFAULT.FROM.SEL \TEDIT.FIND \TEDIT.ITALIC.SEL.OFF \TEDIT.ITALIC.SEL.ON \TEDIT.LARGERSEL \TEDIT.LCASE.SEL \TEDIT.SHOWCARETLOOKS \TEDIT.SMALLERSEL \TEDIT.SUBSCRIPTSEL \TEDIT.SUPERSCRIPTSEL \TEDIT.UCASE.SEL \TEDIT.UNDERLINE.SEL.OFF \TEDIT.UNDERLINE.SEL.ON \TEDIT.STRIKEOUT.SEL.ON \TEDIT.STRIKEOUT.SEL.OFF)) (COMS (* ;; "Auxiliary functions used in the above main functions:") (FNS \TEDIT.BOLD.CARET.OFF \TEDIT.BOLD.CARET.ON \TEDIT.ITALIC.CARET.OFF \TEDIT.ITALIC.CARET.ON \TEDIT.LARGER.CARET \TEDIT.SMALLER.CARET \TEDIT.SUBSCRIPT.CARET \TEDIT.SUPERSCRIPT.CARET \TEDIT.UNDERLINE.CARET.OFF \TEDIT.UNDERLINE.CARET.ON \TEDIT.STRIKEOUT.CARET.OFF \TEDIT.STRIKEOUT.CARET.ON)) (COMS (* ; "little selection utilities etc., for building hacks") (FNS \SEL.LIMIT \SEL.LINEDESC \TK.DESCRIBEFONT \PARAS.IN.SEL)) (VARS (TEDIT.FNKEY.VERBOSE T) (\TEDIT.KEYS (QUOTE (("2,4" UNDO) ("2,44" UNDO) ("2,3" FN \TEDIT.FIND) ("2,43" FN \TEDIT.FIND) ("2,10" REDO) ("2,50" REDO) ("2,22" NEXT) ("2,62" NEXT) (ESC EXPAND) ("2,24" EXPAND) ("2,101" FN \TEDIT.CENTER.SEL) ("2,141" FN \TEDIT.CENTER.SEL.REV) ("2,102" FN \TEDIT.BOLD.SEL.ON) ("2,142" FN \TEDIT.BOLD.SEL.OFF) ("2,103" FN \TEDIT.ITALIC.SEL.ON) ("2,143" FN \TEDIT.ITALIC.SEL.OFF) ("2,104" FN \TEDIT.UCASE.SEL) ("2,144" FN \TEDIT.LCASE.SEL) ("2,105" FN \TEDIT.STRIKEOUT.SEL.ON) ("2,145" FN \TEDIT.STRIKEOUT.SEL.OFF) ("2,106" FN \TEDIT.UNDERLINE.SEL.ON) ("2,146" FN \TEDIT.UNDERLINE.SEL.OFF) ("2,107" FN \TEDIT.SUBSCRIPTSEL) ("2,147" FN \TEDIT.SUPERSCRIPTSEL) ("2,110" FN \TEDIT.SMALLERSEL) ("2,150" FN \TEDIT.LARGERSEL) ("2,113" FN \TEDIT.SUPERSCRIPTSEL) ("2,153" FN \TEDIT.SUBSCRIPTSEL) ("2,114" FN \TEDIT.SUBSCRIPTSEL) ("2,154" FN \TEDIT.SUPERSCRIPTSEL) ("2,115" FN \TEDIT.DEFAULTSSEL) ("2,155" FN \TEDIT.SETDEFAULT.FROM.SEL) ("2,1" FN \TEDIT.SHOWCARETLOOKS))))) (P (MAPC \TEDIT.KEYS (FUNCTION (LAMBDA (ENTRY) (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))))) (* ; "Original was %"(FOR ENTRY IN \TEDIT.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))%".") (* ; "Changed by yabu.fx, for SUNLOADUP without DWIM.")) -) - -(FILESLOAD TEDITDCL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) TEDITDCL) -) - - - -(* ;; "Functions that actually implement the commands for the function keys:") - -(DEFINEQ - -(\TEDIT.BOLD.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* ; "Edited 6-Nov-87 11:00 by jds") (* ;; "Turn boldness off for the selected characters, and for future type-in.") (\TEDIT.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL]) - -(\TEDIT.BOLD.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 6-Nov-87 11:00 by jds") (* ;; "Turn boldness on for selected characters and for future type-in.") (\TEDIT.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL]) - -(\TEDIT.CENTER.SEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "makes the current paragraph centered") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (fetch (SELECTION CH#) of SEL)) (SAVEDCH (fetch (SELECTION DCH) of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) - -(\TEDIT.CENTER.SEL.REV [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "acts like center.sel but cycles in the opposite direction") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (fetch (SELECTION CH#) of SEL)) (SAVEDCH (fetch (SELECTION DCH) of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) - -(\TEDIT.DEFAULTS.CARET (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds "21-Sep-85 11:24") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS)) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)))) - -(\TEDIT.DEFAULTSSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:12 by jds") (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS) SEL]) - -(\TEDIT.SETDEFAULT.FROM.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds " 8-Nov-85 15:22") (* Set the defaults from the current  selection.) (PROG ((LOOKS (TEDIT.GET.LOOKS TEXTSTREAM SEL))) (SETQ TEDIT.DEFAULT.CHARLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST LOOKS))))) - -(\TEDIT.FIND [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* just calls the normal tedit.find  starting at the right of the current  selection) (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* Case sensitive search, with * and  %# wildcards) [SETQ W (CAR (MKLIST (fetch (TEXTOBJ \WINDOW) of TEXTOBJ] [SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC] [COND (TARGET (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* We found the target text.) (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (replace (SELECTION CH#) of SEL with (CAR CH)) (* Set up SELECTION to be the found  text) (replace (SELECTION CHLIM) of SEL with (ADD1 (CADR CH))) [replace (SELECTION DCH) of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH] (replace (SELECTION POINT) of SEL with 'RIGHT) (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with ( \TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* And get it into the window) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\SHOWSEL SEL NIL T] (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with -1]) - -(\TEDIT.ITALIC.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* ; "Edited 20-Oct-87 10:43 by jds") (\TEDIT.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL]) - -(\TEDIT.ITALIC.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 10:43 by jds") (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL]) - -(\TEDIT.LARGERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\TEDIT.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT 2) SEL))))) - -(\TEDIT.LCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "LOWER-CASEs the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch (SELECTION CH#) of SEL)) (LEN (fetch (SELECTION DCH) of SEL)) (POINT (fetch (SELECTION POINT) of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (replace (TEDITHISTORYEVENT THACTION) of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with 'LowerCase]) - -(\TEDIT.SHOWCARETLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:09 by jds") (* * comment) (PROG ((LOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\TK.DESCRIBEFONT (fetch (CHARLOOKS CLFONT) of LOOKS)) (COND ((AND (fetch (CHARLOOKS CLOFFSET) of LOOKS) (NEQ (fetch (CHARLOOKS CLOFFSET) of LOOKS) 0)) (CONCAT " offset " (fetch (CHARLOOKS CLOFFSET) of LOOKS))) (T "")) (COND ((fetch (CHARLOOKS CLOLINE) of LOOKS) " overlined") (T "")) (COND ((fetch (CHARLOOKS CLULINE) of LOOKS) " underlined") (T ""))) T) (RETURN]) - -(\TEDIT.SMALLERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\TEDIT.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT -2) SEL))))) - -(\TEDIT.SUBSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:12 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT -2) SEL]) - -(\TEDIT.SUPERSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:13 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT 2) SEL]) - -(\TEDIT.UCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ; "uppercasifies the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch (SELECTION CH#) of SEL)) (LEN (fetch (SELECTION DCH) of SEL)) (POINT (fetch (SELECTION POINT) of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (replace (TEDITHISTORYEVENT THACTION) of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with 'UpperCase]) - -(\TEDIT.UNDERLINE.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:26 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL]) - -(\TEDIT.UNDERLINE.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL]) - -(\TEDIT.STRIKEOUT.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT ON) SEL]) - -(\TEDIT.STRIKEOUT.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT OFF) SEL]) -) - - - -(* ;; "Auxiliary functions used in the above main functions:") - -(DEFINEQ - -(\TEDIT.BOLD.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(WEIGHT MEDIUM) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.BOLD.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(WEIGHT BOLD) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.ITALIC.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SLOPE REGULAR) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.ITALIC.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SLOPE ITALIC) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.LARGER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SIZEINCREMENT 2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.SMALLER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SIZEINCREMENT -2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.SUBSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(OFFSETINCREMENT -2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.SUPERSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(OFFSETINCREMENT 2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.UNDERLINE.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(UNDERLINE OFF) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.UNDERLINE.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(UNDERLINE ON) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.STRIKEOUT.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(STRIKEOUT OFF) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.STRIKEOUT.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(STRIKEOUT ON) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) -) - - - -(* ; "little selection utilities etc., for building hacks") - -(DEFINEQ - -(\SEL.LIMIT [LAMBDA (SEL) (* ; "Edited 30-May-91 21:06 by jds") (* returns the character that delimits this selection.  The first char if the point is left else the last) (COND ((EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (fetch (SELECTION CH#) of SEL)) (T (SUB1 (fetch (SELECTION CHLIM) of SEL]) - -(\SEL.LINEDESC [LAMBDA (SEL) (* ; "Edited 30-May-91 21:06 by jds") (* returns the first line descriptor  if the point is left, otherwise the  last) (COND [(EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (CAR (MKLIST (fetch (SELECTION L1) of SEL] (T (CAR (MKLIST (fetch (SELECTION LN) of SEL]) - -(\TK.DESCRIBEFONT (LAMBDA (FONT) (* gbn "15-Dec-84 17:54") (* * returns a string which describes a font  (in short. If it's not italic then no mention is made of slope, etc.)) (CONCAT (L-CASE (FONTPROP FONT 'FAMILY)) " " (FONTPROP FONT 'SIZE) (COND ((NEQ (FONTPROP FONT 'WEIGHT) 'MEDIUM) (CONCAT " " (L-CASE (FONTPROP FONT 'WEIGHT)))) (T "")) (COND ((NEQ (FONTPROP FONT 'SLOPE) 'REGULAR) (CONCAT " " (L-CASE (FONTPROP FONT 'SLOPE)))) (T ""))))) - -(\PARAS.IN.SEL [LAMBDA (SEL TEXTOBJ) (* ; "Edited 30-May-91 21:06 by jds") (* returns a list which contains one character number for each paragraph  included in the selection) (PROG ((PARAS) PARAENDED PCS (POS (fetch (SELECTION CH#) of SEL))) (COND ((ZEROP (fetch (SELECTION DCH) of SEL)) (* there are not really any pieces in this selection, however, effect the  change to the para containing this selection by starting the selection one  character earlier. This is not the right soln, but TEdit has no looks on the  empty last para as yet.) (replace (SELECTION CH#) of SEL with (IDIFFERENCE (fetch (SELECTION CH#) of SEL) 1)) (replace (SELECTION DCH) of SEL with 1) (\FIXSEL SEL TEXTOBJ))) (SETQ PCS (TEDIT.SELECTED.PIECES TEXTOBJ SEL)) (* to include the first char) (SETQ PARAENDED T) (for PC in PCS do (COND (PARAENDED (* the last piece ended a paragraph,  so include this character in the  list) (SETQ PARAENDED NIL) (push PARAS POS))) (SETQ PARAENDED (fetch (PIECE PPARALAST) of PC)) (add POS (fetch (PIECE PLEN) of PC))) (RETURN (DREVERSE PARAS]) -) - -(RPAQQ TEDIT.FNKEY.VERBOSE T) - -(RPAQQ \TEDIT.KEYS (("2,4" UNDO) ("2,44" UNDO) ("2,3" FN \TEDIT.FIND) ("2,43" FN \TEDIT.FIND) ("2,10" REDO) ("2,50" REDO) ("2,22" NEXT) ("2,62" NEXT) (ESC EXPAND) ("2,24" EXPAND) ("2,101" FN \TEDIT.CENTER.SEL) ("2,141" FN \TEDIT.CENTER.SEL.REV) ("2,102" FN \TEDIT.BOLD.SEL.ON) ("2,142" FN \TEDIT.BOLD.SEL.OFF) ("2,103" FN \TEDIT.ITALIC.SEL.ON) ("2,143" FN \TEDIT.ITALIC.SEL.OFF) ("2,104" FN \TEDIT.UCASE.SEL) ("2,144" FN \TEDIT.LCASE.SEL) ("2,105" FN \TEDIT.STRIKEOUT.SEL.ON) ("2,145" FN \TEDIT.STRIKEOUT.SEL.OFF) ("2,106" FN \TEDIT.UNDERLINE.SEL.ON) ("2,146" FN \TEDIT.UNDERLINE.SEL.OFF) ("2,107" FN \TEDIT.SUBSCRIPTSEL) ("2,147" FN \TEDIT.SUPERSCRIPTSEL) ("2,110" FN \TEDIT.SMALLERSEL) ("2,150" FN \TEDIT.LARGERSEL) ("2,113" FN \TEDIT.SUPERSCRIPTSEL) ("2,153" FN \TEDIT.SUBSCRIPTSEL) ("2,114" FN \TEDIT.SUBSCRIPTSEL) ("2,154" FN \TEDIT.SUPERSCRIPTSEL) ("2,115" FN \TEDIT.DEFAULTSSEL) ("2,155" FN \TEDIT.SETDEFAULT.FROM.SEL) ("2,1" FN \TEDIT.SHOWCARETLOOKS)) -) - -(MAPC \TEDIT.KEYS (FUNCTION (LAMBDA (ENTRY) (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY)))))) - - - -(* ; -"Original was %"(FOR ENTRY IN \TEDIT.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))%"." -) - - - - -(* ; "Changed by yabu.fx, for SUNLOADUP without DWIM.") - -(PUTPROPS TEDITFNKEYS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3284 15682 (\TEDIT.BOLD.SEL.OFF 3294 . 3633) (\TEDIT.BOLD.SEL.ON 3635 . 3964) ( -\TEDIT.CENTER.SEL 3966 . 5021) (\TEDIT.CENTER.SEL.REV 5023 . 6103) (\TEDIT.DEFAULTS.CARET 6105 . 6389) - (\TEDIT.DEFAULTSSEL 6391 . 6714) (\TEDIT.SETDEFAULT.FROM.SEL 6716 . 7155) (\TEDIT.FIND 7157 . 10281) -(\TEDIT.ITALIC.SEL.OFF 10283 . 10525) (\TEDIT.ITALIC.SEL.ON 10527 . 10710) (\TEDIT.LARGERSEL 10712 . -11007) (\TEDIT.LCASE.SEL 11009 . 11760) (\TEDIT.SHOWCARETLOOKS 11762 . 13402) (\TEDIT.SMALLERSEL 13404 - . 13702) (\TEDIT.SUBSCRIPTSEL 13704 . 13908) (\TEDIT.SUPERSCRIPTSEL 13910 . 14115) (\TEDIT.UCASE.SEL -14117 . 14924) (\TEDIT.UNDERLINE.SEL.OFF 14926 . 15114) (\TEDIT.UNDERLINE.SEL.ON 15116 . 15302) ( -\TEDIT.STRIKEOUT.SEL.ON 15304 . 15490) (\TEDIT.STRIKEOUT.SEL.OFF 15492 . 15680)) (15754 21194 ( -\TEDIT.BOLD.CARET.OFF 15764 . 16212) (\TEDIT.BOLD.CARET.ON 16214 . 16659) (\TEDIT.ITALIC.CARET.OFF -16661 . 17111) (\TEDIT.ITALIC.CARET.ON 17113 . 17561) (\TEDIT.LARGER.CARET 17563 . 18011) ( -\TEDIT.SMALLER.CARET 18013 . 18463) (\TEDIT.SUBSCRIPT.CARET 18465 . 18919) (\TEDIT.SUPERSCRIPT.CARET -18921 . 19376) (\TEDIT.UNDERLINE.CARET.OFF 19378 . 19831) (\TEDIT.UNDERLINE.CARET.ON 19833 . 20284) ( -\TEDIT.STRIKEOUT.CARET.OFF 20286 . 20739) (\TEDIT.STRIKEOUT.CARET.ON 20741 . 21192)) (21263 25011 ( -\SEL.LIMIT 21273 . 21711) (\SEL.LINEDESC 21713 . 22309) (\TK.DESCRIBEFONT 22311 . 23026) ( -\PARAS.IN.SEL 23028 . 25009))))) -STOP diff --git a/library/TEDITFNKEYS.~3~ b/library/TEDITFNKEYS.~3~ deleted file mode 100644 index 8d0b269a..00000000 --- a/library/TEDITFNKEYS.~3~ +++ /dev/null @@ -1,162 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Aug-94 10:53:59" {DSK}export>lispcore>library>TEDITFNKEYS.;2 26541 - - changes to%: (VARS TEDITFNKEYSCOMS) (FILES TEDITDCL) - - previous date%: "30-May-91 21:11:34" {DSK}export>lispcore>library>TEDITFNKEYS.;1) - - -(* ; " -Copyright (c) 1985, 1986, 1987, 1990, 1991, 1994 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITFNKEYSCOMS) - -(RPAQQ TEDITFNKEYSCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "Functions that actually implement the commands for the function keys:") (FNS \TEDIT.BOLD.SEL.OFF \TEDIT.BOLD.SEL.ON \TEDIT.CENTER.SEL \TEDIT.CENTER.SEL.REV \TEDIT.DEFAULTS.CARET \TEDIT.DEFAULTSSEL \TEDIT.SETDEFAULT.FROM.SEL \TEDIT.FIND \TEDIT.ITALIC.SEL.OFF \TEDIT.ITALIC.SEL.ON \TEDIT.LARGERSEL \TEDIT.LCASE.SEL \TEDIT.SHOWCARETLOOKS \TEDIT.SMALLERSEL \TEDIT.SUBSCRIPTSEL \TEDIT.SUPERSCRIPTSEL \TEDIT.UCASE.SEL \TEDIT.UNDERLINE.SEL.OFF \TEDIT.UNDERLINE.SEL.ON \TEDIT.STRIKEOUT.SEL.ON \TEDIT.STRIKEOUT.SEL.OFF)) (COMS (* ;; "Auxiliary functions used in the above main functions:") (FNS \TEDIT.BOLD.CARET.OFF \TEDIT.BOLD.CARET.ON \TEDIT.ITALIC.CARET.OFF \TEDIT.ITALIC.CARET.ON \TEDIT.LARGER.CARET \TEDIT.SMALLER.CARET \TEDIT.SUBSCRIPT.CARET \TEDIT.SUPERSCRIPT.CARET \TEDIT.UNDERLINE.CARET.OFF \TEDIT.UNDERLINE.CARET.ON \TEDIT.STRIKEOUT.CARET.OFF \TEDIT.STRIKEOUT.CARET.ON)) (COMS (* ; "little selection utilities etc., for building hacks") (FNS \SEL.LIMIT \SEL.LINEDESC \TK.DESCRIBEFONT \PARAS.IN.SEL)) (VARS (TEDIT.FNKEY.VERBOSE T) (\TEDIT.KEYS (QUOTE (("2,4" UNDO) ("2,44" UNDO) ("2,3" FN \TEDIT.FIND) ("2,43" FN \TEDIT.FIND) ("2,10" REDO) ("2,50" REDO) ("2,22" NEXT) ("2,62" NEXT) (ESC EXPAND) ("2,24" EXPAND) ("2,101" FN \TEDIT.CENTER.SEL) ("2,141" FN \TEDIT.CENTER.SEL.REV) ("2,102" FN \TEDIT.BOLD.SEL.ON) ("2,142" FN \TEDIT.BOLD.SEL.OFF) ("2,103" FN \TEDIT.ITALIC.SEL.ON) ("2,143" FN \TEDIT.ITALIC.SEL.OFF) ("2,104" FN \TEDIT.UCASE.SEL) ("2,144" FN \TEDIT.LCASE.SEL) ("2,105" FN \TEDIT.STRIKEOUT.SEL.ON) ("2,145" FN \TEDIT.STRIKEOUT.SEL.OFF) ("2,106" FN \TEDIT.UNDERLINE.SEL.ON) ("2,146" FN \TEDIT.UNDERLINE.SEL.OFF) ("2,107" FN \TEDIT.SUBSCRIPTSEL) ("2,147" FN \TEDIT.SUPERSCRIPTSEL) ("2,110" FN \TEDIT.SMALLERSEL) ("2,150" FN \TEDIT.LARGERSEL) ("2,113" FN \TEDIT.SUPERSCRIPTSEL) ("2,153" FN \TEDIT.SUBSCRIPTSEL) ("2,114" FN \TEDIT.SUBSCRIPTSEL) ("2,154" FN \TEDIT.SUPERSCRIPTSEL) ("2,115" FN \TEDIT.DEFAULTSSEL) ("2,155" FN \TEDIT.SETDEFAULT.FROM.SEL) ("2,1" FN \TEDIT.SHOWCARETLOOKS))))) (P (MAPC \TEDIT.KEYS (FUNCTION (LAMBDA (ENTRY) (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))))) (* ; "Original was %"(FOR ENTRY IN \TEDIT.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))%".") (* ; "Changed by yabu.fx, for SUNLOADUP without DWIM.")) -) - -(FILESLOAD TEDITDCL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) TEDITDCL) -) - - - -(* ;; "Functions that actually implement the commands for the function keys:") - -(DEFINEQ - -(\TEDIT.BOLD.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* ; "Edited 6-Nov-87 11:00 by jds") (* ;; "Turn boldness off for the selected characters, and for future type-in.") (\TEDIT.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL]) - -(\TEDIT.BOLD.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 6-Nov-87 11:00 by jds") (* ;; "Turn boldness on for selected characters and for future type-in.") (\TEDIT.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL]) - -(\TEDIT.CENTER.SEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "makes the current paragraph centered") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (fetch (SELECTION CH#) of SEL)) (SAVEDCH (fetch (SELECTION DCH) of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) - -(\TEDIT.CENTER.SEL.REV [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "acts like center.sel but cycles in the opposite direction") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (fetch (SELECTION CH#) of SEL)) (SAVEDCH (fetch (SELECTION DCH) of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) - -(\TEDIT.DEFAULTS.CARET (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds "21-Sep-85 11:24") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS)) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)))) - -(\TEDIT.DEFAULTSSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:12 by jds") (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS) SEL]) - -(\TEDIT.SETDEFAULT.FROM.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds " 8-Nov-85 15:22") (* Set the defaults from the current  selection.) (PROG ((LOOKS (TEDIT.GET.LOOKS TEXTSTREAM SEL))) (SETQ TEDIT.DEFAULT.CHARLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST LOOKS))))) - -(\TEDIT.FIND [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* just calls the normal tedit.find  starting at the right of the current  selection) (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* Case sensitive search, with * and  %# wildcards) [SETQ W (CAR (MKLIST (fetch (TEXTOBJ \WINDOW) of TEXTOBJ] [SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC] [COND (TARGET (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* We found the target text.) (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (replace (SELECTION CH#) of SEL with (CAR CH)) (* Set up SELECTION to be the found  text) (replace (SELECTION CHLIM) of SEL with (ADD1 (CADR CH))) [replace (SELECTION DCH) of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH] (replace (SELECTION POINT) of SEL with 'RIGHT) (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with ( \TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* And get it into the window) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\SHOWSEL SEL NIL T] (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with -1]) - -(\TEDIT.ITALIC.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* ; "Edited 20-Oct-87 10:43 by jds") (\TEDIT.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL]) - -(\TEDIT.ITALIC.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 10:43 by jds") (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL]) - -(\TEDIT.LARGERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\TEDIT.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT 2) SEL))))) - -(\TEDIT.LCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "LOWER-CASEs the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch (SELECTION CH#) of SEL)) (LEN (fetch (SELECTION DCH) of SEL)) (POINT (fetch (SELECTION POINT) of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (replace (TEDITHISTORYEVENT THACTION) of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with 'LowerCase]) - -(\TEDIT.SHOWCARETLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:09 by jds") (* * comment) (PROG ((LOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\TK.DESCRIBEFONT (fetch (CHARLOOKS CLFONT) of LOOKS)) (COND ((AND (fetch (CHARLOOKS CLOFFSET) of LOOKS) (NEQ (fetch (CHARLOOKS CLOFFSET) of LOOKS) 0)) (CONCAT " offset " (fetch (CHARLOOKS CLOFFSET) of LOOKS))) (T "")) (COND ((fetch (CHARLOOKS CLOLINE) of LOOKS) " overlined") (T "")) (COND ((fetch (CHARLOOKS CLULINE) of LOOKS) " underlined") (T ""))) T) (RETURN]) - -(\TEDIT.SMALLERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* jds "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\TEDIT.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT -2) SEL))))) - -(\TEDIT.SUBSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:12 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT -2) SEL]) - -(\TEDIT.SUPERSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:13 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT 2) SEL]) - -(\TEDIT.UCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ; "uppercasifies the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch (SELECTION CH#) of SEL)) (LEN (fetch (SELECTION DCH) of SEL)) (POINT (fetch (SELECTION POINT) of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (replace (TEDITHISTORYEVENT THACTION) of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with 'UpperCase]) - -(\TEDIT.UNDERLINE.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:26 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL]) - -(\TEDIT.UNDERLINE.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL]) - -(\TEDIT.STRIKEOUT.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT ON) SEL]) - -(\TEDIT.STRIKEOUT.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT OFF) SEL]) -) - - - -(* ;; "Auxiliary functions used in the above main functions:") - -(DEFINEQ - -(\TEDIT.BOLD.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(WEIGHT MEDIUM) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.BOLD.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(WEIGHT BOLD) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.ITALIC.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SLOPE REGULAR) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.ITALIC.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SLOPE ITALIC) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.LARGER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SIZEINCREMENT 2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.SMALLER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SIZEINCREMENT -2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.SUBSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(OFFSETINCREMENT -2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.SUPERSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(OFFSETINCREMENT 2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.UNDERLINE.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(UNDERLINE OFF) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.UNDERLINE.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(UNDERLINE ON) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.STRIKEOUT.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(STRIKEOUT OFF) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) - -(\TEDIT.STRIKEOUT.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(STRIKEOUT ON) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) -) - - - -(* ; "little selection utilities etc., for building hacks") - -(DEFINEQ - -(\SEL.LIMIT [LAMBDA (SEL) (* ; "Edited 30-May-91 21:06 by jds") (* returns the character that delimits this selection.  The first char if the point is left else the last) (COND ((EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (fetch (SELECTION CH#) of SEL)) (T (SUB1 (fetch (SELECTION CHLIM) of SEL]) - -(\SEL.LINEDESC [LAMBDA (SEL) (* ; "Edited 30-May-91 21:06 by jds") (* returns the first line descriptor  if the point is left, otherwise the  last) (COND [(EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (CAR (MKLIST (fetch (SELECTION L1) of SEL] (T (CAR (MKLIST (fetch (SELECTION LN) of SEL]) - -(\TK.DESCRIBEFONT (LAMBDA (FONT) (* gbn "15-Dec-84 17:54") (* * returns a string which describes a font  (in short. If it's not italic then no mention is made of slope, etc.)) (CONCAT (L-CASE (FONTPROP FONT 'FAMILY)) " " (FONTPROP FONT 'SIZE) (COND ((NEQ (FONTPROP FONT 'WEIGHT) 'MEDIUM) (CONCAT " " (L-CASE (FONTPROP FONT 'WEIGHT)))) (T "")) (COND ((NEQ (FONTPROP FONT 'SLOPE) 'REGULAR) (CONCAT " " (L-CASE (FONTPROP FONT 'SLOPE)))) (T ""))))) - -(\PARAS.IN.SEL [LAMBDA (SEL TEXTOBJ) (* ; "Edited 30-May-91 21:06 by jds") (* returns a list which contains one character number for each paragraph  included in the selection) (PROG ((PARAS) PARAENDED PCS (POS (fetch (SELECTION CH#) of SEL))) (COND ((ZEROP (fetch (SELECTION DCH) of SEL)) (* there are not really any pieces in this selection, however, effect the  change to the para containing this selection by starting the selection one  character earlier. This is not the right soln, but TEdit has no looks on the  empty last para as yet.) (replace (SELECTION CH#) of SEL with (IDIFFERENCE (fetch (SELECTION CH#) of SEL) 1)) (replace (SELECTION DCH) of SEL with 1) (\FIXSEL SEL TEXTOBJ))) (SETQ PCS (TEDIT.SELECTED.PIECES TEXTOBJ SEL)) (* to include the first char) (SETQ PARAENDED T) (for PC in PCS do (COND (PARAENDED (* the last piece ended a paragraph,  so include this character in the  list) (SETQ PARAENDED NIL) (push PARAS POS))) (SETQ PARAENDED (fetch (PIECE PPARALAST) of PC)) (add POS (fetch (PIECE PLEN) of PC))) (RETURN (DREVERSE PARAS]) -) - -(RPAQQ TEDIT.FNKEY.VERBOSE T) - -(RPAQQ \TEDIT.KEYS (("2,4" UNDO) ("2,44" UNDO) ("2,3" FN \TEDIT.FIND) ("2,43" FN \TEDIT.FIND) ("2,10" REDO) ("2,50" REDO) ("2,22" NEXT) ("2,62" NEXT) (ESC EXPAND) ("2,24" EXPAND) ("2,101" FN \TEDIT.CENTER.SEL) ("2,141" FN \TEDIT.CENTER.SEL.REV) ("2,102" FN \TEDIT.BOLD.SEL.ON) ("2,142" FN \TEDIT.BOLD.SEL.OFF) ("2,103" FN \TEDIT.ITALIC.SEL.ON) ("2,143" FN \TEDIT.ITALIC.SEL.OFF) ("2,104" FN \TEDIT.UCASE.SEL) ("2,144" FN \TEDIT.LCASE.SEL) ("2,105" FN \TEDIT.STRIKEOUT.SEL.ON) ("2,145" FN \TEDIT.STRIKEOUT.SEL.OFF) ("2,106" FN \TEDIT.UNDERLINE.SEL.ON) ("2,146" FN \TEDIT.UNDERLINE.SEL.OFF) ("2,107" FN \TEDIT.SUBSCRIPTSEL) ("2,147" FN \TEDIT.SUPERSCRIPTSEL) ("2,110" FN \TEDIT.SMALLERSEL) ("2,150" FN \TEDIT.LARGERSEL) ("2,113" FN \TEDIT.SUPERSCRIPTSEL) ("2,153" FN \TEDIT.SUBSCRIPTSEL) ("2,114" FN \TEDIT.SUBSCRIPTSEL) ("2,154" FN \TEDIT.SUPERSCRIPTSEL) ("2,115" FN \TEDIT.DEFAULTSSEL) ("2,155" FN \TEDIT.SETDEFAULT.FROM.SEL) ("2,1" FN \TEDIT.SHOWCARETLOOKS)) -) - -(MAPC \TEDIT.KEYS (FUNCTION (LAMBDA (ENTRY) (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY)))))) - - - -(* ; -"Original was %"(FOR ENTRY IN \TEDIT.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))%"." -) - - - - -(* ; "Changed by yabu.fx, for SUNLOADUP without DWIM.") - -(PUTPROPS TEDITFNKEYS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3284 15682 (\TEDIT.BOLD.SEL.OFF 3294 . 3633) (\TEDIT.BOLD.SEL.ON 3635 . 3964) ( -\TEDIT.CENTER.SEL 3966 . 5021) (\TEDIT.CENTER.SEL.REV 5023 . 6103) (\TEDIT.DEFAULTS.CARET 6105 . 6389) - (\TEDIT.DEFAULTSSEL 6391 . 6714) (\TEDIT.SETDEFAULT.FROM.SEL 6716 . 7155) (\TEDIT.FIND 7157 . 10281) -(\TEDIT.ITALIC.SEL.OFF 10283 . 10525) (\TEDIT.ITALIC.SEL.ON 10527 . 10710) (\TEDIT.LARGERSEL 10712 . -11007) (\TEDIT.LCASE.SEL 11009 . 11760) (\TEDIT.SHOWCARETLOOKS 11762 . 13402) (\TEDIT.SMALLERSEL 13404 - . 13702) (\TEDIT.SUBSCRIPTSEL 13704 . 13908) (\TEDIT.SUPERSCRIPTSEL 13910 . 14115) (\TEDIT.UCASE.SEL -14117 . 14924) (\TEDIT.UNDERLINE.SEL.OFF 14926 . 15114) (\TEDIT.UNDERLINE.SEL.ON 15116 . 15302) ( -\TEDIT.STRIKEOUT.SEL.ON 15304 . 15490) (\TEDIT.STRIKEOUT.SEL.OFF 15492 . 15680)) (15754 21194 ( -\TEDIT.BOLD.CARET.OFF 15764 . 16212) (\TEDIT.BOLD.CARET.ON 16214 . 16659) (\TEDIT.ITALIC.CARET.OFF -16661 . 17111) (\TEDIT.ITALIC.CARET.ON 17113 . 17561) (\TEDIT.LARGER.CARET 17563 . 18011) ( -\TEDIT.SMALLER.CARET 18013 . 18463) (\TEDIT.SUBSCRIPT.CARET 18465 . 18919) (\TEDIT.SUPERSCRIPT.CARET -18921 . 19376) (\TEDIT.UNDERLINE.CARET.OFF 19378 . 19831) (\TEDIT.UNDERLINE.CARET.ON 19833 . 20284) ( -\TEDIT.STRIKEOUT.CARET.OFF 20286 . 20739) (\TEDIT.STRIKEOUT.CARET.ON 20741 . 21192)) (21263 25011 ( -\SEL.LIMIT 21273 . 21711) (\SEL.LINEDESC 21713 . 22309) (\TK.DESCRIBEFONT 22311 . 23026) ( -\PARAS.IN.SEL 23028 . 25009))))) -STOP diff --git a/library/TEXTOFD.~1~ b/library/TEXTOFD.~1~ deleted file mode 100644 index 3349be0b..00000000 --- a/library/TEXTOFD.~1~ +++ /dev/null @@ -1,1327 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Apr-2000 22:31:12" {DSK}sybalsky>lispcore>library>TEXTOFD.;8 176218 changes to%: (FNS \TEXTBIN \SETUPGETCH \TEDIT.TEXTBIN.FILESETUP) previous date%: "21-Jun-99 20:01:34" {DSK}sybalsky>lispcore>library>TEXTOFD.;6) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1995, 1999, 2000 by John Sybalsky & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEXTOFDCOMS) (RPAQQ TEXTOFDCOMS [(FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS COPYTEXTSTREAM OPENTEXTSTREAM REOPENTEXTSTREAM TEDIT.STREAMCHANGEDP TEXTSTREAMP TXTFILE \DELETECH \SETUPGETCH \TEDIT.REOPEN.STREAM \TEDIT.COPYTEXTSTREAM.PIECEMAPFN \TEXTINIT \TEXTMARK \TEXTTTYBOUT) (FNS \INSERTCH \INSERTCR) (COMS (* ;;; "Functions to manipulate the Piece Table (PCTB)") (FNS \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE \INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE)) (COMS (* ;  "Generic-IO type operations support") (FNS \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR \TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR \TEXTBOUT \TEDITOUTCHARFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION \TEXTDSPYPOSITION \TEXTLEFTMARGIN \TEXTRIGHTMARGIN \TEXTDSPCHARWIDTH \TEXTDSPSTRINGWIDTH \TEXTDSPLINEFEED) (FNS \TEXTBIN \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP \TEDIT.TEXTBIN.NEW.PAGE) (FNS \TEXTPEEKBIN \TEDIT.PEEKBIN.NEW.PAGE)) (COMS (* ; "Support for TEXTPROP") (FNS CGETTEXTPROP CTEXTPROP GETTEXTPROP PUTTEXTPROP TEXTPROP)) [COMS (* ;; "Support for error handling: The old error handler for the stream-not-open error. This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)") (INITVARS (*TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTINIT))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TEXTPROP]) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DEFINEQ (COPYTEXTSTREAM - [LAMBDA (ORIGINAL CROSSCOPY) (* ; - "Edited 24-Apr-95 12:02 by sybalsky:mv:envos") - - (* ;; "Given a stream, textobj or window, returns a new textstream with the same contents. If CROSSCOPY then strings will really be allocated providing copies of the text else the fileptrs still will be aliases as in the rest of TEDIT.") - - (PROG ((TEXTOBJ (TEXTOBJ ORIGINAL)) - TSEL PCTB PCLST NEWSTREAM NEWTEXTOBJ) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (SETQ TSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - (SETQ NEWSTREAM (OPENTEXTSTREAM NIL NIL NIL NIL (fetch (TEXTOBJ EDITPROPS) - of TEXTOBJ))) - (* ; - "First create an empty textstream into which the pieces can be hammered") - (SETQ NEWTEXTOBJ (TEXTOBJ NEWSTREAM)) - (replace (SELECTION CH#) of TSEL with 1) - (* ; - "Set up to select the whole source text") - (replace (SELECTION CHLIM) of TSEL with (ADD1 (fetch (TEXTOBJ TEXTLEN) - of TEXTOBJ))) - (replace (SELECTION DCH) of TSEL with (fetch (TEXTOBJ TEXTLEN) of - TEXTOBJ)) - (SETQ PCLST (TEDIT.SELECTED.PIECES TEXTOBJ TSEL CROSSCOPY (FUNCTION - \TEDIT.COPYTEXTSTREAM.PIECEMAPFN - ) - TEXTOBJ NEWTEXTOBJ)) (* ; - "now get a list of copies of the pieces to be inserted into the empty textstream") - (\TEDIT.INSERT.PIECES NEWTEXTOBJ 1 PCLST (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) - NIL NIL CROSSCOPY) (* ; - "Put the pieces into the copy textstream") - (replace (TEXTOBJ TEXTLEN) of NEWTEXTOBJ with (fetch (TEXTOBJ TEXTLEN) - of TEXTOBJ)) - (* ; - "The copy is the same length as the original") - (replace (TEXTOBJ MENUFLG) of NEWTEXTOBJ with (fetch (TEXTOBJ MENUFLG) - of TEXTOBJ)) - (* ; - "And if the original is a menu, so's the copy") - (RETURN NEWSTREAM]) (OPENTEXTSTREAM - [LAMBDA (TEXT WINDOW START END PROPS) (* ; "Edited 4-May-93 14:38 by jds") - (* ; - "Create a text-type STREAM to describe TEXT. Optionally, connect that to WINDOW for display.") - (PROG* ([WAS-TEXTSTREAM (AND (type? STREAM TEXT) - (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT] - [TEXTOBJ (COND - (WAS-TEXTSTREAM (* ; - "If the guy gave us a text stream to edit, use its TEXTOBJ as ours.") - (create TEXTOBJ - reusing (fetch (TEXTSTREAM TEXTOBJ) of TEXT) - \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 \INSERTPCVALID _ NIL)) - ((type? TEXTOBJ TEXT) - (create TEXTOBJ using TEXT \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 - \INSERTPCVALID _ NIL)) - (T (create TEXTOBJ] - (TEDIT.GET.FINISHEDFORMS NIL) - [PROPS (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS) - (COPY (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ] - [TEXTOBJ.WINDOW.VALID (AND WINDOW (EQ WINDOW (\TEDIT.PRIMARYW TEXTOBJ)) - (EQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ] - FONT SEL PCTB PC TEXTSTREAM OTEXTOBJ PROP CLEARGET? PARALOOKS PWINDOW) - (* ; - "Remember if the textobj had a window already.") - (replace (TEXTOBJ \WINDOW) of TEXTOBJ with (AND WINDOW (LIST WINDOW))) - (* ; - "Necessary because some incoming object types depend on knowing where the window is.") - (replace (TEXTOBJ LINES) of TEXTOBJ with NIL) - - (* ;; "This is here so if we re-OPENTEXTSTREAM an existing stream/window pair we don't get two sets of line descriptors") - - (for PROPNAME in PROPS by (CDDR PROPNAME) as PROPVAL - in (CDR PROPS) by (CDDR PROPVAL) do (TEXTPROP TEXTOBJ PROPNAME PROPVAL) - ) (* ; - "Save the PROPS for later people who'd like to know them") - [SETQ FONT (COND - ((type? CHARLOOKS (LISTGET PROPS 'FONT)) - (LISTGET PROPS 'FONT)) - (T (\TEDIT.PARSE.CHARLOOKS.LIST [OR (LISTGET PROPS 'LOOKS) - (COND - [(LISTP (LISTGET PROPS 'FONT)) - (FONTCREATE (LISTGET PROPS - 'FONT] - (T (OR (LISTGET PROPS 'FONT) - DEFAULTFONT] - NIL TEXTOBJ] (* ; -"Find the default font for this session -- either what the guy tells us, or the global default font") - (SETQ PARALOOKS (LISTGET PROPS 'PARALOOKS)) - - (* ;; "Get the default paragraph looks. This must come before the first piece is created, so its fields can be filled in right.") - - (replace (TEXTOBJ FMTSPEC) of TEXTOBJ - with (\TEDIT.UNIQUIFY.PARALOOKS [SETQ PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST - (OR PARALOOKS - (create FMTSPEC - using - TEDIT.DEFAULT.FMTSPEC - ] - TEXTOBJ)) - [COND - [WAS-TEXTSTREAM (* ; - "We got a TEXTOFD stream to edit; just use it") - (SETQ OTEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) - (SETQ TEXTSTREAM TEXT) - (for SELN in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ) - (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) - (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) - (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) - (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) - do - - (* ;; "Make all the selections point to the CURRENT textobj!") - - (COND - ((EQ OTEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELN)) - (replace (SELECTION \TEXTOBJ) of SELN with TEXTOBJ)) - (T (replace (SELECTION SET) of SELN with NIL))) - (replace (SELECTION ONFLG) of SELN with NIL)) - (replace (TEXTSTREAM TEXTOBJ) of TEXTSTREAM with TEXTOBJ) - (replace (TEXTOBJ STREAMHINT) of TEXTOBJ with TEXTSTREAM) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ with NIL) - (* ; "Mark the edit incomplete.") - (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL) - (* ; "And mark it not changed.") - (COND - (FONT (* ; - "If a new default font was specified, set it up.") - (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ - with (\TEDIT.UNIQUIFY.CHARLOOKS FONT TEXTOBJ] - ((type? TEXTOBJ TEXT) (* ; - "We got a TEXTOBJ to edit; fill in the stream, since it might have been GC'd.") - (SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ - with (create TEXTSTREAM - TEXTOBJ _ TEXTOBJ))) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM))) - (T (* ; - "Otherwise, create a TEXTOFD to describe the text we're editing.-") - (SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ - with (create TEXTSTREAM - TEXTOBJ _ TEXTOBJ))) - [replace (TEXTOBJ PCTB) of TEXTOBJ - with (SETQ PCTB (TEDIT.BUILD.PCTB TEXT TEXTOBJ START END FONT PARALOOKS - (LISTGET PROPS 'CLEARGET] - - (* ;; "(setq pc (\\editelt pctb (add1 |\\FirstPieceOffset|)))") - - (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) - 0)) - (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM)) - (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN) - of PCTB] - (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ - with (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CARETLOOKS.VERIFY TEXTOBJ - (replace (TEXTOBJ DEFAULTCHARLOOKS) - of TEXTOBJ with ( - \TEDIT.UNIQUIFY.CHARLOOKS - FONT TEXTOBJ))) - TEXTOBJ)) - (replace (TEXTOBJ CARET) of TEXTOBJ with (create - TEDITCARET - TCCARETDS _ - (AND WINDOW (WINDOWPROP WINDOW - 'DSP)) - TCFORCEUP _ T)) - (replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with (LISTGET PROPS 'READONLY)) - (replace (TEXTOBJ TXTTERMSA) of TEXTOBJ with (AND (SETQ PROP - (LISTGET PROPS 'TERMTABLE)) - (fetch TERMSA - of PROP))) - (replace (TEXTOBJ TXTRTBL) of TEXTOBJ with (LISTGET PROPS 'READTABLE)) - (replace (TEXTOBJ TXTWTBL) of TEXTOBJ with (LISTGET PROPS 'BOUNDTABLE)) - [COND - ((LISTGET PROPS 'PAGEFORMAT) (* ; - "A default page formatting was supplied. Impose it on the document.") - (TEDIT.PAGEFORMAT TEXTOBJ (LISTGET PROPS 'PAGEFORMAT] - (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (SETQ PROP (LISTGET PROPS 'SEL)) (* ; "Initial Selection, if any.") - (COND - ((EQ PROP 'DON'T) (* ; - "A SEL prop of DON'T means don't make an initial selection") - (replace (SELECTION SET) of SEL with NIL)) - ((type? SELECTION PROP) (* ; - "We came in with an explicit initial sel. Set it up.") - (\COPYSEL PROP SEL) - (replace (SELECTION SET) of SEL with T) - (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)) - ((AND (fetch (SELECTION SET) of SEL) - (NOT PROP)) (* ; - "If we came into this with a valid selection, highlight it.") - (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)) - (T (* ; - "Starting without a selection; let's start with a point selection before the first character.") - (replace (SELECTION CH#) of SEL with (COND - ((FIXP PROP)) - (PROP (CAR PROP)) - (1))) - (replace (SELECTION CHLIM) of SEL with (COND - ((FIXP PROP)) - (PROP (IPLUS (CAR PROP) - (CADR PROP))) - (1))) - (replace (SELECTION DCH) of SEL with (COND - ((FIXP PROP) - 0) - (PROP (CADR PROP)) - (0))) - (replace (SELECTION DX) of SEL with 0) - (replace (SELECTION POINT) of SEL with 'LEFT) - (replace (SELECTION SELKIND) of SEL with 'CHAR) - (replace (SELECTION SET) of SEL with (NOT (fetch (TEXTOBJ - TXTREADONLY) - of TEXTOBJ))) - (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ))) - [COND - ((fetch (SELECTION SET) of SEL) (* ; - "If there's an initial selection, it implies initial caret looks, too.") - (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS - TEXTOBJ SEL] - (COND - ((AND WINDOW (NOT TEXTOBJ.WINDOW.VALID)) (* ; - "Only if there's a window to display it in:") - (replace (TEXTOBJ \WINDOW) of TEXTOBJ with NIL) - (\TEDIT.WINDOW.SETUP WINDOW TEXTOBJ TEXTSTREAM PROPS) - (* ; - "Set up the window, and display the initial text.") - ) - ((SETQ PWINDOW (LISTGET PROPS 'PROMPTWINDOW)) - - (* ;; "There is no window for the session, but he has passed in a promptwindow to use, install it in the textobj") - - (replace (TEXTOBJ PROMPTWINDOW) of TEXTOBJ with PWINDOW))) - (\SETUPGETCH (create EDITMARK - PC _ (\GETBASEPTR (\FIRSTNODE PCTB) - 0) - PCOFF _ 0 - PCNO _ 1) - TEXTOBJ) (* ; "Set the file ptr to 0") - (RETURN TEXTSTREAM]) (REOPENTEXTSTREAM - [LAMBDA (STREAM) (* ; "Edited 31-May-91 14:18 by jds") - (replace (STREAM ACCESS) of STREAM with 'BOTH) - (replace (STREAM BINABLE) of STREAM with T) - (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \TEXTBIN)) - (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \TEXTBOUT)) - STREAM]) (TEDIT.STREAMCHANGEDP - [LAMBDA (STREAM RESET?) (* ; "Edited 31-May-91 13:57 by jds") - (PROG1 (fetch (TEXTOBJ \DIRTY) of (TEXTOBJ STREAM)) - (COND - (RESET? (replace (TEXTOBJ \DIRTY) of (TEXTOBJ STREAM) with NIL))))]) (TEXTSTREAMP - (LAMBDA (STREAM) (* jds " 3-Apr-84 14:34") - - (* Returns the stream if it is a text stream, else NIL) - - (AND (STREAMP STREAM) - (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - STREAM))) (TXTFILE - [LAMBDA (TEXTOBJ) (* ; "Edited 31-May-91 13:58 by jds") - (* This function is for compiled - access to the TXTFILE field in - RESETSAVE expressions) - (fetch (TEXTOBJ TXTFILE) of TEXTOBJ]) (\DELETECH [LAMBDA (CH# CHLIM LEN TEXTOBJ DONTDIRTY) (* ; "Edited 29-Jan-99 17:28 by kaplan") (* ;; "Delete the indicated characters from the text object represented by TEXTOBJ") (* ;;  "If DONTDIRTY is non-NIL, then don't notice this change for purposes of UNDO or dirtiness.") (COND ((OR DONTDIRTY (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) (* ;; "Only delete characters if changes are permitted, or if it's a TEdit-internal fixup change, e.g., when an NS character 255-x sequence is seen.") (LET ((\INFIRSTCH (fetch (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ)) (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) START-OF-PIECE PCLST) (\TEDIT.CHECK (IGEQ LEN 0) "LEN of delete must be >0.") (\TEDIT.CHECK (IEQP LEN (IDIFFERENCE CHLIM CH#))) [COND ((AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ) (IEQP CHLIM (fetch (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ)) (IGEQ CH# \INFIRSTCH)) (* ;  "The deletion is from the end of the most recent type-in. Just adjust the buffer string.") (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with (replace (PIECE PLEN) of (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ) with (IDIFFERENCE CH# \INFIRSTCH))) (* ; "Cut back the length") (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ) \INFIRSTCH)) (* ;  "and ch# of next insertion (i.e., 1 past the top CH# in the insert piece.)") (replace THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with (IDIFFERENCE (fetch THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) LEN)) (* ;  "Reduce the length of the insertion in the history list, too.") (COND ((ZEROP (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ)) (* ;; "He's completely emptied the type-in piece. Remove it and force creation of a fresh one at next type-in.") (\DELETEPIECE (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ) PCTB) (* UPDATEPCNODES (fetch  (TEXTOBJ \INSERTPC) of TEXTOBJ)  (IMINUS LEN) PCTB) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force the next insertion to be in a fresh piece.") ) (T (UPDATEPCNODES (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ) (IMINUS LEN) PCTB))) (* ; "Adjust CH#s in the Piece Table.") ) ((ILEQ CH# TEXTLEN) (* ;  "General case of deletion: Remove pieces as needed to do it.") (PROG (PCN PC1 PCNON PCSOUT (HIPC NIL) HI LO) (SETQ PC1 (\CHTOPC CH# PCTB T)) (* ;  "Piece # of piece containing start of deleted text") (COND ((IGREATERP CH# START-OF-PIECE) (* ;  "Split the piece, so the deleted text now starts on a piece boundary") (\SPLITPIECE PC1 (- CH# START-OF-PIECE) TEXTOBJ)) (T (SETQ PC1 (fetch (PIECE PREVPIECE) of PC1)) (* ;  "PC1 _ piece before the first piee to be deleted.-") )) (COND ((ILEQ CHLIM TEXTLEN) (* ;  "Find the peice that contains the END of the deleted section") (SETQ PCN (\CHTOPC CHLIM PCTB T))) (T (* ;;  "Deleting past end, so n+1-th piece is the symbol LASTPIECE, which starts 1 past end of all text.") (SETQ START-OF-PIECE (ADD1 TEXTLEN)) (SETQ PCN 'LASTPIECE) (SETQ HIPC NIL))) [COND ((ATOM PCN) (* ;  "Deleting before the end of text.") ) (T (* ;  "Deleting in front of a real piece of text") (COND ([AND (IGREATERP CHLIM START-OF-PIECE) (ILESSP CHLIM (IPLUS START-OF-PIECE (fetch (PIECE PLEN) of PCN] (SETQ HIPC (\SPLITPIECE PCN (- CHLIM START-OF-PIECE) TEXTOBJ PCNON)) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))) (T (SETQ HIPC PCN] (* ;  "if not on a piece bound, split the last piece.") (AND PC1 (EQ PC1 HIPC) (HELP "circular")) [SETQ PCLST (bind NPC [PC _ (COND (PC1 (fetch (PIECE NEXTPIECE) of PC1)) (T (* ;;  "(\EDITELT PCTB (ADD1 \FirstPieceOffset))") (\GETBASEPTR (\FIRSTNODE PCTB) 0] while (AND PC (NEQ PC HIPC)) collect (PROG1 PC (SETQ PC (fetch (PIECE NEXTPIECE) of PC)))] [OR DONTDIRTY (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Delete THLEN _ LEN THCH# _ CH# THFIRSTPIECE _ (CAR PCLST] (* ;  "Add this event to the history list") (* ;; "Actually delete the pieces:") (for PC in PCLST do [AND (fetch (PIECE POBJ) of PC) (IMAGEOBJPROP (fetch (PIECE POBJ) of PC) 'WHENDELETEDFN) (APPLY* (IMAGEOBJPROP (fetch (PIECE POBJ) of PC) 'WHENDELETEDFN) (fetch (PIECE POBJ) of PC) (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ] (* \DELETEPIECE PC PCTB) (\DELETETREE PC (fetch (PIECE PTREENODE) of PC))) (* ;; "Link around the deleted pieces:") (COND (PC1 (replace (PIECE NEXTPIECE) of PC1 with HIPC))) (COND (HIPC (replace (PIECE PREVPIECE) of HIPC with PC1))) (* ;; "Unchain the deleted pieces from the rest of the document.") (AND (CAR (FLAST PCLST)) (replace (PIECE PREVPIECE) of (CAR (FLAST PCLST)) with NIL)) (AND (CAR PCLST) (replace (PIECE PREVPIECE) of (CAR PCLST) with NIL)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force the next insertion to be in a fresh piece.") (\TEDIT.DIFFUSE.PARALOOKS PC1 HIPC) (* ;  "PROPOGATE PARALOOKS THRU THE DELETION") ] (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IDIFFERENCE TEXTLEN LEN)) (* ; "Update the file's length") (OR DONTDIRTY (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T]) (\SETUPGETCH [LAMBDA (CH# TEXTOBJ) (* ; "Edited 21-Apr-2000 20:54 by jds") (* ;;; "Set up TEXTOBJ so that the next \GETCH will retrieve character # CH#") (* ;; "NB that 1st char in the textobj is #1.") (* ;; "(declare (localvars . t))") (PROG (PC PCNO PS PF CHOFFSET CHARSLEFT (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) FPOS OFFST SUBSTREAM START-OF-PIECE) (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL) [COND [(LISTP CH#) (* ;  "If CH# is a piece-offset pair, make use of it.") (SETQ PC (fetch (EDITMARK PC) of CH#)) (SETQ CHOFFSET (fetch (EDITMARK PCOFF) of CH#)) (COND ((ATOM PC) (* ;  "This SETUPGETCH is to the final pseudo-piece!") (freplace (TEXTSTREAM PIECE) of STREAM with PC) (freplace (STREAM COFFSET) of STREAM with 0) (freplace (STREAM CPAGE) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) (freplace (TEXTSTREAM PCOFFSET) of STREAM with 0) (RETURN] ((IGREATERP CH# (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) (ERROR "TRYING TO \SETUPGETCH BEYOND END OF TEXT")) (T (* ;; "CH# is indeed a character number. Find the corresponding piece, its pcno, and the offset within that piece.") (SETQ PC (\CHTOPC CH# PCTB T)) (* ;; "(setq pc (\\editelt pctb (add1 pcno)))") (SETQ CHOFFSET (- CH# START-OF-PIECE)) (* ;  "If this is a fat piece, then CHOFFSET is half the byte offset.") (AND NIL (fetch (PIECE PFATP) of PC) (SETQ CHOFFSET (LRSH CHOFFSET 1] (freplace (TEXTSTREAM PIECE) of STREAM with PC) (replace (STREAM BINABLE) of STREAM with T) (SETQ CHARSLEFT (IDIFFERENCE (fetch (PIECE PLEN) of PC) CHOFFSET)) (freplace (TEXTSTREAM PCOFFSET) of STREAM with CHOFFSET) (COND ((SETQ PS (ffetch (PIECE PSTR) of PC)) (* ; "This piece resides in a STRING.") (\TEDIT.TEXTBIN.STRINGSETUP CHOFFSET CHARSLEFT STREAM PS)) ((SETQ PF (ffetch (PIECE PFILE) of PC)) (* ; "This piece resides on a FILE") (\TEDIT.TEXTBIN.FILESETUP PC CHOFFSET CHARSLEFT STREAM PF (fetch (PIECE PFATP) of PC))) [(SETQ PF (ffetch (PIECE POBJ) of PC)) (* ;  "This piece points to an object. set up so \TextBin will be called, and will return it.") (COND ((SETQ SUBSTREAM (IMAGEOBJPROP PF 'SUBSTREAM)) (* ;  "There is a stream below this one! Reflect things upward.") (* ;  "This is a simple object. Just set things up so it gets read.") (\SETUPGETCH (ADD1 CHOFFSET) (fetch (TEXTSTREAM TEXTOBJ) of SUBSTREAM)) (replace (STREAM BINABLE) of STREAM with NIL) (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) (freplace (STREAM COFFSET) of STREAM with CHOFFSET) (freplace (STREAM CBUFSIZE) of STREAM with (fetch (PIECE PLEN) of PC)) (freplace (STREAM CPAGE) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTCH) of STREAM with CHOFFSET) (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTPARALOOKS ) of SUBSTREAM)) (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTLOOKS) of SUBSTREAM)) (RETURN)) (T (* ;  "This is a simple object. Just set things up so it gets read.") (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 1) (freplace (STREAM COFFSET) of STREAM with 0) (freplace (STREAM CBUFSIZE) of STREAM with 1) (freplace (STREAM CPAGE) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) (replace (STREAM BINABLE) of STREAM with NIL) (* ;  "Force the next BIN to go thru our code.") ] (T (ERROR "Piece is neither a file nor a string??" PC))) (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with (\TEDIT.APPLY.PARASTYLES (fetch (PIECE PPARALOOKS) of PC) PC TEXTOBJ)) (* ;  "Set the character looks and font caches.") (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) of PC) PC TEXTOBJ]) (\TEDIT.REOPEN.STREAM [LAMBDA (TEXTSTREAM PIECESTREAM) (* ; "Edited 11-Jun-99 15:12 by rmk:") (* ; "Edited 11-Jun-99 15:12 by rmk:") (* ; "Edited 11-Jun-99 14:24 by rmk:") (* ; "Edited 15-Apr-93 15:53 by jds") (* ;; "Re-open the backing file stream, and propogate the change thru the entire piece table. Also, if TXTFILE is set to the closed stream, fill it in as well.") (LET* ([NEWSTREAM (OPENSTREAM PIECESTREAM 'INPUT NIL '((TYPE TEXT] (TEXTOBJ (TEXTOBJ TEXTSTREAM)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) PC) (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) 0)) (* ;; "Run thru the pieces, correcting any that used this stream to use the new one:") (while PC do (COND ((EQ (fetch (PIECE PFILE) of PC) PIECESTREAM) (replace (PIECE PFILE) of PC with NEWSTREAM))) (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) (* ;; "Check the TXTFILE, and if it uses the closed stream, fix it as well:") (COND ((EQ (fetch (TEXTOBJ TXTFILE) of TEXTOBJ) PIECESTREAM) (* ;  "Yup, it was the old, closed stream. Fix it.") (replace (TEXTOBJ TXTFILE) of TEXTOBJ with NEWSTREAM))) (* ;; "Return the new value for the stream:") NEWSTREAM]) (\TEDIT.COPYTEXTSTREAM.PIECEMAPFN - [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ) (* ; "Edited 31-May-91 14:00 by jds") - (* Called by COPYTEXTSTREAM via - TEDIT.SELECTED.PIECES, to do the - copy-operation processing on the - candidate pieces.) - (PROG (OBJ NEWOBJ COPYFN) - (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh - copy.) - [COND - ((fetch (PIECE POBJ) of PC) (* This piece describes an object) - (SETQ OBJ (fetch (PIECE POBJ) of PC)) - [COND - [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN)) - (SETQ NEWOBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) - (fetch (TEXTOBJ STREAMHINT) of TOOBJ))) - (COND - ((EQ NEWOBJ 'DON'T) (* He said not to copy this piece -- - abort the whole copy.) - (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T) - (RETFROM 'TEDIT.COPY)) - (NEWOBJ (replace (PIECE POBJ) of PC with NEWOBJ)) - (T (replace (PIECE POBJ) of PC with (COPYALL OBJ] - (OBJ (* No copy fn; just strike off a - copy of our own) - (replace (PIECE POBJ) of PC with (COPYALL OBJ] - (COND - ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN)) - (* If there's an eventfn for - copying, use it.) - (APPLY* COPYFN OBJ (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ)) - (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) - (fetch (TEXTOBJ STREAMHINT) of TOOBJ] - (RETURN PC]) (\TEXTINIT - [LAMBDA NIL (* ; "Edited 31-May-91 14:18 by jds") - (* ; - "Create the FDEV and STREAM prototypes for TEXT streams.") - - (* ;; "TEXT streams make use of the following STREAM fields:") - - (* ;; "(DEVICE (* FDEV of this guy -- The TEXT device)") - - (* ;; "F1 (* The STREAM for the PFILE of the current piece (or NIL))") - - (* ;; "F2 (* # chars left in piece at end of underlying file's page)") - - (* ;; "F3 (* The TEXTOBJ for this stream)") - - (* ;; "F4") - - (* ;; "F5 (* The PIECE we're currently inside)") - - (* ;; "(FW6 WORD) (* CPAGE for the start of the piece, for BACKFILEPTR)") - - (* ;; "(FW7 WORD) (* COFFSET for the start of the piece, for BACKFILEPTR)") - - (* ;; "(FW8 WORD)") - - (SETQ \TEXTIMAGEOPS (create IMAGEOPS - IMAGETYPE _ 'TEXT - IMXPOSITION _ (FUNCTION \TEXTDSPXPOSITION) - IMYPOSITION _ (FUNCTION \TEXTDSPYPOSITION) - IMLEFTMARGIN _ (FUNCTION \TEXTLEFTMARGIN) - IMRIGHTMARGIN _ (FUNCTION \TEXTRIGHTMARGIN) - IMFONT _ (FUNCTION \TEXTDSPFONT) - IMCLOSEFN _ (FUNCTION NILL) - IMFONTCREATE _ 'DISPLAY - IMLINEFEED _ (FUNCTION \TEXTDSPLINEFEED) - IMCHARWIDTH _ (FUNCTION \TEXTDSPCHARWIDTH) - IMSTRINGWIDTH _ (FUNCTION \TEXTDSPSTRINGWIDTH))) - (SETQ \TEXTFDEV (create FDEV - DEVICENAME _ 'TEXT - RESETABLE _ T - RANDOMACCESSP _ T - PAGEMAPPED _ NIL - GETFILENAME _ (FUNCTION NILL) - BIN _ (FUNCTION \TEXTBIN) - BOUT _ (FUNCTION \TEXTBOUT) - CLOSEFILE _ (FUNCTION \TEXTCLOSEF) - OPENFILE _ (FUNCTION \TEXTOPENF) - DELETEFILE _ (FUNCTION NILL) - DIRECTORYNAMEP _ (FUNCTION NILL) - EVENTFN _ (FUNCTION NILL) - GENERATEFILES _ (FUNCTION \GENERATENOFILES) - GETFILEINFO _ (FUNCTION NILL) - HOSTNAMEP _ (FUNCTION NILL) - READPAGES _ (FUNCTION NILL) - REOPENFILE _ [FUNCTION (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV STREAM) - (replace (STREAM ACCESS) of STREAM - with 'BOTH) - STREAM] - SETFILEINFO _ (FUNCTION NILL) - BACKFILEPTR _ (FUNCTION \TEXTBACKFILEPTR) - SETFILEPTR _ (FUNCTION \TEXTSETFILEPTR) - PEEKBIN _ (FUNCTION \TEXTPEEKBIN) - GETEOFPTR _ (FUNCTION \TEXTGETEOFPTR) - GETFILEPTR _ (FUNCTION \TEXTGETFILEPTR) - EOFP _ (FUNCTION \TEXTEOFP) - FDBINABLE _ T - FDBOUTABLE _ NIL - FDEXTENDABLE _ NIL - TRUNCATEFILE _ (FUNCTION NILL) - WRITEPAGES _ (FUNCTION NILL) - READCHARCODE _ (FUNCTION BIN))) - (SETQ \TEXTOFD - (create STREAM - BINABLE _ T - BOUTABLE _ NIL - ACCESS _ 'BOTH - USERCLOSEABLE _ T - USERVISIBLE _ T - DEVICE _ \TEXTFDEV - F1 _ NIL - F2 _ 0 - F3 _ NIL - F5 _ NIL - FW6 _ 0 - FW7 _ 0 - MAXBUFFERS _ 10 - IMAGEOPS _ \TEXTIMAGEOPS - IMAGEDATA _ (create TEXTIMAGEDATA) - OUTCHARFN _ (FUNCTION \TEDITOUTCHARFN))) (* ; "The prototypical Text stream") - - (* ;; "Set up so that FILE NOT OPENs on TEdit streams are caught and fixed.") - - (CL:SETF (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN) - (FUNCTION (LAMBDA (CONDITION) - (LET ((STREAM (STREAM-ERROR-STREAM CONDITION))) - (COND - [(AND (BOUNDP 'ERRORPOS) - (TEXTSTREAMP STREAM)) - (* ; - "This happened in the error handler, and it happened to a TEdit stream, so try the fix:") - (LET ((XCL::RESULT (REOPENTEXTSTREAM STREAM))) - (CL:WHEN XCL::RESULT - (ENVAPPLY (STKNAME ERRORPOS) - (SUBST XCL::RESULT STREAM (STKARGS ERRORPOS)) - (STKNTH -1 ERRORPOS ERRORPOS) - ERRORPOS T T))] - (*TEDIT-OLD-STREAM-ERROR-HANDLER* - (* ; - "Some other kind of stream, so punt to the old handler (if there is one):") - (APPLY* *TEDIT-OLD-STREAM-ERROR-HANDLER* CONDITION]) (\TEXTMARK - [LAMBDA (TEXTOBJ) (* ; "Edited 31-May-91 14:18 by jds") - (PROG ((STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) - (RETURN (CONS (ffetch (TEXTSTREAM PIECE) of STREAM) - (IDIFFERENCE (create BYTEPTR - PAGE _ (ffetch (STREAM CPAGE) of STREAM) - OFFSET _ (ffetch (STREAM COFFSET) of STREAM)) - (create BYTEPTR - PAGE _ (ffetch (TEXTSTREAM PCSTARTPG) of STREAM) - OFFSET _ (ffetch (TEXTSTREAM PCSTARTCH) of STREAM]) (\TEXTTTYBOUT - [LAMBDA (STREAM BYTE) (* ; "Edited 31-May-91 14:18 by jds") - (* Do BOUT to a text stream, which - is an insertion at the caret.) - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - (COND - ((EQ BYTE ERASECHARCODE) - (\TEDIT.CHARDELETE TEXTOBJ "" (fetch (TEXTOBJ SEL) of TEXTOBJ))) - ((EQ IGNORE.CCE (fetch CCECHO of (\SYNCODE (OR (fetch (TEXTOBJ TXTTERMSA) - of TEXTOBJ) - \PRIMTERMSA) - BYTE))) - (* Nothing, ignore it) - ) - (T (SELCHARQ BYTE - ((EOL CR LF) - (\TEXTBOUT STREAM BYTE) - (replace (STREAM CHARPOSITION) of STREAM with 0)) - (PROGN (\TEXTBOUT STREAM BYTE) - (add (fetch (STREAM CHARPOSITION) of STREAM) - 1]) ) (DEFINEQ (\INSERTCH [LAMBDA (CH CH# TEXTOBJ INSERTMARK) (* ; "Edited 29-Jan-99 17:19 by kaplan") (* ;; "If the current ch is 1+last ch in the distinguished INPUTPIECE, then append this text to that piece (make a new one if need be.), and fix up ch#s in the PCTB") (* ;; "else, create a new input piece (as a substring of the old one) and INSERT it at the right spot, perhaps after splitting a piece to make room.") (COND ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) (* ;; "Only insert if the document is allowed to change.") (PROG (PC (LEN (COND ((type? STRINGP CH) (NCHARS CH)) (T 1))) [FATP (COND [(type? STRINGP CH) (AND (fetch (STRINGP FATSTRINGP) of CH) (NOT (NULL (for CHAR instring CH thereis (IGREATERP CHAR \MAXTHINCHAR] (T (IGREATERP CH \MAXTHINCHAR] CHNO NEWPC PREVPC EVENT REPLACING (NEWFLAG NIL) (\INEXTCH (fetch (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ)) (\INLEN (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ)) (\INLEFT (fetch (TEXTOBJ \INSERTLEFT) of TEXTOBJ)) (\INSTRING (fetch (TEXTOBJ \INSERTSTRING) of TEXTOBJ)) (\INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) (\INFIRSTCH (fetch (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ)) (PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ)) (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (IMARKPC (fetch (EDITMARK PC) of INSERTMARK)) (IMARKCH (fetch (EDITMARK PCOFF) of INSERTMARK)) PLOOKS NLOOKS START-OF-PIECE) [COND ((ZEROP LEN) (* ; "Nothing to insert, really!") (RETURN)) [(ZEROP (fetch (BTREENODE COUNT) of PCTB)) (* ; "PCTB is empty.") (\INSERT.FIRST.PIECE TEXTOBJ) (SETQ \INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) (SETQ \INSTRING (fetch (TEXTOBJ \INSERTSTRING) of TEXTOBJ)) (COND ((type? STRINGP CH) (* ;  "If input is a string, copy it to the insert piece's string") (RPLSTRING \INSTRING 1 CH)) (T (* ;  "If it's a single charcode, move it to the piece's string") (RPLCHARCODE \INSTRING 1 CH))) (replace (PIECE PLEN) of \INPC (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN)) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN)) (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with LEN) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Insert THLEN _ (fetch (PIECE PLEN) of \INPC) THCH# _ CH# THFIRSTPIECE _ (LIST \INPC) THPOINT _ 'RIGHT] ((OR [AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ) (OR (IEQP CH# \INEXTCH) (AND INSERTMARK (EQ IMARKPC (fetch (PIECE NEXTPIECE) of \INPC) ) (EQ IMARKCH 0] (AND NIL (EQ CH# 1) (EQ \INEXTCH -1))) (* ;; "We're inserting at the end of a previous insertion, for which we already have a piece built. Just add to it.") (* ;; "Or, First insertion to empty document.") (COND ((IGEQ \INLEFT LEN) (* ;  "There's enough room in this piece -- fill it in.") (COND ((type? STRINGP CH) (* ;  "If input is a string, copy it to the insert piece's string") (RPLSTRING \INSTRING (ADD1 \INLEN) CH)) (T (* ;  "If it's a single charcode, move it to the piece's string") (RPLCHARCODE \INSTRING (ADD1 \INLEN) CH))) (replace (PIECE PLEN) of \INPC with (freplace (TEXTOBJ \INSERTLEN ) of TEXTOBJ with (IPLUS \INLEN LEN)) ) (* ;  "Fix the length of the insert piece") (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE \INLEFT LEN) ) (* ; "And the space left in the piece") (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS \INEXTCH LEN)) (* ; "And the next CH#") (* ; "And the piece # for future use") ) (T (* ;  "No room. Chop this piece & start a new one.") (replace (PIECE PSTR) of \INPC with (SUBSTRING \INSTRING 1 \INLEN )) (* ;  "Chop the current piece's string to length") (SETQ NEWPC (create PIECE PSTR _ (ALLOCSTRING 512 '% ) PLOOKS _ (fetch (PIECE PLOOKS) of \INPC) PPARALOOKS _ (fetch (PIECE PPARALOOKS) of \INPC) PPARALAST _ NIL PNEW _ T)) (* ; "Create the new piece") (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with (SETQ \INSTRING (fetch (PIECE PSTR) of NEWPC))) (* ;  "Set the \INSTRING field in TEXTOBJ") (COND ((type? STRINGP CH) (* ;  "If input is a string, copy it to the insert piece's string") (RPLSTRING \INSTRING 1 CH)) (T (* ;  "If it's a single charcode, move it to the piece's string") (RPLCHARCODE \INSTRING 1 CH))) (replace (PIECE PLEN) of NEWPC with LEN) (* ;  "So far, the present input is the only thing in the piece") (replace (TEXTOBJ \INSERTPCNO) of TEXTOBJ with (\INSERTPIECE NEWPC (OR (fetch (PIECE NEXTPIECE) of \INPC) 'LASTPIECE) TEXTOBJ)) (* ;  "Insert the new piece into the text and save the piece #") (* ;; "(SETQ PCTB (fetch PCTB of TEXTOBJ))") (* ;  "Which may have caused a PCTB overflow") (* ;  "This does not happen, after change pctree.") (freplace (TEXTOBJ \INSERTPC) of TEXTOBJ with (SETQ \INPC NEWPC)) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN)) (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN) (replace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with CH#) (* ;  "CH# of the first inserted character") (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS CH# LEN)) (* ;  "The CH# of the next character, if it's inserted at the current caret.") (replace THFIRSTPIECE of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with (NCONC1 (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) NEWPC)) (SETQ NEWFLAG T) (* ; "Note the new piece's creation") )) (add (fetch THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) LEN) (* ;  "Update the length of the insertion/replacement text.") ) (T (* ;; "NEW INSERTION POINT; IF THERE'S ANYTHING LEFT OF THE PREVIOUS INSERT PIECE, CRACK OFF A NEW ONE & FILL IT. THEN FIGURE OUT WHERE TO SHOEHORN IT IN.") (SETQ PC (OR IMARKPC (\CHTOPC CH# PCTB T))) [COND ((AND \INPC (IGEQ \INLEFT LEN)) (* ;  "There's room left in the prior input-piece's string; re-use it.") (SETQ NEWPC (create PIECE PSTR _ (SUBSTRING \INSTRING (ADD1 \INLEN)) PLOOKS _ (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) PPARALOOKS _ (fetch (PIECE PPARALOOKS) of \INPC) PPARALAST _ NIL PNEW _ T)) (* ; "Build the new piece") (replace (PIECE PSTR) of \INPC with (SUBSTRING \INSTRING 1 \INLEN )) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE \INLEFT LEN))) (T (* ;  "No room left; build a whole new piece.") (SETQ NEWPC (create PIECE PSTR _ (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with (ALLOCSTRING 512)) PLOOKS _ (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) PPARALOOKS _ (OR (AND \INPC (fetch (PIECE PPARALOOKS ) of \INPC)) (\TEDIT.UNIQUIFY.PARALOOKS (create FMTSPEC copying (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) TEXTOBJ)) PPARALAST _ NIL PNEW _ T)) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN] (freplace (TEXTOBJ \INSERTPC) of TEXTOBJ with (SETQ \INPC NEWPC)) (replace (PIECE PLEN) of NEWPC with LEN) (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with (SETQ \INSTRING (fetch (PIECE PSTR) of NEWPC))) (COND ((type? STRINGP CH) (* ;  "Insert the characters into the piece") (RPLSTRING \INSTRING 1 CH)) (T (RPLCHARCODE \INSTRING 1 CH))) (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN) (freplace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with CH#) (* ;  "Cache the first-inserted-ch #, for backspace speed") (SETQ NEWFLAG T) (COND ((OR (IGREATERP CH# TEXTLEN) (IEQP CH# START-OF-PIECE)) (* ;  "We're inserting on a piece boundary; do it, then remember the prior piece.") (\INSERTPIECE \INPC PC TEXTOBJ NIL)) (T (* ;  "Not on a piece boundary; split the piece we're inside of, then insert.") (\INSERTPIECE \INPC (\SPLITPIECE PC (- CH# START-OF-PIECE) TEXTOBJ) TEXTOBJ NIL))) [COND ((NOT (fetch (PIECE PPARALOOKS) of \INPC)) (* ;  "There weren't any paralooks available at creation time. Find some now.") [SETQ PLOOKS (AND (fetch (PIECE PREVPIECE) of \INPC) (fetch (PIECE PPARALOOKS) of (fetch (PIECE PREVPIECE) of \INPC] [SETQ NLOOKS (AND (fetch (PIECE NEXTPIECE) of \INPC) (fetch (PIECE PPARALOOKS) of (fetch (PIECE NEXTPIECE) of \INPC] (replace (PIECE PPARALOOKS) of \INPC with (COND ((NOT PLOOKS) (* ;  "No preceding para to take looks from") (OR NLOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))) ((NOT NLOOKS) (* ;  "No succeeding paras to take looks from") (OR PLOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))) (T PLOOKS] (replace (TEXTOBJ \INSERTPCNO) of TEXTOBJ with 0) (* ;  "Save the pcno for future insertions") (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (* ;  "The PCTB may have expanded during the insert.") (SETQ PREVPC (OR (fetch (PIECE PREVPIECE) of NEWPC) PC)) (* ;  "The piece we're to take the inserted characters' looks from") (replace (PIECE PLOOKS) of NEWPC with (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)) [replace (PIECE PPARALOOKS) of NEWPC with (COND ((ZEROP TEXTLEN) (* ;  "No text yet; use default paralooks") (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) ((SETQ PREVPC (fetch (PIECE NEXTPIECE) of \INPC)) (* ;  "There's later text. Use its para looks") (fetch (PIECE PPARALOOKS) of PREVPC)) ((SETQ PREVPC (fetch (PIECE PREVPIECE) of \INPC)) (* ;  "There's earlier text. Use its looks, copied if need be.") (COND ((fetch (PIECE PPARALAST) of PREVPC) (fetch (PIECE PPARALOOKS) of PREVPC)) (T (fetch (PIECE PPARALOOKS) of PREVPC] (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) (* ; "Prior edit event.") [SETQ REPLACING (AND (EQ (fetch THACTION of EVENT) 'Delete) (IEQP CH# (fetch THCH# of EVENT] (COND ((AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ) (IEQP CH# \INEXTCH) (EQ (fetch THACTION of EVENT) 'Insert)) (* ;; "We're continuing a prior insertion, even if we had to create a new piece. Just continue the old history event, too.") (add (fetch THLEN of EVENT) LEN)) (T (* ;  "Nope, this is a new insertion/replacement. Make the new history event.") (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ (COND (REPLACING 'Replace) (T 'Insert)) THLEN _ (fetch (PIECE PLEN) of \INPC) THCH# _ CH# THFIRSTPIECE _ \INPC THPOINT _ 'RIGHT THOLDINFO _ (AND REPLACING EVENT] [OR NEWFLAG (PROGN (* ;  "We didn't add a piece, so we must update character numbers in the PCTB") (* ; "The insert-piece's PCTB entry") (* ;; "(for I from (IPLUS PCNO \EltsPerPiece) to (\EDITELT PCTB \PCTBLastPieceOffset) by \EltsPerPiece do (\EDITSETA PCTB I (IPLUS (\EDITELT PCTB I) LEN)))") (COND ((NOT (AND (EQ CH# 1) (EQ \INEXTCH -1))) (* ;  "Update character numbers in the PCTB doesn't need when 1st insertion.") (UPDATEPCNODES \INPC LEN PCTB] (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ with (SETQ TEXTLEN (IPLUS LEN TEXTLEN))) (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS CH# LEN)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with T) (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) (replace (PIECE PFATP) of \INPC with (OR (fetch (PIECE PFATP) of \INPC) FATP]) (\INSERTCR - [LAMBDA (CH CH# TEXTOBJ) (* ; "Edited 31-May-91 14:00 by jds") - - (* ;; "Handle insertion of CR and meta-CR. The former causes a paragraph break, while the latter doesn't. Note, though, that inserting a meta-CR causes the doucment to become formatted.") - - (COND - ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) - (T (LET (INPC) - (COND - ([AND (NOT (fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ)) - (NOT (IEQP CH (CHARCODE CR] (* ; - "Inserting a meta-CR into an unformatted document. Start by setting up para breaks.") - (\TEDIT.CONVERT.TO.FORMATTED TEXTOBJ))) - (\INSERTCH (CHARCODE CR) - CH# TEXTOBJ) (* ; "Put the CR in") - (COND - ((IEQP CH (CHARCODE CR)) (* ; - "It's really a CR, rather than a meta-CR so do para breaking.") - (SETQ INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) - (AND INPC (replace (PIECE PPARALAST) of INPC with T)) - (* ; - "Mark the end of the paragraph (INPC might be NIL if the insert got refused somehow).") - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "FORCE A NEW PIECE ON THE NEXT CHARACTER") - ]) ) (* ;;; "Functions to manipulate the Piece Table (PCTB)") (DEFINEQ (\CHTOPC - [LAMBDA (CH# PCTB TELL-PC-START?) (* ; "Edited 15-Apr-93 16:05 by jds") - - (* ;; "Given a character # in a text object, and the object's piece table, return a pointer to the piece containing that character, else NIL.") - - (* ;; "If TELL-PC-START? is not NIL, sets the free variable START-OF-PIECE to the ch# of the piece's start.") - - (LET ((TREE PCTB) - (BASE-CH# 1) - TBASE-CH# FOUND) - (while (type? BTREENODE TREE) - do [for I from 1 to (fetch (BTREENODE COUNT) of TREE) - as OFST from 2 by 4 - do (COND - ((IGREATERP (SETQ TBASE-CH# (IPLUS BASE-CH# (\GETBASEFIXP TREE OFST)) - ) - CH#) - (SETQ FOUND (\GETBASEPTR TREE (- OFST 2))) - (RETURN)) - (T (SETQ BASE-CH# TBASE-CH#] - (SETQ TREE FOUND)) - (AND TELL-PC-START? (SETQ START-OF-PIECE BASE-CH#)) - (OR TREE 'LASTPIECE]) (\CHTOPCNO - [LAMBDA (CH# PCTB) (* ; "Edited 13-Jun-90 00:47 by mitani") - - (* ;; "Given a character # in a text object, and the object's piece table, return a pointer to the piece containing that character, else NIL") - - (DECLARE (LOCALVARS . T)) - (LET ((INDEX 0) - (TREE (fetch (PCTNODE HI) of PCTB)) - CHNUM) - [while TREE do (COND - [(IEQP CH# (SETQ CHNUM (fetch (PCTNODE CHNUM) of TREE))) - (* ; "FIND NODE") - (RETURN (SETQ INDEX (IPLUS INDEX (fetch (PCTNODE RANK) - of TREE] - ((IGREATERP CH# CHNUM) (* ; "MOVE RIGHT") - (SETQ INDEX (IPLUS INDEX (fetch (PCTNODE RANK) of TREE))) - (SETQ TREE (fetch (PCTNODE HI) of TREE))) - ((ILESSP CH# CHNUM) (* ; "MOVE LEFT") - (SETQ TREE (fetch (PCTNODE LO) of TREE] - (IMAX INDEX 1]) (\CLEARPCTB - [LAMBDA (PCTB) (* ; "Edited 23-Feb-88 11:11 by jds") - - (* ;; "(PROG ((OLASTPC (\EDITELT PCTB \PCTBLastPieceOffset))) (\EDITSETA PCTB \FirstPieceOffset 1) (* Create the LASTPIECE pseudo-piece placeholder in the first piece of the table) (\EDITSETA PCTB (ADD1 \FirstPieceOffset) (QUOTE LASTPIECE)) (for I from \SecondPieceOffset to OLASTPC do (* Now remove the other pieces, setting them to NIL) (\EDITSETA PCTB I NIL)) (\EDITSETA PCTB \PCTBLastPieceOffset (ADD1 \FirstPieceOffset)) (* Fix up the last-piece pointer) (\EDITSETA PCTB \PCTBFreePieces (IPLUS (\EDITELT PCTB \PCTBFreePieces) (LRSH (IDIFFERENCE OLASTPC (ADD1 \FirstPieceOffset)) 1))) (* And the free count of pieces.) (RETURN PCTB))") - - (HELP]) (\CREATEPIECEORSTREAM [LAMBDA (STRING LOOKS PARALOOKS START END) (* ; "Edited 11-Jun-99 14:25 by rmk:") (* ; "Edited 31-May-91 14:18 by jds") (* ;; "Given a source for text, build a PIECE to describe it.") (* ;; "HOWEVER-- if it's aformatted file, return the stream for that file.") (PROG (PC) [SETQ PC (COND ((STRINGP STRING) (* ; "It's a string.") (create PIECE PSTR _ STRING PFILE _ NIL PLEN _ (NCHARS STRING) PPARALAST _ NIL PPARALOOKS _ PARALOOKS PFATP _ (fetch (STRINGP FATSTRINGP) of STRING))) ((NULL STRING) (* ;  "If it's NIL, use an empty string for the text.") (create PIECE PSTR _ "" PFILE _ NIL PLEN _ 0 PPARALAST _ NIL PPARALOOKS _ PARALOOKS)) ((ATOM STRING) (* ;  "An atom is a file name. Open it.") [SETQ STRING (OPENSTREAM STRING 'INPUT 'OLD '(TYPE TEXT] (RETURN STRING)) [(STREAMP STRING) (COND [(EQ NoBits (fetch (STREAM ACCESSBITS) of STRING)) (* ;  "If the stream is no longer open, open it.") (RETURN (OPENSTREAM STRING 'INPUT 'OLD '((TYPE TEXT] (T (RETURN STRING] ((type? PIECE STRING) STRING) (T (* ;  "Anything else is coerced to a string first.") (SETQ STRING (MKSTRING STRING)) (create PIECE PSTR _ STRING PFILE _ NIL PLEN _ (NCHARS STRING) PPARALAST _ NIL PPARALOOKS _ PARALOOKS] (replace (PIECE PLOOKS) of PC with (OR LOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)) ) (replace (PIECE PPARALOOKS) of PC with (OR PARALOOKS (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC ))) (RETURN PC]) (\DELETEPIECE - [LAMBDA (PC PCTB PC#) (* ; "Edited 20-Apr-93 19:06 by jds") - - (* ;; "Remove piece PC from the piece table PCTB. Adjust the character numbers of succeeding pieces, if need be.") - - (PROG (PCNODE (NEXT (fetch (PIECE NEXTPIECE) of PC)) - (PREV (fetch (PIECE PREVPIECE) of PC))) - (\DELETETREE PC (fetch (PIECE PTREENODE) of PC)) - (COND - (NEXT (replace (PIECE PREVPIECE) of NEXT with PREV))) - (* ; - "Break any forward link from the piece") - (COND - (PREV (replace (PIECE NEXTPIECE) of PREV with NEXT))) - (* ; "and any backward link.") - ]) (\FINDPIECE - [LAMBDA (PC PCTB) (* ; "Edited 31-May-91 13:53 by jds") - - (* Given a piece and the pctb it's in, return the elt %# of the CH# entry for - that piece in the table) - - (LET ((NODE (FINDPCNODE PC PCTB))) - (INDEX (fetch (PCTNODE CHNUM) of NODE) - PCTB]) (\INSERTPIECE - [LAMBDA (NEW OLD TEXTOBJ DONTUPDATECH#S PC# NEW-PREVLEN PREV) - (* ; "Edited 7-Oct-94 17:43 by jds") - - (* ;; "Insert the piece NEW in front of the piece OLD; re-allocate PCTB if need be") - - (PROG* ((PLEN (fetch (PIECE PLEN) of NEW)) - (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - OLDLEN PCNODE PREVPC) - (COND - ((ZEROP (fetch (BTREENODE COUNT) of PCTB)) - (* ; "PCTB is empty.") - (replace (PIECE NEXTPIECE) of NEW with NIL) - (replace (PIECE PREVPIECE) of NEW with NIL) - (replace (BTREENODE DOWN1) of PCTB with NEW) - (replace (BTREENODE COUNT) of PCTB with 1) - (replace (BTREENODE TOTLEN) of PCTB with PLEN) - (RETURN 1))) - (SETQ OLDLEN (fetch (BTREENODE TOTLEN) of PCTB)) - [SETQ PCNODE (COND - ((OR (NULL OLD) - (ATOM OLD)) (* ; "Inserting in front of a symbol OR NIL, which must be LASTPIECE, the end-of-doc marker. Go find the node that contains it.") - (\LASTNODE PCTB)) - (T (* ; - "Normal case; go find the btree node that contains the piece we're inserting in front of.") - (FINDPCNODE OLD PCTB] - (\INSERTTREE NEW OLD PCNODE NEW-PREVLEN NIL PREV) - - (* ;; "Update inter-piece linkages:") - - (COND - [(OR (NULL OLD) - (ATOM OLD)) (* ; "Inserting in front of a symbol OR NIL, which must be LASTPIECE, the end-of-doc marker. Go find the node that contains it.") - (replace (PIECE NEXTPIECE) of NEW with NIL) - (replace (PIECE PREVPIECE) of NEW with (AND (NOT (ZEROP OLDLEN)) - (SETQ PREVPC (\CHTOPC - OLDLEN PCTB] - (T (* ; - "Normal case; go find the btree node that contains the piece we're inserting in front of.") - (replace (PIECE NEXTPIECE) of NEW with OLD) - (replace (PIECE PREVPIECE) of NEW with (SETQ PREVPC (ffetch - (PIECE PREVPIECE) - of OLD))) - (replace (PIECE PREVPIECE) of OLD with NEW))) - (AND PREVPC (replace (PIECE NEXTPIECE) of PREVPC with NEW]) (\MAKEPCTB - [LAMBDA (PC1 MINLEN) (* ; "Edited 15-Apr-93 15:48 by jds") - - (* ;; "Create a new piece table, with PC1 as its first piece, and a dummy piece at the end, with 1st ch# of 1+ (chlim of pc1)") - - (* ;; "A piece Table has the following format: It's an array, with 2 header words (1_# of pieces left in table unused) (2_offset of last used word in tbl), followed by 2-word entries: the first ch# in the piece, and a pointer to the piece.") - - (* ;; "NEW piece tree ") - - (* ;; "ROOT->LO: total hight of piece tree") - - (* ;; "ROOT->HI : Top node of piece tree") - - (LET ((PCTB (CREATE BTREENODE)) - PLEN) - (COND - (PC1 (FREPLACE (BTREENODE COUNT) OF PCTB WITH 2) - (FREPLACE (BTREENODE TOTLEN) OF PCTB WITH (SETQ PLEN (FETCH - (PIECE PLEN) - OF PC1))) - (FREPLACE (BTREENODE DOWN1) OF PCTB WITH PC1) - (FREPLACE (BTREENODE DLEN1) OF PCTB WITH PLEN) - (FREPLACE (BTREENODE DOWN2) OF PCTB WITH 'LASTPIECE) - (FREPLACE (BTREENODE DLEN2) OF PCTB WITH 0) - (FREPLACE (PIECE PTREENODE) OF PC1 WITH PCTB)) - (T - (* ;; - "No initial piece, so create a 0-long document, with only the ending-piece dummy") - - (FREPLACE (BTREENODE COUNT) OF PCTB WITH 1) - (FREPLACE (BTREENODE TOTLEN) OF PCTB WITH 0) - (FREPLACE (BTREENODE DOWN1) OF PCTB WITH 'LASTPIECE) - (FREPLACE (BTREENODE DLEN1) OF PCTB WITH 0))) - PCTB]) (\SPLITPIECE - [LAMBDA (PC CH TEXTOBJ PC#) (* ; "Edited 21-Apr-93 17:49 by jds") - - (* ;; "Split the piece PC before CH (rel to start of PIECE); return the new second piece.") - - (* ;; "PC#, if present, points at the CH# entry for the piece being split.") - - (PROG* ((PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ)) - (NEWPC (create PIECE using PC)) - CHNO NEWLEN NEXTPC) - (SETQ CHNO CH) (* ; - "Offset within the piece before which to break") - (COND - ((ILEQ CHNO 0) - (SHOULDNT "Splitting a piece at the start."))) - (replace (PIECE PPARALAST) of PC with NIL) - (* ; - "There can be no para break before the split, as things now work.") - (COND - ((ffetch (PIECE PSTR) of PC) (* ; - "This piece points to a string. Split it for the two new pieces") - (freplace (PIECE PSTR) of NEWPC with (SUBSTRING (ffetch (PIECE PSTR) - of PC) - (ADD1 CHNO))) - (freplace (PIECE PLEN) of NEWPC with (IDIFFERENCE (ffetch (PIECE - PLEN) - of PC) - CHNO)) - (freplace (PIECE PSTR) of PC with (SUBSTRING (ffetch (PIECE PSTR) - of PC) - 1 CHNO)) - (freplace (PIECE PLEN) of PC with CHNO)) - ((ffetch (PIECE PFILE) of PC) (* ; - "This piece points to a file. Set the fileptrs accordingly") - (freplace (PIECE PFILE) of NEWPC with (ffetch (PIECE PFILE) - of PC)) - [freplace (PIECE PFPOS) of NEWPC with (COND - ((fetch (PIECE PFATP) - of NEWPC) - (* ; - "This is a FAT piece; need to allow 2 bytes per char skipped") - (IPLUS (ffetch (PIECE PFPOS) - of PC) - CHNO CHNO)) - (T - (* ; - "Regular piece; allow 1 byte per char") - (IPLUS (ffetch - (PIECE PFPOS) - of PC) - CHNO] - (freplace (PIECE PLEN) of NEWPC with (IDIFFERENCE (ffetch (PIECE - PLEN) - of PC) - CHNO)) - (FREPLACE (PIECE PLEN) OF PC WITH CHNO))) - (PROGN (* UNINTERRUPTABLY) - (SETQ NEXTPC (ffetch (PIECE NEXTPIECE) of PC)) - (* LET ((PCNODE (FETCH - (PIECE PTREENODE) OF PC))) - (* ;; - "Update the length of the original piece in it's tree entry.") - (for ITEM# from 0 by 4 as I from 1 - to (fetch (BTREENODE COUNT) of - PCNODE) when (EQ (\GETBASEPTR PCNODE - ITEM#) PC) do (* ;; - "FIXME - I think this can be done as aport of \INSERTPIECE / \INSERTTREEE, by looking back 1 from the OLD entry and updating. --JDS") - (\PUTBASEFIXP PCNODE - (IPLUS ITEM# 2) (fetch - (PIECE PLEN) of PC)) - (RETURN))) - (\INSERTPIECE NEWPC (OR NEXTPC 'LASTPIECE) - TEXTOBJ NIL NIL (IMINUS (fetch (PIECE PLEN) of NEWPC)) - PC) - - (* ;; "update nextlink and prevlink") - - (COND - ((NULL NEXTPC) (* ; - "PC is last piece (not LASTPIECE)") - (* ; "NEWPC is new last piece.") - (replace (PIECE NEXTPIECE) of NEWPC with NIL)) - (T (replace (PIECE NEXTPIECE) of NEWPC with NEXTPC) - (replace (PIECE PREVPIECE) of NEXTPC with NEWPC))) - (replace (PIECE NEXTPIECE) of PC with NEWPC) - (replace (PIECE PREVPIECE) of NEWPC with PC)) - (* ; "Now set its starting CH#") - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "Whenever you split a piece, you can't add to it anymore.") - (RETURN NEWPC]) (\INSERT.FIRST.PIECE - [LAMBDA (TEXTOBJ) (* ; "Edited 31-May-91 14:00 by jds") - - (* ;; "Insert 1st piece to empty PCTB.") - - (PROG (PC) - (\INSERTPIECE [SETQ PC (\CREATEPIECEORSTREAM NIL (CHARLOOKS.FROM.FONT DEFAULTFONT) - (COND - (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) - (T (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC - ] - NIL TEXTOBJ) - (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with PC) - (replace (PIECE PSTR) of PC with (freplace (TEXTOBJ \INSERTSTRING) - of TEXTOBJ with (ALLOCSTRING 512]) ) (* ; "Generic-IO type operations support") (DEFINEQ (\TEXTCLOSEF - [LAMBDA (STREAM) (* ; "Edited 15-Apr-93 16:43 by jds") - (* ; - "Close the files underlying a stream") - (PROG ((TEXTOBJ (TEXTOBJ STREAM)) - PCTB PC) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - [OR (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (COND - ((TYPE? PIECE (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) - 0))) - (fetch (PIECE PFILE) of PC) - (CLOSEF? (fetch (PIECE PFILE) of PC)) - (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC)) - (WHILE PC DO (AND (fetch (PIECE PFILE) of PC) - (CLOSEF? (fetch (PIECE PFILE) of PC))) - (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC] - - (* ;; "And close the REAL file as well, in case we'd made a local cache.") - - (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ]) (\TEXTCLOSEF-SUBTREE - [LAMBDA (PCTREE) (* ; "Edited 31-May-91 14:00 by jds") - - (* ;; "Run thru the pieces in the document, closing the underlying file") - - (* ;; "by traverse pctree") - - (LET (PC) - (COND - ((NULL PCTREE) - NIL) - (T (SETQ PC (fetch (PCTNODE PCE) of PCTREE)) - (AND (NOT (ATOM PC)) - (fetch (PIECE PFILE) of PC) - (CLOSEF? (fetch (PIECE PFILE) of PC))) - (\TEXTCLOSEF-SUBTREE (fetch (PCTNODE LO) of PCTREE)) - (\TEXTCLOSEF-SUBTREE (fetch (PCTNODE HI) of PCTREE]) (\TEXTDSPFONT - [LAMBDA (STREAM NEWFONT) (* ; "Edited 31-May-91 14:02 by jds") - - (* ;; "Set the font for a TEdit window. Need change the caret looks, for character insertion, and the WINDOW's looks, so that TEXEC type-out to the window does the right thing.") - - (LET ((TEXTOBJ (TEXTOBJ STREAM))) - (PROG1 (fetch (CHARLOOKS CLFONT) of (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)) - [COND - (NEWFONT - - (* ;; "Only do this if there's a new font to set:") - - (TEDIT.CARETLOOKS STREAM (\GETFONTDESC NEWFONT 'DISPLAY)) - (COND - ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - - (* ;; "Update the windows, if there are any.") - - (for WIN in (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - do (DSPFONT NEWFONT WIN])]) (\TEXTEOFP - [LAMBDA (STREAM) (* ; "Edited 31-May-91 14:18 by jds") - - (* ;; "Test for EOF on a text stream: At end of a piece, and there's no more pieces.") - - (OR (NOT (fetch (TEXTSTREAM PIECE) of STREAM)) - (EQ (fetch (TEXTSTREAM PIECE) of STREAM) - 'LASTPIECE) - (AND (IEQP (fetch (STREAM COFFSET) of STREAM) - (fetch (STREAM CBUFSIZE) of STREAM)) - (ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) - (OR (NOT (fetch (PIECE NEXTPIECE) of (fetch (TEXTSTREAM PIECE) of STREAM - ))) - (bind (PC _ (fetch (PIECE NEXTPIECE) of (fetch (TEXTSTREAM PIECE) - of STREAM))) while - PC - do (COND - ((NOT (ZEROP (fetch (PIECE PLEN) of PC))) - (RETURN NIL))) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (RETURN - T]) (\TEXTGETEOFPTR - [LAMBDA (STREAM) (* ; "Edited 31-May-91 13:58 by jds") - (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) of STREAM]) (\TEXTGETFILEPTR - [LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:32 by jds") - - (* ;; "GETFILEPTR fn for text streams.") - - (PROG ((PC (fetch (TEXTSTREAM PIECE) of STREAM)) - (CHARSLEFT (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) - (OFFSET (fetch (STREAM COFFSET) of STREAM)) - (LIMIT (fetch (STREAM CBUFSIZE) of STREAM)) - PLEN) - (COND - ((EQ PC 'LASTPIECE) (* ; "STREAM is Empty Document") - (RETURN 0)) - [PC (* ; - "There's a piece. That means he's inside the file somewhere.") - (SETQ PLEN (fetch (PIECE PLEN) of PC)) - (RETURN (IMIN [SUB1 (IPLUS (\TEDIT.PIECE-CHNO PC) - (IDIFFERENCE PLEN CHARSLEFT) - (COND - ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) - (* ; - "This is a 16-bit stream; The difference is in BYTES, and needs to be divided by 2 to get chars") - (IQUOTIENT (IDIFFERENCE OFFSET LIMIT) - 2)) - (T (IDIFFERENCE OFFSET LIMIT] - (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) - of STREAM] - (T (* ; - "Lack of a current piece means he walked off the end.") - (RETURN (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) - of STREAM]) (\TEXTOPENF - [LAMBDA (STREAM ACCESS ASDF QWER ZXCV) (* ; "Edited 31-May-91 13:58 by jds") - (* Return the stream, opened for - input) - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - PCTB PC) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (\TEXTOPENF-SUBTREE (fetch (PCTNODE HI) of PCTB)) - - (* ;; "(for I from (ADD1 \FirstPieceOffset) to (SUB1 (\EDITELT PCTB \PCTBLastPieceOffset)) by \EltsPerPiece do (SETQ PC (\EDITELT PCTB I)) (COND ((AND (fetch PFILE of PC) (EQ (fetch ACCESSBITS of (fetch PFILE of PC)) NoBits)) (\TEDIT.REOPEN.STREAM STREAM (fetch PFILE of PC)))))") - - (RETURN STREAM]) (\TEXTOPENF-SUBTREE - [LAMBDA (PCTREE) (* ; "Edited 31-May-91 14:19 by jds") - (LET (PC) - (COND - ((NULL PCTREE) - NIL) - (T (SETQ PC (fetch (PCTNODE PCE) of PCTREE)) - [COND - ((AND (fetch (PIECE PFILE) of PC) - (EQ (fetch (STREAM ACCESSBITS) of (fetch (PIECE PFILE) - of PC)) - NoBits)) - (\TEDIT.REOPEN.STREAM STREAM (fetch (PIECE PFILE) of PC] - (\TEXTOPENF-SUBTREE (fetch (PCTNODE LO) of PCTREE)) - (\TEXTOPENF-SUBTREE (fetch (PCTNODE HI) of PCTREE]) (\TEXTOUTCHARFN - [LAMBDA (CH STREAM) (* ; "Edited 31-May-91 13:59 by jds") - (\INSERTCH CH (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) - of STREAM)) - (fetch (TEXTSTREAM TEXTOBJ) of STREAM]) (\TEXTBACKFILEPTR - [LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:32 by jds") - - (* ;; "Use this to BACKFILEPTR a text stream.") - - [PROG (PC PS PF REALFILE) - (COND - [(AND (IEQP (fetch (STREAM CPAGE) of STREAM) - (fetch (TEXTSTREAM PCSTARTPG) of STREAM)) - (IEQP (fetch (STREAM COFFSET) of STREAM) - (fetch (TEXTSTREAM PCSTARTCH) of STREAM))) - (* ; - "Hit start of piece; back to PREVPIECE & keep going.") - [SETQ PC (replace (TEXTSTREAM PIECE) of STREAM - with (fetch (PIECE PREVPIECE) of (fetch (TEXTSTREAM PIECE) - of STREAM] - (* ; "Move to previous piece") - (replace (STREAM BINABLE) of STREAM with T) - (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL) - (* add (fetch (TEXTSTREAM PCNO) of - STREAM) -1) - (while (AND PC (ZEROP (fetch (PIECE PLEN) of PC))) - do (* ; - "Skip over any zero-length pieces as we back along.") - (SETQ PC (fetch (PIECE PREVPIECE) of PC))) - (COND - [PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM - with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of PC) - PC - (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - (COND - ((SETQ PS (fetch (PIECE PSTR) of PC)) - (* ; "This piece lives in a string.") - (\TEDIT.TEXTBIN.STRINGSETUP (SUB1 (fetch (PIECE PLEN) of PC)) - 1 STREAM PS) - - (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.") - - ) - ((SETQ PF (fetch (PIECE PFILE) of PC)) - (* ; "This piece lives on a file.") - (\TEDIT.TEXTBIN.FILESETUP PC (SUB1 (fetch (PIECE PLEN) of PC)) - 1 STREAM PF (fetch (PIECE PFATP) of PC) - 'PEEKBIN)) - ((fetch (PIECE POBJ) of PC) - (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)) - (T (ERROR "CAN'T GET TO NEXT PIECE"] - (T (ERROR "Trying to BACKFILEPTR thru start of text."] - ((ZEROP (fetch (STREAM COFFSET) of STREAM)) - (* ; "Move back 1 file page") - (SETQ REALFILE (fetch (TEXTSTREAM REALFILE) of STREAM)) - (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IPLUS (fetch - (TEXTSTREAM - CHARSLEFT) - of STREAM) - (fetch - (STREAM CBUFSIZE) - of STREAM))) - (replace (STREAM COFFSET) of REALFILE with 0) - (COND - ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) - (* ; - "16 bit stream, so back up 2 bytes.") - (\BACKFILEPTR REALFILE) - (\BACKFILEPTR REALFILE)) - (T (\BACKFILEPTR REALFILE))) - (\PEEKBIN REALFILE) - (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) - of REALFILE)) - (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET) - of REALFILE)) - (replace (STREAM CBUFSIZE) of STREAM with (fetch (STREAM CBUFSIZE) - of REALFILE)) - (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) - of REALFILE))) - (T (* ; "JUST ACT CASUAL & DO IT.") - (COND - ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) - (* ; - "16 bit stream, so back up 2 bytes.") - (\PAGEDBACKFILEPTR STREAM) - (\PAGEDBACKFILEPTR STREAM)) - (T (\PAGEDBACKFILEPTR STREAM] - T]) (\TEXTBOUT - [LAMBDA (STREAM BYTE) (* ; "Edited 10-May-93 16:59 by jds") - (* ; - "Do BOUT to a text stream, which is an insertion at the caret.") - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) - (CH# (ADD1 (\TEXTGETFILEPTR STREAM))) - WINDOW TEXTLEN PS PC PSTR OFFST) - (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (SETQ WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) - (AND WINDOW (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# CH#)) - (\INSERTCH BYTE CH# TEXTOBJ) - (AND WINDOW (TEDIT.UPDATE.SCREEN TEXTOBJ)) - (AND (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) - (RETURN)) (* ; - "If teh stream is readonly, nothing happened!") - [SETQ PS (ffetch (PIECE PSTR) of (SETQ PC (fetch (TEXTOBJ \INSERTPC) - of TEXTOBJ] - (* ; "This piece resides in a STRING.") - (replace (TEXTSTREAM PIECE) of STREAM with PC) - (freplace (STREAM CPPTR) of STREAM with (ADDBASE (ffetch (STRINGP BASE) - of PS) - (LRSH (SETQ OFFST - (ffetch (STRINGP - OFFST) - of PS)) - 1))) - (freplace (STREAM CPAGE) of STREAM with 0) - (freplace (STREAM COFFSET) of STREAM with (IPLUS (freplace (TEXTSTREAM - PCSTARTCH) - of STREAM - with (LOGAND 1 OFFST)) - (fetch (TEXTOBJ \INSERTLEN - ) - of TEXTOBJ))) - (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) - (* ; - "Page # within the 'file' where this piece starts") - (freplace (STREAM CBUFSIZE) of STREAM with (fetch (STREAM COFFSET) - of STREAM)) - (freplace (STREAM EPAGE) of STREAM with 1) - (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) - (freplace (TEXTSTREAM REALFILE) of STREAM with NIL]) (\TEDITOUTCHARFN - [LAMBDA (STREAM CHARCODE) (* ; "Edited 31-May-91 14:19 by jds") - - (* ;; "OUTCHARFN for TEdit streams -- always BOUTs the character, because TEdit streams deal in complete charcodes rather than bytes. BUT -- does update the CHARPOSITION of the stream, which is used by some code to decide things.") - - (COND - ((EQ CHARCODE (CHARCODE EOL)) - (\BOUT STREAM (CHARCODE CR)) - (freplace (STREAM CHARPOSITION) of STREAM with 0)) - (T (\BOUT STREAM CHARCODE) - (freplace (STREAM CHARPOSITION) of STREAM with - (PROGN - (* ; "Ugh. Don't overflow") - (IPLUS16 (ffetch (STREAM - CHARPOSITION - ) - of STREAM) - 1]) (\TEXTSETEOF - [LAMBDA (STREAM EOFPTR) (* ; "Edited 31-May-91 14:19 by jds") - (* Set the EPAGE/EOFFSET of the - stream to be (SUB1 of EOFPTR)) - (replace (STREAM EPAGE) of STREAM with (fetch (BYTEPTR PAGE) of EOFPTR)) - (replace (STREAM EOFFSET) of STREAM with (fetch (BYTEPTR OFFSET) of EOFPTR]) (\TEXTSETFILEPTR - [LAMBDA (STREAM FILEPOS) (* ; "Edited 22-Apr-93 13:44 by jds") - (* ; - "Sets the file ptr for a text stream.") - (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) - (COND - ((ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) - ((OR (IEQP FILEPOS -1) - (IEQP FILEPOS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) - (* ; "Means end of file") - (\SETUPGETCH (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - TEXTOBJ) - (\BIN STREAM)) - ((OR (ILESSP FILEPOS 0) - (IGREATERP FILEPOS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) - (* ; - "If the fileptr is not within the text, punt.") - (\ILLEGAL.ARG FILEPOS)) - (T (\SETUPGETCH (IMAX 1 (ADD1 FILEPOS)) - TEXTOBJ]) (\TEXTDSPXPOSITION [LAMBDA (STREAM XPOSITION) (* ; "Edited 2-Nov-88 12:33 by drc:") (* Simply returns the XPOSITION of the primary window's display stream, this is  a read-only function) (LET [(WINDOW (CAR (fetch \WINDOW of (TEXTOBJ STREAM] (COND (WINDOW (DSPXPOSITION NIL WINDOW)) (T (POSITION STREAM XPOSITION]) (\TEXTDSPYPOSITION - [LAMBDA (STREAM YPOSITION) (* ; "Edited 31-May-91 13:59 by jds") - - (* Simply returns the XPOSITION of the primary window's display stream, this is - a read-only function) - - (LET [(WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM] - (IF WINDOW - THEN (DSPYPOSITION NIL WINDOW) - ELSE (AND \#DISPLAYLINES (NEQ \CURRENTDISPLAYLINE -1) - (DIFFERENCE \#DISPLAYLINES \CURRENTDISPLAYLINE]) (\TEXTLEFTMARGIN - [LAMBDA (STREAM XPOSITION) (* ; "Edited 31-May-91 14:03 by jds") - -(* ;;; "Returns the left margin of the textstream. This is a read-only function") - - (IF (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM))) - THEN [IPLUS 8 (fetch (FMTSPEC LEFTMAR) of (fetch (TEXTOBJ FMTSPEC) - of (TEXTOBJ STREAM] - ELSE 0]) (\TEXTRIGHTMARGIN - [LAMBDA (STREAM XPOSITION) (* ; "Edited 31-May-91 14:03 by jds") - -(* ;;; "Returns the right margin of the textstream. This is a read-only function") - - (LET ((TEXTOBJ (TEXTOBJ STREAM))) - (IF (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - THEN (LET [(RIGHTMAR (fetch (FMTSPEC RIGHTMAR) of (fetch (TEXTOBJ - FMTSPEC) - of TEXTOBJ] - (IF (ZEROP RIGHTMAR) - THEN (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) - ELSE RIGHTMAR)) - ELSE (LINELENGTH NIL STREAM]) (\TEXTDSPCHARWIDTH [LAMBDA (STREAM CHARCODE) (* ;  "Edited 9-Feb-99 12:59 by kaplan") (LET [(WINDOW (CAR (fetch \WINDOW of (TEXTOBJ STREAM] (COND (WINDOW (CHARWIDTH CHARCODE (DSPFONT NIL STREAM))) (T 1]) (\TEXTDSPSTRINGWIDTH [LAMBDA (STREAM STRING) (* ;  "Edited 9-Feb-99 13:00 by kaplan") (LET [(WINDOW (CAR (fetch \WINDOW of (TEXTOBJ STREAM] (COND (WINDOW (STRINGWIDTH STRING (DSPFONT NIL STREAM))) (T (NCHARS STRING]) (\TEXTDSPLINEFEED - [LAMBDA (STREAM VALUE) - (FONTPROP (DSPFONT NIL STREAM) - 'HEIGHT]) ) (DEFINEQ (\TEXTBIN [LAMBDA (STREAM) (* ; "Edited 21-Apr-2000 22:31 by jds") (* ;;; "Do BIN slow case for a text stream") (* ;  "NB that PEEKBIN and BACKFILEPTR need to track changes in this code") (DECLARE (LOCALVARS . T)) (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM) (COND [(ILESSP (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM)) (* ;  "Simple case -- just do the usual BIN") (COND [(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) of STREAM ))) (* ; "Handle objects specially") (COND ((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM)) (* ;  "If this object has a substream in it, go to that substream") (add (fetch (STREAM COFFSET) of STREAM) 1) (RETURN (\BIN SUBSTREAM))) (T (* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.") (replace (STREAM COFFSET) of STREAM with (fetch (STREAM CBUFSIZE) of STREAM)) (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0) (RETURN PO] [(fetch (TEXTSTREAM FATSTREAMP) of STREAM) (* ;  "This is a 16 bit BIN. grab 2 bytes.") (* ;  "WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??") (RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM) 256) (COND ((ILESSP (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM)) (* ;  "This pair of characters doesn't straddle a file page bound. Just grab the next char.") (\PAGEDBIN STREAM)) (T (* ;  "Need to move to the next page on the backing file. Doing so also grabs the next character.") (\TEDIT.TEXTBIN.NEW.PAGE STREAM T] (T (RETURN (\PAGEDBIN STREAM] (T (* ;  "We've either hit a page bound in a file, or a piece bound.") (RETURN (COND [(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) (* ; "Time for a new piece.") [repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN) of PC))) do (* ;  "Skip over any zero-length pieces at the end of the file.") (SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM)) (SETQ PC (replace (TEXTSTREAM PIECE) of STREAM with (AND OPC (fetch (PIECE NEXTPIECE) of OPC] (replace (STREAM BINABLE) of STREAM with T) (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL) (* ;  "Move to the next piece in the chain") (COND [PC (* ;  "There IS a next piece to move to.") (AND (fetch (TEXTSTREAM LOOKSUPDATEFN) of STREAM) (SETQ NPC (APPLY* (fetch (TEXTSTREAM LOOKSUPDATEFN) of STREAM) STREAM PC)) (replace (TEXTSTREAM PIECE) of STREAM with (SETQ PC NPC))) (* ;  "Take care of any piece-change uproar. uproar -- which may include picking a new piece to go to.") [COND (NPC (* ;  "If we got an NPC, this was taken care of by the LOOKSUPDATEFN") ) ([AND (SETQ PO (fetch (PIECE POBJ) of PC)) (SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM] (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of SUBSTREAM)) (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTPARALOOKS) of SUBSTREAM)) (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTLOOKS) of SUBSTREAM ))) [(NEQ (fetch (PIECE PPARALOOKS) of OPC) (fetch (PIECE PPARALOOKS) of PC)) (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with (\TEDIT.APPLY.PARASTYLES (fetch (PIECE PPARALOOKS ) of PC) PC (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of PC) PC (fetch (TEXTSTREAM TEXTOBJ) of STREAM] ((NOT (EQCLOOKS (fetch (PIECE PLOOKS) of PC) (fetch (PIECE PLOOKS) of OPC))) (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of PC) PC (fetch (TEXTSTREAM TEXTOBJ) of STREAM] (COND ((SETQ PS (fetch (PIECE PSTR) of PC)) (* ; "This piece lives in a string.") (\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN) of PC) STREAM PS) (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.") (* ;  "Then actually grab the next character to hand back to the caller.") (\BIN STREAM)) ((SETQ PF (fetch (PIECE PFILE) of PC)) (* ; "This piece lives on a file.") (\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN) of PC) STREAM PF (fetch (PIECE PFATP) of PC) 'PEEKBIN) (\BIN STREAM)) [(SETQ PO (fetch (PIECE POBJ) of PC)) (replace (STREAM BINABLE) of STREAM with NIL) (COND (SUBSTREAM (* ;  "There is a stream below this one, to feed chars upward.") (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of SUBSTREAM)) (freplace (STREAM COFFSET) of STREAM with 0) (freplace (TEXTSTREAM CHARSLEFT) of STREAM with (fetch (PIECE PLEN) of PC)) (freplace (STREAM CBUFSIZE) of STREAM with (fetch (PIECE PLEN) of PC)) (freplace (STREAM CPAGE) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTPARALOOKS ) of SUBSTREAM)) (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTLOOKS) of SUBSTREAM)) (RETURN (\BIN SUBSTREAM))) (T (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0) (RETURN PO] (T (ERROR "CAN'T GET TO NEXT PIECE"] (T (* ;  "There are no more pieces. Punt gracefully") (COND ((fetch (STREAM ENDOFSTREAMOP) of STREAM) (* ;  "If there's an EOF handler, call it & return the result") (RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM ) STREAM))) (T (* ; "Otherwise, return NIL") (RETURN NIL] [(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) of STREAM))) (* ; "This is an object") (replace (STREAM BINABLE) of STREAM with NIL) (COND (SUBSTREAM (* ;  "There is a stream below this one, to feed chars upward.") (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of SUBSTREAM)) (freplace (STREAM COFFSET) of STREAM with 1) (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) (freplace (STREAM CBUFSIZE) of STREAM with (fetch (PIECE PLEN) of PC)) (freplace (STREAM CPAGE) of STREAM with 0) (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 1) (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTPARALOOKS) of SUBSTREAM)) (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (fetch (TEXTSTREAM CURRENTLOOKS) of SUBSTREAM )) (RETURN (\BIN SUBSTREAM))) (T (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0) (RETURN PO] (T (* ;  "Need to move to the next page in a file.") (RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM]) (\TEDIT.TEXTBIN.STRINGSETUP - [LAMBDA (CHOFFSET CHARSLEFT STREAM PS) (* ; "Edited 31-May-91 14:21 by jds") - (PROG (OFFST) - (COND - ((fetch (STRINGP FATSTRINGP) of PS) - - (* The string is FAT. Therefore, make all the offsets and things take account - of the fact that each char is really 2 bytes.) - - (freplace (STREAM CPPTR) of STREAM with (ADDBASE (ffetch (STRINGP - BASE) - of PS) - (ffetch (STRINGP OFFST) - of PS))) - - (* The char page ptr can point to the real first char, since it's a word.) - - (freplace (STREAM CPAGE) of STREAM with 0) - (freplace (STREAM COFFSET) of STREAM with (UNFOLD CHOFFSET 2)) - (* Offset into the string, in bytes. - That 2 should really be something - like BYTESPERFATCHAR.) - (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) - (* Page %# within the "file" where - this piece starts) - (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) - (* Char within "page" where the - piece starts (for BACKFILEPTR)) - (freplace (STREAM CBUFSIZE) of STREAM with (IPLUS (UNFOLD CHARSLEFT 2) - (ffetch (STREAM - COFFSET) - of STREAM))) - (* Since the chars-left field is - words, and we're talking bytes.) - (freplace (STREAM EPAGE) of STREAM with 1) - (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) - - (* When we hit the end of the string, we'll have run out off the piece, too.) - - (freplace (TEXTSTREAM REALFILE) of STREAM with NIL) - (replace (STREAM BINABLE) of STREAM with NIL) - (* To force BINs thru the \TEXTBIN - function so we can get two bytes.) - (replace (TEXTSTREAM FATSTREAMP) of STREAM with T) - (* And mark the stream as having - wide characters, so \TEXTBIN knows - what to do.) - ) - (T (* Characters are thin in this - string (the usual case)) - (freplace (STREAM CPPTR) of STREAM with - (ADDBASE (ffetch (STRINGP BASE) - of PS) - (LRSH (SETQ OFFST - (ffetch (STRINGP OFFST) - of PS)) - 1))) - (freplace (STREAM CPAGE) of STREAM with 0) - (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) - (* Page %# within the "file" where - this piece starts) - (freplace (TEXTSTREAM PCSTARTCH) of STREAM with (LOGAND 1 OFFST)) - (* Char within "page" where the - piece starts (for BACKFILEPTR)) - (freplace (STREAM COFFSET) of STREAM with (IPLUS (LOGAND 1 OFFST) - CHOFFSET)) - (freplace (STREAM CBUFSIZE) of STREAM with (IPLUS CHARSLEFT - (ffetch - (STREAM COFFSET) - of STREAM))) - (freplace (STREAM EPAGE) of STREAM with 1) - (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) - (freplace (TEXTSTREAM REALFILE) of STREAM with NIL) - (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL]) (\TEDIT.TEXTBIN.FILESETUP [LAMBDA (PC CHOFFSET CHARSLEFT STREAM PF FATP OPERATION NOERRORFLG) (* ; "Edited 21-Apr-2000 22:28 by jds") (* ; "Edited 8-Jun-99 23:33 by rmk:") (* ; "Edited 8-Jun-99 23:32 by rmk:") (* ; "Edited 15-Apr-93 15:53 by jds") (* ;  "Do the setup needed to make a text stream read from a file.") (PROG ((BYTESLEFT (COND (FATP (UNFOLD CHARSLEFT 2)) (T CHARSLEFT))) (BYTEOFFSET (COND (FATP (UNFOLD CHOFFSET 2)) (T CHOFFSET))) CH FPOS) [COND ((IEQP (ffetch (STREAM ACCESSBITS) of PF) NoBits) (* ; "ASSURE THAT THE FILE IS OPEN") (SETQ PF (\TEDIT.REOPEN.STREAM STREAM PF] [freplace (TEXTSTREAM PCSTARTPG) of STREAM with (ffetch (BYTEPTR PAGE) of (SETQ FPOS (ffetch (PIECE PFPOS) of PC] (* ;  "Page within the file where the piece starts") (freplace (TEXTSTREAM PCSTARTCH) of STREAM with (ffetch (BYTEPTR OFFSET) of FPOS)) (* ;  "Char within the page where it starts.") (SETFILEPTR PF (IPLUS FPOS BYTEOFFSET)) [COND ((ZEROP (GETEOFPTR PF)) (* ;  "For zero-length files, do nothing.") ) ((ILESSP (IPLUS FPOS BYTEOFFSET) (GETEOFPTR PF)) (* ;  "Only get the next character if we aren't positioning past the end of the file.") (SETQ CH (COND ((EQ OPERATION 'BIN) (CL:IF FATP (LOGOR (UNFOLD (\PAGEDBIN PF) 256) (\PAGEDPEEKBIN PF NOERRORFLG)) (\BIN PF))) (T (CL:IF FATP (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PF) 256) (\PAGEDPEEKBIN PF NOERRORFLG)) (\PAGEDBACKFILEPTR PF) (\PEEKBIN PF NOERRORFLG)) (\PEEKBIN PF NOERRORFLG))] (* ;;; "Move all the relevant fields from the backing file's stream into the text stream, so that microcoded BINs will do the right thing.") (freplace (STREAM CPPTR) of STREAM with (ffetch (STREAM CPPTR) of PF)) (freplace (STREAM CPAGE) of STREAM with (ffetch (STREAM CPAGE) of PF)) (freplace (STREAM COFFSET) of STREAM with (ffetch (STREAM COFFSET) of PF)) (freplace (STREAM EPAGE) of STREAM with 32767) (freplace (STREAM CBUFSIZE) of STREAM with (IMIN (ffetch (STREAM CBUFSIZE) of PF) (IPLUS (ffetch (STREAM COFFSET) of PF) BYTESLEFT))) [freplace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE BYTESLEFT (IDIFFERENCE (ffetch (STREAM CBUFSIZE) of STREAM) (ffetch (STREAM COFFSET ) of STREAM] (freplace (TEXTSTREAM REALFILE) of STREAM with PF) (replace (TEXTSTREAM FATSTREAMP) of STREAM with FATP) (* ;  "Mark the stream, if it contains fat characters for this piece.") (replace (STREAM BINABLE) of STREAM with (NOT FATP)) (* ;  "A stream that has fat chars can't use the micrododed BIN.") (* ;  "And return the next character in line") (RETURN CH]) (\TEDIT.TEXTBIN.NEW.PAGE [LAMBDA (STREAM SPLITCHAR) (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 15:01 by rmk:") (* ; "Edited 11-Jun-99 15:01 by rmk:") (* ; "Edited 11-Jun-99 14:18 by rmk:") (* ; "Edited 31-May-91 14:21 by jds") (* * Handle crossing a file-page boundary within TEXTBIN) (* If SPLITCHAR is non-NIL, we've already read the first byte of a two-byte  character, and only need to read the second byte.  Otherwise, this function will read 2 bytes for a fat character.) (PROG ((FILE (fetch (TEXTSTREAM REALFILE) of STREAM)) CH) (* Get the STREAM which describes  the file for real) [COND ((IEQP (fetch (STREAM ACCESSBITS) of FILE) NoBits) (* The file was closed for some  reason; reopen it.) (SETQ FILE (\GETSTREAM [OPENFILE (fetch (STREAM FULLNAME) of FILE) 'INPUT NIL '((TYPE TEXT] 'INPUT] (replace (STREAM COFFSET) of FILE with (fetch (STREAM CBUFSIZE) of FILE)) (* Force it to do a page switch for  us) (SETQ CH (\BIN FILE)) (* Get the next character in the  usual manner) (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) of FILE)) (* Steal the fields we need to  simulate that stream) (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET) of FILE)) (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) of FILE)) (replace (STREAM CBUFSIZE) of STREAM with (IMIN (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE) of FILE))) (* Can't read farther than  end-of-piece, tho) (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE ) of STREAM))) (COND [(AND (fetch (TEXTSTREAM FATSTREAMP) of STREAM) (NOT SPLITCHAR)) (* This piece contains fat characters. Need to grab a second byte from the  file, and construct a 16-bit character) (RETURN (LOGOR (UNFOLD CH 256) (\PAGEDBIN STREAM] (T (* Regular, 8-bit characters.  Just return the one we BINned.) (* or we only need the second byte, since the first byte was on the prior page.) (RETURN CH]) ) (DEFINEQ (\TEXTPEEKBIN - [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 28-Mar-94 15:34 by jds") - (* ; "DO PEEKBIN for a text stream") - (PROG (CH FILE STR PF PS PC PO SUBSTREAM) - (SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM)) - (COND - [(ILESSP (fetch (STREAM COFFSET) of STREAM) - (fetch (STREAM CBUFSIZE) of STREAM)) - (* ; - "Simple case -- just do the usual PEEKBIN") - (COND - ((AND PC (fetch (PIECE POBJ) of PC)) - (RETURN (fetch (PIECE POBJ) of PC))) - [(fetch (TEXTSTREAM FATSTREAMP) of STREAM) - (* ; - "This is a 16 bit PEEKBIN. Grab two chars...") - (RETURN (COND - [(\EOFP STREAM) - (COND - (NOERRORFLG NIL) - (T (\PEEKBIN STREAM] - ((ILESSP (fetch (STREAM COFFSET) of STREAM) - (SUB1 (fetch (STREAM CBUFSIZE) of STREAM))) - (* ; - "We're sure of staying on the same page. Just grab the characters") - (PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM) - 256) - (\PAGEDPEEKBIN STREAM NOERRORFLG)) - (\PAGEDBACKFILEPTR STREAM))) - (T (SETQ PS (fetch (STREAM F1) of STREAM)) - (replace (STREAM COFFSET) of PS with (fetch - (STREAM COFFSET) - of STREAM)) - (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS) - 256) - (\PAGEDPEEKBIN PS NOERRORFLG)) - (\PAGEDBACKFILEPTR PS] - (T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG] - [PC (* ; - "We've either hit a page bound in a file, or a piece bound.") - (RETURN (COND - [(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) - (* ; "Time for a new piece.") - (SETQ PC (replace (TEXTSTREAM PIECE) of STREAM - with (fetch (PIECE NEXTPIECE) of PC))) - (* ; - "Move to the next piece in the chain") - (COND - [PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM - with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) - of PC) - PC - (fetch (TEXTSTREAM TEXTOBJ) of STREAM) - )) - (COND - [(SETQ PO (fetch (PIECE POBJ) of PC)) - (replace (STREAM BINABLE) of STREAM with NIL) - (freplace (STREAM CBUFSIZE) of STREAM - with (fetch (PIECE PLEN) of PC)) - (freplace (STREAM COFFSET) of STREAM with 0) - (COND - (SUBSTREAM (* ; - "There is a stream below this one, to feed chars upward.") - (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) - of SUBSTREAM)) - (freplace (TEXTSTREAM CHARSLEFT) of STREAM - with (fetch (PIECE PLEN) of PC)) - (freplace (STREAM CPAGE) of STREAM - with 0) - (freplace (TEXTSTREAM PCSTARTCH) of STREAM - with 0) - (freplace (TEXTSTREAM PCSTARTPG) of STREAM - with 0) - (replace (TEXTSTREAM CURRENTPARALOOKS) - of STREAM with (fetch (TEXTSTREAM - - CURRENTPARALOOKS - ) - of SUBSTREAM)) - (replace (TEXTSTREAM CURRENTLOOKS) of - STREAM - with (fetch (TEXTSTREAM CURRENTLOOKS) - of SUBSTREAM)) - (RETURN (\BIN SUBSTREAM))) - (T (replace (TEXTSTREAM CHARSLEFT) of STREAM - with 0) - (RETURN PO] - ((SETQ PS (fetch (PIECE PSTR) of PC)) - (* ; "This piece lives in a string.") - (\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN) - of PC) - STREAM PS) - - (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.") - - (\PEEKBIN STREAM NOERRORFLG)) - ((SETQ PF (fetch (PIECE PFILE) of PC)) - (* ; "This piece lives on a file.") - (\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN) - of PC) - STREAM PF (fetch (PIECE PFATP) of PC) - 'PEEKBIN NOERRORFLG)) - (T (ERROR "CAN'T GET TO NEXT PIECE"] - (NOERRORFLG (* ; - "There are no more pieces. Punt gracefully") - (RETURN NIL)) - (T (* ; "He wants it the hard way.") - (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM) - STREAM] - (T (* ; - "Need to move to the next page in a file.") - (RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG] - (NOERRORFLG (* ; - "There are no more pieces. Punt gracefully") - (RETURN NIL)) - (T (* ; "He wants it the hard way.") - (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM) - STREAM]) (\TEDIT.PEEKBIN.NEW.PAGE [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 11-Jun-99 15:11 by rmk:") (* ; "Edited 31-May-91 14:21 by jds") (* * Handle crossing a file-page boundary within \TEXTPEEKBIN) (* If SPLITCHAR is non-NIL, we've already read the first byte of a two-byte  character, and only need to read the second byte.  Otherwise, this function will read 2 bytes for a fat character.) (PROG ((FILE (fetch (TEXTSTREAM REALFILE) of STREAM)) CH) (* Get the STREAM which describes  the file for real) [COND ((IEQP (fetch (STREAM ACCESSBITS) of FILE) NoBits) (* The file was closed for some  reason; reopen it.) (SETQ FILE (\GETSTREAM [OPENFILE (fetch (STREAM FULLNAME) of FILE) 'INPUT NIL '((TYPE TEXT] 'INPUT] (replace (STREAM COFFSET) of FILE with (fetch (STREAM CBUFSIZE) of FILE)) (* Force it to do a page switch for  us) [SETQ CH (COND [(\EOFP FILE) (COND (NOERRORFLG NIL) (T (\PEEKBIN FILE] ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) (PROG1 (LOGOR (UNFOLD (\PAGEDBIN FILE) 256) (\PAGEDPEEKBIN FILE NOERRORFLG)) (\PAGEDBACKFILEPTR FILE))) (T (\PEEKBIN FILE NOERRORFLG] (* Get the next character in the  usual manner) (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) of FILE)) (* Steal the fields we need to  simulate that stream) (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET) of FILE)) (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) of FILE)) (replace (STREAM CBUFSIZE) of STREAM with (IMIN (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE) of FILE))) (* Can't read farther than  end-of-piece, tho) (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE ) of STREAM))) (RETURN CH]) ) (* ; "Support for TEXTPROP") (DEFINEQ (CGETTEXTPROP - [LAMBDA (TEXTOBJ PROP) (* ; "Edited 20-Oct-87 12:36 by jds") - - (* ;; "compiles calls on TEXTPROP that are fetching values. This needs to be changed whenever GETTEXTPROP is changed.") - - (SELECTQ PROP - ((READONLY READ-ONLY) - `(fetch (TEXTOBJ TXTREADONLY) of ,TEXTOBJ)) - `(LISTGET (fetch (TEXTOBJ EDITPROPS) of ,TEXTOBJ) - ',PROP]) (CTEXTPROP - [LAMBDA (FORMTAIL) (* ; "Edited 31-May-91 13:59 by jds") - - (* ;; "compiles calls to TEXTPROP") - - (COND - ((NULL (CDR FORMTAIL)) (* ; "less that 2 args") - (printout T "Possible error in call to TEXTPROP: less than 2 args" T (LIST 'TEXTPROP FORMTAIL - ) - T) - (CGETTEXTPROP (LIST 'TEXTOBJ (CAR FORMTAIL)) - NIL)) - ((NOT (EQ (CAADR FORMTAIL) - 'QUOTE)) (* ; "property is not quoted.") - 'IGNOREMACRO) - [(NULL (CDDR FORMTAIL)) (* ; "fetching a TEXTPROP property.") - (CGETTEXTPROP (LIST 'TEXTOBJ (CAR FORMTAIL)) - (CADR (CADR FORMTAIL] - (T (* ; "storing a window property") - (LET ((TEXTOBJ (CAR FORMTAIL)) - (PROP (CDADR FORMTAIL)) - (VAL (CADDR FORMTAIL))) - [SELECTQ PROP - ((READONLY READ-ONLY) - `(REPLACE (TEXTOBJ TXTREADONLY) OF ,TEXTOBJ WITH ,VAL)) - `(COND - [(FETCH (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ)) - (LISTPUT (FETCH (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ)) - ',PROP - ',VAL] - (T (REPLACE (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ) - WITH (LIST ,PROP ,VAL] - (LIST 'COND (LIST (LIST 'FETCH 'EDITPROPS 'OF (LIST 'TEXTOBJ (CAR FORMTAIL))) - (LIST 'LISTPUT (LIST 'FETCH 'EDITPROPS 'OF (LIST 'TEXTOBJ - (CAR FORMTAIL))) - (CADR FORMTAIL) - (CADDR FORMTAIL))) - (LIST T (LIST 'REPLACE 'EDITPROPS 'OF (LIST 'TEXTOBJ (CAR FORMTAIL)) - 'WITH - (LIST 'LIST (CADR FORMTAIL) - (CADDR FORMTAIL]) (GETTEXTPROP - [LAMBDA (TEXTOBJ PROP) (* ; "Edited 9-Feb-89 11:20 by jds") - - (* ;; "Gets values for document properties. Used by TEXTPROP.") - - (SELECTQ PROP - ((READONLY READ-ONLY) - (FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ)) - ((BEING-EDITED ACTIVE) - (FETCH (TEXTOBJ TXTEDITING) OF TEXTOBJ)) - ((NO-NS-CHARS NONSCHARS NO-NSCHARS) - (FETCH (TEXTOBJ TXTNONSCHARS) OF TEXTOBJ)) - (LISTGET (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ) - PROP]) (PUTTEXTPROP - [LAMBDA (TEXTOBJ PROP VALUE) (* ; "Edited 9-Feb-89 11:19 by jds") - (* ; - "put a value on prop list for a textobj") - (SELECTQ PROP - ((READONLY READ-ONLY) - (PROG1 (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) - (replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with VALUE))) - ((BEING-EDITED ACTIVE) - (PROG1 (fetch (TEXTOBJ TXTEDITING) of TEXTOBJ) - (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with VALUE))) - ((NO-NS-CHARS NONSCHARS NO-NSCHARS) - (PROG1 (fetch (TEXTOBJ TXTNONSCHARS) of TEXTOBJ) - (replace (TEXTOBJ TXTNONSCHARS) of TEXTOBJ with VALUE))) - (COND - ((fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ)) - (PROG1 (LISTGET (ffetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ)) - PROP) - (LISTPUT (ffetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ)) - PROP VALUE))) - (T (freplace (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ) with (LIST PROP VALUE)) - NIL]) (TEXTPROP - [LAMBDA X (* ; "Edited 9-Feb-89 11:20 by jds") - - (* ;; "general top level entry for both fetching and setting window properties.") - - (COND - ((IGREATERP X 2) - (PUTTEXTPROP (TEXTOBJ (ARG X 1)) - (ARG X 2) - (ARG X 3))) - ((EQ X 2) - (GETTEXTPROP (TEXTOBJ (ARG X 1)) - (ARG X 2))) - (T (\ILLEGAL.ARG NIL]) ) (* ;; "Support for error handling: The old error handler for the stream-not-open error. This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)" ) (RPAQ? *TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN)) (DECLARE%: DONTEVAL@LOAD DOCOPY (\TEXTINIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TEXTPROP) ) (PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1995 1999 2000)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3047 53330 (COPYTEXTSTREAM 3057 . 6179) (OPENTEXTSTREAM 6181 . 21058) (REOPENTEXTSTREAM 21060 . 21482) (TEDIT.STREAMCHANGEDP 21484 . 21782) (TEXTSTREAMP 21784 . 22098) (TXTFILE 22100 . 22545) (\DELETECH 22547 . 33803) (\SETUPGETCH 33805 . 41323) (\TEDIT.REOPEN.STREAM 41325 . 43175) ( \TEDIT.COPYTEXTSTREAM.PIECEMAPFN 43177 . 45615) (\TEXTINIT 45617 . 51223) (\TEXTMARK 51225 . 51973) ( \TEXTTTYBOUT 51975 . 53328)) (53331 78763 (\INSERTCH 53341 . 77067) (\INSERTCR 77069 . 78761)) (78829 99145 (\CHTOPC 78839 . 80028) (\CHTOPCNO 80030 . 81292) (\CLEARPCTB 81294 . 82090) ( \CREATEPIECEORSTREAM 82092 . 85066) (\DELETEPIECE 85068 . 85981) (\FINDPIECE 85983 . 86349) ( \INSERTPIECE 86351 . 89361) (\MAKEPCTB 89363 . 91278) (\SPLITPIECE 91280 . 98239) (\INSERT.FIRST.PIECE 98241 . 99143)) (99197 123132 (\TEXTCLOSEF 99207 . 100434) (\TEXTCLOSEF-SUBTREE 100436 . 101142) ( \TEXTDSPFONT 101144 . 102136) (\TEXTEOFP 102138 . 103497) (\TEXTGETEOFPTR 103499 . 103709) ( \TEXTGETFILEPTR 103711 . 105774) (\TEXTOPENF 105776 . 106606) (\TEXTOPENF-SUBTREE 106608 . 107409) ( \TEXTOUTCHARFN 107411 . 107759) (\TEXTBACKFILEPTR 107761 . 113662) (\TEXTBOUT 113664 . 117012) ( \TEDITOUTCHARFN 117014 . 118260) (\TEXTSETEOF 118262 . 118771) (\TEXTSETFILEPTR 118773 . 119998) ( \TEXTDSPXPOSITION 120000 . 120427) (\TEXTDSPYPOSITION 120429 . 120974) (\TEXTLEFTMARGIN 120976 . 121459) (\TEXTRIGHTMARGIN 121461 . 122297) (\TEXTDSPCHARWIDTH 122299 . 122654) (\TEXTDSPSTRINGWIDTH 122656 . 123026) (\TEXTDSPLINEFEED 123028 . 123130)) (123133 156890 (\TEXTBIN 123143 . 139931) ( \TEDIT.TEXTBIN.STRINGSETUP 139933 . 145646) (\TEDIT.TEXTBIN.FILESETUP 145648 . 152045) ( \TEDIT.TEXTBIN.NEW.PAGE 152047 . 156888)) (156891 170299 (\TEXTPEEKBIN 156901 . 166040) ( \TEDIT.PEEKBIN.NEW.PAGE 166042 . 170297)) (170337 175555 (CGETTEXTPROP 170347 . 170823) (CTEXTPROP 170825 . 173169) (GETTEXTPROP 173171 . 173766) (PUTTEXTPROP 173768 . 175093) (TEXTPROP 175095 . 175553 ))))) STOP \ No newline at end of file diff --git a/library/TFBRAVO.~1~ b/library/TFBRAVO.~1~ deleted file mode 100644 index 553f78b1..00000000 --- a/library/TFBRAVO.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-May-91 15:27:45" |{PELE:MV:ENVOS}LIBRARY>TFBRAVO.;4| 74543 changes to%: (FNS \TFBRAVO.HANDLE.HEADING \TFBRAVO.INIT.CHARLOOKS \TFBRAVO.WRITE.RUN \SHIFT.DOCUMENT \TFBRAVO.ADD.NAMEDTAB \TFBRAVO.APPLY.PARALOOKS \TFBRAVO.WRITE.PARAGRAPH \TFBRAVO.INIT.PARALOOKS \TFBRAVO.READ.PARALOOKS \TFBRAVO.READ.CHARLOOKS \TFBRAVO.FONT.FROM.CHARLOOKS) previous date%: "26-Apr-91 14:27:21" |{PELE:MV:ENVOS}LIBRARY>TFBRAVO.;3|) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TFBRAVOCOMS) (RPAQQ TFBRAVOCOMS [(FILES TEDITDECLS) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDECLS)) [DECLARE%: EVAL@COMPILE DONTCOPY (COMS (* ; "Compile-time needs") (RECORDS FONT PARA RUN TFBRAVOPAGEFRAMES) (CONSTANTS (PTSPERINCH 72.27) (DefaultLeftMargin 2540) (DefaultFirstLineLeftMargin 2540) (DefaultRightMargin 19050) (HardwareLeftMargin 2540) (HardwareRightMargin (ITIMES 8 2540)) (BRAVO.TRAILER.CHARS '(l d z x e y k j c q %( %) %, s S u U b B i I g G v V w W t f o % \ 0 1 2 3 4 5 6 7 8 9] (FNS \TFBRAVO.FIND.LAST.TRAILER \TFBRAVO.HANDLE.HEADING \TFBRAVO.INIT.CHARLOOKS \TFBRAVO.INIT.PAGEFORMAT \TFBRAVO.INSTALL.PAGEFORMAT \TFBRAVO.PARSE.PROFILE.PARA \TFBRAVO.PARSE.PROFILE.VALUE \TFBRAVO.GET.FONTSIZE \TFBRAVO.GET.FONTSTYLE \TFBRAVO.WRITE.RUN \TFBRAVO.ASSERT \SHIFT.DOCUMENT \TEDIT.BRAVOFILE? \TEST.CHARACTER.LOOKS \TEST.PARAGRAPH.LOOKS) (FNS \TFBRAVO.COPY.NAMEDTAB \TFBRAVO.PUT.NAMEDTAB \TFBRAVO.GET.NAMEDTAB \TFBRAVO.ADD.NAMEDTAB \NAMEDTABNYET \NAMEDTABSIZE \NAMEDTAB.INIT) (FNS \TFBRAVO.APPLY.PARALOOKS TEDITFROMBRAVO \TFBRAVO.WRITE.PARAGRAPH \TFBRAVO.WRITE.RUNS \TFBRAVO.SPREAD.LOOKS \TFBRAVO.PARSE.PARA \TFBRAVO.INIT.PARALOOKS \TFBRAVO.READ.PARALOOKS \TFBRAVO.READ.CHARLOOKS \TFBRAVO.READ.USER.CM \TFBRAVO.GETPARAMS \TFBRAVO.PARAMNAMEP \TFBRAVO.EOLS \TFBRAVO.LCASER \TFBRAVO.FONT.FROM.CHARLOOKS) (INITVARS (USER.CM.RDTBL (COPYREADTABLE)) (PROFILE.PARA.RDTBL (COPYREADTABLE))) (P (SETSYNTAX (CHARCODE %:) 'SEPRCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE EOL) 'BREAKCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE ^Z) 'SEPRCHAR PROFILE.PARA.RDTBL)) (GLOBALVARS \NAMEDTAB.IMAGEFNS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADDTOVAR TEDIT.INPUT.FORMATS (\TEDIT.BRAVOFILE? TEDITFROMBRAVO)) (\NAMEDTAB.INIT]) (FILESLOAD TEDITDECLS) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDECLS) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* ; "Compile-time needs") (DECLARE%: EVAL@COMPILE (RECORD FONT (SIZE STYLE THICKNESS . SLANT)) (RECORD PARA (PARALOOKS . RUNS)) (RECORD RUN (RUNLENGTH . RUNLOOKS)) (RECORD TFBRAVOPAGEFRAMES (TFBRAVODEFAULT TFBRAVOODD TFBRAVOEVEN)) ) (DECLARE%: EVAL@COMPILE (RPAQQ PTSPERINCH 72.27) (RPAQQ DefaultLeftMargin 2540) (RPAQQ DefaultFirstLineLeftMargin 2540) (RPAQQ DefaultRightMargin 19050) (RPAQQ HardwareLeftMargin 2540) (RPAQ HardwareRightMargin (ITIMES 8 2540)) (RPAQQ BRAVO.TRAILER.CHARS (l d z x e y k j c q %( %) %, s S u U b B i I g G v V w W t f o % \ 0 1 2 3 4 5 6 7 8 9)) [CONSTANTS (PTSPERINCH 72.27) (DefaultLeftMargin 2540) (DefaultFirstLineLeftMargin 2540) (DefaultRightMargin 19050) (HardwareLeftMargin 2540) (HardwareRightMargin (ITIMES 8 2540)) (BRAVO.TRAILER.CHARS '(l d z x e y k j c q %( %) %, s S u U b B i I g G v V w W t f o % \ 0 1 2 3 4 5 6 7 8 9] ) ) (DEFINEQ (\TFBRAVO.FIND.LAST.TRAILER (LAMBDA (FILE) (* jds "27-Dec-84 19:13") (* scans backwards from the end of the file trying to find the beginning of the  last Bravo trailer. Returns NIL if not found, otherwise T) (PROG ((STREAM (GETSTREAM FILE))) (SETFILEPTR STREAM -1) (RETURN (COND ((IGREATERP (GETFILEPTR STREAM) 0) (COND ((NEQ (\BACKBIN STREAM) (CHARCODE CR)) (* last character of a trailer must be a carriage return) NIL) (T (while (AND (IGREATERP (GETFILEPTR STREAM) 0) (FMEMB (CHARACTER (\BACKBIN STREAM)) BRAVO.TRAILER.CHARS)) do NIL) (COND ((EQ (\PEEKBIN STREAM) (CHARCODE ^Z)) (* this is a potentially legal trailer) T) (T NIL))))) (T (* empty files are not Bravo files.  It says here!) NIL)))))) (\TFBRAVO.HANDLE.HEADING [LAMBDA (INPUT TEXTOBJ) (* ; "Edited 31-May-91 15:26 by jds") (* Called from  \tfbravo.parse.profile.para) (DECLARE%: USEDFREE NEXTPARAPTR) (PROG ((AFTERHEADINGPTR) PARALOOKS HEADINGDESC) (SETFILEPTR IN NEXTPARAPTR) (* skip over the trailer of the  profile para) (SETQ HEADINGPARA (\TFBRAVO.PARSE.PARA USER.CM.PARALOOKS IN)) (SETQ AFTERHEADINGPTR (GETFILEPTR IN)) (SETQ PARALOOKS (fetch PARALOOKS of HEADINGPARA)) (replace (FMTSPEC FMTPARATYPE) of PARALOOKS with 'PAGEHEADING) (* This is where the vertical tab info is placed for the heading, remove the  special x and y and use them as the position for the descriptor) (SETQ HEADINGDESC (LIST (GENSYM 'PageHeading) (OR (fetch (FMTSPEC FMTSPECIALX) of PARALOOKS) 0) (OR (fetch (FMTSPEC FMTSPECIALY) of PARALOOKS) 0))) (replace (FMTSPEC FMTPARASUBTYPE) of PARALOOKS with (CAR HEADINGDESC)) (replace (FMTSPEC FMTSPECIALX) of PARALOOKS with NIL) (replace (FMTSPEC FMTSPECIALY) of PARALOOKS with NIL) (* now write out the paragraph) (SETFILEPTR IN NEXTPARAPTR) (\TFBRAVO.WRITE.PARAGRAPH HEADINGPARA IN TEXTOBJ MAX.FIXP) (SETQ NEXTPARAPTR AFTERHEADINGPTR) (RETURN HEADINGDESC]) (\TFBRAVO.INIT.CHARLOOKS [LAMBDA NIL (* ; "Edited 31-May-91 15:25 by jds") (* * Creates the charlooks instance which is used as the template for the rest) (PROG ((LOOKS (create CHARLOOKS))) (replace (CHARLOOKS CLSIZE) of LOOKS with (\TFBRAVO.GET.FONTSIZE 0)) (replace (CHARLOOKS CLNAME) of LOOKS (\TFBRAVO.GET.FONTSTYLE 0)) (* (FONTCREATE (  \TFBRAVO.GET.FONTSTYLE)  (fetch (CHARLOOKS CLSIZE) of LOOKS))) (replace (CHARLOOKS CLOFFSET) of LOOKS with 0) (RETURN LOOKS]) (\TFBRAVO.INIT.PAGEFORMAT (LAMBDA (TEXTOBJ) (* gbn "31-May-85 17:13") (* * installs the default values of the page formatting nonsense as textprops) (TEXTPROP TEXTOBJ 'PAGENUMBERS T) (TEXTPROP TEXTOBJ 'PAGENUMBERX 307) (TEXTPROP TEXTOBJ 'PAGENUMBERY 756) (TEXTPROP TEXTOBJ 'TOPMARGIN 72) (TEXTPROP TEXTOBJ 'BOTTOMMARGIN 72) (TEXTPROP TEXTOBJ 'PAGENUMBER.NOTONFIRSTPAGE T))) (\TFBRAVO.INSTALL.PAGEFORMAT [LAMBDA (TEXTOBJ) (* ; "Edited 13-Jun-90 01:00 by mitani") (* * using the information from the profile paragraphs, this function installs  the pageframes) (PROG (PAGENUMBERS PAGENUMBERX PAGENUMBERY TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS BETWEENCOLUMNS ODDHEADINGDESC HEADINGDESC EVENHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE EVENHEADING.NOTONFIRSTPAGE ODDHEADING.NOTONFIRSTPAGE PAGEFRAMES) (for VAR in '(PAGENUMBERS PAGENUMBERX PAGENUMBERY TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS BETWEENCOLUMNS ODDHEADINGDESC HEADINGDESC EVENHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE EVENHEADING.NOTONFIRSTPAGE ODDHEADING.NOTONFIRSTPAGE) do (SET VAR (TEXTPROP TEXTOBJ VAR))) (SETQ PAGEFRAMES (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with (create TFBRAVOPAGEFRAMES ))) (* this assumes that TEdit does not build a default page spec.  If it ever does, then this logic must change.) (* * the default page frame is always built.  It is sometimes built as the only page frame when there is no headings  specified. However, if heading is specified with the not-on-first-page  specified, then we must build the default page frame simply for that reason) (replace (TFBRAVOPAGEFRAMES TFBRAVODEFAULT) of PAGEFRAMES with (TEDIT.SINGLE.PAGEFORMAT (AND PAGENUMBERS (NOT PAGENUMBER.NOTONFIRSTPAGE)) PAGENUMBERX PAGENUMBERY NIL NIL 0 0 TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS NIL BETWEENCOLUMNS [COND (HEADINGDESC (if HEADING.NOTONFIRSTPAGE then NIL else (LIST HEADINGDESC))) (ODDHEADINGDESC (if ODDHEADING.NOTONFIRSTPAGE then NIL else (LIST HEADINGDESC))) (EVENHEADINGDESC (if EVENHEADING.NOTONFIRSTPAGE then NIL else (LIST EVENHEADINGDESC] 'POINTS)) [COND ((OR ODDHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE) (replace TFBRAVOODD of PAGEFRAMES with (TEDIT.SINGLE.PAGEFORMAT PAGENUMBERS PAGENUMBERX PAGENUMBERY NIL NIL 0 0 TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS NIL BETWEENCOLUMNS (COND (ODDHEADINGDESC (LIST ODDHEADINGDESC)) (HEADINGDESC (LIST HEADINGDESC)) (T NIL)) 'POINTS] [COND ((OR EVENHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE) (replace TFBRAVOEVEN of PAGEFRAMES with (TEDIT.SINGLE.PAGEFORMAT PAGENUMBERS PAGENUMBERX PAGENUMBERY NIL NIL 0 0 TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS NIL BETWEENCOLUMNS (COND (EVENHEADINGDESC (LIST EVENHEADINGDESC)) (HEADINGDESC (LIST HEADINGDESC)) (T NIL)) 'POINTS] (RETURN]) (\TFBRAVO.PARSE.PROFILE.PARA (LAMBDA (IN PARA TEXTOBJ) (* gbn " 3-Jun-85 17:23") (* * Parse a Bravo profile paragraph, and set up the corresponding TEdit page  looks, headings, page numbers, Much of the state for building the pageframe  must be stuffed on the textstream, so that after this fn has been called for  the last time, the pageframe can be built) (DECLARE%: USEDFREE NEXTPARAPTR) (PROG (TOKEN TOKENS (PARAEND NEXTPARAPTR)) (* * check that the positioning takes into account binding and edgemargin etc.) (while (ILESSP (GETFILEPTR IN) PARAEND) do (SETQ TOKENS (U-CASE (RATOMS (CHARACTER (CHARCODE EOL)) IN PROFILE.PARA.RDTBL))) (SELECTQ (SETQ TOKEN (pop TOKENS)) (PAGE (* parse the page numbers stuff) (\TFBRAVO.ASSERT 'NUMBERS (pop TOKENS)) (while TOKENS do (SELECTQ (SETQ TOKEN (pop TOKENS)) (NO (TEXTPROP TEXTOBJ 'PAGENUMBERS 'NIL)) (YES (* this is default)) (FIRST (\TFBRAVO.ASSERT 'PAGE (pop TOKENS)) (* If a first page is specified, we can't handle that yet, but at least number  the first page, since the only way to number the first page in Bravo is to  specify the number for the first page. Not-on-first-page is assumed) (TEXTPROP TEXTOBJ 'PAGENUMBER.NOTONFIRSTPAGE 'NIL) (TEXTPROP TEXTOBJ 'FIRSTPAGENO (pop TOKENS))) (NOT-ON-FIRST-PAGE (TEXTPROP TEXTOBJ 'PAGENUMBER.NOTONFIRSTPAGE 'T)) (X (TEXTPROP TEXTOBJ 'PAGENUMBERX (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (Y (TEXTPROP TEXTOBJ 'PAGENUMBERY (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (ROMAN (* tough, I don't do Roman Numerals) NIL) (PROGN (* otherwise, just presume we've hit the end of the page number stuff) NIL)))) (COLUMNS (* parse the columns numbers stuff) (TEXTPROP TEXTOBJ 'NUMBEROFCOLUMNS (pop TOKENS)) (while TOKENS do (SELECTQ (SETQ TOKEN (pop TOKENS)) (EDGE (\TFBRAVO.ASSERT 'MARGIN (pop TOKENS)) (TEXTPROP TEXTOBJ 'EDGEMARGIN (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (BETWEEN (\TFBRAVO.ASSERT 'COLUMNS (pop TOKENS)) (TEXTPROP TEXTOBJ 'BETWEENCOLUMNS (\TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (PROGN NIL)))) (MARGINS (* parse the margins stuff) (while TOKENS do (SELECTQ (SETQ TOKEN (pop TOKENS)) (TOP (TEXTPROP TEXTOBJ 'TOPMARGIN (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (BOTTOM (TEXTPROP TEXTOBJ 'BOTTOMMARGIN (\TFBRAVO.PARSE.PROFILE.VALUE TOKENS ))) (BINDING (TEXTPROP TEXTOBJ 'BINDING (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (PROGN (* otherwise, just presume we've hit the end of the page number stuff) NIL)))) (ODD (\TFBRAVO.ASSERT (pop TOKENS) 'HEADING) (COND ((AND TOKENS (EQ (CAR TOKENS) 'NOT-ON-FIRST-PAGE)) (pop TOKENS) (TEXTPROP TEXTOBJ 'ODDHEADING.NOTONFIRSTPAGE T))) (TEXTPROP TEXTOBJ 'ODDHEADINGDESC (\TFBRAVO.HANDLE.HEADING IN TEXTOBJ))) (EVEN (\TFBRAVO.ASSERT (pop TOKENS) 'HEADING) (COND ((AND TOKENS (EQ (CAR TOKENS) 'NOT-ON-FIRST-PAGE)) (pop TOKENS) (TEXTPROP TEXTOBJ 'EVENHEADING.NOTONFIRSTPAGE T))) (TEXTPROP TEXTOBJ 'EVENHEADINGDESC (\TFBRAVO.HANDLE.HEADING IN TEXTOBJ))) (HEADING (COND ((AND TOKENS (EQ (CAR TOKENS) 'NOT-ON-FIRST-PAGE)) (pop TOKENS) (TEXTPROP TEXTOBJ 'HEADING.NOTONFIRSTPAGE T))) (TEXTPROP TEXTOBJ 'HEADINGDESC (\TFBRAVO.HANDLE.HEADING IN TEXTOBJ))) (LINE (* don't support Line Numbers) NIL) (PRIVATE (* private data stamp bull, ignore) NIL) (PROGN (* do nothing with this line,) NIL))) (* The left margin is 0 for all bravo relative measurements) (COND ((TEXTPROP TEXTOBJ 'NUMBEROFCOLUMNS) (* if this is to be printed multicolumn then determine the column width from  the numberofcolumns and the space between them) (TEXTPROP TEXTOBJ 'COLUMNWIDTH (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (CONSTANT (TIMES 8.5 PTSPERINCH )) (ITIMES 2 (TEXTPROP TEXTOBJ 'EDGEMARGIN))) (ITIMES (SUB1 (TEXTPROP TEXTOBJ ' NUMBEROFCOLUMNS)) (TEXTPROP TEXTOBJ 'BETWEENCOLUMNS))) (TEXTPROP TEXTOBJ 'NUMBEROFCOLUMNS)))))))) (\TFBRAVO.PARSE.PROFILE.VALUE (LAMBDA (TOKENLIST) (* gbn "15-Nov-84 13:48") (* * returns a value always specified in pts, regardless of whether it was that  way in the token list (NB since RPLNODE is being used, there must always be a  token after the value and/or inches sign)) (PROG ((VALUE (PROG1 (CAR TOKENLIST) (RPLNODE2 TOKENLIST (CDR TOKENLIST)))) (POINTSPERINCH 72.27) (INCHES '%")) (if (EQ (CAR TOKENLIST) INCHES) then (SETQ VALUE (TIMES VALUE POINTSPERINCH)) (RPLNODE2 TOKENLIST (CDR TOKENLIST))) (RETURN (FIX VALUE))))) (\TFBRAVO.GET.FONTSIZE (LAMBDA (FONT) (* gbn "19-Sep-84 01:47") (* ADD CL:DECLARATION TO ADMIT THAT YOU ARE USING L FREE, BEST TO REPLACE WITH  AN ARRAY IN FACT) (CADDR (FASSOC FONT (FASSOC 'Font USER.CM.ALIST))))) (\TFBRAVO.GET.FONTSTYLE (LAMBDA (FONT) (* gbn "19-Sep-84 01:46") (* ADD CL:DECLARATION TO ADMIT THAT YOU ARE USING USER.CM.ALIST FREE, BEST TO  REPLACE WITH AN ARRAY IN FACT) (CADR (FASSOC FONT (FASSOC 'Font USER.CM.ALIST))))) (\TFBRAVO.WRITE.RUN [LAMBDA (RUN IN PARALOOKS TEXTOBJ) (* ; "Edited 31-May-91 15:25 by jds") (PROG (START END NAMEDTABNUMBER (LOOKS (fetch RUNLOOKS of RUN))) (SETQ NAMEDTABNUMBER (fetch (CHARLOOKS CLUSERINFO) of (fetch RUNLOOKS of RUN))) (COND ((ILEQ (fetch RUNLENGTH of RUN) 0) (RETURN)) ([AND NAMEDTABNUMBER (EQUAL (PEEKC) (CHARACTER (CHARCODE ^I] (* only treat the run like a tab if it has charcode 9, even if it has a tab  number. Color is overloaded onto tab numbers in BRAVO.  Jerks! Jerks!) (\TFBRAVO.ADD.NAMEDTAB TEXTOBJ NAMEDTABNUMBER PARALOOKS)) (T (SETQ END (IPLUS (SETQ START (GETFILEPTR IN)) (fetch RUNLENGTH of RUN))) (TEDIT.RAW.INCLUDE TEXTOBJ IN START END) (TEDIT.LOOKS TEXTOBJ LOOKS]) (\TFBRAVO.ASSERT (LAMBDA (X Y) (* gbn "19-Sep-84 21:39") (if (NEQ X Y) then (HELP "While parsing profile paragraph, " (CONCAT X " was expected, but " Y " was found."))))) (\SHIFT.DOCUMENT [LAMBDA (PCTB DELTAX) (* ; "Edited 31-May-91 15:26 by jds") (* ;; "shifts all tabs, left and right margins by deltax. DOES NOT VERIFY that this produces reasonable values") (* ; "a change for DFNFLG") (PROG ((PC (\EDITELT PCTB (ADD1 \FirstPieceOffset))) TSPEC LASTPARALOOKS PARALOOKS) (while PC do (COND [(NEQ (fetch (PIECE PPARALOOKS) of PC) LASTPARALOOKS) (* ;  "This is a new set of looks -- go ahead and change it.") (COND ((SETQ TAB.OBJECT (fetch (PIECE POBJ) of PC)) (* ; "shift the tabspec by deltax") (IMAGEOBJPROP TAB.OBJECT 'OBJECTDATUM (IPLUS (fetch OBJECTDATUM of TAB.OBJECT) DELTAX))) ((SETQ PARALOOKS (fetch (PIECE PPARALOOKS) of PC)) (SETQ PARALOOKS (replace (PIECE PPARALOOKS) of PC with (create FMTSPEC using PARALOOKS))) (replace (FMTSPEC 1STLEFTMAR) of PARALOOKS with (IPLUS (fetch (FMTSPEC 1STLEFTMAR) of PARALOOKS) DELTAX)) (replace (FMTSPEC LEFTMAR) of PARALOOKS with (IPLUS (fetch (FMTSPEC LEFTMAR) of PARALOOKS) DELTAX)) (replace (FMTSPEC RIGHTMAR) of PARALOOKS with (IPLUS (fetch (FMTSPEC RIGHTMAR) of PARALOOKS) DELTAX)) (SETQ TSPEC (fetch (FMTSPEC TABSPEC) of PARALOOKS)) (* ;; "only subtract the deltax from the absolute positions, not from the relative tabstop (the car of the tabspec)") (* ;  "this has too much leeway. I think tabspecs are fixed format. Check!") [replace (FMTSPEC TABSPEC) of PARALOOKS with (CONS (CAR TSPEC) (for ELEMENT in (CDR TSPEC) collect (SELECTQ (TYPENAME ELEMENT) (FIXP (IPLUS DELTAX ELEMENT)) (LISTP (CONS (IPLUS DELTAX (CAR ELEMENT)) (CDR ELEMENT))) (NILL] (replace (PIECE PPARALOOKS) of PC with ( \TEDIT.UNIQUIFY.PARALOOKS PARALOOKS TEXTOBJ] (T (replace (PIECE PPARALOOKS) of PC with LASTPARALOOKS))) (SETQ LASTPARALOOKS (fetch (PIECE PPARALOOKS) of PC)) (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) (\TEDIT.BRAVOFILE? (LAMBDA (FILE A B C) (* gbn " 3-Jun-85 21:06") (* Test a file to see if it is a BRAVO file, asking if it is to be converted) (* Returns the name of the user.cm file to be used in the conversion of this  file) (PROG (PLOOKS ENDCONDITION (ORIGINAL.FILE.POSITION (GETFILEPTR FILE)) NAME DIRS) (* first look for a ^z,  (beginning of a Bravo trailer)) (COND ((NOT (\TFBRAVO.FIND.LAST.TRAILER FILE)) (SETFILEPTR FILE ORIGINAL.FILE.POSITION) (RETURN NIL))) (* BIN past the ^z) (BIN FILE) (SETQ PLOOKS (\TEST.PARAGRAPH.LOOKS FILE)) (* if the next symbol is a slash then check if the character looks are valid) (SETQ ENDCONDITION (COND ((EQ (CAR PLOOKS) '\) (repeatuntil (\TEST.CHARACTER.LOOKS FILE))))) (COND ((EQ ENDCONDITION 'BADLOOKS) (SETFILEPTR FILE ORIGINAL.FILE.POSITION) (RETURN NIL)) (T (SETFILEPTR FILE ORIGINAL.FILE.POSITION) (* look for user.cm files in the following order, the directory the file came  from, the connected directory, the login dir, {dsk} device) (SETQ NAME (FULLNAME FILE)) (SETQ DIRS '(T NIL {DSK})) (if (LITATOM NAME) then (push DIRS (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY NAME))) (RETURN (MKATOM (TEDIT.GETINPUT TEXTOBJ "USER.CM file:(NIL to suppress BRAVO conversion) " (FINDFILE 'USER.CM T DIRS))))))))) (\TEST.CHARACTER.LOOKS (LAMBDA (FILE) (* gbn " 6-Feb-84 19:11") (* returns nil until done when it returns BADLOOKS or T) (PROG (PROPERTY VALFLAG TEM (VALUE 0) CHAR) LP (while (NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE)))) do (SETQ VALUE CHAR) (SETQ VALFLAG T)) (COND (PROPERTY (COND ((NULL VALFLAG) (RETURN 'BADLOOKS)) (T NIL)) (SETQ PROPERTY NIL)) (VALFLAG (SETFILEPTR FILE (IDIFFERENCE (GETFILEPTR FILE) (COND ((EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL)))) 2) (T 1)))) (RETURN NIL))) (COND ((SETQ TEM (SELECTQ CHAR ((s u b i g v S U B I G V) T) NIL)) T (SETQ PROPERTY T)) ((SETQ TEM (SELECTQ CHAR ((t f o) T) NIL)) T) ((EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL)))) (RETURN T)) ((NEQ CHAR '% ) (RETURN 'BADLOOKS))) (SETQ VALUE 0) (SETQ VALFLAG NIL) (GO LP)))) (\TEST.PARAGRAPH.LOOKS (LAMBDA (FILE) (* gbn " 6-Feb-84 18:30") (* test if the sequence form valid paragraph looks, do not allow empty  paragraph looks) (PROG ((VALUE 0) CHAR PROPERTY (TABS) NONEMPTY) LP (while (NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE)))) do (SETQ VALUE CHAR)) (COND ((SELECTQ PROPERTY ((l d z x e y k j c q) (SETQ NONEMPTY T)) NIL) (* keep going, these are all ok) NIL) (T (SELECTQ PROPERTY (%( (SELECTQ CHAR (%) (SETQ NONEMPTY T)) (%, (COND ((IGREATERP VALUE 14) (* not a legal tab no) (RETURN NIL)) (T (SETQ NONEMPTY T))) T) (* not legal after) (RETURN NIL))) (%, (SETQ NONEMPTY T)) ((%) (SETQ NONEMPTY T))) (* not a legal paragraph look) (RETURN NIL)))) (COND ((AND (NEQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL)))) (NEQ CHAR '\)) (SETQ PROPERTY CHAR) (SETQ VALUE 0) (GO LP))) (if NONEMPTY then (RETURN CHAR) else (RETURN))))) ) (DEFINEQ (\TFBRAVO.COPY.NAMEDTAB (LAMBDA (OBJ PIECE OLDCH NEWCH) (* jds " 8-Feb-84 19:58") (* just creates a named tab stop with the same value as the original) (* Note that the USING phrase will create a new TEDITOBJ as well as a  TEDITUSEROBJ) (COPY OBJ))) (\TFBRAVO.PUT.NAMEDTAB (LAMBDA (OBJ CHARSTREAM FMTSTREAM) (* jds " 8-Feb-84 19:59") (* just writes the position of the tab so that a new one can be created on read) (PRINT (IMAGEOBJPROP OBJ 'OBJECTDATUM) CHARSTREAM))) (\TFBRAVO.GET.NAMEDTAB (LAMBDA (CHARSTREAM TEXTSTREAM) (* jds " 8-Feb-84 19:59") (* should read the position, create an obj and return it) (IMAGEOBJCREATE (RATOM CHARSTREAM) \NAMEDTAB.IMAGEFNS))) (\TFBRAVO.ADD.NAMEDTAB [LAMBDA (TEXTOBJ TABNO PARALOOKS) (* ; "Edited 31-May-91 15:26 by jds") [COND ((NEQ TABNO 0) (BIN) (* Advance the input stream past the  tab character) (TEDIT.INSERT.OBJECT (IMAGEOBJCREATE (LISTGET (fetch (FMTSPEC FMTUSERINFO) of PARALOOKS ) (SUB1 TABNO)) \NAMEDTAB.IMAGEFNS) TEXTOBJ (ADD1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ] (* one is subtracted from the tabno because BRAVO seems to specify there  numbers differently in the run from the paragraph looks) ]) (\NAMEDTABNYET (LAMBDA NIL (* gbn "30-Dec-83 17:23") (PROMPTPRINT "Can't do that to a named tab!"))) (\NAMEDTABSIZE (LAMBDA (TABOBJECT IMAGESTREAM CURRENTX RIGHTMARGIN MODE) (* gbn "19-May-84 22:52") (PROG ((PTSIZE (IMAGEOBJPROP TABOBJECT 'OBJECTDATUM)) (MODE (if (STKPOS '\FORMATLINE) then 'DISPLAY else 'HARDCOPY))) (* hack until I get called with the right mode.  SHit!) (RETURN (create IMAGEBOX XSIZE _ (IMAX 1 (IDIFFERENCE (COND ((EQ MODE 'DISPLAY) PTSIZE) (T (ITIMES PTSIZE 35))) CURRENTX)) YSIZE _ 1 YDESC _ 0 XKERN _ 0))))) (\NAMEDTAB.INIT (LAMBDA NIL (* jds "22-Aug-84 14:49") (SETQ \NAMEDTAB.IMAGEFNS (IMAGEFNSCREATE 'NILL '\NAMEDTABSIZE '\TFBRAVO.PUT.NAMEDTAB ' \TFBRAVO.GET.NAMEDTAB '\TFBRAVO.COPY.NAMEDTAB 'NILL 'NILL 'MOVE.NAMED.TAB 'NILL 'NILL 'NILL 'NILL 'NIL)))) ) (DEFINEQ (\TFBRAVO.APPLY.PARALOOKS [LAMBDA (PARALOOKS LENGTH TEXTOBJ MARGIN.CANDIDATE) (* ; "Edited 31-May-91 15:26 by jds") (* Returns the smaller of%: the left margin so far, the smallest left margin in  this para) (PROG (TABPHRASE (SMALLEST.MARGIN MARGIN.CANDIDATE)) (TEDIT.PARALOOKS TEXTOBJ PARALOOKS (ADD1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) LENGTH)) LENGTH) (TEDIT.SETSEL TEXTOBJ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 1 'RIGHT) (* now return the smallest margin) (RETURN (IMIN (fetch (FMTSPEC RIGHTMAR) of PARALOOKS) (fetch (FMTSPEC LEFTMAR) of PARALOOKS) (fetch (FMTSPEC 1STLEFTMAR) of PARALOOKS) MARGIN.CANDIDATE]) (TEDITFROMBRAVO [LAMBDA (FILIN USER.CM TEXTSTREAM) (* ; "Edited 13-Jun-90 01:00 by mitani") (* * Top level entry for conversion from Bravo to a Textstream which is  returned) (INFILE FILIN) (PROG (OLDPLOOKS CURRENT.PARAGRAPH USER.CM.ALIST START NEXTPARAPTR TEDITWINDOW TEXTOBJ (NONFEATURES NIL) (SMALLEST.MARGIN MAX.FIXP) (NEWSTREAM (OR TEXTSTREAM (OPENTEXTSTREAM ""))) USER.CM.PARALOOKS USER.CM.CHARLOOKS) (DECLARE (SPECVARS NOUT)) (SETQ TEXTOBJ (TEXTOBJ NEWSTREAM)) (SETQ USER.CM.ALIST (\TFBRAVO.READ.USER.CM USER.CM)) (* read the user.cm file and produce  the alist of default values) (CLOSEF? USER.CM) (SETQ OLDPLOOKS (SETQ USER.CM.PARALOOKS (\TFBRAVO.INIT.PARALOOKS USER.CM.ALIST))) (SETQ USER.CM.CHARLOOKS (\TFBRAVO.INIT.CHARLOOKS)) (SETFILEPTR FILIN 0) (\TFBRAVO.INIT.PAGEFORMAT TEXTOBJ) (ERSETQ (first (SETQ START (GETFILEPTR FILIN)) (SETQ CURRENT.PARAGRAPH (\TFBRAVO.PARSE.PARA OLDPLOOKS FILIN)) while (fetch RUNS of CURRENT.PARAGRAPH) do (SETQ NEXTPARAPTR (GETFILEPTR FILIN)) (SETFILEPTR FILIN START) (SETQ SMALLEST.MARGIN (\TFBRAVO.WRITE.PARAGRAPH CURRENT.PARAGRAPH FILIN TEXTOBJ SMALLEST.MARGIN)) (SETFILEPTR FILIN NEXTPARAPTR) (SETQ OLDPLOOKS (fetch PARALOOKS of CURRENT.PARAGRAPH)) (SETQ START (GETFILEPTR FILIN)) (SETQ CURRENT.PARAGRAPH (\TFBRAVO.PARSE.PARA OLDPLOOKS FILIN)) finally (* (\SHIFT.DOCUMENT  (fetch (TEXTOBJ PCTB) of TEXTOBJ)  (MINUS SMALLEST.MARGIN))) NIL)) (CLOSEF (INPUT)) (\TFBRAVO.INSTALL.PAGEFORMAT TEXTOBJ) (RETURN NEWSTREAM]) (\TFBRAVO.WRITE.PARAGRAPH [LAMBDA (PARA INFILE TEXTOBJ MARGIN.CANDIDATE) (* ; "Edited 31-May-91 15:26 by jds") (* outputs the character runs, writes an EOL, then apply paragraph looks.  Returns the smallest left margin seen to date) (* * this is not a guaranteed free field.  Perhaps later the profile bit will have to be elsewhere.) (SELECTQ (fetch (FMTSPEC FMTPARATYPE) of (fetch PARALOOKS of PARA)) (PROFILE (replace (FMTSPEC FMTPARATYPE) of (fetch PARALOOKS of PARA) with NIL) (\TFBRAVO.PARSE.PROFILE.PARA INFILE PARA TEXTOBJ) MARGIN.CANDIDATE) (PROG (LENGTH) (SETQ LENGTH (ADD1 (\TFBRAVO.WRITE.RUNS PARA INFILE TEXTOBJ))) (\TFBRAVO.EOLS 1 TEXTOBJ) (RETURN (\TFBRAVO.APPLY.PARALOOKS (fetch PARALOOKS of PARA) LENGTH TEXTOBJ MARGIN.CANDIDATE]) (\TFBRAVO.WRITE.RUNS (LAMBDA (PARA INFILE TEXTOBJ) (* gbn "18-Sep-84 16:29") (DECLARE (USEDFREE UNDERLINE SUPERSCRIPT)) (PROG ((RUNS (fetch RUNS of PARA)) (PARALOOKS (fetch PARALOOKS of PARA)) (LENGTH 0)) (for RUN in old RUNS do (\TFBRAVO.WRITE.RUN RUN INFILE PARALOOKS TEXTOBJ) (SETQ LENGTH (IPLUS (fetch RUNLENGTH of RUN) LENGTH))) (RETURN LENGTH)))) (\TFBRAVO.SPREAD.LOOKS (LAMBDA (RUN LOOKS) (* jds "22-Aug-84 14:53") (DECLARE (USEDFREE STYLE SLANT THICKNESS SIZE OVERSTRIKE UNDERLINE SUPERSCRIPT)) (for INSTR in (fetch RUNLOOKS of RUN) do (SELECTQ (CAR INSTR) (Bold (LISTPUT LOOKS 'WEIGHT (COND ((CDR INSTR) 'BOLD) (T 'MEDIUM)))) (Font (LISTPUT LOOKS 'SIZE (\TFBRAVO.GET.FONTSIZE (CDR INSTR))) (LISTPUT LOOKS 'FAMILY (\TFBRAVO.GET.FONTSTYLE (CDR INSTR)))) (Italic (LISTPUT LOOKS 'SLOPE (COND ((CDR INSTR) 'ITALIC) (T 'REGULAR)))) (Overstrike (add OVERSTRIKE 1)) (Underline (LISTPUT LOOKS 'UNDERLINE (COND ((CDR INSTR) 'ON) (T 'OFF)))) (Superscript (COND ((IGREATERP (CDR INSTR) 127) (* turn off subscripting and set superscripting, though possibly to zero) (LISTPUT LOOKS 'SUBSCRIPT (IDIFFERENCE 256 (CDR INSTR))) (LISTPUT LOOKS 'SUPERSCRIPT NIL)) (T (LISTPUT LOOKS 'SUPERSCRIPT (CDR INSTR)) (LISTPUT LOOKS 'SUBSCRIPT NIL)))) NIL)) LOOKS)) (\TFBRAVO.PARSE.PARA (LAMBDA (OLDPLOOKS FILE) (* gbn "31-May-85 22:08") (* PLOOKS are the paragraph looks, and RUNi are the character runs in the form  returned by READCHARACTERLOOKS, except that the character count for the last  run has been filled in correctly. Leaves the input file pointer at the end of  the trailer, after the EOL.) (PROG (LEN PLOOKS RUNS ORIGPTR) (SETQ ORIGPTR (GETFILEPTR FILE)) (SETQ LEN (FILEPOS (CHARACTER (CHARCODE ^Z)) FILE)) (COND ((NOT LEN) (RETURN (create PARA PARALOOKS _ DefaultParagraphLooks RUNS _ NIL)))) (SETQ LEN (IDIFFERENCE LEN ORIGPTR)) (BIN FILE) (* BIN past the ^z) (SETQ PLOOKS (\TFBRAVO.READ.PARALOOKS OLDPLOOKS FILE)) (COND ((NEQ (CAR (PROG1 PLOOKS (SETQ PLOOKS (CDR PLOOKS)))) '\) (RETURN (create PARA PARALOOKS _ PLOOKS RUNS _ (LIST (create RUN RUNLENGTH _ LEN RUNLOOKS _ (\TFBRAVO.FONT.FROM.CHARLOOKS USER.CM.CHARLOOKS))))))) CLP (while (fetch RUNLENGTH of (CAR (push RUNS (\TFBRAVO.READ.CHARLOOKS FILE)))) do (SETQ LEN (IDIFFERENCE LEN (fetch RUNLENGTH of (CAR RUNS))))) (replace RUNLENGTH of (CAR RUNS) with LEN) (RETURN (create PARA PARALOOKS _ PLOOKS RUNS _ (DREVERSE RUNS)))))) (\TFBRAVO.INIT.PARALOOKS [LAMBDA (USER.CM.LOOKS) (* ; "Edited 31-May-91 15:26 by jds") (* * creates the first paragraph looks from the USER.CM) (PROG ((INITPARALOOKS (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC)) LM VALUE 1LM (MICASPERPOINT 35)) (SETQ HardwareWidth (IDIFFERENCE HardwareRightMargin HardwareLeftMargin)) (* Basic page width) (SETQ DefaultParagraphLooks USER.CM.LOOKS) (COND [(SETQ LM (CDR (ASSOC 'LeftMargin DefaultParagraphLooks] (T (SETQ LM HardwareLeftMargin))) (COND [(SETQ 1LM (CDR (ASSOC 'FirstLineLeftMargin DefaultParagraphLooks] (T (SETQ 1LM LM))) (replace (FMTSPEC LEFTMAR) of INITPARALOOKS with (IQUOTIENT LM MICASPERPOINT)) (replace (FMTSPEC 1STLEFTMAR) of INITPARALOOKS with (IQUOTIENT 1LM MICASPERPOINT)) (replace (FMTSPEC LINELEAD) of INITPARALOOKS with (COND ((SETQ VALUE (ASSOC 'LineLeading DefaultParagraphLooks )) (CDR VALUE)) (T 1))) (replace (FMTSPEC LEADBEFORE) of INITPARALOOKS with (COND ((SETQ VALUE (ASSOC ' ParagraphLeading DefaultParagraphLooks )) (CDR VALUE)) (T 1))) (replace (FMTSPEC RIGHTMAR) of INITPARALOOKS with (IQUOTIENT (COND ((SETQ VALUE (ASSOC 'RightMargin DefaultParagraphLooks)) (CDR VALUE)) (T DefaultRightMargin)) MICASPERPOINT)) (replace (FMTSPEC LEADAFTER) of INITPARALOOKS with 0) (replace (FMTSPEC TABSPEC) of INITPARALOOKS with (LIST NIL)) (replace (FMTSPEC FMTSPECIALX) of INITPARALOOKS with 0) (replace (FMTSPEC FMTSPECIALY) of INITPARALOOKS with 0) (RETURN INITPARALOOKS]) (\TFBRAVO.READ.PARALOOKS [LAMBDA (OLDLOOKS FILE) (* ; "Edited 31-May-91 15:26 by jds") (PROG ((TEDITPARALOOKS (create FMTSPEC using USER.CM.PARALOOKS)) LMFLAG FLLMFLAG PROPERTY CHAR TABINDEX TEM (VALUE 0) (MICASPERPOINT 35)) (replace (FMTSPEC TABSPEC) of TEDITPARALOOKS with (COPY (fetch (FMTSPEC TABSPEC) of OLDLOOKS))) (replace (FMTSPEC FMTUSERINFO) of TEDITPARALOOKS with (COPY (fetch (FMTSPEC FMTUSERINFO ) of OLDLOOKS))) LP (while [NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE] do (SETQ VALUE (IPLUS (ITIMES VALUE 10) CHAR))) [COND ((SELECTQ PROPERTY (l (SETQQ LMFLAG LeftMargin) (replace (FMTSPEC LEFTMAR) of TEDITPARALOOKS with (IQUOTIENT VALUE MICASPERPOINT ))) (d (SETQQ FLLMFLAG FirstLineLeftMargin) (replace (FMTSPEC 1STLEFTMAR) of TEDITPARALOOKS with (IQUOTIENT VALUE MICASPERPOINT) )) (z (replace (FMTSPEC RIGHTMAR) of TEDITPARALOOKS with (IQUOTIENT VALUE MICASPERPOINT ))) (x (replace (FMTSPEC LINELEAD) of TEDITPARALOOKS with VALUE)) (e (replace (FMTSPEC LEADAFTER) of TEDITPARALOOKS with 0) (replace (FMTSPEC LEADBEFORE) of TEDITPARALOOKS with VALUE)) (y (* (COND ((IEQP VALUE 65535)  (SETQ VALUE NIL)))) (* vertical tabs are supported) (replace (FMTSPEC FMTSPECIALX) of TEDITPARALOOKS with 0) (replace (FMTSPEC FMTSPECIALY) of TEDITPARALOOKS with VALUE)) (k (* same with Keep) 'Keep) (w 'HardcopyMode) NIL)) ((SETQ TEM (SELECTQ PROPERTY (j (replace (FMTSPEC QUAD) of TEDITPARALOOKS with 'JUSTIFIED)) (c (replace (FMTSPEC QUAD) of TEDITPARALOOKS with 'CENTERED)) (q (* not a legal value for FMTPARATYPE But it signals that this is a profile  paragraph) (replace (FMTSPEC FMTPARATYPE) of TEDITPARALOOKS with 'PROFILE)) NIL))) (T (SELECTQ PROPERTY (%( (SELECTQ CHAR (%) (RPLACA (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS) (IQUOTIENT VALUE MICASPERPOINT))) (%, [COND ((IGREATERP VALUE 14) (HELP VALUE '" is not a legal tab #"] (SETQ TABINDEX VALUE)) (HELP CHAR '" is not legal after ("))) (%, [COND ((NOT (IEQP VALUE 65535)) (* this is not a delete tab, record  it) (SETQ VALUE (IQUOTIENT VALUE MICASPERPOINT)) (* * returning to adding a normal tab as well, since there are docs, e.b.  refreminder.bravo which do not have named tab looks on the tab chars  (* I no longer gratuitously add a normal tab at the position of each named tab.  Turns out that, in some cases, that will change the meaning of an already  present unnamed tab. (RPLACD (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS)  (CONS (CONS VALUE (QUOTE LEFT)) (CDR (fetch  (FMTSPEC TABSPEC) of TEDITPARALOOKS)))))) [RPLACD (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS) (CONS (CONS VALUE 'LEFT) (CDR (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS] (replace (FMTSPEC FMTUSERINFO) of TEDITPARALOOKS with (NCONC (LIST TABINDEX VALUE) (fetch (FMTSPEC FMTUSERINFO) of TEDITPARALOOKS ]) ((%) NIL)) (HELP CHAR '" is not a legal paragraph look"] (COND ((AND [NEQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL] (NEQ CHAR '\)) (SETQ PROPERTY CHAR) (SETQ VALUE 0) (GO LP))) [COND ((AND LMFLAG (NOT FLLMFLAG)) (* If there was a Left margin but no  firstline left then default it) (replace (FMTSPEC 1STLEFTMAR) of TEDITPARALOOKS with (fetch (FMTSPEC LEFTMAR) of TEDITPARALOOKS ] (RETURN (CONS CHAR TEDITPARALOOKS)) (* return the looks together with  the indication of how the looks  ended) ]) (\TFBRAVO.READ.CHARLOOKS [LAMBDA (FILE) (* ; "Edited 31-May-91 15:25 by jds") (* this function reads the character looks trailer building a TEDIT charlooks  record. Most fields are immediately valid, however, the tabcolor is stored in  the cluserinfo field of the looks, and the font is still in numeric form) (PROG ((TEDITCHARLOOKS (create CHARLOOKS using USER.CM.CHARLOOKS)) PROPERTY VALFLAG TEM (VALUE 0) CHAR) (RETURN (while T do (* Keep going until we run out of  things to read) (while [NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE] do (* If we're looking at digits, read  them as a number) (SETQ VALUE (IPLUS (ITIMES VALUE 10) CHAR)) (SETQ VALFLAG T)) [COND (PROPERTY [COND ((NULL VALFLAG) (HELP PROPERTY '"- no value for character look")) (T (SELECTQ PROPERTY (TabColor (* Hide the named tab in the user field of the looks where writerun can look  for it) (replace (CHARLOOKS CLUSERINFO) of TEDITCHARLOOKS with VALUE)) (Font (replace (CHARLOOKS CLSIZE) of TEDITCHARLOOKS with (\TFBRAVO.GET.FONTSIZE VALUE) ) (replace (CHARLOOKS CLNAME) of TEDITCHARLOOKS with (\TFBRAVO.GET.FONTSTYLE VALUE)) (* (* a hack so that font is  cumulative. Change the  "default charlooks" to reflect this  font each time) (replace  (CHARLOOKS CLSIZE) of  USER.CM.CHARLOOKS with  (fetch (CHARLOOKS CLSIZE) of  TEDITCHARLOOKS)) (replace  (CHARLOOKS CLNAME) of  USER.CM.CHARLOOKS with  (fetch (CHARLOOKS CLNAME) of  TEDITCHARLOOKS))) ) (Superscript (replace (CHARLOOKS CLOFFSET) of TEDITCHARLOOKS with (COND ((IGREATERP VALUE 127) (* is a negative numero) (IDIFFERENCE VALUE 256 )) (T VALUE)))) (HELP PROPERTY " is unknown property in \TFBRAVO.READ.CHARLOOKS" ] (SETQ PROPERTY NIL)) (VALFLAG [SETFILEPTR FILE (IDIFFERENCE (GETFILEPTR FILE) (COND ([EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL] 2) (T 1] (RETURN (CONS VALUE (\TFBRAVO.FONT.FROM.CHARLOOKS TEDITCHARLOOKS] (COND ((SELECTQ CHAR (s (replace (CHARLOOKS CLSTRIKE) of TEDITCHARLOOKS with T)) (S (replace (CHARLOOKS CLSTRIKE) of TEDITCHARLOOKS with NIL) T) (u (replace (CHARLOOKS CLULINE) of TEDITCHARLOOKS with T)) (U (replace (CHARLOOKS CLULINE) of TEDITCHARLOOKS with NIL) T) (b (replace (CHARLOOKS CLBOLD) of TEDITCHARLOOKS with T)) (B (replace (CHARLOOKS CLBOLD) of TEDITCHARLOOKS with NIL) T) (i (replace (CHARLOOKS CLITAL) of TEDITCHARLOOKS with T)) (I (replace (CHARLOOKS CLITAL) of TEDITCHARLOOKS with NIL) T) (g '(Graphic . T)) (G '(Graphic)) (v (replace (CHARLOOKS CLINVISIBLE) of TEDITCHARLOOKS with NIL) T) (V (replace (CHARLOOKS CLINVISIBLE) of TEDITCHARLOOKS with T)) NIL) (SETQ PROPERTY NIL)) ((SETQ TEM (SELECTQ CHAR (t 'TabColor) (f 'Font) (o 'Superscript) NIL)) (SETQ PROPERTY TEM)) [[EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL] (RETURN (CONS NIL (\TFBRAVO.FONT.FROM.CHARLOOKS TEDITCHARLOOKS] ((NEQ CHAR '% ) (HELP CHAR " is not a legal character look"))) (SETQ VALUE 0) (SETQ VALFLAG NIL]) (\TFBRAVO.READ.USER.CM (LAMBDA (FILE) (* gbn "17-Sep-84 18:53") (* digests a user.cm file returning an alist of contents.  Returns ((Font)) if no bravo section of user.cm file) (PROG ((RDTBL USER.CM.RDTBL) (ALIST (LIST (LIST 'Font))) LINE) (* (ERRORTYPELST (CONS (QUOTE (16 (RETFROM  (QUOTE RATOM) (QUOTE END.OF.FILE)))) ERRORTYPELST)) The errortypelist inclusion  guarantees that eof's will return from RATOM as  (CHARCODE 13)) (* (DECLARE (SPECVARS ERRORTYPELST))) (SETBRK (CHARCODE (%, %: = EOL)) NIL RDTBL) (SETSEPR '(% ) NIL RDTBL) (OR (OPENP FILE) (SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD))) (COND ((NOT (FILEPOS (CONCAT '"[BRAVO]" (CONSTANT (CHARACTER (CHARCODE EOL)))) FILE NIL NIL NIL T)) (RETURN ALIST))) (* Read lines of the user.cm file until getting the empty line caused by eof  (and the errortypelst entry) or until a line starts with "[" %.) LLP (COND ((NOT (NLSETQ (SETQ LINE (RATOMS (CONSTANT (CHARACTER (CHARCODE EOL))) FILE RDTBL)))) (RETURN ALIST))) (* If the "[BRAVO]" section is the  last one) (COND ((NULL LINE) (* ignore blank lines) (GO LLP)) ((EQ (CAR LINE) 'END.OF.FILE) (RETURN ALIST)) ((EQ (NTHCHAR (CAR LINE) 1) '%[) (* if "[" is the first character of the line, return the alist so far, because  this is the beginning of the next section of the user.cm) (RETURN ALIST)) ((NEQ (CADR LINE) '%:) (GO LLP))) (SELECTQ (PROG1 (CAR LINE) (SETQ LINE (CDDR LINE))) (FONT (COND ((NUMBERP (CAR LINE)) (NCONC1 (FASSOC 'Font ALIST) (LIST (CAR LINE) (CADR LINE) (CADDR LINE)))))) (TABS (SETQ ALIST (NCONC (\TFBRAVO.GETPARAMS LINE '((Tabs standard tab width))) ALIST))) (MARGINS (SETQ ALIST (NCONC (\TFBRAVO.GETPARAMS LINE '((LeftMargin left margin) (RightMargin right margin))) ALIST))) (LEAD (SETQ ALIST (NCONC (\TFBRAVO.GETPARAMS LINE '((ParagraphLeading paragraph leading ) (LineLeading line leading))) ALIST))) NIL) (GO LLP)))) (\TFBRAVO.GETPARAMS (LAMBDA (LIS NAMES) (* jds "27-Aug-84 09:37") (PROG ((L LIS) ALIST TEST REST) (MAP L (FUNCTION (LAMBDA (WORDL) (COND ((LITATOM (CAR WORDL)) (FRPLACA WORDL (\TFBRAVO.LCASER (CAR WORDL)))))))) LP (COND ((NULL L) (RETURN ALIST))) (SETQ TEST NAMES) NLP (COND ((SETQ REST (\TFBRAVO.PARAMNAMEP L (CDAR TEST))) (SETQ ALIST (CONS (CONS (CAAR TEST) (CAR REST)) ALIST))) ((SETQ TEST (CDR TEST)) (GO NLP))) (SETQ L (CDR (FMEMB '%, L))) (GO LP)))) (\TFBRAVO.PARAMNAMEP (LAMBDA (LIS NAME) (* lpd "16-JUL-77 19:55") (PROG ((L LIS)) (RETURN (AND (EVERY NAME (FUNCTION (LAMBDA (WORD) (PROG1 (EQ WORD (CAR L)) (SETQ L (CDR L)))))) (EQ (CAR L) '=) (CDR L)))))) (\TFBRAVO.EOLS [LAMBDA (N TEXTOBJ) (* ; "Edited 13-Jun-90 01:00 by mitani") (* ;; "Insert N carriage-returns into the document named by TEXTOBJ at the current location.") (for I FROM 1 to N do (TEDIT.INSERT TEXTOBJ (CHARCODE EOL))) (TEDIT.SETSEL TEXTOBJ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 1 'RIGHT]) (\TFBRAVO.LCASER (LAMBDA (WORD) (* lpd "23-SEP-77 14:40") (PROG ((LST (CHCON WORD)) Z) (MAP LST (FUNCTION (LAMBDA (L) (COND ((AND (IGREATERP (SETQ Z (CAR L)) 64) (ILESSP Z 91)) (* Z is an uppercase character) (FRPLACA L (IPLUS Z 32))))))) (RETURN (PACKC LST))))) (\TFBRAVO.FONT.FROM.CHARLOOKS [LAMBDA (CHARLOOKS) (* ; "Edited 31-May-91 15:26 by jds") (* Takes a CHARLOOKS with fields filled in  (CLNAME = family name) and creates the font to fill it.) [replace (CHARLOOKS CLFONT) of CHARLOOKS with (FONTCREATE (fetch (CHARLOOKS CLNAME) of CHARLOOKS) (fetch (CHARLOOKS CLSIZE) of CHARLOOKS) (LIST (COND ((fetch (CHARLOOKS CLBOLD ) of CHARLOOKS) 'BOLD) (T 'MEDIUM)) (COND ((fetch (CHARLOOKS CLITAL ) of CHARLOOKS) 'ITALIC) (T 'REGULAR)) 'REGULAR] CHARLOOKS]) ) (RPAQ? USER.CM.RDTBL (COPYREADTABLE)) (RPAQ? PROFILE.PARA.RDTBL (COPYREADTABLE)) (SETSYNTAX (CHARCODE %:) 'SEPRCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE EOL) 'BREAKCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE ^Z) 'SEPRCHAR PROFILE.PARA.RDTBL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NAMEDTAB.IMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR TEDIT.INPUT.FORMATS (\TEDIT.BRAVOFILE? TEDITFROMBRAVO)) (\NAMEDTAB.INIT) ) (PUTPROPS TFBRAVO COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4522 34398 (\TFBRAVO.FIND.LAST.TRAILER 4532 . 6025) (\TFBRAVO.HANDLE.HEADING 6027 . 7905) (\TFBRAVO.INIT.CHARLOOKS 7907 . 8723) (\TFBRAVO.INIT.PAGEFORMAT 8725 . 9203) ( \TFBRAVO.INSTALL.PAGEFORMAT 9205 . 13842) (\TFBRAVO.PARSE.PROFILE.PARA 13844 . 22357) ( \TFBRAVO.PARSE.PROFILE.VALUE 22359 . 23126) (\TFBRAVO.GET.FONTSIZE 23128 . 23444) ( \TFBRAVO.GET.FONTSTYLE 23446 . 23774) (\TFBRAVO.WRITE.RUN 23776 . 24883) (\TFBRAVO.ASSERT 24885 . 25197) (\SHIFT.DOCUMENT 25199 . 29075) (\TEDIT.BRAVOFILE? 29077 . 31124) (\TEST.CHARACTER.LOOKS 31126 . 32766) (\TEST.PARAGRAPH.LOOKS 32768 . 34396)) (34399 37946 (\TFBRAVO.COPY.NAMEDTAB 34409 . 34768) ( \TFBRAVO.PUT.NAMEDTAB 34770 . 35066) (\TFBRAVO.GET.NAMEDTAB 35068 . 35345) (\TFBRAVO.ADD.NAMEDTAB 35347 . 36324) (\NAMEDTABNYET 36326 . 36491) (\NAMEDTABSIZE 36493 . 37378) (\NAMEDTAB.INIT 37380 . 37944)) (37947 73951 (\TFBRAVO.APPLY.PARALOOKS 37957 . 38988) (TEDITFROMBRAVO 38990 . 41392) ( \TFBRAVO.WRITE.PARAGRAPH 41394 . 42416) (\TFBRAVO.WRITE.RUNS 42418 . 42999) (\TFBRAVO.SPREAD.LOOKS 43001 . 45973) (\TFBRAVO.PARSE.PARA 45975 . 47880) (\TFBRAVO.INIT.PARALOOKS 47882 . 51206) ( \TFBRAVO.READ.PARALOOKS 51208 . 58384) (\TFBRAVO.READ.CHARLOOKS 58386 . 66519) (\TFBRAVO.READ.USER.CM 66521 . 69851) (\TFBRAVO.GETPARAMS 69853 . 70682) (\TFBRAVO.PARAMNAMEP 70684 . 71132) (\TFBRAVO.EOLS 71134 . 71547) (\TFBRAVO.LCASER 71549 . 72101) (\TFBRAVO.FONT.FROM.CHARLOOKS 72103 . 73949))))) STOP \ No newline at end of file diff --git a/library/UNICODE.LCOM.~17~ b/library/UNICODE.LCOM.~17~ deleted file mode 100644 index bc8516acdbb94446c19290e992d2d0ed656c0276..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 22583 zcmdUXYj9iVnH~UAzOA8<6eBCFSNRNk6;Kgq8~_9_abz5Vpm0b4hXO#8l(j}60umvD zmmw&xHBBeVtxdBt?O0wXyOYg!G96!o{^?Bqbh6X&cAV+XtQ^aeAN^6W z?#{HGiPh(QzwaCz0HkFnZD%Sc#CN{?<-I)b`+n#6ClgafCJ~r2Qi*_(nKH%kY(k&R z>l3Mj@EMtWBAYUDvp#WrR*%opf(;3`NW0IvOScy z{M^Q7?f1sTTz+bF$ehc^lX`Y4LyuZ?BH_qM>obXf>OYXr>X}?h&l_eYz?+a0l{Mk@ zrFm)sa}!fns#TG@T3f%eCA4UB#Y00wK2a)eVVyo_ekeR1!cGKzA8)&U+uae~=KYf6br&YI;+p)R}*xyL>zbsid-Jlm>v}FNSDji6}!iUe|pt>`}xcNQa=3b zo|Sk0!#xw%_4?SCxbTea8j|H`gc=eiG2 zgTCHgk5T&bp02+zUSIx(;eOrlyjHz7z4s@vX)bTn-&?!SHNCggghofi`3W$O2#tiT)Ns^Fg~zOvW|eAVR-QH*Ql;APu$78v zR!Xz-M#I8l?zv1_pPfxif>B0B#mR+uJeN0B;YksWbYy9x>b%9Ub?{!l2#rOB&nAkk z^>uNfa!FiV-((K(iBL!rq2SnvHXH&2hedRFI2=_ZXJq0;N)Qx^u^qxHw6N{xo?w7XR$E(+j zy%$Q`?*8g+WAFO5>+3Ob?vVSBh{XO4pOrDaJTRaLN<4kY{bKdn%-&AFDw{!}U3#8N zQ+qo{tX4;ryn3*DCF@u6ixG_eaU|+wQ-r-cAyK{HK^` zsCtWF1!Hf=7rUPbq@n*?ruw8|^UK8bZTF2-PqW22w15B}QZ1~8HzYSDnbj1xOziwD z#WQHOextRSdYai8B96S_Pb%gzK)lRcZRCIJ*7zQ|Gs*Ym-f$_ zL#d^mux8k~w3i^f+b8&X>jbBF9;4;nIG(f^lBOmZk~!?w`TAM?M%tRq@<4s8Ifd6$ zXU5I|ZS#%(q|Khx4cdOXbH`IVUyR?744Y~)?4dLvOdvvOT{E<~)7ab@+T3Yu?##5@ z+-b+=vX0evKRxkspVavJAKS`bDJDyw(~d{NYR4fS)jkech6GH3R_W*z@h#GEtm72K zaB$y)35Q!ml@?|DQ;)+_g5w~Gq(z6?MG~8-`;h2o0aHA3_kO6q{OQX*GX0|d^8Hm$ z59H4ZEs=~chaPBEFt!Y8@ncMx*|eU|>A@hh2+JZTzH$*ha>ptb*+wNz!7XC*<6XNQ zwz|D5nsfaQM(c{{6O{*%aA8G2-pUQ*Alti+IBJb}fXVNo<$ypdG#(8zVh>~cf9^I& zDB>7op99->h|!O~ZK0^u|8Kf&qeGuy&p`j`@ITR>IUHsmxnWl4z)B0C|BRkWm?`*P zK9Bu($4Zyz9B#kRSgAj(($^c8|CP+WUiEzAJ}ST9;*2j*`m?2#p98m-Vn28FHe{22 zJaUD8kCo`Q68AKifd7AQ4@xDM#d#x>%j>DskhPbRheaq1jeJ0vM&R;iw+Trgv6J-yIR+gUz|-m`em$U zM2u4>aKl8z0Wu3@8zKi059W}iA*k1bnnZ;*HgaHTL}+j+9W*Ho-YuR~fDBYE8a${U zH~=&l9Gy~L!;%k}85W{JX&h7<7Md10cxG@Q(98&3^5j4$>e1oCCN~}DIu#GrYt?i} z3<1}JmEAls=(>aUCIUgP8o(bY;@Q*`T<-W4QIVPg^#Fq?=e(_UZSb1`4cPDlUWPxGDg}9(~Q@dZqUfPb}$Xj^CY+B|RSZ-i?Ro*W>>6 z-d{U$7*$_+=at2h$MCpU-ah6&S2C#j_Z*cPvFW6n6~%PSPzlntL3r=x@<~0H6k|Z0 zDhZ=U!aD4RGS`O1nFQBU5>kx7k&;+Q>T@{?h9HiBU#pn*12IcN*U zpA;5R;A*8}lvpIsTWd~aROA=(u=KeglS2%Lpfp@xylb?3a3?c4Dgu>}1pLLeD|#D& zdFW+IaVV)hu1?@N)k+hLH!*N48%bYc5z~P($7Pnl4Q%rtD z1G(8mTuccYrB52!L_BY14K#*Gk*5&ICGr985Uc&G`#pdWy{zuI^%J3+h##a zSM>omny1VjkNfs_%%0t!R_bqW%5$2jHta_uBTI^2~|Xx9=1nJ3?U)duEar z3!y#?c9hO2CU&yu;$|kU=LI~^IX#y%;{qgWw}6Ah*#LX4VN-~rwIHMpXq`!##L^eV zDE60Rg@8wR!kk8!j+w{toWxPW z>7ALxZv@<`XY)vfMG8S(vD~m3X*a&1x*ZBiHd&? zO(s}+5YoxbO`r-m6rwdMGE@ap7UX6(4C5FaooeuM*<~0Yo*HL{=Yt05fKtJkiP14Z zN2duIH#IKDK-Anw3&?6&G(2Y2#&|9LKpRNy2^nokdB8SS5l{n`CM7uL^NEoW1p0jl z&p}_VRhHIEWwBb^*r=>s8W+fiDdo$Ud7)b}7Z8hu5_gB@C@!v+$07Ik6J137AxZpG zwt^&zv)aZj+ek2T~cE+EixJQ`nr-`yWP`0?l-0#(yl4qyzq&+ zT$NtWAsd~1+j{Y3$8zRce&hrq|1B;*=jfc%BNg?sN{zC+EGEuI#~?grL*=CPuK2$bW}ZC zTDx=S_IG8A`q0{)4{v{mi|f9sIBSK8&sJmaFj4Th-#p7{+5a-9A)vJ35sS;oB9ff1 z0Und6VQ(0$9aw{PIjx%r->Z>frsislb9l{C^G^e>Z4QPx8mmY0>b8nWzB5AfwK<39xP+a%I` zB&lc;M<9f@?|ca~M~V#_%=;^G3e5VZ3?gsH-8h(ZAiRMj2sFY>QmtvB5sShIx3PxP zpdKg{5@Qy9V|>*B=DsEQKtE1hmV-W^Q`mPRfh0h5A`7`j7f(9Yg1DQU8!Dg=Tm-;> zqo7P8*pDDhl4!UfwT~X7v;Ty8Y~P7nicH}(FfidbFsxK%5dLKE=8!$oB+Xg42yD_M zMwmi5ZViAP=rTYeJ)2)NXOIrDVnaehd?TKk1CSxWlE_Qr)j{2eX%Os1k!2;gAN0Ci z-FoHr&h*5MGqIiE{D35Am<;YWV=4EtgkrzH+x0D=_6HfYlUn-+;P(3eU|MZKh|4{_ zvk$1q2J=Fp-~Cgw-&5#w1Lc{09lrlxw`FXg>gsoV$K2;4l%8Rjut z>Gs5LeBCi2`2W8Ki0H^^=%uc|C_TSCAi?Z%Wm#e5hC;X7cj5q#(U3)_Atg-n5Ph_i%m2#2ajevDBa!y9lGA|y(?Yq&tNFI`9zf;?tY!9xV^ThG?%#7tJN z&;zZN)!|RleHF!MQHwF5L0T&-svurMM+zipaBuBfjV20L8<0p7CumRs9Y8^gph_k& zA0THHZIlLw&A2fYNGt%114QE<+PEb_*uTzptilrH)bz32hi>u!p^{rCA$0sdV_EnQFY@a#MwF~ZWd(DUY z&Kr_}7txWi?M`?7$m}WfHI)=9;BUD7VrKWxD)n!rJ==G_QsQCFV;(ou;6P!hVV>GOVh&;TrwS(4x7-Dv`@NZ?g~xWg>%!oIADWLD1FxCBf@qk> z(X&9$#|xOyfTu99{b9otCkn^W^If+7?0|W)5bAot4DAk>r~1y7de0s=LtVQU%}C$5 zlrjC7y9+xV!S-rt!vuODM(gjGeRR0>zcml{ z4HSY6b7;5645D-hOGT^t^Jee_Hl+TK?n1PI9;3Wf?!prdGg@++Pu%_!H|OAvQc|Ym zNj|~3d>n;Qb>M~Z-A|#F$Me00If@1k(SHAH*~*j+tdMdcLZcT#+jkyy`J({2mfaJD zurT8Y&?uA|1q5h$h8JIXb)xXsDBv4~*T-3F7@?MyXF!UUXGl_J?=V1hI+31$U4qb% zvc19-ZBC8D&6}g!`uW5e_>3t4 z3m%QCXE`R7by5X1AsW6R#f7S(dv=~=LbRH6tHcC?pfKFrhI)2XA}j5EY0B42j{HW| zYOK3G?#^}%WP9B8&$Cdtz2j?X>UGv1Bd%n6n@W!;~`!h^KO06`c|MazKPyJ^gKrUjE zqXq*^Q#?RkswGZKmn}I6$fRm@fYXIxa)7f}69;FBHDETCq!WcBlAYd=bxo(Y2B~7L zbCGZi;|c76a&VJl()UFi3vMT#!l|%)8T7UUT|458cF+O>4)_p%frFx)1j!4aWy&R6 z2bhqOAaLrMk|0R|aY#u}u7Kq>OFu!*0iLEX9~DwQ{2-JBqmZ)!Nn{|&BcU3SJQB)~ zFpxT;8G$R1gyKMwM}h+uNgfHI1|)eTP%@G{5?sPa@s=TFB+mh^>kFD3?Y9A0r99h$K4CCZ3{HRN!r#^aLa^T+Vog zlW&4Tfk;M_s|!i^x+sS*rA`S6Sh+)9q1-1LoBNw&+p^hJvnSON_{L1>*{r^ZCQt+j zEXgN+QwU{G=~*@~sYIqJ%FhntLE(8N2ybfDgTV1SOvcMB<~uTaA%=U4_f1RedHBeh z`_ARwzTYwX&At!t?#AgOfTq3XF9~$|3sBO zoRp=%YmS>ybCgQ;-TsN)`;rFTdz9$1QU4&xFtbtrmHTPWGw!$GP)zUb1ZNPX1Guv; zd;{;%q)c!72b&I1A9B^>NUqP6pl8i zwEhSbsOB?|7A70!X*YT-Od#PY#LP)^;wPlfZYFyl`8~70Fx^0{q&a0y|Ky0-4;0NUmXg?^Z+py#_g*x8=EI+90MZwZZU6dz8XvhTDwV4`h50Tt%q*|!DI`1v zL}SgTWkAYGlF#-5k)=8R=!qkO!Ig?L9BEcckQW%D) zRE1#(QYgy2Ig3|O@UjXZpZ!Gdp^!GEkdhr)8rvrih_<61P%T}dkh39+x}ydpTt^-x zQb!(SMzbgKBDbtX;^F4Xp+BM!IPmnt$)TqLiBuw;K%g-~anANkNXU*n$f5Q;i6Wp- z5^x~^01$Sa8l9R#5%8_MODdU*H|{P z@FMq^CgzPvoF9SK4AlCU5$^HC!s5pgtzE#|ExTQpFUKH}jMC-X-)SUQKKRq*9}?-l zMmO5)|7E4G*V8p!n%Vn7W2UbfWJc}nJ+yj7bf3*H)g-# zXji;dk6Se#kEs_V-=&(?%aQxHy7g_@iua0z5dj%Myyo=n`^I+E0c!iB-Zlh{ST7p_ z45)VvGqfkfS@brcf+5yP2dvF_ex--E;(E1PT{GXiUhQfoJw5l4XAx5b5NTfL<5v<0 zCRoElc{_)d=j9j}>Rr88D+v#G;HFY%nDS&@oX{X$!&-r^!yPQ%opV1hdJO&f>2FT+ zKJlNoCFT7CUamvfvUQ2TAolGWXnjZM*`^aJSHxsvVv9(?7g!@MCL|V^SIDV_%ZRAX zyyBQL0Yhur?xVQ1Ze3aDDT4NC6vPb`sjPAcdFKvB4Ilc1sxfy1GZP(vn z|M6<&=Vhi;3!q130&-1BnX3L@GWnpzY1zV}QD+02Se==UUg`y_le4N5`F^jnx=qF{ znbsS_&P+$g^15xqSa}M~pnUGWmObSDah4an)ZNIT-4Ay^m0h|gOX?^2!5=U8a9RDo zR=;9kXZHS@{#LJ5A9;IkN6$OGb{u3=C8u2Lahn9J=eEk5YsD(P zvAFNk zJKncY*IRJu&JS6((;eGFE*^$HCzSn>DkM_0Y z+A*~KFZfu_?A7yEy>pF)30o;gI>#`bOoQgS-T|GFN&fltuI|! zEw61Aw<`Gh4L+c9vGN>I^j-HFvIW;IGYG=@)m;{nOkQHOwg7-{YHA7}4zN7!QQGr4 zASL>+&m=WEpbab-M;mIz>$6U`!!hol_D;{E0PLhLK+>~wxg-Lp7K>YMJG$rVCyyX# zmBv^I-~xRj^AzstBqmddMbx8>k-YP`^#!2EugI%^k3U!5Tz~FykainMd40L^mbkJZ zwl<4vwW{3bt>OjHmHo{RQCut0TMrWnQ9eMrv~Z|J*9hvWuK*2Vy{qd;S*}$|SDhA?f@mzz-a-H$Gs)!x%Cn@=j(~X(!>~T5rJ8|H4B~Nv{4)4f z6~4VA_Nm6b(>}J8C5@>(F(OAk)lhx}EdiQ3M^as&53jQ{t>owFGKiEuNhSYD{PUz!!&{vaUhuZE@qT!~OK>1>g2%+ig##Ao zYE@mpT|PLhSQ=rId=Y%P%aU6Bj8Cdr!i%57zBU=gxeF;K&z_pb*f0f~$J*j0q+a z6WPSPEJjshmd6Z7Ft;Qws?6c_Q)-Dxok^J4GlrfC=vj~}5?nHj*{DT@Wd>$siC$!2 zm?&+EaYoP20ituAC(&GR(zyx$LOc)-X!sAjwY4r3l)~=YEiH8QEIzFVxPfc(;UO%Bnv<4d zBZ*a&-6BtlQZ(xe5gfu|n_bEZ5{jcg{F`D}E_9y^yf&)>06}=jN?cQ90eNQl3xDDX zq=#fWwy|E@8bX-#+2Uqts9d^o8jGhfSppLxWO-SvtU-Rs3;$5%B#%j8E)Wh7aWpS3 zK~RY}y%&(%f`&(L!mpM>-7Um5Y*;uDJO!ui=*S?xkOkT|orP-YB@cz6rUxvA$L!sf*rdMi(L6p*hz0L47E&cD1%uUd0Ci)xxM2Su;|e zL(5ppq-^>~pX#Yur!3ad`KEQuff`gmwNfsjOSLHyJR=6pN049MESJR}ELXP50T%ee z4-_Qu)iZvokw$>d;O`SItyizCu2J|}onD+X;B+SaN1IFp$8TKti#4%aeoh3RTfo1; z_7)+lMeEL3gm{~D6S=_J19ERrA!-` zs68Ffn>8i{;3a8Pwrb_-Md7cpI;C}W)>$jA!T@P9AL-V$^(|3+wpghWbMTU_c0k%w zG}9|JeB}{GC$6lOfauroWN%pwut08S7%ytsK%A!P=qAz9jid1vQQ&g%SvifXz_u64 zghwh>`hsRwzO)7SMdRY^S_T0^lWbwlH?t1Al25KEE>*w|O>z^fl}pQ8Gy#$#EXQa$ zwKBvPx-V5OUc~sAtRg_vMcL Ur+J{2N9bP~;vH5SfAZ>o1HCY$L;wH) diff --git a/library/UNICODE.~123~ b/library/UNICODE.~123~ deleted file mode 100644 index b6841bae..00000000 --- a/library/UNICODE.~123~ +++ /dev/null @@ -1,7 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 6-Aug-2020 17:49:17"  {DSK}kaplan>Local>medley3.5>lispcore>library>UNICODE.;123 53952 changes to%: (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN MAKE-UNICODE-FORMATS UTF16BE.INCCODEFN UTF16BE.OUTCHARFN) (VARS UNICODECOMS) previous date%: " 6-Aug-2020 09:37:13" {DSK}kaplan>Local>medley3.5>lispcore>library>UNICODE.;120) (PRETTYCOMPRINT UNICODECOMS) (RPAQQ UNICODECOMS [[COMS (* ;; "External formats") (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCHARFN) (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCHARFN) (FNS MAKE-UNICODE-FORMATS) (P (MAKE-UNICODE-FORMATS)) (ADDVARS (*DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8] [COMS (* ;; "Unicode mapping files") (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME ) (VARS XCCS-SET-NAMES) (* ;; "Automate dumping of a documentation prefix") [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16] (VARS UNICODE-MAPPING-HEADER) (INITVARS (UNICODEDIRECTORIES NIL)) (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/lispcore/unicode/xerox/] (COMS (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (FNS MAKE-UNICODE-TRANSLATION-TABLES) [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN] (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE)) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES ( READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T) '*XCCSTOUNICODE* '*UNICODETOXCCS*] (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*)) (FNS HEXSTRING UTF8STRING) (FNS SHOWCHARS) (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "This is taken from FILEIO") (CONSTANTS (LF.EOLC 1)) (P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT]) (* ;; "External formats") (DEFINEQ (UTF8.OUTCHARFN [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 6-Aug-2020 17:12 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation of RAW.") (CL:UNLESS RAW (SETQ CHARCODE (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))) (IF (ILESSP CHARCODE 128) THEN (\BOUT STREAM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STREAM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STREAM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STREAM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.INCCODEFN [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2020 17:13 by rmk:") (* ;; "Do not do UNICODE to XCSS translation if RAW.") (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1)) (SETQ BYTE1 (\BIN STREAM)) (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1") (CL:WHEN (SMALLP BYTE1) [SETQ CODE (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE3)) (ILESSP BYTE3 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE4)) (ILESSP BYTE4 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (SETQ COUNT 4) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE3)) (ILESSP BYTE3 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ COUNT 3) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ COUNT 2) (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) (CL:UNLESS (OR RAW (NOT (SMALLP CODE))) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (CL:IF COUNTP (CL:VALUES CODE COUNT) CODE)]) (UTF8.PEEKCCODEFN [LAMBDA (STREAM NOERROR COUNTP RAW) (* ; "Edited 6-Aug-2020 17:12 by rmk:") (* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (* ;; "Distinguish on header bytex") (CL:UNLESS BYTE1 (RETURN (AND COUNTP (CL:VALUES NIL 0)))) [IF (ILESSP BYTE1 128) THEN (* ;;  "Test first: Ascii is the common case. No need to back up, since we peeked.") (SETQ CODE BYTE1) ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE3 128)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) (* ;  "PEEK the last, no need to back it up") (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE4 (IGEQ BYTE4 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE3 (IGEQ BYTE3 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) ELSE (* ; "Must be 2 bytes") (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF (AND BYTE2 (IGEQ BYTE2 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2] (CL:WHEN (AND CODE (NOT RAW)) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE]) (\UTF8.BACKCHARFN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Jul-2020 10:41 by rmk:") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT") (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM) (ADD C 1) (EQ 2 (LRSH (\PEEKBIN STREAM) 6))) REPEATUNTIL (EQ C 4) FINALLY (RETURN (AND COUNTP C]) ) (DEFINEQ (UTF16BE.OUTCHARFN - [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 6-Aug-2020 17:00 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") - (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do XCCS to UNICODE translation if RAW.") - - (CL:UNLESS RAW(SETQ CHARCODE (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))) - (\BOUT STREAM (LRSH CHARCODE 8)) - (\BOUT STREAM (LOGAND CHARCODE 255]) (UTF16BE.INCCODEFN [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2020 17:48 by rmk:") (* ;;  "Do not do UNICODE to XCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") (LET (CODE BYTE1 BYTE2 COUNT) (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) (SMALLP (SETQ BYTE2 (\BIN STREAM] THEN (SETQ COUNT 2) (SETQ CODE (LOGOR (LLSH (\BIN STREAM) 8) (\BIN STREAM))) (CL:UNLESS RAW (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (CL:IF COUNTP (CL:VALUES CODE COUNT) CODE) ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) (UTF16BE.PEEKCCODEFN [LAMBDA (STREAM NOERROR COUNTP RAW) (* ; "Edited 30-Jul-2020 14:06 by rmk:") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (LET (BYTE1 BYTE2 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (IF BYTE1 THEN (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF BYTE2 THEN (SETQ CODE (LOGOR (LLSH BYTE1 8) BYTE2)) (CL:IF COUNTP (CL:VALUES (CL:IF RAW CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)) 0)) ELSEIF NOERROR ELSE (AND COUNTP (CL:VALUES NIL 0))) ELSEIF NOERROR THEN (AND COUNTP (CL:VALUES NIL 0)) ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) (\UTF16.BACKCHARFN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Jul-2020 13:05 by rmk:") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT.") (* ;; "Common for big-ending and little-ending") (IF (NOT (\BACKFILEPTR STREAM)) THEN (AND COUNTP 0) ELSEIF (\BACKFILEPTR STREAM) THEN (AND COUNTP 2) ELSE (AND COUNTP 1]) ) (DEFINEQ (MAKE-UNICODE-FORMATS [LAMBDA NIL (* ; "Edited 6-Aug-2020 17:12 by rmk:") (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.") (* ;; "The EOL forces the EOLCONVENTION of the stream to be changed to LF, so that \CHECKEOLC will do the conversion of LF to CR.") (* ;; "This should be handled in the reading functions here--\CHECKEOLC is a general mistake.") (\INSTALL.EXTERNALFORMAT :UTF16BE (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ LF.EOLC INCCODEFN _ (FUNCTION UTF16BE.INCCODEFN) PEEKCCODEFN _ (FUNCTION UTF16BE.PEEKCCODEFN) BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION UTF16BE.OUTCHARFN))) [\INSTALL.EXTERNALFORMAT :UTF16BE-RAW (CREATE EXTERNALFORMAT INCCODEFN _ [FUNCTION (LAMBDA (STREAM) (UTF16BE.INCCODEFN STREAM T] PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP) (UTF16BE.PEEKCCODEFN STREAM NOERROR COUNTP T] BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE) (UTF16BE.OUTCHARFN STREAM CHARCODE T] [\INSTALL.EXTERNALFORMAT :UTF8-RAW (CREATE EXTERNALFORMAT INCCODEFN _ [FUNCTION (LAMBDA (STREAM COUNTP) (UTF8.INCCODEFN STREAM COUNTP T] PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP) (UTF8.PEEKCCODEFN STREAM NOERROR COUNTP T] BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE) (UTF8.OUTCHARFN STREAM CHARCODE T] (\INSTALL.EXTERNALFORMAT :UTF8 (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ LF.EOLC INCCODEFN _ (FUNCTION UTF8.INCCODEFN) PEEKCCODEFN _ (FUNCTION UTF8.PEEKCCODEFN) BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION UTF8.OUTCHARFN]) ) (MAKE-UNICODE-FORMATS) (ADDTOVAR *DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8)) (* ;; "Unicode mapping files") (DEFINEQ (READ-UNICODE-MAPPING-FILENAMES [LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan") (* ;  "Edited 4-Aug-2020 17:31 by rmk:") (FOR F X CSI INSIDE FILESPEC COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT) T UNICODEDIRECTORIES) ELSEIF [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES) (FIND N IN XCCS-SET-NAMES SUCHTHAT (EQ F (CADR N] THEN (FINDFILE (PACKFILENAME 'BODY (CONCAT 'XCCS- (CAR CSI) '= (CADR CSI)) 'EXTENSION 'TXT) T UNICODEDIRECTORIES) ELSE F]) (READ-UNICODE-MAPPING [LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 6-Aug-2020 08:24 by rmk:") (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") (* ;; " Column 1: Input hex code in the format %"0xXXXX%" (fromcode)") (* ;; " Column 2: Corresponding Unicode code in the format %"0xXXXX%" (tocode)") (* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character for XCCS mapping files") (* ;; "") (* ;; "Result is a list of (fromcode tocode) integer pairs, where pairs are suppress where fromcode and tocode are the same, since the absence of a pair indicates identity.") (FOR FILE IN (READ-UNICODE-MAPPING-FILENAMES FILESPEC) JOIN (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8-RAW) (BIND FROMCODE TOCODE AFTERFROM LINE [WSBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] [CBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE %#] FIRST (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T) (ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM))) (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) (CL:UNLESS NOPRINT (PRINTOUT T T "Unicode mapping: " (CL:STRING-TRIM " " LINE) T)) WHILE (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) UNLESS (OR [EQ (CHARCODE %#) (CHCON1 (SETQ LINE (CL:STRING-LEFT-TRIM " " LINE] (EQ 0 (NCHARS LINE))) COLLECT (SETQ AFTERFROM (STRPOSL WSBITTABLE LINE)) [SETQ FROMCODE (CHARCODE.DECODE (SUBSTRING LINE 1 (SUB1 AFTERFROM) (CONSTANT (CONCAT] [SETQ LINE (CL:STRING-LEFT-TRIM '(#\Space #\Tab) (SUBSTRING LINE AFTERFROM NIL (CONSTANT (CONCAT] [SETQ TOCODE (CHARCODE.DECODE (SUBSTRING LINE 1 [SUB1 (OR (STRPOSL CBITTABLE LINE) (ADD1 (NCHARS LINE] NIL (CONSTANT (CONCAT] (LIST FROMCODE TOCODE]) (WRITE-UNICODE-MAPPING [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 6-Aug-2020 08:20 by rmk:") (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.") (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.") (* ;; "The output lines are of the form x0XXXx0UUUU# Unicode-char") (* ;;  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.") (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.") (IF (AND (EQ INCLUDECHARSETS T) (NULL FILE)) THEN (IF MAPPING THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F (WRITE-UNICODE-MAPPING MAPPING (CAR CSI) NIL T)) COLLECT F) ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T) NIL) ELSE (LET (IMAPPING CSETINFO RANGES) (CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES) (WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS)) (IF IMAPPING THEN (CL:WITH-OPEN-FILE (STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF8-RAW) (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES) (SORT IMAPPING T) (FOR M CSET LEFTC RIGHTC CSI IN IMAPPING DO (SETQ LEFTC (CAR M)) (SETQ RIGHTC (CADR M)) (CL:UNLESS (EQ CSET (LRSH LEFTC 8)) (SETQ CSET (LRSH LEFTC 8)) (SETQ CSI (ASSOC CSET CSETINFO)) (PRINTOUT STREAM T "# " .P2 (CADR CSI) " " (CADDR CSI) T)) (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4) " " "0x" (HEXSTRING RIGHTC 4) " # " (SELECTC RIGHTC (UNDEFINEDCODE (* ;; "FFFF") "UNDEFINED") (MISSINGCODE (* ;; "FFFE") "MISSING") (IF (ILESSP RIGHTC 32) THEN [CONCAT "^" (CHARACTER (IPLUS RIGHTC (CHARCODE @] ELSE (CHARACTER RIGHTC))) T)) (FULLNAME STREAM)) ELSEIF (NOT EMPTYOK) THEN (PRINTOUT T "THERE ARE NO MAPPINGS") (CL:WHEN INCLUDECHARSETS (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS) T)) NIL]) (WRITE-UNICODE-INCLUDED [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") (* ;; "CSETINFO is a list of (num string name) for each included character set.") (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN XCCS-SET-NAMES COLLECT (CAR CSI))) JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES) (FIND N IN XCCS-SET-NAMES SUCHTHAT (EQ C (CADR N))) (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C] (IF (SETQ POS (STRPOS "-" (CAR KNOWN))) THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) 1 (SUB1 POS)) :RADIX 8) TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) (ADD1 POS)) :RADIX 8) COLLECT (LIST I (OCTALSTRING I) (CADR KNOWN))) ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN) :RADIX 8) KNOWN] (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M) 8) ICSETS)) COLLECT (* ;; "The attested subset of INCLUDED") (CL:UNLESS (MEMB CSI CSETINFO) (PUSH CSETINFO CSI)) M)) (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") (SETQ CSETINFO (SORT CSETINFO T)) [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO COLLECT (CAR CSI)) WHILE CTAIL COLLECT (SETQ START (CAR CTAIL)) (SETQ END START) (CONS START (WHILE [AND (CDR CTAIL) (EQ END (SUB1 (CADR CTAIL] COLLECT (SETQ CTAIL (CDR CTAIL)) (SETQ END (CAR CTAIL] (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES JOIN (SETQ LAST (CAR (LAST R))) (IF (EQ (CAR R) LAST) THEN (CONS (OCTALSTRING (CAR R))) ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING (CAR R)) "-" (OCTALSTRING LAST))) XCCS-SET-NAMES)) THEN (CONS (CADR KNOWN)) ELSEIF (CDDR R) THEN (CONS STR) ELSE (LIST (OCTALSTRING (CAR R)) (OCTALSTRING LAST] (CL:VALUES IMAPPING CSETINFO RANGES]) (WRITE-UNICODE-MAPPING-HEADER [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:") (* ;; "Writes the standard per-file header information") (FOR LINE IN UNICODE-MAPPING-HEADER DO (PRINTOUT STREAM "#" 2) (SELECTQ LINE (XCCSCHARACTERSETS (PRINTOUT STREAM " XCCS charset") (IF (CDR CSETINFO) THEN (PRINTOUT STREAM "s:" -4) (FOR R IN RANGES DO (PRINTOUT STREAM R " ")) (TERPRI STREAM) ELSE (* ; "Singleton") (PRINTOUT STREAM ": " -4 (CADAR CSETINFO) " " (CADDAR CSETINFO))) (TERPRI STREAM)) (DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES)) T)) (PRINTOUT STREAM LINE T))) (TERPRI STREAM]) (WRITE-UNICODE-MAPPING-FILENAME [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") (PACKFILENAME 'BODY [OR FILE (CONCATLIST (CONS 'XCCS- (IF (CDR CSETINFO) THEN (FOR RTAIL R ON RANGES JOIN (SETQ R (CAR RTAIL)) (SETQ R (CL:IF (LISTP R) (LIST (CAR R) "-" (CDR R)) (CONS R))) (CL:IF (CDR RTAIL) (NCONC1 R ",")) R) ELSE (LIST (CADAR CSETINFO) "=" (CADDAR CSETINFO] 'DIRECTORY (CAR UNICODEDIRECTORIES) 'EXTENSION 'TXT]) ) (RPAQQ XCCS-SET-NAMES (("0" LATIN) ("41" SYMBOLS1) ("42" SYMBOLS2) ("43" EXTENDED-LATIN) ("44" HIRAGANA) ("45" KATAKANA) ("46" GREEK) ("47" CYRILLIC) ("50" FORMS) ("60-172" JIS) ("340" ARABIC) ("341" HEBREW) ("342" IPA) ("343" HANGUL) ("344" GEORGIAN-ARMENIAN) ("356" SYMBOLS3) ("357" SYMBOLS4) ("360" LIGATURES) ("361" ACCENTED-LATIN) ("365" MORE-ARABIC) ("375" GRAPHIC-VARIANTS))) (* ;; "Automate dumping of a documentation prefix") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)) (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))) ) ) (RPAQQ UNICODE-MAPPING-HEADER ("" " Name: XCCS (XC-3-1-1-0) to Unicode" " Unicode version: 3.0" XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A" DATE " Author: Ron Kaplan " "" "This file contains mappings from the Xerox Character Code Standard (version" "XC1-3-3-0, 1987) into Unicode 3.0. standard codes. That is the version of" "XCCS corresponding to the fonts in the Medley system." "" "The format of this file conforms to the format of the other Unicode-supplied" "mapping files:" " Three white-space (tab or spaces) separated columns:" " Column 1 is the XCCS code (as hex 0xXXXX)" " Column 2 is the corresponding Unicode (as hex 0xXXXX)" " Column 3 (after #) is a comment column. For convenience, it contains the" " Unicode character itself (since the Unicode character names" " are not available)" "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" "Unicode FFFE is used for XCCS codes that have not yet been filled in." "(Column 3 = MISSING)" "" "This file is encoded in UTF8, so that the Unicode characters" "are properly displayed in Column 3 and can be edited by standard" "Unicode-enabled editors (e.g. Mac Textedit)." "" "This file can also be read by the function" "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" "The entries are in XCCS order and grouped by character sets. In front of" "the mappings, for convenience, there is a line with the octal XCCS" "character set, after #." "" "Note that a given XCCS code might map to codes in several different Unicode" "positions, since there are repetitions in the Unicode standard." "" "For more details, see the associated README.TXT file." "" "Any comments or problems, contact ")) (RPAQ? UNICODEDIRECTORIES NIL) (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/lispcore/unicode/xerox/)) (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (DEFINEQ (MAKE-UNICODE-TRANSLATION-TABLES [LAMBDA (MAPPING LTORVAR RTOLVAR EXTERNALEOL) (* ; "Edited 1-Aug-2020 09:38 by rmk:") (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.") (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") (* ;; "") (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme. But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.") (* ;; " ") (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code. An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes). The latter is used to save space for sparsely populated character sets.") (* ;; "") (* ;; "The absence of a recoding (NIL) is treated as an identity.") (* ;; "") (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.") (CL:UNLESS EXTERNALEOL (* ; "Unix default") (SETQ EXTERNALEOL (CHARCODE LF))) (LET ((LTORARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (RTOLARRAY (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))) (* ;; "The left-to-right direction (into Unicode). We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte). The second loop converts long alists into arrays.") [FOR PAIR LEFTC RIGHTC IN MAPPING UNLESS (OR (EQ (SETQ LEFTC (CAR PAIR)) (SETQ RIGHTC (CADR PAIR))) (IGEQ RIGHTC MISSINGCODE)) DO (CL:WHEN (EQ LEFTC (CHARCODE EOL)) (SETQ LEFTC EXTERNALEOL)) (CL:PUSH (CONS (LOGAND LEFTC 255) RIGHTC) (CL:SVREF LTORARRAY (LRSH LEFTC 8] (FOR I CSA FROM 0 TO 255 WHEN (IGREATERP (LENGTH (CL:SVREF LTORARRAY I)) 20) DO (* ;; "Leave it alone if the alist is short") (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF LTORARRAY I) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P) 255)) (CDR P))) (* ;; "Fill in the identities in the array case--avoid an extra NIL test in translating, and allows for identity testing below") (FOR J FROM 0 TO 255 UNLESS (CL:SVREF CSA J) DO (CL:SETF (CL:SVREF CSA J) (LOGOR (LLSH I 8) J))) (CL:SETF (CL:SVREF LTORARRAY I) CSA)) (* ;; "") (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.") (* ;;  "Thus, we don't suppress identities in the alist, so that the PREV test below is always complete.") (FOR PAIR LEFTC RIGHTC PREV IN MAPPING UNLESS (IGEQ (SETQ RIGHTC (CADR PAIR)) MISSINGCODE) DO (SETQ LEFTC (CAR PAIR)) (CL:WHEN (EQ RIGHTC EXTERNALEOL) (SETQ RIGHTC (CHARCODE EOL))) (* ;; "Have we already seen an explicit mapping from right to left?") [SETQ PREV (ASSOC (LOGAND RIGHTC 255) (CL:SVREF RTOLARRAY (LRSH RIGHTC 8] (IF (NULL PREV) THEN (CL:PUSH (CONS (LOGAND RIGHTC 255) LEFTC) (CL:SVREF RTOLARRAY (LRSH RIGHTC 8))) ELSEIF (IGREATERP (CDR PREV) LEFTC) THEN (RPLACD PREV LEFTC))) (* ;; "Since we didn't suppress identities before, and we still want to conserve a little storage, we have to count the number of non-identities here") [FOR I CSA FROM 0 TO 255 DO (IF (FOR P (CNT _ 1) IN (CL:SVREF RTOLARRAY I) UNLESS (EQ (CAR P) (CDR P)) DO (ADD CNT 1) (CL:WHEN (EQ CNT 20) (RETURN T))) THEN (SETQ CSA (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF RTOLARRAY I) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P) 255)) (CDR P))) (FOR J FROM 0 TO 255 UNLESS (CL:SVREF CSA J) DO (CL:SETF (CL:SVREF CSA J) (LOGOR (LLSH I 8) J))) (CL:SETF (CL:SVREF RTOLARRAY I) CSA) ELSE (* ;; "Shrink the alist to nonidentities") (CL:SETF (CL:SVREF RTOLARRAY I) (FOR P IN (CL:SVREF RTOLARRAY I) UNLESS (EQ (CAR P) (CDR P)) COLLECT P] (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY)) (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY)) (CL:VALUES LTORARRAY RTOLARRAY]) ) (RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE) (LET [(X (CL:SVREF TRANSLATION-TABLE (LRSH CODE 8] (COND ((LISTP X) (OR (CDR (FASSOC (LOGAND CODE 255) X)) CODE)) (T (CL:SVREF X (LOGAND CODE 255]) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MAKE-UNICODE-TRANSLATION-TABLES (READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T) '*XCCSTOUNICODE* '*UNICODETOXCCS*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*) ) (DEFINEQ (HEXSTRING [LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:") (* ; "Edited 20-Dec-93 17:51 by rmk:") (* ;;  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.") (CL:UNLESS (FIXP N) (SETQ N (CHARCODE.DECODE N))) (LET [CHAR (STR (ALLOCSTRING [IMAX (OR WIDTH 0) (FOR I (LEFT _ N) FROM 0 UNTIL (EQ LEFT 0) DO (SETQ LEFT (LRSH LEFT 4)) FINALLY (RETURN (MAX I 1] (CHARCODE 0] (FOR I FROM -1 BY -1 UNTIL (EQ N 0) DO (SETQ CHAR (LOGAND N 15)) [RPLCHARCODE STR I (IF (ILESSP CHAR 10) THEN (+ CHAR (CHARCODE 0)) ELSE (+ (- CHAR 10) (CHARCODE A] (SETQ N (LRSH N 4))) STR]) (UTF8STRING [LAMBDA (CHARCODE) (* ; "Edited 6-Aug-2020 07:47 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "Utility to produces the UTF8 hexstring representing CODE") (HEXSTRING (IF (ILESSP CHARCODE 128) THEN CHARCODE ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (LOGOR (LLSH (LOGOR (LLSH 3 6) (LRSH CHARCODE 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (LOGOR (LLSH (LOGOR (LLSH 7 5) (LRSH CHARCODE 12)) 16) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (LOGOR (LLSH (LOGOR (LLSH 15 4) (LRSH CHARCODE 18)) 24) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6)) 16) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) ) (DEFINEQ (SHOWCHARS [LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:") (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12)) T) (CL:WHEN (AND (SMALLP FROMCHAR) (NOT TOCHAR)) (* ;;  "If a small number, assume it's an octal (in decimal) character set, no need for string quotes") (SETQ TOCHAR (CONCAT FROMCHAR "," 376)) (SETQ FROMCHAR (CONCAT FROMCHAR "," 41))) (CL:UNLESS (SMALLP FROMCHAR) (SETQ FROMCHAR (CHARCODE.DECODE FROMCHAR))) (CL:UNLESS (SMALLP TOCHAR) (SETQ TOCHAR (CL:IF TOCHAR (CHARCODE.DECODE TOCHAR) FROMCHAR))) (FOR C FROM FROMCHAR TO TOCHAR UNLESS (AND (IGEQ (LOGAND C 255) 127) (ILEQ (LOGAND C 255) (PLUS 128 33))) DO (PRINTOUT T .P2 (CONCAT (OCTALSTRING (LRSH CODE 8)) "," (OCTALSTRING (LOGAND CODE 255))) 10 (CHARACTER C) T]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ LF.EOLC 1) (CONSTANTS (LF.EOLC 1)) ) (EVAL (SYSRECLOOK1 'EXTERNALFORMAT)) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3316 15086 (UTF8.OUTCHARFN 3326 . 5196) (UTF8.INCCODEFN 5198 . 9297) (UTF8.PEEKCCODEFN 9299 . 14577) (\UTF8.BACKCHARFN 14579 . 15084)) (15087 18196 (UTF16BE.OUTCHARFN 15097 . 15617) ( UTF16BE.INCCODEFN 15619 . 16496) (UTF16BE.PEEKCCODEFN 16498 . 17753) (\UTF16.BACKCHARFN 17755 . 18194) ) (18197 21871 (MAKE-UNICODE-FORMATS 18207 . 21869)) (21995 37526 (READ-UNICODE-MAPPING-FILENAMES 22005 . 23167) (READ-UNICODE-MAPPING 23169 . 26060) (WRITE-UNICODE-MAPPING 26062 . 30034) ( WRITE-UNICODE-INCLUDED 30036 . 34758) (WRITE-UNICODE-MAPPING-HEADER 34760 . 35992) ( WRITE-UNICODE-MAPPING-FILENAME 35994 . 37524)) (40872 47740 (MAKE-UNICODE-TRANSLATION-TABLES 40882 . 47738)) (48822 52308 (HEXSTRING 48832 . 49993) (UTF8STRING 49995 . 52306)) (52309 53778 (SHOWCHARS 52319 . 53776))))) STOP \ No newline at end of file diff --git a/library/UNICODE.~166~ b/library/UNICODE.~166~ deleted file mode 100644 index 290a1711..00000000 --- a/library/UNICODE.~166~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-Aug-2020 08:48:36"  {DSK}kaplan>Local>medley3.5>lispcore>library>UNICODE.;166 65800 changes to%: (FNS UTF8.OUTCHARFN UTF16BE.OUTCHARFN MAKE-UNICODE-TRANSLATION-TABLES) previous date%: "16-Aug-2020 23:24:01" {DSK}kaplan>Local>medley3.5>lispcore>library>UNICODE.;165) (PRETTYCOMPRINT UNICODECOMS) (RPAQQ UNICODECOMS [(COMS (* ;; "External formats") (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCHARFN) (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCHARFN) (INITVARS (EXTERNALEOL 'LF)) (FNS MAKE-UNICODE-FORMATS) (P (MAKE-UNICODE-FORMATS EXTERNALEOL)) (ADDVARS (*DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8))) (FNS UNICODE.UNMAPPED) (FNS XCCS-UTF8-AFTER-OPEN) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE)) (FNS XTOUCODE UTOXCODE)) [COMS (* ;; "Unicode mapping files") (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME ) (VARS XCCS-SET-NAMES) (* ;; "Automate dumping of a documentation prefix") [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16] (VARS UNICODE-MAPPING-HEADER) (INITVARS (UNICODEDIRECTORIES NIL)) (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/lispcore/unicode/xerox/] (COMS (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (FNS MAKE-UNICODE-TRANSLATION-TABLES) [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN] [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES ( READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T) '*XCCSTOUNICODE* '*UNICODETOXCCS*] (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*)) (FNS HEXSTRING UTF8HEXSTRING NUTF8CODEBYTES NUTF8STRINGBYTES XTOUSTRING XCCSSTRING) (FNS SHOWCHARS) (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "This is taken from FILEIO") (CONSTANTS (LF.EOLC 1) (CR.EOLC 0) (CRLF.EOLC 2)) (* ;; "These control the layout of the translation tables. Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter") (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128) (MAX-ALIST-LENGTH 10) (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE)) (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE))) (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE))) (P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT)) (EVAL (SYSRECLOOK1 'STREAM]) (* ;; "External formats") (DEFINEQ (UTF8.OUTCHARFN [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 17-Aug-2020 08:45 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation of RAW.") (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM) (CL:IF (EQ CHARCODE (CHARCODE EOL)) 0 (IPLUS DATUM 1))) (* ; "Avoid overflow") (FOR C INSIDE (CL:IF RAW CHARCODE (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*)) DO (IF (ILESSP C 128) THEN (\BOUT STREAM C) ELSEIF (ILESSP C 2048) THEN (* ; "x800") (\BOUT STREAM (LOGOR (LLSH 3 6) (LRSH C 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 0 6))) ELSEIF (ILESSP C 65536) THEN (* ; "x10000") (\BOUT STREAM (LOGOR (LLSH 7 5) (LRSH C 12))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 6 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 0 6))) ELSEIF (ILESSP C 2097152) THEN (* ; "x200000") (\BOUT STREAM (LOGOR (LLSH 15 4) (LRSH C 18))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 12 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 6 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE C 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" C]) (UTF8.INCCODEFN [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2020 17:13 by rmk:") (* ;; "Do not do UNICODE to XCSS translation if RAW.") (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1)) (SETQ BYTE1 (\BIN STREAM)) (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1") (CL:WHEN (SMALLP BYTE1) [SETQ CODE (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE3)) (ILESSP BYTE3 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE4)) (ILESSP BYTE4 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (SETQ COUNT 4) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE3)) (ILESSP BYTE3 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ COUNT 3) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ COUNT 2) (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) (CL:UNLESS (OR RAW (NOT (SMALLP CODE))) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (CL:IF COUNTP (CL:VALUES CODE COUNT) CODE)]) (UTF8.PEEKCCODEFN [LAMBDA (STREAM NOERROR COUNTP RAW) (* ; "Edited 6-Aug-2020 17:12 by rmk:") (* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (* ;; "Distinguish on header bytex") (CL:UNLESS BYTE1 (RETURN (AND COUNTP (CL:VALUES NIL 0)))) [IF (ILESSP BYTE1 128) THEN (* ;;  "Test first: Ascii is the common case. No need to back up, since we peeked.") (SETQ CODE BYTE1) ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE3 128)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) (* ;  "PEEK the last, no need to back it up") (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE4 (IGEQ BYTE4 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE3 (IGEQ BYTE3 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) ELSE (* ; "Must be 2 bytes") (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF (AND BYTE2 (IGEQ BYTE2 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2] (CL:WHEN (AND CODE (NOT RAW)) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE]) (\UTF8.BACKCHARFN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Jul-2020 10:41 by rmk:") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT") (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM) (ADD C 1) (EQ 2 (LRSH (\PEEKBIN STREAM) 6))) REPEATUNTIL (EQ C 4) FINALLY (RETURN (AND COUNTP C]) ) (DEFINEQ (UTF16BE.OUTCHARFN [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 17-Aug-2020 08:48 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do XCCS to UNICODE translation if RAW.") (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM) (CL:IF (EQ CHARCODE (CHARCODE EOL)) 0 (IPLUS DATUM 1))) (FOR C INSIDE (CL:IF RAW CHARCODE (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*)) DO (\BOUT STREAM (LRSH C 8)) (\BOUT STREAM (LOGAND C 255]) (UTF16BE.INCCODEFN [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2020 17:48 by rmk:") (* ;;  "Do not do UNICODE to XCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") (LET (CODE BYTE1 BYTE2 COUNT) (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) (SMALLP (SETQ BYTE2 (\BIN STREAM] THEN (SETQ COUNT 2) (SETQ CODE (LOGOR (LLSH (\BIN STREAM) 8) (\BIN STREAM))) (CL:UNLESS RAW (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (CL:IF COUNTP (CL:VALUES CODE COUNT) CODE) ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) (UTF16BE.PEEKCCODEFN [LAMBDA (STREAM NOERROR COUNTP RAW) (* ; "Edited 30-Jul-2020 14:06 by rmk:") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (LET (BYTE1 BYTE2 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (IF BYTE1 THEN (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF BYTE2 THEN (SETQ CODE (LOGOR (LLSH BYTE1 8) BYTE2)) (CL:IF COUNTP (CL:VALUES (CL:IF RAW CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)) 0)) ELSEIF NOERROR ELSE (AND COUNTP (CL:VALUES NIL 0))) ELSEIF NOERROR THEN (AND COUNTP (CL:VALUES NIL 0)) ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) (\UTF16.BACKCHARFN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Jul-2020 13:05 by rmk:") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT.") (* ;; "Common for big-ending and little-ending") (IF (NOT (\BACKFILEPTR STREAM)) THEN (AND COUNTP 0) ELSEIF (\BACKFILEPTR STREAM) THEN (AND COUNTP 2) ELSE (AND COUNTP 1]) ) (RPAQ? EXTERNALEOL 'LF) (DEFINEQ (MAKE-UNICODE-FORMATS [LAMBDA (EXTERNALEOL) (* ; "Edited 9-Aug-2020 08:40 by rmk:") (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.") (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention. On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.") (SETQ EXTERNALEOL (SELECTQ EXTERNALEOL (LF LF.EOLC) (CR CR.EOLC) (CRLF CRLF.EOLC) (SHOULDNT))) (\INSTALL.EXTERNALFORMAT :UTF16BE (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ (FUNCTION UTF16BE.INCCODEFN) PEEKCCODEFN _ (FUNCTION UTF16BE.PEEKCCODEFN) BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION UTF16BE.OUTCHARFN))) [\INSTALL.EXTERNALFORMAT :UTF16BE-RAW (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ [FUNCTION (LAMBDA (STREAM) (UTF16BE.INCCODEFN STREAM T] PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP) (UTF16BE.PEEKCCODEFN STREAM NOERROR COUNTP T] BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE) (UTF16BE.OUTCHARFN STREAM CHARCODE T] [\INSTALL.EXTERNALFORMAT :UTF8-RAW (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ [FUNCTION (LAMBDA (STREAM COUNTP) (UTF8.INCCODEFN STREAM COUNTP T] PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP) (UTF8.PEEKCCODEFN STREAM NOERROR COUNTP T] BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE) (UTF8.OUTCHARFN STREAM CHARCODE T] (\INSTALL.EXTERNALFORMAT :UTF8 (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ (FUNCTION UTF8.INCCODEFN) PEEKCCODEFN _ (FUNCTION UTF8.PEEKCCODEFN) BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION UTF8.OUTCHARFN]) ) (MAKE-UNICODE-FORMATS EXTERNALEOL) (ADDTOVAR *DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8)) (DEFINEQ (UNICODE.UNMAPPED [LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 11-Aug-2020 20:23 by rmk:") (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.") (* ;; "We return an existing entry in the hash array of the table. If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.") (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS)) INVERSE NEXTCODE) (IF (GETHASH CODE (CAR FORWARD)) ELSEIF (AND (ILEQ CODE (CADDR FORWARD)) (IGEQ CODE (CADDDR FORWARD))) THEN (ERROR "UNMAPPED CODE IS EITHER XCCS-UNUSED OR UNICODE-PRIVATE" CODE) ELSE (SETQ INVERSE (CL:SVREF TRANSLATION-TABLE (ADD1 N-TRANSLATION-SEGMENTS))) (SETQ NEXTCODE (ADD (CADR INVERSE) 1)) (CL:WHEN (IGREATERP NEXTCODE (CADDR INVERSE)) (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES" CODE)) (PUTHASH CODE NEXTCODE (CAR FORWARD)) (PUTHASH NEXTCODE CODE (CAR INVERSE)) NEXTCODE]) ) (DEFINEQ (XCCS-UTF8-AFTER-OPEN [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 13-Aug-2020 11:54 by rmk:") (* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.") (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM))) [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM) 'EXTENSION] (NOT (ASSOC 'EXTERNALFORMAT PARAMETERS))) (STREAMPROP STREAM 'EXTERNALFORMAT :UTF8))]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE) (LET [(X (CL:SVREF TRANSLATION-TABLE (LRSH CODE TRANSLATION-SHIFT ] (COND ((LISTP X) (OR (CDR (FASSOC (LOGAND CODE TRANSLATION-SHIFT) X)) CODE)) [(AND X (CL:SVREF X (LOGAND CODE TRANSLATION-MASK ] (T (UNICODE.UNMAPPED CODE TRANSLATION-TABLE]) ) ) (DEFINEQ (XTOUCODE [LAMBDA (XCCSCODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*]) (UTOXCODE [LAMBDA (UNICODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*]) ) (* ;; "Unicode mapping files") (DEFINEQ (READ-UNICODE-MAPPING-FILENAMES [LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan") (* ;  "Edited 4-Aug-2020 17:31 by rmk:") (FOR F X CSI INSIDE FILESPEC COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT) T UNICODEDIRECTORIES) ELSEIF [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES) (FIND N IN XCCS-SET-NAMES SUCHTHAT (EQ F (CADR N] THEN (FINDFILE (PACKFILENAME 'BODY (CONCAT 'XCCS- (CAR CSI) '= (CADR CSI)) 'EXTENSION 'TXT) T UNICODEDIRECTORIES) ELSE F]) (READ-UNICODE-MAPPING [LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 16-Aug-2020 16:46 by rmk:") (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") (* ;; " Column 1: Input hex code in the format 0xXXXX") (* ;; " Column 2: Corresponding Unicode code-sequence in the format") (* ;; " 0xXXXX ... 0xYYYY") (* ;;  " Column 3: (after #) Character name in some mapping files, utf-8 character") (* ;; " for XCCS mapping files") (* ;; "") (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode") (FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (  READ-UNICODE-MAPPING-FILENAMES FILESPEC) JOIN (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8-RAW) (BIND LINE START FIRST (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T) (ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM))) (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) (CL:UNLESS NOPRINT (PRINTOUT T T "Unicode mapping: " (CL:STRING-TRIM " " LINE) T)) WHILE (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) WHEN (SETQ START (STRPOSL SEPBITTABLE LINE 1 T)) UNLESS (EQ (CHARCODE %#) (NTHCHARCODE LINE START)) COLLECT (BIND END WHILE [SETQ END (OR (STRPOSL SEPBITTABLE LINE START) (ADD1 (NCHARS LINE] COLLECT [CHARCODE.DECODE (SUBSTRING LINE START (SUB1 END) (CONSTANT (CONCAT] REPEATWHILE (AND (SETQ START (STRPOSL SEPBITTABLE LINE END T)) (NEQ (CHARCODE %#) (NTHCHARCODE LINE START]) (WRITE-UNICODE-MAPPING [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:") (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.") (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.") (* ;; "The output lines are of the form x0XXXx0UUUU# Unicode-char") (* ;;  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.") (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.") (IF (AND (EQ INCLUDECHARSETS T) (NULL FILE)) THEN (IF MAPPING THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F (WRITE-UNICODE-MAPPING MAPPING (CAR CSI) NIL T)) COLLECT F) ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T) NIL) ELSE (LET (IMAPPING CSETINFO RANGES) (CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES) (WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS)) (IF IMAPPING THEN (CL:WITH-OPEN-FILE (STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF8-RAW) (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES) (SORT IMAPPING T) (FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING DO (SETQ LEFTC (CAR M)) (SETQ FIRSTRIGHTC (CADR M)) (CL:UNLESS (EQ CSET (LRSH LEFTC 8)) (SETQ CSET (LRSH LEFTC 8)) (SETQ CSI (ASSOC CSET CSETINFO)) (PRINTOUT STREAM T "# " .P2 (CADR CSI) " " (CADDR CSI) T)) (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4) %# (FOR RIGHTC IN (CDR M) DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4))) " # " (SELECTC FIRSTRIGHTC (UNDEFINEDCODE (* ;; "FFFF") "UNDEFINED") (MISSINGCODE (* ;; "FFFE") "MISSING") (IF (ILESSP FIRSTRIGHTC 32) THEN (* ; "Control chars") [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @] ELSE (CHARACTER FIRSTRIGHTC))) T)) (FULLNAME STREAM)) ELSEIF (NOT EMPTYOK) THEN (PRINTOUT T "THERE ARE NO MAPPINGS") (CL:WHEN INCLUDECHARSETS (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS) T)) NIL]) (WRITE-UNICODE-INCLUDED [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") (* ;; "CSETINFO is a list of (num string name) for each included character set.") (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN XCCS-SET-NAMES COLLECT (CAR CSI))) JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES) (FIND N IN XCCS-SET-NAMES SUCHTHAT (EQ C (CADR N))) (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C] (IF (SETQ POS (STRPOS "-" (CAR KNOWN))) THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) 1 (SUB1 POS)) :RADIX 8) TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) (ADD1 POS)) :RADIX 8) COLLECT (LIST I (OCTALSTRING I) (CADR KNOWN))) ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN) :RADIX 8) KNOWN] (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M) 8) ICSETS)) COLLECT (* ;; "The attested subset of INCLUDED") (CL:UNLESS (MEMB CSI CSETINFO) (PUSH CSETINFO CSI)) M)) (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") (SETQ CSETINFO (SORT CSETINFO T)) [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO COLLECT (CAR CSI)) WHILE CTAIL COLLECT (SETQ START (CAR CTAIL)) (SETQ END START) (CONS START (WHILE [AND (CDR CTAIL) (EQ END (SUB1 (CADR CTAIL] COLLECT (SETQ CTAIL (CDR CTAIL)) (SETQ END (CAR CTAIL] (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES JOIN (SETQ LAST (CAR (LAST R))) (IF (EQ (CAR R) LAST) THEN (CONS (OCTALSTRING (CAR R))) ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING (CAR R)) "-" (OCTALSTRING LAST))) XCCS-SET-NAMES)) THEN (CONS (CADR KNOWN)) ELSEIF (CDDR R) THEN (CONS STR) ELSE (LIST (OCTALSTRING (CAR R)) (OCTALSTRING LAST] (CL:VALUES IMAPPING CSETINFO RANGES]) (WRITE-UNICODE-MAPPING-HEADER [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:") (* ;; "Writes the standard per-file header information") (FOR LINE IN UNICODE-MAPPING-HEADER DO (PRINTOUT STREAM "#" 2) (SELECTQ LINE (XCCSCHARACTERSETS (PRINTOUT STREAM " XCCS charset") (IF (CDR CSETINFO) THEN (PRINTOUT STREAM "s:" -4) (FOR R IN RANGES DO (PRINTOUT STREAM R " ")) (TERPRI STREAM) ELSE (* ; "Singleton") (PRINTOUT STREAM ": " -4 (CADAR CSETINFO) " " (CADDAR CSETINFO))) (TERPRI STREAM)) (DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES)) T)) (PRINTOUT STREAM LINE T))) (TERPRI STREAM]) (WRITE-UNICODE-MAPPING-FILENAME [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") (PACKFILENAME 'BODY [OR FILE (CONCATLIST (CONS 'XCCS- (IF (CDR CSETINFO) THEN (FOR RTAIL R ON RANGES JOIN (SETQ R (CAR RTAIL)) (SETQ R (CL:IF (LISTP R) (LIST (CAR R) "-" (CDR R)) (CONS R))) (CL:IF (CDR RTAIL) (NCONC1 R ",")) R) ELSE (LIST (CADAR CSETINFO) "=" (CADDAR CSETINFO] 'DIRECTORY (CAR UNICODEDIRECTORIES) 'EXTENSION 'TXT]) ) (RPAQQ XCCS-SET-NAMES (("0" LATIN) ("41" SYMBOLS1) ("42" SYMBOLS2) ("43" EXTENDED-LATIN) ("44" HIRAGANA) ("45" KATAKANA) ("46" GREEK) ("47" CYRILLIC) ("50" FORMS) ("60-172" JIS) ("340" ARABIC) ("341" HEBREW) ("342" IPA) ("343" HANGUL) ("344" GEORGIAN-ARMENIAN) ("356" SYMBOLS3) ("357" SYMBOLS4) ("360" LIGATURES) ("361" ACCENTED-LATIN) ("365" MORE-ARABIC) ("375" GRAPHIC-VARIANTS))) (* ;; "Automate dumping of a documentation prefix") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)) (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))) ) ) (RPAQQ UNICODE-MAPPING-HEADER ("" " Name: XCCS (XC-3-1-1-0) to Unicode" " Unicode version: 3.0" XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A" DATE " Author: Ron Kaplan " "" "This file contains mappings from the Xerox Character Code Standard (version" "XC1-3-3-0, 1987) into Unicode 3.0. standard codes. That is the version of" "XCCS corresponding to the fonts in the Medley system." "" "The format of this file conforms to the format of the other Unicode-supplied" "mapping files:" " Three white-space (tab or spaces) separated columns:" " Column 1 is the XCCS code (as hex 0xXXXX)" " Column 2 is the corresponding Unicode (as hex 0xXXXX)" " Column 3 (after #) is a comment column. For convenience, it contains the" " Unicode character itself (since the Unicode character names" " are not available)" "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" "Unicode FFFE is used for XCCS codes that have not yet been filled in." "(Column 3 = MISSING)" "" "This file is encoded in UTF8, so that the Unicode characters" "are properly displayed in Column 3 and can be edited by standard" "Unicode-enabled editors (e.g. Mac Textedit)." "" "This file can also be read by the function" "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" "The entries are in XCCS order and grouped by character sets. In front of" "the mappings, for convenience, there is a line with the octal XCCS" "character set, after #." "" "Note that a given XCCS code might map to codes in several different Unicode" "positions, since there are repetitions in the Unicode standard." "" "For more details, see the associated README.TXT file." "" "Any comments or problems, contact ")) (RPAQ? UNICODEDIRECTORIES NIL) (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/lispcore/unicode/xerox/)) (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (DEFINEQ (MAKE-UNICODE-TRANSLATION-TABLES [LAMBDA (MAPPING LTORVAR RTOLVAR) (* ; "Edited 17-Aug-2020 08:46 by rmk:") (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.") (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") (* ;; "") (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme. But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.") (* ;; " ") (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code. An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes). The latter is used to save space for sparsely populated character sets.") (* ;; "") (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping. Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.") (* ;; "") (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).") (* ;; "") (* ;;  "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF") (* ;; "") (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.") (* ;; "") (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) :INITIAL-ELEMENT NIL)) (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) :INITIAL-ELEMENT NIL))) (* ;; "The left-to-right direction (into Unicode). We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte). The second loop converts long alists into arrays.") [FOR M LEFTC RBASE RCODES IN MAPPING EACHTIME (SETQ RCODES (CDR M)) (SETQ RBASE (CAR RCODES)) UNLESS (IGEQ RBASE MISSINGCODE) DO (SETQ LEFTC (CAR M)) (* ;;  "(CDR RCODES) contains combiners on the base") (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK) (CL:IF (CDR RCODES) RCODES RBASE)) (CL:SVREF LTORARRAY (LRSH LEFTC TRANSLATION-SHIFT ] (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS) WHEN (IGREATERP (LENGTH (CL:SVREF LTORARRAY I)) MAX-ALIST-LENGTH) DO (* ;; "Leave it alone if the alist is short") (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF LTORARRAY I) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P) TRANSLATION-MASK)) (CDR P))) (CL:SETF (CL:SVREF LTORARRAY I) CSA)) (* ;; "") (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.") (FOR M LEFTC RBASE RCOMBINERS PREV IN MAPPING EACHTIME (SETQ RBASE (CADR M)) (SETQ RCOMBINERS (CDDR M)) UNLESS (OR (IGEQ RBASE MISSINGCODE) RCOMBINERS) DO (* ;;  "Have we already seen an explicit mapping from right to left?") (SETQ LEFTC (CAR M)) [SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK) (CL:SVREF RTOLARRAY (LRSH RBASE TRANSLATION-SHIFT ] (IF (NULL PREV) THEN (CL:PUSH (CONS (LOGAND RBASE TRANSLATION-MASK) LEFTC) (CL:SVREF RTOLARRAY (LRSH RBASE TRANSLATION-SHIFT ))) ELSEIF (IGREATERP (CDR PREV) LEFTC) THEN (RPLACD PREV LEFTC))) (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS) WHEN (IGREATERP (LENGTH (CL:SVREF RTOLARRAY I)) MAX-ALIST-LENGTH) DO (* ;; "Long list, make an array") (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF RTOLARRAY I) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P) TRANSLATION-MASK)) (CDR P))) (CL:SETF (CL:SVREF RTOLARRAY I) CSA)) (* ;; "") (* ;; "Allocate the hash arrays for future out-of-map codes. We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.") (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS) (LIST (HASHARRAY 10) (CHARCODE.DECODE "5,0") (CHARCODE.DECODE "40,0") (CHARCODE.DECODE "5,0"))) (CL:SETF (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS) (LIST (HASHARRAY 10) (CHARCODE.DECODE "E000") (CHARCODE.DECODE "F8FF") (CHARCODE.DECODE "E000"))) (* ;; "Now put in the inverse unmapped hash arrays") (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)) (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)) (* ;; "") (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY)) (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY)) (CL:VALUES LTORARRAY RTOLARRAY]) ) (RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN)) (DECLARE%: DONTEVAL@LOAD DOCOPY (MAKE-UNICODE-TRANSLATION-TABLES (READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T) '*XCCSTOUNICODE* '*UNICODETOXCCS*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*) ) (DEFINEQ (HEXSTRING [LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:") (* ; "Edited 20-Dec-93 17:51 by rmk:") (* ;;  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.") (CL:UNLESS (FIXP N) (SETQ N (CHARCODE.DECODE N))) (LET [CHAR (STR (ALLOCSTRING [IMAX (OR WIDTH 0) (FOR I (LEFT _ N) FROM 0 UNTIL (EQ LEFT 0) DO (SETQ LEFT (LRSH LEFT 4)) FINALLY (RETURN (MAX I 1] (CHARCODE 0] (FOR I FROM -1 BY -1 UNTIL (EQ N 0) DO (SETQ CHAR (LOGAND N 15)) [RPLCHARCODE STR I (IF (ILESSP CHAR 10) THEN (+ CHAR (CHARCODE 0)) ELSE (+ (- CHAR 10) (CHARCODE A] (SETQ N (LRSH N 4))) STR]) (UTF8HEXSTRING [LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:") (* ;; "Utility to produces the UTF8 hexstring representing CODE") (HEXSTRING (IF (ILESSP CHARCODE 128) THEN CHARCODE ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (LOGOR (LLSH (LOGOR (LLSH 3 6) (LRSH CHARCODE 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (LOGOR (LLSH (LOGOR (LLSH 7 5) (LRSH CHARCODE 12)) 16) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (LOGOR (LLSH (LOGOR (LLSH 15 4) (LRSH CHARCODE 18)) 24) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6)) 16) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (NUTF8CODEBYTES [LAMBDA (N) (* ; "Edited 10-Aug-2020 12:35 by rmk:") (* ;; "Returns the number of bytes needed to encode N in UTF8, ") (IF (ILESSP N 128) THEN 1 ELSEIF (ILESSP N 2048) THEN (* ; "x800") 4 ELSEIF (ILESSP N 65536) THEN (* ; "x10000") 3 ELSEIF (ILESSP N 2097152) THEN (* ; "x200000") 2 ELSE (SHOULDNT]) (NUTF8STRINGBYTES [LAMBDA (STRING RAWFLG) (* ; "Edited 10-Aug-2020 09:06 by rmk:") (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ") (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I)) SUM (NUTF8CODEBYTES (CL:IF RAWFLG C (XTOUCODE C))]) (XTOUSTRING [LAMBDA (XCCSSTRING RAWFLG) (* ; "Edited 10-Aug-2020 21:42 by rmk:") (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING. Applies the XCCSTOUNICODE translation unless RAWFLG. ") (* ;; "The resulting string will not be readable inside Medley.") (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG] (FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING I)) DO (CL:UNLESS RAWFLG (SETQ CHARCODE (XTOUCODE CHARCODE))) (IF (ILESSP CHARCODE 128) THEN (RPLCHARCODE USTR (ADD SINDEX 1) CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (SHOULDNT))) USTR]) (XCCSSTRING [LAMBDA (CODE) (* ; "Edited 13-Aug-2020 12:16 by rmk:") (* ;; "Returns XCCS character representation of string %"cset,char%"") (CL:UNLESS (FIXP CODE) (SETQ CODE (CHCON1 CODE))) (CONCAT (OCTALSTRING (LRSH CODE 8)) "," (OCTALSTRING (LOGAND CODE 255]) ) (DEFINEQ (SHOWCHARS [LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:") (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12)) T) (CL:WHEN (AND (SMALLP FROMCHAR) (NOT TOCHAR)) (* ;;  "If a small number, assume it's an octal (in decimal) character set, no need for string quotes") (SETQ TOCHAR (CONCAT FROMCHAR "," 376)) (SETQ FROMCHAR (CONCAT FROMCHAR "," 41))) (CL:UNLESS (SMALLP FROMCHAR) (SETQ FROMCHAR (CHARCODE.DECODE FROMCHAR))) (CL:UNLESS (SMALLP TOCHAR) (SETQ TOCHAR (CL:IF TOCHAR (CHARCODE.DECODE TOCHAR) FROMCHAR))) (FOR C FROM FROMCHAR TO TOCHAR UNLESS (AND (IGEQ (LOGAND C 255) 127) (ILEQ (LOGAND C 255) (PLUS 128 33))) DO (PRINTOUT T .P2 (CONCAT (OCTALSTRING (LRSH CODE 8)) "," (OCTALSTRING (LOGAND CODE 255))) 10 (CHARACTER C) T]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ LF.EOLC 1) (RPAQQ CR.EOLC 0) (RPAQQ CRLF.EOLC 2) (CONSTANTS (LF.EOLC 1) (CR.EOLC 0) (CRLF.EOLC 2)) ) (DECLARE%: EVAL@COMPILE (RPAQQ TRANSLATION-SEGMENT-SIZE 128) (RPAQQ MAX-ALIST-LENGTH 10) (RPAQ N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE)) (RPAQ TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE))) (RPAQ TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE)) (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128) (MAX-ALIST-LENGTH 10) (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE)) (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE))) (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE))) ) (EVAL (SYSRECLOOK1 'EXTERNALFORMAT)) (EVAL (SYSRECLOOK1 'STREAM)) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4144 16328 (UTF8.OUTCHARFN 4154 . 6438) (UTF8.INCCODEFN 6440 . 10539) (UTF8.PEEKCCODEFN 10541 . 15819) (\UTF8.BACKCHARFN 15821 . 16326)) (16329 19651 (UTF16BE.OUTCHARFN 16339 . 17072) ( UTF16BE.INCCODEFN 17074 . 17951) (UTF16BE.PEEKCCODEFN 17953 . 19208) (\UTF16.BACKCHARFN 19210 . 19649) ) (19681 23821 (MAKE-UNICODE-FORMATS 19691 . 23819)) (23918 25224 (UNICODE.UNMAPPED 23928 . 25222)) ( 25225 25761 (XCCS-UTF8-AFTER-OPEN 25235 . 25759)) (26831 27180 (XTOUCODE 26841 . 27009) (UTOXCODE 27011 . 27178)) (27220 43402 (READ-UNICODE-MAPPING-FILENAMES 27230 . 28392) (READ-UNICODE-MAPPING 28394 . 31691) (WRITE-UNICODE-MAPPING 31693 . 35910) (WRITE-UNICODE-INCLUDED 35912 . 40634) ( WRITE-UNICODE-MAPPING-HEADER 40636 . 41868) (WRITE-UNICODE-MAPPING-FILENAME 41870 . 43400)) (46748 55117 (MAKE-UNICODE-TRANSLATION-TABLES 46758 . 55115)) (55532 63436 (HEXSTRING 55542 . 56703) ( UTF8HEXSTRING 56705 . 58910) (NUTF8CODEBYTES 58912 . 59575) (NUTF8STRINGBYTES 59577 . 60058) ( XTOUSTRING 60060 . 63071) (XCCSSTRING 63073 . 63434)) (63437 64906 (SHOWCHARS 63447 . 64904))))) STOP \ No newline at end of file diff --git a/library/UNIXCOMM.~1~ b/library/UNIXCOMM.~1~ deleted file mode 100644 index 58539748..00000000 --- a/library/UNIXCOMM.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "24-Sep-90 11:29:31" |{PELE:MV:ENVOS}LIBRARY>UNIXCOMM.;4| 14727 changes to%: (FNS UNIX-WRITE) previous date%: " 4-Jul-90 02:13:51" |{PELE:MV:ENVOS}LIBRARY>UNIXCOMM.;3|) (* ; " Copyright (c) 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNIXCOMMCOMS) (RPAQQ UNIXCOMMCOMS [ (* ;; "streams to UNIX processes & pseudo terminals") (* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices") (COMS (* ; "Forking stuff") (FNS FORK-SHELL FORK-UNIX UNIX-KILL UNIX-WRITE CREATE-SHELL-STREAM CREATE-PROCESS-STREAM UNIXCOMM-AROUNDEXITFN)) [COMS (* ; "Operations on the shell device") (FNS INITIALIZE-NEW-SHELL-DEVICE UNIX-GET-NEXT-BUFFER UNIX-BACKFILEPTR-NEW UNIX-STREAM-EOFP-NEW UNIX-STREAM-OUT UNIX-STREAM-CLOSE) (GLOBALVARS *NEW-SHELL-DEVICE*) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-NEW-SHELL-DEVICE)) (ADDVARS (AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN] (COMS (* ;  "Stuff for direct manipulation of Unix sockets") (FNS CREATE-UNIX-SOCKET-STREAM ACCEPT-UNIX-SOCKET-STREAM)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-CHANNEL) (P (CHECKIMPORTS '(FILEIO LLSUBRS) T))) (COMS (* ;; "Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device") (FNS UNIX-BACKFILEPTR UNIX-READ INITIALIZE-SHELL-DEVICE UNIX-STREAM-IN UNIX-STREAM-EOFP UNIX-STREAM-PEEK) (GLOBALVARS *SHELL-DEVICE*) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-PEEKEDCHAR UNIX-LASTCHAR)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-SHELL-DEVICE]) (* ;; "streams to UNIX processes & pseudo terminals") (* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices") (* ; "Forking stuff") (DEFINEQ (FORK-SHELL (LAMBDA (TERMTYPE COMMAND) (* ; "Edited 14-Feb-90 14:27 by bvm") (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ; "Yes, lde supports this new version") (SUBRCALL UNIX-HANDLECOMM 11 (if (NULL TERMTYPE) then "" elseif (TYPEP TERMTYPE (QUOTE ONED-ARRAY)) then TERMTYPE else (\DTEST (LISP-TO-UNIX-TERMTYPE TERMTYPE) (QUOTE ONED-ARRAY))) (if (NULL COMMAND) then "" else (\DTEST COMMAND (QUOTE ONED-ARRAY)))) elseif COMMAND then (* ; "have to use a different old call") (FORK-UNIX COMMAND) else (SUBRCALL UNIX-HANDLECOMM 4))) ) (FORK-UNIX (LAMBDA (STR) (* ; "Edited 25-May-88 15:47 by drc:") (SUBRCALL UNIX-HANDLECOMM 0 (\DTEST STR (QUOTE ONED-ARRAY)))) ) (UNIX-KILL (LAMBDA (CONN) (* ; "Edited 25-May-88 16:04 by drc:") (if CONN then (SUBRCALL UNIX-HANDLECOMM 3 CONN 0))) ) (UNIX-WRITE [LAMBDA (CONN VAL) (* ; "Edited 24-Sep-90 11:27 by jds") (* ;; "Write a byte (VAL) to the outgoing pipe connection CONN. If the write fails for non-fatal reasons (i.e., would block), loop unitl it succeeds. If the write returns NIL (meaning total failure), pass that along to the caller.") (PROG (LENGTH-WRITTEN) WRITE-LOOP [SETQ LENGTH-WRITTEN (SUBRCALL UNIX-HANDLECOMM 1 (\DTEST CONN 'SMALLP) (\DTEST VAL 'SMALLP] (COND ((AND LENGTH-WRITTEN (IEQP 0 LENGTH-WRITTEN)) (BLOCK) (GO WRITE-LOOP))) (RETURN LENGTH-WRITTEN]) (CREATE-SHELL-STREAM (LAMBDA (TERMTYPE COMMAND) (* ; "Edited 21-May-90 15:39 by jrb:") (LET ((CHAN (FORK-SHELL TERMTYPE COMMAND)) (SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ; "SUBRCALL tests that this is supported") *NEW-SHELL-DEVICE* else *SHELL-DEVICE*))) (COND (CHAN (LET ((STR (create STREAM ACCESS _ (QUOTE BOTH) DEVICE _ SHELL-DEV))) (CL:SETF (UNIX-CHANNEL STR) CHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) STR) (STREAMPROP STR (QUOTE SENDSCREENPARAMS) (FUNCTION UNIX.SENDSCREENPARAMS)) (STREAMPROP STR (QUOTE SETDISPLAYTYPE) (FUNCTION UNIX.SETDISPLAYTYPE)) STR))))) ) (CREATE-PROCESS-STREAM (LAMBDA (COMM) (* ; "Edited 21-May-90 15:39 by jrb:") (LET* ((SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ; "SUBRCALL tests that this is supported") *NEW-SHELL-DEVICE* else *SHELL-DEVICE*)) (STR (create STREAM ACCESS _ (QUOTE BOTH) DEVICE _ SHELL-DEV EOLCONVENTION _ LF.EOLC)) (CHAN (FORK-UNIX COMM))) (if CHAN then (CL:SETF (UNIX-CHANNEL STR) CHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) STR) STR else NIL))) ) (UNIXCOMM-AROUNDEXITFN (LAMBDA (EVENT) (* ; "Edited 2-Jul-90 16:35 by jrb:") (CASE EVENT ((AFTERLOGOUT AFTERMAKESYS AFTERSAVEVM AFTERSYSOUT) (for STREAM in (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) do (CLOSEF STREAM))) ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT) (* ;; "Make sure any Unix sockets get closed here, so their file system handles get closed as well") (for STREAM in (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) when (EQ -3 (SUBRCALL UNIX-HANDLECOMM 14 (UNIX-CHANNEL STREAM))) do (CLOSEF STREAM))))) ) ) (* ; "Operations on the shell device") (DEFINEQ (INITIALIZE-NEW-SHELL-DEVICE (LAMBDA NIL (* ; "Edited 12-Feb-90 17:00 by bvm") (SETQ *NEW-SHELL-DEVICE* (create FDEV FDBINABLE _ T NODIRECTORIES _ T DEVICENAME _ (FUNCTION UNIX-PTY-NEW) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION UNIX-STREAM-OUT) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) CLOSEFILE _ (FUNCTION UNIX-STREAM-CLOSE) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) EOFP _ (FUNCTION UNIX-STREAM-EOFP-NEW) BACKFILEPTR _ (FUNCTION UNIX-BACKFILEPTR-NEW) GETNEXTBUFFER _ (FUNCTION UNIX-GET-NEXT-BUFFER) BLOCKIN _ (FUNCTION \BUFFERED.BINS)))) ) (UNIX-GET-NEXT-BUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* ; "Edited 13-Jun-90 01:07 by mitani") (CASE WHATFOR (READ [PROG ([BUF (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM] (CONN (UNIX-CHANNEL STREAM)) LEN) RETRY (BLOCK) (* ;  "Just so other procs get to run when someone is pounding output at Chat") (if [AND CONN (SETQ LEN (SUBRCALL UNIX-HANDLECOMM 9 (\DTEST CONN 'SMALLP) (OR BUF (replace (STREAM CBUFPTR) of STREAM with (SETQ BUF (NCREATE 'VMEMPAGEP] then (if (EQ LEN T) then (* ;  " no input available, but still alive") (if NOERRORFLG then (RETURN NIL) else (* ;  "Called from BIN--wait and try again") (GO RETRY)) else (UNINTERRUPTABLY (replace (STREAM COFFSET) of STREAM with 0) (replace (STREAM CBUFSIZE) of STREAM with LEN)) (RETURN T)) else (RETURN (AND (NOT NOERRORFLG) (\EOF.ACTION STREAM]) (T (SHOULDNT)))]) (UNIX-BACKFILEPTR-NEW [LAMBDA (STREAM) (* ; "Edited 13-Jun-90 01:07 by mitani") (COND ((AND (fetch (STREAM CBUFPTR) of STREAM) (> (fetch (STREAM COFFSET) of STREAM) 0)) (add (fetch (STREAM COFFSET) of STREAM) -1)) (T (ERROR "Can't back up this unix Stream" STREAM]) (UNIX-STREAM-EOFP-NEW [LAMBDA (STREAM) (* ; "Edited 13-Jun-90 01:07 by mitani") (* ;;; "true if bsp STREAM is at end of file, i.e. is at a mark") (COND ((AND (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM)) (< (ffetch (STREAM COFFSET) of STREAM) (ffetch (STREAM CBUFSIZE) of STREAM))) NIL) (T (NOT (UNIX-GET-NEXT-BUFFER STREAM 'READ T]) (UNIX-STREAM-OUT (LAMBDA (STREAM CHAR) (* ; "Edited 12-Jun-90 12:58 by jrb:") (OR (UNIX-WRITE (UNIX-CHANNEL STREAM) (\DTEST CHAR (QUOTE SMALLP))) (CL:ERROR (QUOTE XCL:STREAM-NOT-OPEN) STREAM))) ) (UNIX-STREAM-CLOSE (LAMBDA (STREAM) (* ; "Edited 12-Aug-88 13:24 by drc:") (PROG1 (UNIX-KILL (UNIX-CHANNEL STREAM)) (CL:SETF (UNIX-CHANNEL STREAM) NIL) (CL:SETF (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) (REMOVE STREAM (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*))))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *NEW-SHELL-DEVICE*) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITIALIZE-NEW-SHELL-DEVICE) (ADDTOVAR AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN) ) (* ; "Stuff for direct manipulation of Unix sockets") (DEFINEQ (CREATE-UNIX-SOCKET-STREAM (LAMBDA (PATHNAME) (* ; "Edited 29-May-90 16:23 by jrb:") (LET ((STR (create STREAM ACCESS _ (QUOTE BOTH) DEVICE _ *NEW-SHELL-DEVICE* EOLCONVENTION _ LF.EOLC)) (CHAN (SUBRCALL UNIX-HANDLECOMM 12 (\DTEST PATHNAME (QUOTE ONED-ARRAY))))) (if CHAN then (CL:SETF (UNIX-CHANNEL STR) CHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) STR) STR else NIL))) ) (ACCEPT-UNIX-SOCKET-STREAM (LAMBDA (SOCKSTREAM) (* ; "Edited 29-May-90 16:31 by jrb:") (LET ((CHAN (UNIX-CHANNEL SOCKSTREAM)) NEWCHAN) (SELECTQ (SETQ NEWCHAN (SUBRCALL UNIX-HANDLECOMM 13 CHAN)) ((-1 NIL) NEWCHAN) (LET ((NEWSTREAM (create STREAM ACCESS _ (QUOTE BOTH) DEVICE _ *NEW-SHELL-DEVICE* EOLCONVENTION _ LF.EOLC))) (CL:SETF (UNIX-CHANNEL NEWSTREAM) NEWCHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) NEWSTREAM) NEWSTREAM)))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNIX-CHANNEL MACRO ((STR) (fetch (STREAM F1) of STR))) ) (CHECKIMPORTS '(FILEIO LLSUBRS) T) ) (* ;; "Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device" ) (DEFINEQ (UNIX-BACKFILEPTR (LAMBDA (STREAM) (* ; "Edited 14-Dec-88 09:52 by bane") (* ;; "The trick here is to use the existing mechanisms for UNIX-PEEKCHAR") (COND ((UNIX-PEEKEDCHAR STREAM) (ERROR "Can only back up one character" STREAM)) ((NOT (UNIX-LASTCHAR STREAM)) (ERROR "Can't back up past beginning of stream" STREAM)) (T (CL:SETF (UNIX-PEEKEDCHAR STREAM) (UNIX-LASTCHAR STREAM))))) ) (UNIX-READ (LAMBDA (STREAM NO-ERROR) (* ; "Edited 14-Dec-88 09:18 by bane") (LET* ((CONN (UNIX-CHANNEL STREAM)) (CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN (QUOTE SMALLP)) 0)))) (COND ((EQ CH T) NIL) ((EQ CH NIL) (COND (NO-ERROR NIL) (T (\EOF.ACTION STREAM)))) (T (CL:SETF (UNIX-LASTCHAR STREAM) CH))))) ) (INITIALIZE-SHELL-DEVICE (LAMBDA NIL (* ; "Edited 14-Dec-88 10:45 by bane") (SETQ *SHELL-DEVICE* (create FDEV NODIRECTORIES _ T DEVICENAME _ (QUOTE UNIX-PTY) BIN _ (QUOTE UNIX-STREAM-IN) BOUT _ (QUOTE UNIX-STREAM-OUT) PEEKBIN _ (QUOTE UNIX-STREAM-PEEK) CLOSEFILE _ (QUOTE UNIX-STREAM-CLOSE) GETFILEINFO _ (QUOTE NILL) SETFILEINFO _ (QUOTE NILL) EOFP _ (QUOTE UNIX-STREAM-EOFP) BACKFILEPTR _ (QUOTE UNIX-BACKFILEPTR)))) ) (UNIX-STREAM-IN (LAMBDA (STREAM) (* ; "Edited 9-May-88 15:05 by ") (LET (CH) (if (SETQ CH (UNIX-PEEKEDCHAR STREAM)) then (CL:SETF (UNIX-PEEKEDCHAR STREAM) NIL) else (while (NOT (SETQ CH (UNIX-READ STREAM))) do (BLOCK))) CH)) ) (UNIX-STREAM-EOFP [LAMBDA (STREAM) (* ; "Edited 2-Apr-90 11:51 by jds") (* ;; "EOFP method for unix-shell streams. Notices when there are chars yet to read and doesn't set EOFP.") (AND (NOT (UNIX-PEEKEDCHAR STREAM)) (LET* [(CONN (UNIX-CHANNEL STREAM)) (CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP) 0] (COND ((EQ CH T) NIL) ((EQ CH NIL) T) (T (CL:SETF (UNIX-PEEKEDCHAR STREAM) CH) (CL:SETF (UNIX-LASTCHAR STREAM) CH) NIL]) (UNIX-STREAM-PEEK (LAMBDA (STREAM NO-ERROR) (* ; "Edited 24-Jun-88 15:07 by drc:") (OR (UNIX-PEEKEDCHAR STREAM) (CL:SETF (UNIX-PEEKEDCHAR STREAM) (UNIX-READ STREAM NO-ERROR)))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *SHELL-DEVICE*) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNIX-PEEKEDCHAR MACRO ((STR) (FETCH (STREAM F2) OF STR))) (PUTPROPS UNIX-LASTCHAR MACRO ((STR) (FETCH (STREAM F3) OF STR))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITIALIZE-SHELL-DEVICE) ) (PUTPROPS UNIXCOMM COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2397 5868 (FORK-SHELL 2407 . 2938) (FORK-UNIX 2940 . 3071) (UNIX-KILL 3073 . 3195) ( UNIX-WRITE 3197 . 3908) (CREATE-SHELL-STREAM 3910 . 4697) (CREATE-PROCESS-STREAM 4699 . 5344) ( UNIXCOMM-AROUNDEXITFN 5346 . 5866)) (5916 10010 (INITIALIZE-NEW-SHELL-DEVICE 5926 . 6494) ( UNIX-GET-NEXT-BUFFER 6496 . 8631) (UNIX-BACKFILEPTR-NEW 8633 . 9047) (UNIX-STREAM-EOFP-NEW 9049 . 9530 ) (UNIX-STREAM-OUT 9532 . 9731) (UNIX-STREAM-CLOSE 9733 . 10008)) (10266 11489 ( CREATE-UNIX-SOCKET-STREAM 10276 . 10851) (ACCEPT-UNIX-SOCKET-STREAM 10853 . 11487)) (11846 14186 ( UNIX-BACKFILEPTR 11856 . 12243) (UNIX-READ 12245 . 12565) (INITIALIZE-SHELL-DEVICE 12567 . 12991) ( UNIX-STREAM-IN 12993 . 13224) (UNIX-STREAM-EOFP 13226 . 14000) (UNIX-STREAM-PEEK 14002 . 14184))))) STOP \ No newline at end of file diff --git a/library/UNIXPRINT.~1~ b/library/UNIXPRINT.~1~ deleted file mode 100644 index d66d53fb..00000000 --- a/library/UNIXPRINT.~1~ +++ /dev/null @@ -1,250 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "20-May-92 14:38:56" {DSK}nilsson>UNIXPRINT.;2 10799 - - changes to%: (VARS UNIXPRINTCOMS) - (FNS UnixPrint UnixPrintCommand) - - previous date%: "20-May-92 14:27:57" {DSK}nilsson>UNIXPRINT.;1) - - -(* ; " -Copyright (c) 1990, 1991, 1992 by Venue. All rights reserved. -") - -(PRETTYCOMPRINT UNIXPRINTCOMS) - -(RPAQQ UNIXPRINTCOMS [(FNS InstallUnixPrinter UnixPrint UnixShellQuote UnixTempFile - UnixPrintCommand) - (FUNCTIONS ShellCommand) - (INITVARS (UnixPrinterName NIL)) - (P (InstallUnixPrinter) - (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 14-Feb-91 15:45 by gadener") - - (* ;; "Set up any printers in PrinterTypes (or just Postscript by default) so that they'll be printed using the unix LPR command.") - - (DECLARE (GLOBAL 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 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)) - (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"] - (CL:MULTIPLE-VALUE-BIND (tmpstream tmpname) - (UnixTempFile NIL NIL) - (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 "")) - "...") - (COPYCHARS in out))) - - (* ;; "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 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 (OPENSTREAM file 'OUTPUT] - unix]) - -(UnixPrintCommand - [LAMBDA (PRINTER COPIES NAME TMPNAME) (* ; "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") - - (CONCAT "/usr/ucb/lpr " (COND - (PRINTER (CONCAT "-P" (UnixShellQuote PRINTER) - " ")) - (T "")) - (COND - ((AND (FIXP COPIES) - (NEQ COPIES 1)) - (CONCAT "-#" COPIES " ")) - (T "")) - " -J" - (UnixShellQuote NAME) - " -r -s " 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) - -(InstallUnixPrinter) - -(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 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") - - (CONCAT "/usr/ucb/lpr " (COND - (PRINTER (CONCAT "-P" (UnixShellQuote PRINTER) - " ")) - (T "")) - (COND - ((AND (FIXP COPIES) - (NEQ COPIES 1)) - (CONCAT "-#" COPIES " ")) - (T "")) - " -J" - (UnixShellQuote NAME) - " -r -s " 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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1517 8477 (InstallUnixPrinter 1527 . 2132) (UnixPrint 2134 . 4556) (UnixShellQuote 4558 - . 6112) (UnixTempFile 6114 . 7123) (UnixPrintCommand 7125 . 8475)) (9064 10426 (UnixPrintCommand 9074 - . 10424))))) -STOP diff --git a/library/VIRTUALKEYBOARDS.~2~ b/library/VIRTUALKEYBOARDS.~2~ deleted file mode 100644 index cc18a746..00000000 --- a/library/VIRTUALKEYBOARDS.~2~ +++ /dev/null @@ -1,1489 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL" BASE 10) (FILECREATED "14-Jun-2017 14:22:33"  |{DSK}Personal>local>medley3.5>library>VIRTUALKEYBOARDS.;2| 143787 |changes| |to:| (FNS VKBD.INIT) |previous| |date:| "13-Dec-96 17:40:51" |{DSK}Personal>local>medley3.5>library>VIRTUALKEYBOARDS.;1|) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993, 1995, 1996, 2017 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT VIRTUALKEYBOARDSCOMS) (RPAQQ VIRTUALKEYBOARDSCOMS ((FNS FINDVIRTUALKEYBOARD PROCESS.KEYBOARD VKBD.CREATE-KEYACTION-TABLE VKBD.WINDOWMENUFN VKBD.WINDOWMENUINIT) (COMS (FNS LOADKEYBOARDDISPLAYFONTS) (INITVARS VKBD.CACHEDCHARSETS) (GLOBALVARS VKBD.CACHEDCHARSETS)) (FNS DEFINEKEYBOARD) (FNS VKBD.ADD-ITEM-TO-BACKGROUND-MENU VKBD.INIT VKBD.CREATE-DEFAULT-KEYBOARD VKBD.ADD-DEFAULT-KEYBOARD) (FNS VKBD.LOAD-FILE-COMMAND VKBD.LOAD-KEYBOARD-FILE VKBD.STORE-FILE-COMMAND VKBD.STORE-KEYBOARD-FILE) (FNS SWITCHKEYBOARDS VKBD.POP-MENU-AND-SWITCH-KEYBOARDS VKBD.POP-UP-KEYBOARDS-MENU VKBD.GET-CONFIGURATION VKBD.SUBCONFIGURATION) (FNS VKBD.BUTTONEVENTFN VKBD.CENTER-BITMAP-IN-REGION VKBD.CLEAR-KEY-DISPLAY VKBD.CREATE-KEYBOARD-BITMAP VKBD.CREATE-KEYBOARD-DISPLAY VKBD.CURSORMOVEDFN VKBD.DISPLAY-CHARACTER VKBD.DISPLAY-EMPTY-KEY-CAP VKBD.DISPLAY-KEY VKBD.DISPLAY-KEY-CHARACTERS VKBD.DRAW-KEY-CAPS VKBD.ERASE-FRAME VKBD.EXTEND-REGION VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION VKBD.GET-KEY-REGIONS VKBD.INVERT-KEY VKBD.INVERT-REGION VKBD.KEYBOARD-WINDOW-REPAINTFN VKBD.LOWER-HALF-REGION VKBD.POSITION-IS-IN-KEY-REGION VKBD.REMOVE-KEYBOARD-COMMAND VKBD.UNION-REGIONS VKBD.UPPER-HALF-REGION) (FNS VKBD.KEY-ASSOC VKBD.CHAR-ASSIGNMENTP VKBD.COMPLETE-KEYBOARD VKBD.CTRL-ASSIGNMENTP VKBD.EVENT-ASSIGNMENTP VKBD.META-ASSIGNMENTP VKBD.FRAME-KEY VKBD.GET-CURRENT-KEY-ASSIGNMENT VKBD.GET-NON-CHAR-LABEL VKBD.ICONFN VKBD.INVERT-LOCK-KEYS VKBD.INVERT-SHIFT-KEYS VKBD.TRANSLATE-KEY-ID VKBD.KEY-ID-TO-KEY-NAMES VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD VKBD.LOCK-ASSIGNMENTP VKBD.LOCK-KEYP VKBD.LOCK/NOLOCK VKBD.LOCKDOWN-ASSIGNMENTP VKBD.LOCKUP-ASSIGNMENTP VKBD.PARSE-CHAR-CODE VKBD.PARSE-KEY-ASSIGNMENT VKBD.RESET-KEYBOARD-WINDOW VKBD.SEND-CHARACTER VKBD.SHIFT-ASSIGNMENTP VKBD.SHIFTED-CHAR VKBD.UNDEFINE-KEYBOARD VKBD.UNSHIFTED-CHAR) (ALISTS (CHARACTERNAMES BREAK HOME PGUP END PGDN INS HELP SCRL NUMLK CLEAR DOIT CENTER NOTCENTER BOLD NOTBOLD ITALIC NOTITALIC UCASE LCASE STRIKEOUT NOTSTRIKEOUT UNDERLINE NOTUNDERLINE SUBSCRIPT SUPERSCRIPT SMALLER LARGER MARGINS NOTMARGINS LOOKS NOTLOOKS F11 NOTF11 F12 NOTF12)) (RECORDS KEYBOARDCONFIGURATION VIRTUALKEYBOARD) (INITVARS (VKBD.KNOWN-KEYBOARDS NIL)) (FILES (SOURCE) KEYBOARDCONFIGS) (VARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.WINDOW-MENU-SUBITEMS) (BITMAPS VKBD.ICON VKBD.MASK) (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) (COMS (DECLARE\: FIRST (P (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN))) (INITVARS (\\ORIGINALDEFAULTKEYACTION)) (FNS VKBD.\\KEYBOARDEVENTFN VKBD.RESETKEYACTIONTABLES) (P (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN))) (COMS (DECLARE\: FIRST (P (MOVD? 'KEYACTION 'OLDKEYACTION))) (FNS NEWKEYACTION) (P (MOVD 'NEWKEYACTION 'KEYACTION)) (INITVARS (MODEKEYS)) (VARS MODEACTIONS) (GLOBALVARS MODEKEYS MODEACTIONS)) (COMS (FNS METASHIFT) (* \;  "Call new definition if the old one had been called") (P (AND (EQ (MACHINETYPE) 'DORADO) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)))) (ADDVARS (BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT))) (FNS FIXKEYBOARD FIXKEYBOARDCONFIG FIXKEYASSIGNMENTS) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (VKBD.INIT))) (FILES ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA METASHIFT))))) (DEFINEQ (FINDVIRTUALKEYBOARD - (LAMBDA (KEYBOARDNAME CONFIGURATIONNAME) (* \; "Edited 27-Feb-96 10:27 by rmk") - (LET ((KBTYPE (COND - (CONFIGURATIONNAME) - ((LISTP KEYBOARDNAME) - (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) OF KEYBOARDNAME)) - ((KEYBOARDTYPE)) - (T DEFAULTVIRTUALKEYBOARDTYPE)))) - (CL:WHEN (AND (LISTP KEYBOARDNAME) - (MEMB KEYBOARDNAME VKBD.KNOWN-KEYBOARDS)) - - (* |;;| "Gave a keyboard, use it to indicate keyboard name for new configuration") - - (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARDNAME))) - - (* |;;| "Find keyboard of default type if current type doesn't exist and CONFIGURATIONNAME wasn't given--PROCESS.KEYBOARD won't switch this in. Note that a keyboard that has a NIL configuration is declared to go with anything,but we look for an explicit match first") - - (IF (FIND KB IN VKBD.KNOWN-KEYBOARDS - SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - (EQ KBTYPE (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF KB)))) - ELSEIF (FIND KB IN VKBD.KNOWN-KEYBOARDS - SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - (NULL (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF KB)))) - ELSEIF (OR (NOT CONFIGURATIONNAME) - (EQ CONFIGURATIONNAME KBTYPE)) - THEN (OR (FOR C IN (CDR (ASSOC KBTYPE KEYBOARDCONFIGCOERCIONS)) - WHEN (SETQ C (FINDVIRTUALKEYBOARD KEYBOARDNAME C)) - DO (RETURN C)) - (AND DEFAULTVIRTUALKEYBOARDTYPE (NEQ DEFAULTVIRTUALKEYBOARDTYPE KBTYPE) - (FOR KB IN VKBD.KNOWN-KEYBOARDS - WHEN (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD - KEYBOARDNAME) - OF KB)) - (EQ DEFAULTVIRTUALKEYBOARDTYPE (FETCH - (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF KB))) - DO (RETURN KB)))))))) (PROCESS.KEYBOARD (LAMBDA (PROCESS/WINDOW KEYBOARD) (* \; "Edited 23-May-95 17:00 by rmk:") (* |;;;| "Get/set the keyboard just for this process/window. Value is previous keyboard.") (PROG (KEYACTIONTABLE FOUND (PROCESS (COND ((NULL PROCESS/WINDOW) (TTY.PROCESS)) ((PROCESSP PROCESS/WINDOW) PROCESS/WINDOW) ((AND (WINDOWP PROCESS/WINDOW) (WINDOWPROP PROCESS/WINDOW 'PROCESS))) (T (THIS.PROCESS))))) (COND ((SETQ KEYACTIONTABLE (IF (AND KEYBOARD (SETQ FOUND (FINDVIRTUALKEYBOARD KEYBOARD))) THEN (* |;;| "We believe in whatever FINDVIRTUALKEYBOARD returns, even though it might not have the configuration we expect.") (* \;  "Get/create the KEYACTIONTABLE for the FOUND") (VKBD.CREATE-KEYACTION-TABLE FOUND))) (* \;  "Make sure to copy the current interrupt list.") (REPLACE (KEYACTION INTERRUPTLIST) OF KEYACTIONTABLE WITH (COPY (FETCH (KEYACTION INTERRUPTLIST) OF (OR (PROCESSPROP PROCESS 'KEYACTION) \\DEFAULTKEYACTION)))) (PROCESSPROP PROCESS 'KEYACTION KEYACTIONTABLE) (COND ((TTY.PROCESSP PROCESS) (* \; "install the key action table") (* \;  "Hack--wait until dangerous shifts are up") (|while| (OR (SHIFTDOWNP 'META) (SHIFTDOWNP 'CTRL))) (SETQ \\CURRENTKEYACTION (OR KEYACTIONTABLE (KEYACTIONTABLE))))) (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD KEYBOARD) 'DEFAULT))) (T (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD) 'DEFAULT))))))) (VKBD.CREATE-KEYACTION-TABLE - (LAMBDA (NEW-KEYBOARD OLDTABLE) (* \; "Edited 29-Feb-96 12:32 by rmk") - (PROG (KEYBOARDNAME FOUND KEYACTION-TABLE CONFIG) - (CL:UNLESS (COND - ((AND (ATOM NEW-KEYBOARD) - (SETQ FOUND (FINDVIRTUALKEYBOARD NEW-KEYBOARD))) - (SETQ NEW-KEYBOARD FOUND)) - ((MEMB NEW-KEYBOARD VKBD.KNOWN-KEYBOARDS))) - - (* |;;| "Use FOUND to preserve NEW-KEYBOARD for error") - - (ERROR "INVALID KEYBOARD" NEW-KEYBOARD)) - (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF NEW-KEYBOARD)) - (COND - (OLDTABLE (SETQ KEYACTION-TABLE (RESETKEYACTION OLDTABLE))) - ((SETQ KEYACTION-TABLE (GETPROP KEYBOARDNAME 'KEYACTIONTABLE)) - (RETURN KEYACTION-TABLE)) - (T (SETQ KEYACTION-TABLE (KEYACTIONTABLE)))) - (SETQ NEW-KEYBOARD (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD)) - (SETQ CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF NEW-KEYBOARD))) - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF NEW-KEYBOARD) DO (OLDKEYACTION (CAR - KEY-ASSIGNMENT - ) - (CDR KEY-ASSIGNMENT) - KEYACTION-TABLE)) - (PUTPROP KEYBOARDNAME 'KEYACTIONTABLE KEYACTION-TABLE) - (RETURN KEYACTION-TABLE)))) (vkbd.windowmenufn - (lambda (w) (* \; "Edited 15-Dec-87 16:27 by Snow") - - (let (keyboard) - (setq keyboard (vkbd.pop-up-keyboards-menu)) - (and keyboard (process.keyboard w keyboard))))) (vkbd.windowmenuinit - (lambda nil (* \; "Edited 15-Dec-87 16:28 by Snow") - - (setq |WindowMenuCommands| (remove (sassoc '|Keyboard| |WindowMenuCommands|) - |WindowMenuCommands|)) - (nconc1 |WindowMenuCommands| `(|Keyboard| (function (lambda (w) - (switchkeyboards t nil w))) - "Changes the keyboard associated with this window." - ,vkbd.window-menu-subitems)) - (setq |WindowMenu| nil))) ) (DEFINEQ (LOADKEYBOARDDISPLAYFONTS (LAMBDA (FONT) (* \; "Edited 13-Dec-96 17:40 by rmk:") (* \; "Edited 7-Mar-96 12:30 by rmk") (* |;;| "Insures that all the characters on virtual keycaps have been instantiated in FONT (or at least on the keycaps). Saves the needed charsets in VKBD.CACHEDCHARSETS. This means that we don't have to parse all the keyboards every time. In order to make use of the cache, we instantiate all the charsets in all the fonts that are specified in any of the keyboards or configurations.") (DECLARE (GLOBALVARS VKBD.CACHEDCHARSETS)) (CL:UNLESS VKBD.CACHEDCHARSETS (FOR K IN VKBD.KNOWN-KEYBOARDS DO (* |;;| "Ignore errorful transitions in this background function, fail when the user actually asks for the keyboard. Accumulate 0th character in each charset (presumably very few), saving them in the cache.") (FOR A TRANS CHARSETS IN (FETCH KEYASSIGNMENTS OF K) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A NIL T))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (FOR CONFIG COMMON IN VKBD.CONFIGURATIONS DO (* |;;| "We aren't letting the configs assignment override the VKBD.COMMONDEFAULTASSIGNMENT on the same key. Thus, in principle we could be instantiating a font that isn't actually needed, but this is unlikely, harmless, and not worth the bother to keep track. VKBD.COMPLETE-KEYBOARD does it right.") (FOR A TRANS IN (APPEND (FETCH DEFAULTASSIGNMENT OF CONFIG) VKBD.COMMONDEFAULTASSIGNMENT) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A CONFIG))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (SETQ VKBD.CACHEDCHARSETS (DREMOVE 0 VKBD.CACHEDCHARSETS))) (IF FONT THEN (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY)) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C FONT)) ELSE (LET (DONEFONTS) (FOR K F IN VKBD.KNOWN-KEYBOARDS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (VIRTUALKEYBOARD KEYBOARDDISPLAYFONT ) OF K) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))) (FOR CONFIG F IN VKBD.CONFIGURATIONS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) OF CONFIG) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))))))) ) (RPAQ? VKBD.CACHEDCHARSETS NIL) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.CACHEDCHARSETS) ) (DEFINEQ (DEFINEKEYBOARD - (LAMBDA (KEYBOARD-OBJECT) (* \; "Edited 28-Feb-96 11:41 by rmk") - (* \; "Edited 15-Dec-87 16:29 by Snow") - - (* |;;| - "Checks assignments before it installs, returns a copy unless the object is already known.") - - (FOR KEY-ASSIGNMENT (CONFIGURATION _ (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF - KEYBOARD-OBJECT - ))) - IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD-OBJECT) - DO (VKBD.PARSE-KEY-ASSIGNMENT KEY-ASSIGNMENT CONFIGURATION)) - (OR (FINDVIRTUALKEYBOARD KEYBOARD-OBJECT) - (CAR (PUSH VKBD.KNOWN-KEYBOARDS (COPY KEYBOARD-OBJECT)))))) ) (DEFINEQ (vkbd.add-item-to-background-menu - (lambda (label command message subitemlist) (* \; "Edited 15-Dec-87 16:29 by Snow") - - (setq |BackgroundMenuCommands| (remove (sassoc label |BackgroundMenuCommands|) - |BackgroundMenuCommands|)) - (nconc1 |BackgroundMenuCommands| (list label command message subitemlist)) - (setq |BackgroundMenu| nil))) (VKBD.INIT (LAMBDA NIL (* \; "Edited 14-Jun-2017 14:22 by kaplan") (* \; "Edited 16-Jun-92 11:14 by kaplan") (* |;;| "Reads virtual keyboard file for current type (or default type), if it can be found. Keyboards that don't match current keyboard can be displayed but not installed (via PROCESS.KEYBOARD)") (CL:UNLESS \\ORIGINALDEFAULTKEYACTION (SETQ \\ORIGINALDEFAULTKEYACTION (KEYACTIONTABLE \\DEFAULTKEYACTION))) (SETQ VKBD.COMMONCODELABELS (FOR X IN VKBD.COMMONCHARLABELS COLLECT (IF (LISTP X) THEN (IF (SMALLP (CAR X)) THEN X ELSE (LIST (CHARCODE.DECODE (CAR X)) (CADR X))) ELSE (LIST (CHARCODE.DECODE X) X)))) (VKBD.ADD-ITEM-TO-BACKGROUND-MENU "Keyboard" ''(SWITCHKEYBOARDS T NIL) "Displays a menu for switching keyboards" VKBD.BACKGROUND-MENU-SUBITEMS) (VKBD.WINDOWMENUINIT) (LET (FILE (KT (KEYBOARDTYPE))) (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION KT)) (COND ((SETQ FILE (COND ((AND KT (FINDFILE (PACK* KT "KEYBOARDS") T))) (T (FINDFILE (PACK* DEFAULTVIRTUALKEYBOARDTYPE "KEYBOARDS") T)))) (VKBD.LOAD-KEYBOARD-FILE FILE) (* |;;| "Loading a keyboard file may change our notion of KEYBOARDTYPE, because of new coercion paths. The default keyboard will be added for the new type") (VKBD.ADD-DEFAULT-KEYBOARD)) (T (* |;;| "Special printing here to avoid file-not-found error in case where user calls VKBD.LOAD-KEYBOARD-FILE directly") (PROMPTPRINT "Note: virtual keyboard file for type " (OR (KEYBOARDTYPE) DEFAULTVIRTUALKEYBOARDTYPE) " keyboards not found")))))) (VKBD.CREATE-DEFAULT-KEYBOARD - (LAMBDA (CONFIGURATION) (* \; "Edited 27-Feb-96 20:51 by rmk") - - (* |;;| "Don't bother copying in the default keyassignments, since they will always be inserted by VKBD.COMPLETE-KEYBOARD") - - (CL:WHEN (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) - (CREATE VIRTUALKEYBOARD - KEYBOARDNAME _ 'DEFAULT - KEYBOARDCONFIGURATION _ (FETCH (KEYBOARDCONFIGURATION CONFIGURATIONNAME) - OF CONFIGURATION))))) (VKBD.ADD-DEFAULT-KEYBOARD (LAMBDA (KEYBOARDTYPE) (* \; "Edited 23-May-95 17:04 by rmk:") (* |;;;| "It is useful practice to be able to switch back to the original key assignments. Thus the program is adding one special keyboard with the name DEFAULT which is the current keyboardtype's default keyboard.") (SETQ KEYBOARDTYPE (OR KEYBOARDTYPE (KEYBOARDTYPE))) (BIND DEFAULT WHILE (SETQ DEFAULT (FINDVIRTUALKEYBOARD 'DEFAULT KEYBOARDTYPE)) DO (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE DEFAULT VKBD.KNOWN-KEYBOARDS))) (SETQ VKBD.KNOWN-KEYBOARDS (CONS (VKBD.CREATE-DEFAULT-KEYBOARD KEYBOARDTYPE) VKBD.KNOWN-KEYBOARDS)) (COND ((EQ KEYBOARDTYPE (KEYBOARDTYPE)) (VKBD.CREATE-KEYACTION-TABLE 'DEFAULT \\DEFAULTKEYACTION))))) ) (DEFINEQ (VKBD.LOAD-FILE-COMMAND - (LAMBDA (REDEFINE? DELETE-FIRST?) (* \; "Edited 3-Mar-96 18:16 by rmk") - (* \; "Edited 15-Dec-87 16:30 by Snow") - (LET (F) - (SETQ F (MKATOM (PROMPTFORWORD "Keyboard file name: " NIL NIL PROMPTWINDOW NIL 'TTY))) - (IF F - THEN (VKBD.LOAD-KEYBOARD-FILE F REDEFINE? DELETE-FIRST? T))))) (VKBD.LOAD-KEYBOARD-FILE - (LAMBDA (FILENAME REDEFINE? DELETE-CURRENT-DEFINITIONS? PROMPTPRINT) - (* \; "Edited 4-Mar-96 10:53 by rmk") - - (* |;;| "Note: Can't switch to READFILE, since it uses OLD-INTERLISP readtable which doesn't honor vertical bars around numeric atoms.") - - (LET ((NEWKEYBOARDS (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :INPUT) - (BIND KB DATE (*PACKAGE* _ *INTERLISP-PACKAGE*) - (RDTBL _ (FIND-READTABLE "INTERLISP")) - FIRST (SETQ DATE (READ STREAM RDTBL)) - (CL:UNLESS (LISTP DATE) - (CL:WHEN (STRINGP DATE) - (SETQ DATE (CONCAT "Keyboards from " (FULLNAME STREAM - ) - " [" DATE "]")) - (IF PROMPTPRINT - THEN (PROMPTPRINT DATE) - ELSE (PRINTOUT T DATE T))) - (SETQ DATE NIL)) WHILE (SKIPSEPRCODES STREAM RDTBL) - UNTIL (EQ 'STOP (SETQ KB (READ STREAM RDTBL))) COLLECT - KB - FINALLY (CL:WHEN DATE - - (* |;;| - "Was a LISTP date, must have been a keyboard") - - (PUSH DATE $$VAL)))))) - (COND - (DELETE-CURRENT-DEFINITIONS? (SETQ VKBD.KNOWN-KEYBOARDS NEWKEYBOARDS) - (VKBD.ADD-DEFAULT-KEYBOARD)) - (T (FOR NEWKEYBOARD KN KC IN NEWKEYBOARDS - DO - - (* |;;| -"To make sure that COMPLETEDASSIGNMENTS cell (or any other new cells) exist--backward compatibility") - - (SETQ NEWKEYBOARD (CREATE VIRTUALKEYBOARD USING NEWKEYBOARD)) - (SETQ KN (FETCH KEYBOARDNAME OF NEWKEYBOARD)) - (SETQ KC (FETCH KEYBOARDCONFIGURATION OF NEWKEYBOARD)) - (FOR TAIL OLDKEYBOARD ON VKBD.KNOWN-KEYBOARDS - WHEN (AND (EQ KN (FETCH KEYBOARDNAME OF (SETQ OLDKEYBOARD - (CAR TAIL)))) - (EQ KC (FETCH KEYBOARDCONFIGURATION OF OLDKEYBOARD)) - ) DO - - (* |;;| "If REDEFINE?, then replace one with same name and configuration. Otherwise, keep the old one instead of installing the new one.") - - (COND - (REDEFINE? (RPLACA TAIL NEWKEYBOARD)) - (T (RETURN))) FINALLY (SETQ - VKBD.KNOWN-KEYBOARDS - (NCONC1 - VKBD.KNOWN-KEYBOARDS - NEWKEYBOARD)))) - ))))) (vkbd.store-file-command - (lambda (f) (* \; "Edited 15-Dec-87 16:31 by Snow") - - (setq f (promptforword "ENTER FILE NAME: " nil nil promptwindow nil 'tty)) - (|if| f - |then| (vkbd.store-keyboard-file (mkatom f)) - |else| (promptprint "FILE NOT FOUND")))) (VKBD.STORE-KEYBOARD-FILE - (LAMBDA (FILENAME CONFIGURATIONNAME) (* \; "Edited 4-Mar-96 13:38 by rmk") - - (* |;;| "COMPLETEDKEYASSIGNMENTS are in a separate hasharray, don't get printed. Can't use WRITEFILE because of vertical-bar problems") - - (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) - (LET ((RDTBL (FIND-READTABLE "INTERLISP"))) - (PRINT (DATE) - STREAM RDTBL) - (IF CONFIGURATIONNAME - THEN (FOR KB IN VKBD.KNOWN-KEYBOARDS - WHEN (EQ CONFIGURATIONNAME (FETCH (VIRTUALKEYBOARD - KEYBOARDCONFIGURATION - ) OF KB)) - UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - DO (PRINT KB STREAM RDTBL)) - ELSE (* \; - "Don't print DEFAULT keyboards, since they are reconstructed from configuration") - (FOR KB IN VKBD.KNOWN-KEYBOARDS - UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) DO (PRINT KB STREAM RDTBL)))) - (PROMPTPRINT (CONCAT "Current known keyboards are stored in " FILENAME)) - (FULLNAME STREAM)))) ) (DEFINEQ (SWITCHKEYBOARDS - (LAMBDA (SWITCH-FLG DISPLAY-FLG PROCESS NEW-KEYBOARD DISPLAY-POSITION) - (* \; "Edited 27-Feb-96 12:35 by rmk") - (* \; "Edited 15-Dec-87 16:32 by Snow") - -(* |;;;| "This is the main function of the package. SWITCH-FLG and DISPLAY-FLG will produce the 3 logical combinations of switching a keyboard. The 4th comb NIl & NIL is NOOP. Any change of the KEYACTION handeling should be reflected here.") - - (PROG (WINDOW) - (COND - ((NULL NEW-KEYBOARD) - (SETQ NEW-KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU)))) - (COND - ((LITATOM NEW-KEYBOARD) - (SETQ NEW-KEYBOARD (FINDVIRTUALKEYBOARD NEW-KEYBOARD)))) - (COND - ((NULL NEW-KEYBOARD) - (RETURN NIL))) - (COND - (SWITCH-FLG (PROCESS.KEYBOARD PROCESS NEW-KEYBOARD))) - (COND - (DISPLAY-FLG (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD) - - (* |;;| "This is necessary to enable the menu to generate the right characters for the keys that are defaulted") - - (* |;;| "(RETURN OLD-KEYACTIONS)") - - (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY NEW-KEYBOARD DISPLAY-POSITION - (FUNCTION VKBD.SEND-CHARACTER)))))))) (vkbd.pop-menu-and-switch-keyboards - (lambda (process switch-flg display-flg) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (prog (keyboard) - (setq keyboard (vkbd.pop-up-keyboards-menu "Select an alternative keyboard")) - (|if| keyboard - |then| (switchkeyboards keyboard switch-flg display-flg))))) (VKBD.POP-UP-KEYBOARDS-MENU - (LAMBDA (PROMPT-STRING) (* \; "Edited 27-Feb-96 13:22 by rmk") - (* \; "Edited 16-Jun-92 11:35 by kaplan") - (COND - (PROMPT-STRING (PROMPTPRINT PROMPT-STRING) - (FLASHWINDOW PROMPTWINDOW 1))) - (LET ((KEYBOARDTYPES `(NIL ,(KEYBOARDTYPE) - ,@(CDR (ASSOC (KEYBOARDTYPE) - KEYBOARDCONFIGCOERCIONS)) - ,DEFAULTVIRTUALKEYBOARDTYPE))) - (MENU (CREATE MENU - ITEMS _ (CONS '(|Quit| NIL) - (SORT (FOR K IN VKBD.KNOWN-KEYBOARDS - WHEN (MEMB (FETCH KEYBOARDCONFIGURATION - OF K) - KEYBOARDTYPES) - UNLESS (MEMB (FETCH KEYBOARDNAME OF K) - $$VAL) - COLLECT (FETCH KEYBOARDNAME OF K)) - (FUNCTION UALPHORDER))) - MENUFONT _ BIGFONT))))) (VKBD.GET-CONFIGURATION - (LAMBDA (CONFNAME/WINDOW) (* \; "Edited 27-Feb-96 11:13 by rmk") - - (* |;;| "NIL means use the CURRENTKEYBOARDCONFIG, if it exists") - - (COND - ((WINDOWP CONFNAME/WINDOW) - (SETQ CONFNAME/WINDOW (|fetch| (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - |of| (WINDOWPROP CONFNAME/WINDOW 'VKBD.KEYBOARD))))) - (COND - ((AND CONFNAME/WINDOW (|type?| KEYBOARDCONFIGURATION CONFNAME/WINDOW)) - CONFNAME/WINDOW) - ((AND (NULL CONFNAME/WINDOW) - CURRENTKEYBOARDCONFIG)) - ((FASSOC (OR CONFNAME/WINDOW VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) - VKBD.CONFIGURATIONS)) - (T (FOR C IN (CDR (ASSOC CONFNAME/WINDOW KEYBOARDCONFIGCOERCIONS)) - WHEN (SETQ C (FASSOC C VKBD.CONFIGURATIONS)) DO (RETURN C)))))) (VKBD.SUBCONFIGURATION (LAMBDA (FULL NEWNAME LOWERLEFTKEY UPPERRIGHTKEY SCALE MARGIN) (* \; "Edited 8-Oct-96 12:28 by rmk:") (* |;;| "Returns a sub-configuration of FULL, including only keys that lie completely within the region enclosed by the bounding box of LOWERLEFTKEY and UPPERRIGHTKEY. Translates regions so that origin is the lower-left corner of the lower-left key.") (SETQ FULL (VKBD.GET-CONFIGURATION FULL)) (CL:UNLESS MARGIN (SETQ MARGIN 0)) (LET (NEWREGIONS (LEFT 65535) (BOTTOM 65535) (TOP 0) (RIGHT 0)) (CL:UNLESS NEWNAME (SETQ NEWNAME (FETCH CONFIGURATIONNAME OF FULL))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC LOWERLEFTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" LOWERLEFTKEY)) DO (CL:WHEN (ILESSP (FETCH LEFT OF R) LEFT) (SETQ LEFT (FETCH LEFT OF R))) (CL:WHEN (ILESSP (FETCH BOTTOM OF R) BOTTOM) (SETQ BOTTOM (FETCH BOTTOM OF R)))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC UPPERRIGHTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" UPPERRIGHTKEY)) DO (CL:WHEN (IGREATERP (FETCH RIGHT OF R) RIGHT) (SETQ RIGHT (FETCH RIGHT OF R))) (CL:WHEN (IGREATERP (FETCH TOP OF R) TOP) (SETQ TOP (FETCH TOP OF R)))) (SETQ NEWREGIONS (FOR KR IN (FETCH KEYREGIONS OF FULL) WHEN (FOR R IN (CDR KR) ALWAYS (AND (IGEQ (FETCH LEFT OF R) LEFT) (IGEQ (FETCH BOTTOM OF R) BOTTOM) (ILEQ (FETCH TOP OF R) TOP) (ILEQ (FETCH RIGHT OF R) RIGHT))) COLLECT (CONS (CAR KR) (FOR R IN (CDR KR) COLLECT (IF SCALE THEN (CREATE REGION LEFT _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH LEFT OF R) LEFT)))) BOTTOM _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))) WIDTH _ (FIXR (TIMES SCALE (FETCH WIDTH OF R))) HEIGHT _ (FIXR (TIMES SCALE (FETCH HEIGHT OF R)))) ELSE (CREATE REGION USING R LEFT _ (+ MARGIN (- (FETCH LEFT OF R) LEFT)) BOTTOM _ (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))))))) (CREATE KEYBOARDCONFIGURATION COPYING FULL CONFIGURATIONNAME _ NEWNAME KEYREGIONS _ NEWREGIONS DEFAULTASSIGNMENT _ (FOR A IN (FETCH DEFAULTASSIGNMENT OF FULL) WHEN (VKBD.KEY-ASSOC (CAR A) NEWREGIONS FULL) COLLECT (COPY A)))))) ) (DEFINEQ (vkbd.buttoneventfn - (lambda (window) (* \; "Edited 15-Dec-87 16:32 by Snow") - -(* |;;;| "This is a general 'menu' function for the keyboard when used as a menu --- it is used for all such uses: When displaying a virtual keyboard, when editing one and when editing a default assignments for a configuration. The only difference is what will be the action taken when a KEY was selected. This will be determined by the property VKBD.MENUFN which specify the name of the function that should be called. This function will get 3 arguments : The KEYID, the WINDOW and the mouse key; In the regular keyboard display this function will send a character to the system buffer. In the Editor it will make the key the CURRENT key. In the configuration info window it will display information about the key") - - (prog (mouse-position shaded-key last-mouse-key current-key-and-regions shift-is-down) - (setq mouse-position (cursorposition nil window)) - (totopw window) (* \; - "This should be checked if changes to the keyboard handling is done") - - (setq shift-is-down (or (keydownp 'rshift) - (keydownp 'lshift))) - (setq shaded-key (windowprop window 'vkbd.shaded-key)) - (setq last-mouse-key (windowprop window 'vkbd.mouse-button)) - (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position - mouse-position window)) - (cond - ((mousestate up) - (cond - ((and shaded-key (eq shaded-key (car current-key-and-regions))) - (apply (windowprop window 'vkbd.menufn) - (list (windowprop window 'vkbd.shaded-key) - window - (windowprop window 'vkbd.last-mouse-state))) - (vkbd.reset-keyboard-window window)))) - ((or (mousestate (only left)) - (mousestate (only middle))) - (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) - (|for| region |in| (cdr current-key-and-regions) |do| (vkbd.invert-region - region window)) - (windowprop window 'vkbd.last-mouse-state (cond - ((lastmousestate (only left)) - 'left) - (t 'middle))) - (cond - ((or shift-is-down (lastmousestate (only middle))) - (vkbd.invert-shift-keys window) - (windowprop window 'vkbd.shift-down t)))))))) (vkbd.center-bitmap-in-region - (lambda (bm region window allignment) (* \; "Edited 15-Dec-87 16:32 by Snow") - - (bitblt bm 0 0 window (iplus (|fetch| (region left) |of| region) - (iquotient (idifference (|fetch| (region width) |of| region) - (bitmapwidth bm)) - 2)) - (cond - ((greaterp (bitmapheight bm) - (|fetch| (region height) |of| region)) - (cond - ((eq allignment 'top) - (idifference (|fetch| (region bottom) |of| region) - (idifference (bitmapheight bm) - (|fetch| (region height) |of| region)))) - ((eq allignment 'bottom) - (|fetch| (region bottom) |of| region)) - (t (iplus (|fetch| (region bottom) |of| region) - (iquotient (idifference (|fetch| (region height) |of| region) - (bitmapheight bm)) - 2))))) - (t (iplus (|fetch| (region bottom) |of| region) - (iquotient (idifference (|fetch| (region height) |of| region) - (bitmapheight bm)) - 2)))) - nil nil 'input 'paint))) (VKBD.CLEAR-KEY-DISPLAY - (LAMBDA (KEY-REGIONS VKBD-WINDOW) (* \; "Edited 27-Feb-96 13:50 by rmk") - (FOR REGION LEFT BOTTOM WIDTH HEIGHT IN KEY-REGIONS - DO (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)) - (BITBLT NIL NIL NIL VKBD-WINDOW (ADD1 LEFT) - (ADD1 BOTTOM) - (IDIFFERENCE WIDTH 2) - (IDIFFERENCE HEIGHT 2) - 'TEXTURE - 'REPLACE WHITESHADE) - (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (ADD1 BOTTOM) - (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - BOTTOM) - (BITMAPBIT VKBD-WINDOW LEFT (ADD1 BOTTOM)))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (ADD1 BOTTOM) - (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - BOTTOM) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) - (ADD1 BOTTOM)))) - (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) - (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (IPLUS BOTTOM (ADD1 HEIGHT))) - (BITMAPBIT VKBD-WINDOW LEFT (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) - (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (IPLUS BOTTOM (SUB1 HEIGHT)))))))) (VKBD.CREATE-KEYBOARD-BITMAP - (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:45 by rmk") - (* \; "Edited 15-Dec-87 16:35 by Snow") - (LET (BM KEYS-REGION BM-WIDTH BM-HEIGHT MAX-REGION) - (COND - ((ATOM CONFIGURATION) - (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)))) - (SETQ MAX-REGION (VKBD.UNION-REGIONS CONFIGURATION)) - (SETQ BM-WIDTH (IPLUS (ITIMES 2 (FETCH (REGION LEFT) OF MAX-REGION)) - (FETCH (REGION WIDTH) OF MAX-REGION))) - (SETQ BM-HEIGHT (IPLUS (ITIMES 2 (FETCH (REGION BOTTOM) OF MAX-REGION)) - (FETCH (REGION HEIGHT) OF MAX-REGION))) - (SETQ BM (BITMAPCREATE BM-WIDTH BM-HEIGHT)) - (BITBLT NIL NIL NIL BM 0 0 BM-WIDTH BM-HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM 1 1 (IDIFFERENCE BM-WIDTH 2) - (IDIFFERENCE BM-HEIGHT 2) - 'TEXTURE - 'REPLACE - (FETCH (KEYBOARDCONFIGURATION BACKGROUNDSHADE) OF CONFIGURATION)) - (FOR KEY-AND-REGIONS IN (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF - CONFIGURATION - ) DO - - (* |;;| - "CDR cause odd-shaped keys (like ENTER) are described by multiple regions") - - (VKBD.DISPLAY-EMPTY-KEY-CAP (CDR - KEY-AND-REGIONS - ) - BM)) - BM))) (VKBD.CREATE-KEYBOARD-DISPLAY - (LAMBDA (KEYBOARD MENU-POSITION MENU-FUNCTION BM SHOWCONFIG) - (* \; "Edited 28-Feb-96 12:02 by rmk") - (* \; "Edited 25-May-95 11:33 by rmk:") - (* \; "Edited 20-Apr-89 13:26 by atm") - (LET (WINDOW WINDOW-WIDTH WINDOW-HEIGHT KEYBOARD-BITMAP CONFIGURATION) - (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION (|fetch| KEYBOARDCONFIGURATION - |of| KEYBOARD))) - (SETQ KEYBOARD-BITMAP (OR BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIGURATION))) - (SETQ WINDOW-WIDTH (IPLUS 8 (BITMAPWIDTH KEYBOARD-BITMAP))) - (SETQ WINDOW-HEIGHT (IPLUS 18 (BITMAPHEIGHT KEYBOARD-BITMAP))) - (CL:UNLESS MENU-POSITION - (SETQ MENU-POSITION (GETBOXPOSITION WINDOW-WIDTH WINDOW-HEIGHT))) - (SETQ WINDOW (CREATEW (CREATEREGION (|fetch| (POSITION XCOORD) |of| MENU-POSITION) - (|fetch| (POSITION YCOORD) |of| MENU-POSITION) - WINDOW-WIDTH WINDOW-HEIGHT) - (CONCAT "Virtual Keyboard : " (|fetch| (VIRTUALKEYBOARD KEYBOARDNAME - ) |of| KEYBOARD) - (CL:IF SHOWCONFIG - (CONCAT " for " (|fetch| (VIRTUALKEYBOARD - KEYBOARDCONFIGURATION) - |of| KEYBOARD)) - "")))) - (WINDOWPROP WINDOW 'VKBD.KEYBOARD KEYBOARD) - (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION VKBD.BUTTONEVENTFN)) - (WINDOWPROP WINDOW 'CURSORMOVEDFN (FUNCTION VKBD.CURSORMOVEDFN)) - (WINDOWPROP WINDOW 'CURSOROUTFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) - (WINDOWPROP WINDOW 'CURSORINFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) - (WINDOWPROP WINDOW 'VKBD.MENUFN MENU-FUNCTION) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION VKBD.KEYBOARD-WINDOW-REPAINTFN)) - (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 0 (BITMAPWIDTH KEYBOARD-BITMAP) - (BITMAPHEIGHT KEYBOARD-BITMAP))) - (WINDOWPROP WINDOW 'ICONFN (FUNCTION VKBD.ICONFN)) - (WINDOWPROP WINDOW 'VKBD.KEYBOARDDISPLAYFONT (OR (|fetch| (VIRTUALKEYBOARD - KEYBOARDDISPLAYFONT) - |of| KEYBOARD) - DEFAULTKEYBOARDDISPLAYFONT)) - (REDISPLAYW WINDOW) - WINDOW))) (vkbd.cursormovedfn - (lambda (window) (* \; "Edited 15-Dec-87 16:41 by Snow") - - (prog (mouse-position shaded-key current-key-and-regions shift-is-down) - (setq mouse-position (cursorposition nil window)) - (setq shaded-key (windowprop window 'vkbd.shaded-key)) - (setq shift-is-down (or (keydownp 'lshift) - (keydownp 'rshift))) - (cond - (shaded-key (cond - ((not (vkbd.position-is-in-key-region shaded-key mouse-position - window)) - (vkbd.reset-keyboard-window window)) - (t (return t))))) - (cond - ((mousestate (or (only left) - (only middle))) - (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position - mouse-position window)) - (cond - (current-key-and-regions (|for| region |in| (cdr current-key-and-regions) - |do| (vkbd.invert-region region window)) - (cond - ((or shift-is-down (lastmousestate (only middle))) - (vkbd.invert-shift-keys window) - (windowprop window 'vkbd.shift-down t))) - (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) - (windowprop window 'vkbd.last-mouse-state (cond - ((lastmousestate (only left)) - 'left) - (t 'middle)))))))))) (VKBD.DISPLAY-CHARACTER - (LAMBDA (CHAR REGION CHARLABELS WINDOW CONF ALLIGNMENT)(* \; "Edited 7-Mar-96 02:14 by rmk") - (* \; "Edited 17-Feb-95 12:58 by rmk:") - (LET (CHARLABEL) - (SETQ REGION (VKBD.EXTEND-REGION REGION -1)) - (COND - ((SETQ CHARLABEL (CADR (OR (FASSOC CHAR CHARLABELS) - (FASSOC CHAR VKBD.COMMONCODELABELS)))) - (DSPFONT (OR (|fetch| (KEYBOARDCONFIGURATION KEYLABELSFONT) |of| CONF) - DEFAULTKEYBOARDLABELSFONT) - WINDOW) - (CENTERPRINTINREGION CHARLABEL REGION WINDOW)) - (T (VKBD.CENTER-BITMAP-IN-REGION (GETCHARBITMAP CHAR - (FONTCREATE (OR (WINDOWPROP WINDOW - - ' - VKBD.KEYBOARDDISPLAYFONT - ) - (|fetch| ( - KEYBOARDCONFIGURATION - - KEYBOARDDISPLAYFONT - ) |of| - CONF) - DEFAULTKEYBOARDDISPLAYFONT))) - REGION WINDOW ALLIGNMENT)))))) (VKBD.DISPLAY-EMPTY-KEY-CAP - (LAMBDA (KEY-REGIONS BM) (* \; "Edited 27-Feb-96 13:32 by rmk") - (LET (LEFT BOTTOM WIDTH HEIGHT) - (FOR REGION IN KEY-REGIONS - DO (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)) - (BITBLT NIL NIL NIL BM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM (ADD1 LEFT) - (ADD1 BOTTOM) - (IDIFFERENCE WIDTH 2) - (IDIFFERENCE HEIGHT 2) - 'TEXTURE - 'REPLACE WHITESHADE) - (BITMAPBIT BM LEFT BOTTOM 0) - (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) - BOTTOM 0) - (BITMAPBIT BM LEFT (IPLUS BOTTOM (SUB1 HEIGHT)) - 0) - (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) - (IPLUS BOTTOM (SUB1 HEIGHT)) - 0)) - (COND - ((CDR KEY-REGIONS) - (FOR REGION1 IN KEY-REGIONS - DO (FOR REGION2 IN KEY-REGIONS BIND INTERSECT - DO (COND - ((NOT (EQUAL REGION1 REGION2)) - (SETQ INTERSECT (INTERSECTREGIONS - (CREATEREGION (SUB1 (FETCH (REGION LEFT) - OF REGION1)) - (SUB1 (FETCH (REGION BOTTOM) - OF REGION1)) - (IPLUS (FETCH (REGION WIDTH) - OF REGION1) - 2) - (IPLUS (FETCH (REGION HEIGHT) - OF REGION1) - 2)) - (CREATEREGION (SUB1 (FETCH (REGION LEFT) - OF REGION2)) - (SUB1 (FETCH (REGION BOTTOM) - OF REGION2)) - (IPLUS (FETCH (REGION WIDTH) - OF REGION2) - 2) - (IPLUS (FETCH (REGION HEIGHT) - OF REGION2) - 2)))) - (COND - (INTERSECT (COND - ((GREATERP (FETCH (REGION HEIGHT) - OF INTERSECT) - (FETCH (REGION WIDTH) OF - INTERSECT - )) - (SETQ INTERSECT - (CREATEREGION (FETCH (REGION LEFT) - OF INTERSECT) - (ADD1 (FETCH (REGION BOTTOM) - OF INTERSECT)) - (FETCH (REGION WIDTH) OF - INTERSECT) - (IDIFFERENCE (FETCH (REGION HEIGHT - ) - OF INTERSECT) - 2))) - (BITBLT NIL NIL NIL BM (FETCH (REGION - LEFT) - OF INTERSECT) - (FETCH (REGION BOTTOM) OF - INTERSECT) - (FETCH (REGION WIDTH) OF - INTERSECT - ) - (FETCH (REGION HEIGHT) OF - INTERSECT) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM (FETCH (REGION - LEFT) - OF INTERSECT) - (ADD1 (FETCH (REGION BOTTOM) - OF INTERSECT)) - (FETCH (REGION WIDTH) OF - INTERSECT - ) - (IDIFFERENCE (FETCH (REGION HEIGHT) - OF INTERSECT) - 2) - 'TEXTURE - 'REPLACE WHITESHADE)) - (T (SETQ INTERSECT - (CREATEREGION (ADD1 (FETCH (REGION - LEFT) - OF INTERSECT)) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (IDIFFERENCE (FETCH (REGION - WIDTH) - OF INTERSECT) - 2) - (FETCH (REGION HEIGHT) - OF INTERSECT))) - (BITBLT NIL NIL NIL BM (FETCH - (REGION LEFT) - OF INTERSECT) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (FETCH (REGION WIDTH) - OF INTERSECT) - (FETCH (REGION HEIGHT) - OF INTERSECT) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM - (ADD1 (FETCH (REGION LEFT) - OF INTERSECT)) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (IDIFFERENCE (FETCH (REGION - WIDTH) - OF INTERSECT) - 2) - (FETCH (REGION HEIGHT) - OF INTERSECT) - 'TEXTURE - 'REPLACE WHITESHADE)))))))))))))) (VKBD.DISPLAY-KEY - (LAMBDA (KEYID WINDOW CONFIG KEYLABELS CHARLABELS KEYREGIONS) - (* \; "Edited 7-Mar-96 01:53 by rmk") - (* \; "Edited 15-Dec-87 17:40 by Snow") - (SETQ KEYID (VKBD.TRANSLATE-KEY-ID KEYID CONFIG)) - (LET (KEY-ASSIGNMENT LABEL-STRING KEYREGIONS) - (CL:WHEN (OR KEYREGIONS (SETQ KEYREGIONS (CDR (VKBD.KEY-ASSOC KEYID (FETCH - ( - KEYBOARDCONFIGURATION - KEYREGIONS) - OF CONFIG) - CONFIG)))) - - (* |;;| "If the REGION doesn't exist, we can't display it. E.g., our picture doesn't include the F1 keys. CAR because some keys (e.g. for ENTER) are defined by two rectangles") - - (VKBD.CLEAR-KEY-DISPLAY KEYREGIONS WINDOW) - (SETQ KEYLABELS (OR KEYLABELS (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG - ))) - (COND - ((SETQ LABEL-STRING (CADR (VKBD.KEY-ASSOC KEYID KEYLABELS CONFIG)))) - (T (SETQ KEY-ASSIGNMENT (VKBD.KEY-ASSOC KEYID (FETCH (VIRTUALKEYBOARD - COMPLETEKEYASSIGNMENTS - ) - OF (WINDOWPROP WINDOW - 'VKBD.KEYBOARD)) - CONFIG)) - (SETQ LABEL-STRING (VKBD.GET-NON-CHAR-LABEL KEY-ASSIGNMENT)))) - (COND - (LABEL-STRING (DSPFONT (OR (FETCH (KEYBOARDCONFIGURATION KEYLABELSFONT) - OF CONFIG) - DEFAULTKEYBOARDLABELSFONT) - WINDOW) - (COND - ((AND (LISTP LABEL-STRING) - (CDR LABEL-STRING)) - (CENTERPRINTINREGION (CAR LABEL-STRING) - (VKBD.UPPER-HALF-REGION (CAR KEYREGIONS)) - WINDOW) - (CENTERPRINTINREGION (CADR LABEL-STRING) - (VKBD.LOWER-HALF-REGION (CAR KEYREGIONS)) - WINDOW)) - (T (CENTERPRINTINREGION LABEL-STRING (CAR KEYREGIONS) - WINDOW)))) - (T (VKBD.DISPLAY-KEY-CHARACTERS KEY-ASSIGNMENT (CAR KEYREGIONS) - WINDOW CONFIG CHARLABELS))))))) (VKBD.DISPLAY-KEY-CHARACTERS - (LAMBDA (KEY-ASSIGNMENT KEY-REGION WINDOW CONFIG CHARLABELS) - (* \; "Edited 7-Mar-96 01:15 by rmk") - (LET (SHIFTED-CHAR UNSHIFTED-CHAR) - (COND - ((AND KEY-ASSIGNMENT (LISTP (CADR KEY-ASSIGNMENT))) - (CL:WHEN KEY-REGION - (SETQ SHIFTED-CHAR (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) - (SETQ UNSHIFTED-CHAR (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)) - (COND - ((EQ SHIFTED-CHAR UNSHIFTED-CHAR) - (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR KEY-REGION CHARLABELS WINDOW CONFIG)) - (T (VKBD.DISPLAY-CHARACTER UNSHIFTED-CHAR (VKBD.LOWER-HALF-REGION - KEY-REGION) - CHARLABELS WINDOW CONFIG 'BOTTOM) - (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR (VKBD.UPPER-HALF-REGION - KEY-REGION) - CHARLABELS WINDOW CONFIG 'TOP))))))))) (VKBD.DRAW-KEY-CAPS - (LAMBDA (LIST-OF-REGIONS BITMAP) (* \; "Edited 13-Jun-90 01:10 by mitani") - (|for| REGION |in| LIST-OF-REGIONS |do| (BITBLT NIL NIL NIL BITMAP - (|fetch| (REGION LEFT) - |of| REGION) - (|fetch| (REGION BOTTOM) - |of| REGION) - (|fetch| (REGION WIDTH) - |of| REGION) - (|fetch| (REGION HEIGHT) - |of| REGION) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BITMAP - (ADD1 (|fetch| (REGION LEFT) - |of| REGION)) - (ADD1 (|fetch| (REGION BOTTOM) - |of| REGION)) - (IDIFFERENCE (|fetch| (REGION WIDTH) - |of| REGION) - 2) - (IDIFFERENCE (|fetch| (REGION HEIGHT) - |of| REGION) - 2) - 'TEXTURE - 'REPLACE WHITESHADE)))) (vkbd.erase-frame - (lambda (key window framesize) (* \; "Edited 15-Dec-87 16:42 by Snow") - - (vkbd.frame-key key window (|fetch| (keyboardconfiguration backgroundshade) - |of| (vkbd.get-configuration window)) - framesize))) (vkbd.extend-region - (lambda (region nbits) (* \; "Edited 15-Dec-87 16:42 by Snow") - - (cond - ((null nbits) - (setq nbits 1))) - (createregion (idifference (|fetch| (region left) |of| region) - nbits) - (idifference (|fetch| (region bottom) |of| region) - nbits) - (iplus (|fetch| (region width) |of| region) - (itimes nbits 2)) - (iplus (|fetch| (region height) |of| region) - (itimes nbits 2))))) (vkbd.get-key-and-regions-of-cursor-position - (lambda (cursor-position window) (* \; "Edited 15-Dec-87 16:43 by Snow") - - (|for| key-regions |in| (|fetch| (keyboardconfiguration keyregions) - |of| (vkbd.get-configuration window)) - |thereis| (|for| region |in| (cdr key-regions) |thereis| (insidep region - cursor-position - ))))) (VKBD.GET-KEY-REGIONS - (LAMBDA (KEY-ID CONFIG) (* \; "Edited 27-Feb-96 21:18 by rmk") - (CDR (VKBD.KEY-ASSOC KEY-ID (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF CONFIG) - CONFIG)))) (VKBD.INVERT-KEY - (LAMBDA (KEY-ID VKBD-WINDOW) (* \; "Edited 27-Feb-96 21:14 by rmk") - (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY-ID (VKBD.GET-CONFIGURATION VKBD-WINDOW)) - DO (VKBD.INVERT-REGION REGION VKBD-WINDOW)))) (vkbd.invert-region - (lambda (region window) (* \; "Edited 15-Dec-87 16:46 by Snow") - - (|if| region - |then| (bitblt window (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - window - (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - (|fetch| (region width) |of| region) - (|fetch| (region height) |of| region) - 'invert - 'replace)))) (VKBD.KEYBOARD-WINDOW-REPAINTFN - (LAMBDA (WINDOW) (* \; "Edited 7-Mar-96 13:38 by rmk") - (LET (BM KEYLABELS CHARLABELS (CONFIG (VKBD.GET-CONFIGURATION WINDOW)) - (KEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD))) - (SETQ KEYLABELS (FOR K IN (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG - ) COLLECT (LIST (VKBD.TRANSLATE-KEY-ID - (CAR K) - CONFIG) - (CADR K)))) - - (* |;;| "Build this up each time, so that the keyids are specialized to this keyboard. But the internal search will be much faster. ") - - (FOR K TR IN VKBD.COMMONKEYLABELS WHEN (SETQ TR (VKBD.TRANSLATE-KEY-ID - (CAR K) - CONFIG)) - UNLESS (ASSOC TR KEYLABELS) DO (PUSH KEYLABELS (LIST TR (CADR K)))) - (SETQ CHARLABELS (FETCH (KEYBOARDCONFIGURATION CHARLABELS) OF CONFIG)) - (SETQ BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIG)) - (BITBLT BM 0 0 WINDOW) - - (* |;;| "Display all the keys") - - (FOR R IN (FETCH KEYREGIONS OF CONFIG) - DO (VKBD.DISPLAY-KEY (VKBD.TRANSLATE-KEY-ID (CAR R) - CONFIG) - WINDOW CONFIG KEYLABELS CHARLABELS (CDR R))) - (COND - ((WINDOWPROP WINDOW 'VKBD.LOCKED) - (VKBD.INVERT-LOCK-KEYS WINDOW))) - (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL) - (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (vkbd.lower-half-region - (lambda (region) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (createregion (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - (|fetch| (region width) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)))) (VKBD.POSITION-IS-IN-KEY-REGION - (LAMBDA (KEY POSITION WINDOW) (* \; "Edited 27-Feb-96 21:21 by rmk") - (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY (VKBD.GET-CONFIGURATION WINDOW)) - THEREIS (INSIDEP REGION POSITION)))) (vkbd.remove-keyboard-command - (lambda nil (* \; "Edited 15-Dec-87 16:49 by Snow") - - (prog (k) - (setq k (vkbd.pop-up-keyboards-menu "Select keyboard to be removed .")) - (|if| k - |then| (vkbd.undefine-keyboard k) - (printout promptwindow "Keyboard " k - " was removed from the list of known keyboards. "))))) (VKBD.UNION-REGIONS - (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:47 by rmk") - - (* |;;| "Don't let too many arguments pile up on the stack.") - - (LET ((KEYREGS (FETCH KEYREGIONS OF CONFIGURATION))) - (APPLY 'UNIONREGIONS (WHILE KEYREGS - COLLECT (APPLY 'UNIONREGIONS - (WHILE KEYREGS FOR I VAL FROM 1 - TO 50 - DO - - (* |;;| - "CDR because odd-shaped keys (e.g. ENTER) have multiple regions") - - (FOR R - IN (CDR (POP KEYREGS)) - DO (PUSH VAL R)) - FINALLY (RETURN VAL)))))))) (vkbd.upper-half-region - (lambda (region) (* |sm| "13-Aug-85 10:38") - (createregion (|fetch| (region left) |of| region) - (iplus 1 (|fetch| (region bottom) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)) - (|fetch| (region width) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)))) ) (DEFINEQ (VKBD.KEY-ASSOC (LAMBDA (KEY ALIST CONFIG) (* \; "Edited 5-Oct-96 16:59 by rmk:") (* \; "Edited 27-Feb-96 21:07 by rmk") (CL:WHEN (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (FIND C IN ALIST SUCHTHAT (EQ (VKBD.TRANSLATE-KEY-ID (CAR C) CONFIG) KEY))))) (VKBD.CHAR-ASSIGNMENTP - (LAMBDA (ASSIGNMENT) (* \; "Edited 26-Feb-96 16:49 by rmk") - (LISTP (CADR ASSIGNMENT)))) (VKBD.COMPLETE-KEYBOARD - (LAMBDA (KEYBOARD) (* \; "Edited 7-Mar-96 13:25 by rmk") - - (* |;;| "Fill in keys that aren't mentioned in the new keyboard, using the configuration's default. Put the parsed results in the COMPLETEKEYASSIGNMENTS field, for future use. This field is not written out by the STORE-KEYBOARD function.") - - (CL:UNLESS (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - (LET (COMPLETE-ASSIGNMENTS (CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF KEYBOARD) - ))) - - (* |;;| "The assignment comes from the keyboard (PARTIAL), the configuration default, or the common default assignments.") - - (FOR K A CA IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD) - DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) - (IF (NULL (SETQ CA (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS))) - THEN (PUSH COMPLETE-ASSIGNMENTS A) - ELSEIF (EQUAL A CA) - ELSE (ERROR "INCOMPATIBLE ASSIGNMENTS OF KEY NUMBER" - (LIST K A CA)))) - (FOR K A IN (FETCH (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) OF CONFIG) - DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) - (CL:UNLESS (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS) - (PUSH COMPLETE-ASSIGNMENTS A))) - - (* |;;| "The configs defaultassignment can override the VKBD.COMMONDEFAULTASSIGNMENT") - - (FOR K A IN VKBD.COMMONDEFAULTASSIGNMENT WHEN (SETQ A ( - VKBD.PARSE-KEY-ASSIGNMENT - K CONFIG T)) - DO (CL:UNLESS (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS) - (PUSH COMPLETE-ASSIGNMENTS A))) - (REPLACE COMPLETEKEYASSIGNMENTS OF KEYBOARD WITH COMPLETE-ASSIGNMENTS))) - KEYBOARD)) (vkbd.ctrl-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:33 by Snow") - - (and (eq (cadr assignment) - 'ctrldown) - (eq (cddr assignment) - 'ctrlup)))) (vkbd.event-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") - - (and (eq (cadr assignment) - 'event) - (eq (cddr assignment) - 'event)))) (vkbd.meta-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") - - (and (eq (cadr assignment) - 'metadown) - (eq (cddr assignment) - 'metaup)))) (VKBD.FRAME-KEY - (LAMBDA (KEY WINDOW SHADE BITS) (* \; "Edited 29-Feb-96 11:06 by rmk") - (LET ((CONFIG (VKBD.GET-CONFIGURATION WINDOW)) - KEY-REGIONS) - (SETQ KEY-REGIONS (VKBD.GET-KEY-REGIONS KEY CONFIG)) - (FOR REGION EXTENDED-REGION IN KEY-REGIONS DO (SETQ EXTENDED-REGION - (VKBD.EXTEND-REGION REGION - BITS)) - (BITBLT NIL NIL NIL WINDOW - (FETCH (REGION LEFT) - OF EXTENDED-REGION) - (FETCH (REGION BOTTOM) - OF EXTENDED-REGION) - (FETCH (REGION WIDTH) - OF EXTENDED-REGION) - (FETCH (REGION HEIGHT) - OF EXTENDED-REGION) - 'TEXTURE - 'REPLACE SHADE)) - (VKBD.DISPLAY-EMPTY-KEY-CAP KEY-REGIONS WINDOW) - (VKBD.DISPLAY-KEY KEY WINDOW CONFIG) - (IF (EQ (WINDOWPROP WINDOW 'VKBD.SHADED-KEY) - KEY) - THEN (VKBD.INVERT-KEY KEY WINDOW))))) (VKBD.GET-CURRENT-KEY-ASSIGNMENT - (LAMBDA (KEY WINDOW/CONFIGURATION) (* \; "Edited 7-Mar-96 12:33 by rmk") - (* \; "Edited 15-Dec-87 16:43 by Snow") - (CONS KEY (KEYACTION (OR (VKBD.TRANSLATE-KEY-ID KEY WINDOW/CONFIGURATION) - KEY))))) (vkbd.get-non-char-label - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:44 by Snow") - - (cond - ((vkbd.shift-assignmentp key-assignment) - "SHIFT") - ((vkbd.lock-assignmentp key-assignment) - "LOCK") - ((vkbd.ctrl-assignmentp key-assignment) - "CTRL") - ((vkbd.lockup-assignmentp key-assignment) - '("LOCK" "UP")) - ((vkbd.lockdown-assignmentp key-assignment) - '("LOCK" "DOWN")) - ((vkbd.meta-assignmentp key-assignment) - "META") - ((vkbd.event-assignmentp key-assignment) - " ") - (t nil)))) (vkbd.iconfn - (lambda (window icon) (* \; "Edited 15-Dec-87 16:44 by Snow") - - (cond - ((null icon) - (setq icon (titlediconw (|create| titledicon - icon _ vkbd.icon - mask _ vkbd.mask - titlereg _ (createregion 5 15 80 50)) - (|fetch| (virtualkeyboard keyboardname) |of| (windowprop - window - 'vkbd.keyboard)) - (fontcreate 'gacha 8))))) - icon)) (VKBD.INVERT-LOCK-KEYS - (LAMBDA (WINDOW) (* \; "Edited 26-Feb-96 17:04 by rmk") - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) - WHEN (VKBD.LOCK-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR - KEY-ASSIGNMENT - ) - WINDOW)))) (VKBD.INVERT-SHIFT-KEYS - (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:13 by rmk") - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) - WHEN (VKBD.SHIFT-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR - KEY-ASSIGNMENT - ) - WINDOW)))) (VKBD.TRANSLATE-KEY-ID - (LAMBDA (KEY-ID CONFIG) (* \; "Edited 7-Mar-96 12:28 by rmk") - - (* |;;| "Assumes that KEY-ID's that look like key numbers ARE key numbers. Thus, integers in the range [0,\\NKEYS) can't be used as ID's. Returns NIL if the KEY-ID doesn't exist") - - (OR (KEYNUMBERP KEY-ID) - (LET ((NUM (CADR (ASSOC KEY-ID (FETCH KEYNAMESMAPPING OF CONFIG))))) - - (* |;;| - "If result is not a keynumber, then try recursing. Introduces a synonym facility") - - (OR (KEYNUMBERP NUM) - (AND NUM (VKBD.TRANSLATE-KEY-ID NUM CONFIG))))))) (vkbd.key-id-to-key-names - (lambda (key-id window/configuration) (* \; "Edited 15-Dec-87 16:46 by Snow") - - (setq window/configuration (vkbd.get-configuration window/configuration)) - (|for| name-id-pair |in| (|fetch| (keyboardconfiguration keynamesmapping) - |of| window/configuration) - |when| (eq (cadr name-id-pair) - key-id) |collect| (car name-id-pair)))) (VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD (LAMBDA (KEYBOARD) (* \; "Edited 24-May-95 15:25 by rmk:") (* |;;| "T if this keyboard is configured for the current physical keyboardtype.") (MEMB (FETCH (KEYBOARDCONFIGURATION KEYBOARDTYPE) OF (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KEYBOARD))) (ASSOC (KEYBOARDTYPE) KEYBOARDCONFIGCOERCIONS)))) (VKBD.LOCK-ASSIGNMENTP - (LAMBDA (ASSIGNMENT) (* \; "Edited 28-Feb-96 14:33 by rmk") - (* \; "Edited 15-Dec-87 16:47 by Snow") - (SELECTQ (CADR ASSIGNMENT) - (LOCKDOWN (EQ (CDDR ASSIGNMENT) - 'LOCKUP)) - (LOCKTOGGLE (MEMB (CDDR ASSIGNMENT) - '(NIL IGNORE))) - NIL))) (VKBD.LOCK-KEYP - (LAMBDA (KEY WINDOW) (* \; "Edited 26-Feb-96 17:05 by rmk") - (VKBD.LOCK-ASSIGNMENTP (FASSOC KEY (|fetch| (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - |of| (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))))) (vkbd.lock/nolock - (lambda (key-action) (* \; "Edited 15-Dec-87 16:47 by Snow") - - (caddr (cadr key-action)))) (vkbd.lockdown-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:47 by Snow") - - (and (eq (cadr assignment) - 'lockdown) - (or (null (cddr assignment)) - (eq (cddr assignment) - 'ignore))))) (vkbd.lockup-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (and (eq (cadr assignment) - 'lockup) - (or (null (cddr assignment)) - (eq (cddr assignment) - 'ignore))))) (VKBD.PARSE-CHAR-CODE - (LAMBDA (CHARSPEC) (* \; "Edited 29-Feb-96 10:29 by rmk") - - (* |;;| - "Does the coercion to a character code, causing error if not possible. NIL is passed through.") - - (COND - ((AND (SMALLP CHARSPEC) - (IGEQ CHARSPEC 0) - (ILEQ CHARSPEC 65535)) - CHARSPEC) - ((CHARCODE.DECODE CHARSPEC T)) - (CHARSPEC (ERROR "ILLEGAL CHARACTER SPECIFICATION" CHARSPEC))))) (VKBD.PARSE-KEY-ASSIGNMENT (LAMBDA (KEY-ASSIGNMENT CONFIG UNKNOWNOK) (* \; "Edited 13-Dec-96 17:26 by rmk:") (* \; "Edited 7-Mar-96 12:29 by rmk") (* |;;| "Parses a key assignment using information in CONFIG. Value returned is an image of the key assignment with the key coerced to a keynumber and also the character specifications coerced to codes. This is what goes into the COMPLETEKEYASSIGNMENTS field. If UNKNOWNOK, returns NIL as the keyid if it isn't found in the CONFIG (or if the CONFIG isn't given (on calls from LOADKEYBOARDDISPLAYFONTS).") (PROG (KEY TRKEY UNSHIFTED-CHAR SHIFTED-CHAR LOCK/NOLOCK DOWN UP) (CL:UNLESS (CDR (LISTP KEY-ASSIGNMENT)) (ERROR "ILLEGAL KEY ASSIGNMENT" KEY-ASSIGNMENT)) (SETQ KEY (CAR KEY-ASSIGNMENT)) (CL:UNLESS (SETQ TRKEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (CL:UNLESS UNKNOWNOK (ERROR (CONCAT "KEY NOT KNOWN IN CONFIGURATION " (FETCH CONFIGURATIONNAME OF CONFIG)) KEY-ASSIGNMENT))) (OR T (CL:UNLESS (VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) (* |;;| "Not sure what else it should be. Perhaps cause an error?") (RETURN NIL))) (CL:WHEN (LISTP (SETQ DOWN (CADR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR DOWN))) (SETQ DOWN (LIST (VKBD.PARSE-CHAR-CODE (CAR DOWN)) (IF (CADR DOWN) THEN (VKBD.PARSE-CHAR-CODE (CADR DOWN)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR DOWN) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (CL:WHEN (LISTP (SETQ UP (CDDR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR UP))) (SETQ UP (LIST (VKBD.PARSE-CHAR-CODE (CAR UP)) (IF (CADR UP) THEN (VKBD.PARSE-CHAR-CODE (CADR UP)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR UP) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (RETURN `(,TRKEY ,DOWN ,@UP))))) (VKBD.RESET-KEYBOARD-WINDOW - (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:22 by rmk") - (LET (SHADED-KEY) - (IF (SETQ SHADED-KEY (WINDOWPROP WINDOW 'VKBD.SHADED-KEY)) - THEN (VKBD.INVERT-KEY SHADED-KEY WINDOW) - (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL)) - (IF (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) - THEN (VKBD.INVERT-SHIFT-KEYS WINDOW) - (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN NIL)) - (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (VKBD.SEND-CHARACTER - (LAMBDA (KEY WINDOW) (* \; "Edited 28-Feb-96 14:35 by rmk") - (LET (KEY-ASSIGNMENT CHAR-CODE (CONFIG (VKBD.GET-CONFIGURATION WINDOW))) - (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) - (COND - ((VKBD.LOCK-KEYP KEY WINDOW) - (WINDOWPROP WINDOW 'VKBD.LOCKED (NOT (WINDOWPROP WINDOW 'VKBD.LOCKED))) - (VKBD.INVERT-LOCK-KEYS WINDOW)) - (T (SETQ KEY-ASSIGNMENT (FASSOC KEY (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))) - (COND - ((VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) - (SETQ CHAR-CODE (COND - ((OR (KEYDOWNP 'RSHIFT) - (KEYDOWNP 'LSHIFT) - (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) - (AND (EQ (VKBD.LOCK/NOLOCK KEY-ASSIGNMENT) - 'LOCKSHIFT) - (WINDOWPROP WINDOW 'VKBD.LOCKED))) - (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) - (T (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)))) - (COND - (CHAR-CODE (BKSYSBUF (CHARACTER CHAR-CODE))))))))))) (vkbd.shift-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (or (and (eq (cadr assignment) - '1shiftdown) - (eq (cddr assignment) - '1shiftup)) - (and (eq (cadr assignment) - '2shiftdown) - (eq (cddr assignment) - '2shiftup))))) (vkbd.shifted-char - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (cadadr key-assignment))) (VKBD.UNDEFINE-KEYBOARD (LAMBDA (KEYBOARD-NAME) (* \; "Edited 25-May-95 11:45 by rmk:") (IF (EQ KEYBOARD-NAME 'DEFAULT) THEN (PROMPTPRINT "Cannot delete the default keyboard. ") ELSE (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE (FINDVIRTUALKEYBOARD KEYBOARD-NAME) VKBD.KNOWN-KEYBOARDS))))) (vkbd.unshifted-char - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (caadr key-assignment))) ) (ADDTOVAR CHARACTERNAMES (BREAK 2) (HOME 524) (PGUP 525) (END 527) (PGDN 528) (INS 529) (HELP 517) (SCRL 521) (NUMLK 522) (CLEAR 523) (DOIT 555) (CENTER 577) (NOTCENTER 609) (BOLD 578) (NOTBOLD 610) (ITALIC 579) (NOTITALIC 611) (UCASE 580) (LCASE 612) (STRIKEOUT 581) (NOTSTRIKEOUT 613) (UNDERLINE 582) (NOTUNDERLINE 614) (SUBSCRIPT 583) (SUPERSCRIPT 615) (SMALLER 584) (LARGER 616) (MARGINS 585) (NOTMARGINS 617) (LOOKS 587) (NOTLOOKS 619) (F11 588) (NOTF11 620) (F12 589) (NOTF12 621)) (DECLARE\: EVAL@COMPILE (RECORD KEYBOARDCONFIGURATION (CONFIGURATIONNAME KBCDUMMY1 KEYREGIONS KBCDUMMY2 DEFAULTASSIGNMENT KEYNAMESMAPPING KEYBOARDTYPE KEYLABELS KEYLABELSFONT BACKGROUNDSHADE KEYBOARDDISPLAYFONT CHARLABELS) (* |;;| "Dummy fields so length test still works") (TYPE? (EQLENGTH DATUM (CONSTANT (LENGTH (RECORDFIELDNAMES ' KEYBOARDCONFIGURATION ))))) KEYBOARDTYPE _ (KEYBOARDTYPE) KEYLABELSFONT _ DEFAULTKEYBOARDLABELSFONT BACKGROUNDSHADE _ 23130 KEYBOARDDISPLAYFONT _ DEFAULTKEYBOARDDISPLAYFONT) (RECORD VIRTUALKEYBOARD (KEYBOARDNAME KEYASSIGNMENTS KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) (HASHLINK VIRTUALKEYBOARD (COMPLETEKEYASSIGNMENTS VKBDHASHARRAY 20))) ) (DECLARE\: EVAL@COMPILE (GLOBALVARS VKBDHASHARRAY)) (SETUPHASHARRAY 'VKBDHASHARRAY 20) (RPAQ? VKBD.KNOWN-KEYBOARDS NIL) (FILESLOAD (SOURCE) KEYBOARDCONFIGS) (RPAQQ VKBD.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" '(ADD.PROCESS '(SWITCHKEYBOARDS T)) "Switches the key actions of the keyborad.") ("Switch and display" '(ADD.PROCESS '(SWITCHKEYBOARDS T T)) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" '(ADD.PROCESS '(SWITCHKEYBOARDS NIL T)) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" '(ADD.PROCESS '(VKBD.STORE-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Stores the current known keyboards") ("Load keyboards file" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL T) 'WINDOW PROMPTWINDOW) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL NIL) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND T NIL) 'WINDOW PROMPTWINDOW) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" '(ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)) "Removes a keyboard from the list of known keyboards") ("Edit" (ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" (SUBITEMS ("New Keyboard, default initial" '(ADD.PROCESS '( VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" ) ("New keyboard, other initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will pop up a menu of the current known keyboards. The selected one will be used as the initial keyboard" ) ("Existing keyboard" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND)) "Will let you select a keyboard from list of the known keyboards, and will calls the keyboard editor on the selected keyboard." ))))) (RPAQQ VKBD.NON-CHAR-ASSIGNMENTS-LABELS ((SHIFT SHIFT) (CTRL CTRL) (META META) (LOCK LOCK) (LOCKUP LOCKUP) (LOCKDOWN LOCKDOWN))) (RPAQQ VKBD.WINDOW-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T NIL W))) "Switches the key actions of the keyborad.") ("Switch and display" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T T W))) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS NIL T W ))) "Displays the new keyboard. The displayed keyboard can be used as a menu." ) ("Store keyboards" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.STORE-FILE-COMMAND )) 'WINDOW PROMPTWINDOW))) "Stores the current known keyboards") ("Load keyboards file" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND )) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND NIL T)) 'WINDOW PROMPTWINDOW))) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND )) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND T NIL)) 'WINDOW PROMPTWINDOW))) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" (FUNCTION (LAMBDA (W) (ADD.PROCESS '( VKBD.REMOVE-KEYBOARD-COMMAND )))) "Removes a keyboard from the list of known keyboards" ))) (RPAQQ VKBD.ICON #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HDNGAHLG@HDBA@HDBA@HDBA@HD@GAHLGOOOOOOOOOOOOOOOOOOOOAHLG@BA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBAFGAHLG@BA@HDBA@HDBA@HDBA@GAHLGOOOOOOOOOOOOOOOOOOHGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HHGAHLGOOOOOOOOOOOOOOOOOOOOAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (RPAQQ VKBD.MASK #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) ) (DECLARE\: FIRST (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN) ) (RPAQ? \\ORIGINALDEFAULTKEYACTION ) (DEFINEQ (VKBD.\\KEYBOARDEVENTFN - (LAMBDA (FDEV EVENT EXTRA) (* \; "Edited 1-Mar-96 23:27 by rmk") - - (* |;;| "call the old keyboard event function, then make sure to reset the Virtual keyboard keyaction tables. ") - - (\\OLDKEYBOARDEVENTFN FDEV EVENT EXTRA) - (SELECTQ EVENT - ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) - (SETQ \\VKBD.KEYBOARD.BEFORETYPE (KEYBOARDTYPE))) - ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) - (CL:UNLESS (EQ (KEYBOARDTYPE) - \\VKBD.KEYBOARD.BEFORETYPE) - (SETQ VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) - (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION (KEYBOARDTYPE))) - - (* |;;| "If keyboardtype has changed, we start by setting default keyaction table to the settings it had at the time that virtualkeyboards was originally loaded.") - - (RESETKEYACTION \\DEFAULTKEYACTION \\ORIGINALDEFAULTKEYACTION T) - (VKBD.ADD-DEFAULT-KEYBOARD VKBD.DEFAULT-CONFIGURATION-NAME) - (VKBD.RESETKEYACTIONTABLES))) - NIL))) (VKBD.RESETKEYACTIONTABLES - (LAMBDA NIL (* \; "Edited 4-Mar-96 13:49 by rmk") - (* \; "Edited 16-Feb-95 18:23 by rmk:") - - (* |;;| "Reinstantiate/recomplete all keyboards that were previously operational, and insure that there is a DEFAULT for the new type. Probably should also redraw any open keyboard windows...later.") - - (CL:UNLESS (FINDVIRTUALKEYBOARD 'DEFAULT) - - (* |;;| "This will look for new keyboard files whenever real keyboard changes.") - - (VKBD.INIT)) - (CLRHASH VKBDHASHARRAY) - - (* |;;| "Throw away any cached information, including COMPLETEKEYASSIGNMENTS") - - (FOR KEYBOARD TABLE IN VKBD.KNOWN-KEYBOARDS - DO (CL:WHEN (SETQ TABLE (GETPROP (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARD - ) - 'KEYACTIONTABLE)) - (VKBD.CREATE-KEYACTION-TABLE (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KEYBOARD) - TABLE))))) ) (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN) (DECLARE\: FIRST (MOVD? 'KEYACTION 'OLDKEYACTION) ) (DEFINEQ (NEWKEYACTION - (LAMBDA (KEYNAME ACTIONS TABLE) (* \; "Edited 7-Mar-96 11:10 by rmk") - - (* |;;| "\\NKEYS is a constant from LLKEY.") - - (PROG (KEYBOARD (KEYNUM (OR (VKBD.TRANSLATE-KEY-ID KEYNAME CURRENTKEYBOARDCONFIG) - (\\KEYNAMETONUMBER KEYNAME)))) - - (* |;;| "Handle the NIL-TABLE cases.") - - (COND - ((AND (NULL TABLE) - (LISTP ACTIONS) - (OR (FMEMB (CAR ACTIONS) - MODEACTIONS) - (FMEMB (CDR ACTIONS) - MODEACTIONS))) - - (* |;;| "If we are setting a mode (as opposed to a character) key, assume that it is intended to be set in all keyboards where that key is still an appropriate mode") - - (FOR KEYBOARD KEYACTION (ORIGKEYACTION _ (CDR (FASSOC KEYNUM \\ORIGKEYACTIONS))) - (MODEACTION _ (CDR (FASSOC KEYNUM MODEKEYS))) IN VKBD.KNOWN-KEYBOARDS - DO (SETQ KEYACTION (CDR (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS - OF KEYBOARD)))) - (COND - ((EQUAL KEYACTION ACTIONS)) - ((OR (NULL KEYACTION) - (EQUAL KEYACTION ORIGKEYACTION) - (EQUAL KEYACTION MODEACTION)) - (NEWKEYACTION KEYNAME ACTIONS KEYBOARD))) - FINALLY (RPLACD (OR (FASSOC KEYNUM MODEKEYS) - (CAR (PUSH MODEKEYS (CONS KEYNUM)))) - ACTIONS)) - (RETURN T) (* \; - "This will cause an error if we try to pass it back in. What else can we do?") - )) - -(* |;;;| "get the keyboard or key action table.") - - (COND - ((NULL TABLE) - (SETQ TABLE \\CURRENTKEYACTION)) - ((LITATOM TABLE) - (COND - ((SETQ KEYBOARD (FASSOC TABLE VKBD.KNOWN-KEYBOARDS)) - (SETQ TABLE (GETPROP TABLE 'KEYACTIONTABLE))) - (T (ERROR TABLE "is not a defined keyboard.")))) - ((LISTP TABLE) - (COND - ((FMEMB TABLE VKBD.KNOWN-KEYBOARDS) - (SETQ KEYBOARD TABLE) - (SETQ TABLE (GETPROP (FETCH KEYBOARDNAME OF TABLE) - 'KEYACTIONTABLE))) - (T (ERROR TABLE "is not a defined keyboard.")))) - (T (FOR VKBD IN VKBD.KNOWN-KEYBOARDS - WHEN (EQ TABLE (GETPROP (FETCH KEYBOARDNAME OF VKBD) - 'KEYACTIONTABLE)) DO (SETQ KEYBOARD VKBD)))) - - (* |;;| "If TABLE is NIL, means that we are setting a virtual keyboard for which a keyaction table hasn't yet been created.") - - (RETURN - (PROG1 - (COND - (TABLE (OLDKEYACTION KEYNUM ACTIONS TABLE)) - (KEYBOARD (* \; - "virtual keyboard package allows incomplete keyboards with defaults from \\ORIGKEYACTIONS.") - (CDR (IF (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - THEN (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS - OF KEYBOARD)) - ELSE (LET (A) - (IF (SETQ A (OR (VKBD.KEY-ASSOC KEYNAME - (FETCH KEYASSIGNMENTS - OF KEYBOARD) - CURRENTKEYBOARDCONFIG) - (VKBD.KEY-ASSOC KEYNAME - (FETCH DEFAULTASSIGNMENT - OF - CURRENTKEYBOARDCONFIG - ) - CURRENTKEYBOARDCONFIG) - (VKBD.KEY-ASSOC KEYNAME - VKBD.COMMONDEFAULTASSIGNMENT - CURRENTKEYBOARDCONFIG))) - THEN (VKBD.PARSE-KEY-ASSIGNMENT A - CURRENTKEYBOARDCONFIG) - ELSE (FASSOC KEYNUM \\ORIGKEYACTIONS)))))) - (T (SHOULDNT))) - (COND - ((AND KEYBOARD ACTIONS) - - (* |;;| -"Set the keyaction in the virtual keyboard, which keeps it consistent with the corresponding table.") - - (CL:WHEN (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - (PUTASSOC KEYNUM (CDR (VKBD.PARSE-KEY-ASSIGNMENT (CONS KEYNUM ACTIONS) - CURRENTKEYBOARDCONFIG)) - (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD))) - (IF (FETCH KEYASSIGNMENTS OF KEYBOARD) - THEN (PUTASSOC KEYNAME ACTIONS (FETCH KEYASSIGNMENTS OF KEYBOARD)) - ELSE (PUSH (FETCH KEYASSIGNMENTS OF KEYBOARD) - (CONS KEYNAME ACTIONS)))))))))) ) (MOVD 'NEWKEYACTION 'KEYACTION) (RPAQ? MODEKEYS ) (RPAQQ MODEACTIONS (EVENT CTRLUP CTRLDOWN 1SHIFTUP 1SHIFTDOWN 2SHIFTUP 2SHIFTDOWN LOCKUP LOCKDOWN LOCKTOGGLE METAUP METADOWN FONTUP FONTDOWN FONTTOGGLE USERMODE1UP USERMODE1DOWN USERMODE1TOGGLE USERMODE2UP USERMODE2DOWN USERMODE2TOGGLE USERMODE3UP USERMODE3DOWN USERMODE3TOGGLE)) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MODEKEYS MODEACTIONS) ) (DEFINEQ (METASHIFT - (LAMBDA FLG (* \; "Edited 16-Jun-92 08:44 by rmk:") - - (* |;;| "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting. Returns previous setting. This differs from LLKEY version in that it changes the \\DORADOKEYACTIONS and \\DEFAULTKEYACTION table to insure that the metashift remains in effect across keyboard switches.") - - (PROG* ((METASTATUS '(METADOWN . METAUP)) - (ARGUMENT (AND (IGREATERP FLG 0) - (COND - ((EQ (ARG FLG 1) - T) - METASTATUS) - (T (OR (ARG FLG 1) - (CDR (ASSOC 'BLANK-BOTTOM \\ORIGKEYACTIONS))))))) - OLDSETTING) - (SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM ARGUMENT)) - - (* |;;| - "Update \\doradokeyactions table so we don't lose the change when we repalce the keyaction table.") - - (AND (EQ (MACHINETYPE) - 'DORADO) - (COND - (ARGUMENT (PUTASSOC 'BLANK-BOTTOM ARGUMENT \\DORADOKEYACTIONS) - (KEYACTION 'BLANK-BOTTOM ARGUMENT \\DEFAULTKEYACTION)) - (T (SETQ \\DORADOKEYACTIONS (|for| X |in| \\DORADOKEYACTIONS - |join| (AND (NEQ (CAR X) - 'BLANK-BOTTOM) - (LIST X)))) - (KEYACTION 'BLANK-BOTTOM NIL \\DEFAULTKEYACTION)))) - (RETURN (COND - ((EQUAL OLDSETTING METASTATUS) - T) - (T OLDSETTING)))))) ) (* \; "Call new definition if the old one had been called") (AND (EQ (MACHINETYPE) 'DORADO) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)) (ADDTOVAR BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT)) (DEFINEQ (FIXKEYBOARD - (LAMBDA (KBD) (* \; "Edited 28-Feb-96 13:36 by rmk") - - (* |;;| "This is a function use to coerce existing keyboards into a more reasonable format. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") - - (LET ((KC (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KBD)))) - - (* |;;| "Fix keyassignments and then remove duplicates of default keyassignments") - - (REPLACE KEYASSIGNMENTS OF KBD - WITH (SORT (FOR KA (DEF _ (FETCH DEFAULTASSIGNMENT OF KC)) - IN (FIXKEYASSIGNMENTS (FETCH KEYASSIGNMENTS OF KBD) - KC) UNLESS (MEMBER KA DEF) COLLECT KA) - T))))) (FIXKEYBOARDCONFIG - (LAMBDA (CONFIG) (* \; "Edited 29-Feb-96 13:27 by rmk") - - (* |;;| "Makes sure that CONFIG obeys keynaming conventions that force all reference to be by name and insure that names are not digits.") - - (LET (KEYNUMBERTONAME) - (FOR KN NAME FNAME FOUND IN (FETCH KEYNAMESMAPPING OF CONFIG) - DO (SETQ NAME (IF (AND (SMALLP (CAR KN)) - (IGEQ (CAR KN) - 0) - (ILEQ (CAR KN) - 9)) - THEN (CL:INTERN (CONCAT (CAR KN)) - 'INTERLISP) - ELSE (CAR KN))) - (IF (NULL (SETQ FOUND (ASSOC (CADR KN) - KEYNUMBERTONAME))) - THEN (PUSH KEYNUMBERTONAME (LIST (CADR KN) - NAME)) - ELSEIF (OR (EQ NAME (SETQ FNAME (CADR FOUND))) - (AND (EQ 1 (NCHARS FNAME)) - (OR (AND (IGEQ (CHCON1 FNAME) - (CHARCODE 0)) - (ILEQ (CHCON1 FNAME) - (CHARCODE 9))) - (EQ FNAME (U-CASE NAME))))) - ELSE - - (* |;;| - "This is the preferred name. We prefer digit-names and upper-case equivalents") - - (RPLACA (CDR FOUND) - NAME))) - - (* |;;| "Coerce digit keynames to atoms") - - (FOR K IN (FETCH KEYNAMESMAPPING OF CONFIG) - WHEN (AND (SMALLP (CAR K)) - (IGEQ (CAR K) - 0) - (ILEQ (CAR K) - 9)) DO (RPLACA K (CL:INTERN (CONCAT (CAR K)) - 'INTERLISP))) - - (* |;;| "Introduce ZERO, ONE... synonyms for digit keys") - - (NCONC (FETCH KEYNAMESMAPPING OF CONFIG) - (FOR I FROM 0 AS N - IN '(ZERO ONE TWO THREE FOUR FIVE SIX SEVEN EIGHT NINE) - UNLESS (ASSOC N (FETCH KEYNAMESMAPPING OF CONFIG)) - COLLECT (LIST N (CL:INTERN (CONCAT I) - 'INTERLISP)))) - (REPLACE KEYREGIONS OF CONFIG - WITH (IF (FOR K IN (FETCH KEYREGIONS OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH KEYREGIONS OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH KEYREGIONS OF CONFIG) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K))))) - (REPLACE DEFAULTASSIGNMENT OF CONFIG - WITH (SORT (IF (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH DEFAULTASSIGNMENT OF CONFIG - ) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K)))) - T)) - - (* |;;| "Convert char-codes to characters, more or less.") - - (FIXKEYASSIGNMENTS (FETCH DEFAULTASSIGNMENT OF CONFIG) - CONFIG) - (REPLACE KEYLABELS OF CONFIG - WITH (SORT (IF (FOR K IN (FETCH KEYLABELS OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH KEYLABELS OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH KEYLABELS OF CONFIG) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K)))) - T))) - CONFIG)) (FIXKEYASSIGNMENTS - (LAMBDA (KALIST CONFIG) (* \; "Edited 7-Mar-96 11:20 by rmk") - - (* |;;| "Fix keynames and convert char-codes to characters, more or less. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") - - (* |;;| "NOTE: This uses names and character labels from CONFIG, so it should only be run with key assignments that are already CONFIG compatible.") - - (FOR KA CODE LAB (CHARLABELS _ (APPEND (FETCH CHARLABELS OF CONFIG) - VKBD.COMMONCHARLABELS)) - (KNM _ (FETCH KEYNAMESMAPPING OF CONFIG)) IN KALIST - DO - - (* |;;| "First make keynames be the ones that are used in he keymapping") - - (RPLACA KA (FOR KN FOUND IN KNM - DO - - (* |;;| "Give preference to digit-labels") - - (IF (NEQ (CAR KA) - (CADR KN)) - ELSEIF (AND (SMALLP (CAR KN)) - (IGEQ (CAR KN) - 0) - (ILEQ (CAR KN) - 9)) - THEN (RETURN (CL:INTERN (CONCAT (CAR KN) - 'INTERLISP))) - ELSEIF (AND (EQ 1 (NCHARS (CAR KN))) - (SMALLP (NTHCHAR (CAR KN) - 1))) - THEN (RETURN (CAR KN)) - ELSEIF (NOT FOUND) - THEN (SETQ FOUND (CAR KN))) - FINALLY (RETURN (OR FOUND (CAR KA))))) - - (* |;;| "Shift to actions") - - (SETQ KA (CDR KA)) - - (* |;;| "Get rid of gratuitous uptransition ignores") - - (CL:WHEN (EQ 'IGNORE (CDR KA)) - (RPLACD KA)) - - (* |;;| "Shift to down transition") - - (SETQ KA (CAR KA)) - - (* |;;| - "Make keyactions use characters in the ascii range instead of codes. 241 is Latin rendering") - - (CL:WHEN (LISTP KA) - - (* |;;| "Eliminate unnecessary NOLOCKSHIFT when lower and upper are the same") - - (IF (AND (EQ (CAR KA) - (CADR KA)) - (MEMB (CADDR KA) - '(NOLOCKSHIFT NLS))) - THEN (RPLACD (CDR KA)) - ELSE - - (* |;;| "Introduce a shorter abbreviation") - - (SELECTQ (CADDR KA) - (LOCKSHIFT (RPLACD (CDR KA) - 'LS)) - (NOLOCKSHIFT (RPLACD (CDR KA) - 'NLS)) - NIL)) - (SETQ CODE (CAR KA)) - (IF (SMALLP CODE) - THEN (RPLACA KA (IF (SMALLP CODE) - THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) - )) - ELSEIF (OR (AND (IGREATERP CODE 32) - (ILESSP CODE 255)) - (EQ (LRSH CODE 8) - 241)) - THEN (SETQ LAB (CHARACTER CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE (MKATOM (CHARCODESTRING CODE))) - ELSEIF (STRINGP CODE) - THEN (SETQ LAB (MKATOM CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE CODE))) - - (* |;;| "Shift to shift code") - - (SETQ KA (CDR KA)) - (SETQ CODE (CAR KA)) - (IF (SMALLP CODE) - THEN (RPLACA KA (IF (SMALLP CODE) - THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) - )) - ELSEIF (OR (AND (IGREATERP CODE 32) - (ILESSP CODE 255)) - (EQ (LRSH CODE 8) - 241)) - THEN (SETQ LAB (CHARACTER CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE - - (* |;;| - "Coerce to octal cset,ccode format") - - (MKATOM (CHARCODESTRING CODE))) - ELSEIF (STRINGP CODE) - THEN (SETQ LAB (MKATOM CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE CODE))))) - - (* |;;| "Remove duplicates, leaving the head of the list unchanged, and keeping first occurrences of duplicates") - - (RPLACD KALIST (FOR XTAIL X ON (CDR KALIST) EACHTIME (SETQ X (CAR XTAIL)) - UNLESS (THEREIS YTAIL ON KALIST UNTIL (EQ YTAIL XTAIL) - SUCHTHAT (EQUAL X (CAR YTAIL))) COLLECT (CAR XTAIL))) - KALIST)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (VKBD.INIT) ) (FILESLOAD ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA METASHIFT) ) (PUTPROPS VIRTUALKEYBOARDS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993 1995 1996 2017)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5192 13848 (FINDVIRTUALKEYBOARD 5202 . 8356) (PROCESS.KEYBOARD 8358 . 11034) ( VKBD.CREATE-KEYACTION-TABLE 11036 . 12952) (VKBD.WINDOWMENUFN 12954 . 13221) (VKBD.WINDOWMENUINIT 13223 . 13846)) (13849 19210 (LOADKEYBOARDDISPLAYFONTS 13859 . 19208)) (19319 20543 (DEFINEKEYBOARD 19329 . 20541)) (20544 24962 (VKBD.ADD-ITEM-TO-BACKGROUND-MENU 20554 . 20962) (VKBD.INIT 20964 . 23502 ) (VKBD.CREATE-DEFAULT-KEYBOARD 23504 . 24096) (VKBD.ADD-DEFAULT-KEYBOARD 24098 . 24960)) (24963 31303 (VKBD.LOAD-FILE-COMMAND 24973 . 25427) (VKBD.LOAD-KEYBOARD-FILE 25429 . 29264) ( VKBD.STORE-FILE-COMMAND 29266 . 29607) (VKBD.STORE-KEYBOARD-FILE 29609 . 31301)) (31304 40605 ( SWITCHKEYBOARDS 31314 . 32792) (VKBD.POP-MENU-AND-SWITCH-KEYBOARDS 32794 . 33164) ( VKBD.POP-UP-KEYBOARDS-MENU 33166 . 34548) (VKBD.GET-CONFIGURATION 34550 . 35468) ( VKBD.SUBCONFIGURATION 35470 . 40603)) (40606 80891 (VKBD.BUTTONEVENTFN 40616 . 43523) ( VKBD.CENTER-BITMAP-IN-REGION 43525 . 45049) (VKBD.CLEAR-KEY-DISPLAY 45051 . 47182) ( VKBD.CREATE-KEYBOARD-BITMAP 47184 . 49228) (VKBD.CREATE-KEYBOARD-DISPLAY 49230 . 52359) ( VKBD.CURSORMOVEDFN 52361 . 54265) (VKBD.DISPLAY-CHARACTER 54267 . 56225) (VKBD.DISPLAY-EMPTY-KEY-CAP 56227 . 66765) (VKBD.DISPLAY-KEY 66767 . 69974) (VKBD.DISPLAY-KEY-CHARACTERS 69976 . 71169) ( VKBD.DRAW-KEY-CAPS 71171 . 73359) (VKBD.ERASE-FRAME 73361 . 73684) (VKBD.EXTEND-REGION 73686 . 74275) (VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION 74277 . 74892) (VKBD.GET-KEY-REGIONS 74894 . 75150) ( VKBD.INVERT-KEY 75152 . 75442) (VKBD.INVERT-REGION 75444 . 76135) (VKBD.KEYBOARD-WINDOW-REPAINTFN 76137 . 78094) (VKBD.LOWER-HALF-REGION 78096 . 78496) (VKBD.POSITION-IS-IN-KEY-REGION 78498 . 78782) ( VKBD.REMOVE-KEYBOARD-COMMAND 78784 . 79241) (VKBD.UNION-REGIONS 79243 . 80388) (VKBD.UPPER-HALF-REGION 80390 . 80889)) (80892 99947 (VKBD.KEY-ASSOC 80902 . 81402) (VKBD.CHAR-ASSIGNMENTP 81404 . 81568) ( VKBD.COMPLETE-KEYBOARD 81570 . 84229) (VKBD.CTRL-ASSIGNMENTP 84231 . 84474) (VKBD.EVENT-ASSIGNMENTP 84476 . 84716) (VKBD.META-ASSIGNMENTP 84718 . 84961) (VKBD.FRAME-KEY 84963 . 86840) ( VKBD.GET-CURRENT-KEY-ASSIGNMENT 86842 . 87211) (VKBD.GET-NON-CHAR-LABEL 87213 . 87868) (VKBD.ICONFN 87870 . 88606) (VKBD.INVERT-LOCK-KEYS 88608 . 89286) (VKBD.INVERT-SHIFT-KEYS 89288 . 89970) ( VKBD.TRANSLATE-KEY-ID 89972 . 90651) (VKBD.KEY-ID-TO-KEY-NAMES 90653 . 91139) ( VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD 91141 . 91739) (VKBD.LOCK-ASSIGNMENTP 91741 . 92188) ( VKBD.LOCK-KEYP 92190 . 92508) (VKBD.LOCK/NOLOCK 92510 . 92669) (VKBD.LOCKDOWN-ASSIGNMENTP 92671 . 92965) (VKBD.LOCKUP-ASSIGNMENTP 92967 . 93257) (VKBD.PARSE-CHAR-CODE 93259 . 93758) ( VKBD.PARSE-KEY-ASSIGNMENT 93760 . 96713) (VKBD.RESET-KEYBOARD-WINDOW 96715 . 97308) ( VKBD.SEND-CHARACTER 97310 . 98819) (VKBD.SHIFT-ASSIGNMENTP 98821 . 99215) (VKBD.SHIFTED-CHAR 99217 . 99375) (VKBD.UNDEFINE-KEYBOARD 99377 . 99784) (VKBD.UNSHIFTED-CHAR 99786 . 99945)) (115876 118322 ( VKBD.\\KEYBOARDEVENTFN 115886 . 117089) (VKBD.RESETKEYACTIONTABLES 117091 . 118320)) (118428 124579 ( NEWKEYACTION 118438 . 124577)) (125031 126887 (METASHIFT 125041 . 126885)) (127244 143432 (FIXKEYBOARD 127254 . 128374) (FIXKEYBOARDCONFIG 128376 . 135600) (FIXKEYASSIGNMENTS 135602 . 143430))))) STOP \ No newline at end of file diff --git a/library/VIRTUALKEYBOARDS.~5~ b/library/VIRTUALKEYBOARDS.~5~ deleted file mode 100644 index a1a6c95e..00000000 --- a/library/VIRTUALKEYBOARDS.~5~ +++ /dev/null @@ -1,1489 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL" BASE 10) (FILECREATED "27-Mar-2018 12:03:18"  |{DSK}kaplan>Local>medley3.5>lispcore>library>VIRTUALKEYBOARDS.;5| |changes| |to:| (FNS VKBD.PARSE-KEY-ASSIGNMENT) |previous| |date:| "14-Jun-2017 14:22:33" |{DSK}kaplan>Local>medley3.5>lispcore>library>VIRTUALKEYBOARDS.;3|) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993, 1995, 1996, 2017, 2018 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT VIRTUALKEYBOARDSCOMS) (RPAQQ VIRTUALKEYBOARDSCOMS ((FNS FINDVIRTUALKEYBOARD PROCESS.KEYBOARD VKBD.CREATE-KEYACTION-TABLE VKBD.WINDOWMENUFN VKBD.WINDOWMENUINIT) (COMS (FNS LOADKEYBOARDDISPLAYFONTS) (INITVARS VKBD.CACHEDCHARSETS) (GLOBALVARS VKBD.CACHEDCHARSETS)) (FNS DEFINEKEYBOARD) (FNS VKBD.ADD-ITEM-TO-BACKGROUND-MENU VKBD.INIT VKBD.CREATE-DEFAULT-KEYBOARD VKBD.ADD-DEFAULT-KEYBOARD) (FNS VKBD.LOAD-FILE-COMMAND VKBD.LOAD-KEYBOARD-FILE VKBD.STORE-FILE-COMMAND VKBD.STORE-KEYBOARD-FILE) (FNS SWITCHKEYBOARDS VKBD.POP-MENU-AND-SWITCH-KEYBOARDS VKBD.POP-UP-KEYBOARDS-MENU VKBD.GET-CONFIGURATION VKBD.SUBCONFIGURATION) (FNS VKBD.BUTTONEVENTFN VKBD.CENTER-BITMAP-IN-REGION VKBD.CLEAR-KEY-DISPLAY VKBD.CREATE-KEYBOARD-BITMAP VKBD.CREATE-KEYBOARD-DISPLAY VKBD.CURSORMOVEDFN VKBD.DISPLAY-CHARACTER VKBD.DISPLAY-EMPTY-KEY-CAP VKBD.DISPLAY-KEY VKBD.DISPLAY-KEY-CHARACTERS VKBD.DRAW-KEY-CAPS VKBD.ERASE-FRAME VKBD.EXTEND-REGION VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION VKBD.GET-KEY-REGIONS VKBD.INVERT-KEY VKBD.INVERT-REGION VKBD.KEYBOARD-WINDOW-REPAINTFN VKBD.LOWER-HALF-REGION VKBD.POSITION-IS-IN-KEY-REGION VKBD.REMOVE-KEYBOARD-COMMAND VKBD.UNION-REGIONS VKBD.UPPER-HALF-REGION) (FNS VKBD.KEY-ASSOC VKBD.CHAR-ASSIGNMENTP VKBD.COMPLETE-KEYBOARD VKBD.CTRL-ASSIGNMENTP VKBD.EVENT-ASSIGNMENTP VKBD.META-ASSIGNMENTP VKBD.FRAME-KEY VKBD.GET-CURRENT-KEY-ASSIGNMENT VKBD.GET-NON-CHAR-LABEL VKBD.ICONFN VKBD.INVERT-LOCK-KEYS VKBD.INVERT-SHIFT-KEYS VKBD.TRANSLATE-KEY-ID VKBD.KEY-ID-TO-KEY-NAMES VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD VKBD.LOCK-ASSIGNMENTP VKBD.LOCK-KEYP VKBD.LOCK/NOLOCK VKBD.LOCKDOWN-ASSIGNMENTP VKBD.LOCKUP-ASSIGNMENTP VKBD.PARSE-CHAR-CODE VKBD.PARSE-KEY-ASSIGNMENT VKBD.RESET-KEYBOARD-WINDOW VKBD.SEND-CHARACTER VKBD.SHIFT-ASSIGNMENTP VKBD.SHIFTED-CHAR VKBD.UNDEFINE-KEYBOARD VKBD.UNSHIFTED-CHAR) (ALISTS (CHARACTERNAMES BREAK HOME PGUP END PGDN INS HELP SCRL NUMLK CLEAR DOIT CENTER NOTCENTER BOLD NOTBOLD ITALIC NOTITALIC UCASE LCASE STRIKEOUT NOTSTRIKEOUT UNDERLINE NOTUNDERLINE SUBSCRIPT SUPERSCRIPT SMALLER LARGER MARGINS NOTMARGINS LOOKS NOTLOOKS F11 NOTF11 F12 NOTF12)) (RECORDS KEYBOARDCONFIGURATION VIRTUALKEYBOARD) (INITVARS (VKBD.KNOWN-KEYBOARDS NIL)) (FILES (SOURCE) KEYBOARDCONFIGS) (VARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.WINDOW-MENU-SUBITEMS) (BITMAPS VKBD.ICON VKBD.MASK) (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) (COMS (DECLARE\: FIRST (P (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN))) (INITVARS (\\ORIGINALDEFAULTKEYACTION)) (FNS VKBD.\\KEYBOARDEVENTFN VKBD.RESETKEYACTIONTABLES) (P (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN))) (COMS (DECLARE\: FIRST (P (MOVD? 'KEYACTION 'OLDKEYACTION))) (FNS NEWKEYACTION) (P (MOVD 'NEWKEYACTION 'KEYACTION)) (INITVARS (MODEKEYS)) (VARS MODEACTIONS) (GLOBALVARS MODEKEYS MODEACTIONS)) (COMS (FNS METASHIFT) (* \;  "Call new definition if the old one had been called") (P (AND (EQ (MACHINETYPE) 'DORADO) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)))) (ADDVARS (BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT))) (FNS FIXKEYBOARD FIXKEYBOARDCONFIG FIXKEYASSIGNMENTS) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (VKBD.INIT))) (FILES ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA METASHIFT))))) (DEFINEQ (FINDVIRTUALKEYBOARD - (LAMBDA (KEYBOARDNAME CONFIGURATIONNAME) (* \; "Edited 27-Feb-96 10:27 by rmk") - (LET ((KBTYPE (COND - (CONFIGURATIONNAME) - ((LISTP KEYBOARDNAME) - (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) OF KEYBOARDNAME)) - ((KEYBOARDTYPE)) - (T DEFAULTVIRTUALKEYBOARDTYPE)))) - (CL:WHEN (AND (LISTP KEYBOARDNAME) - (MEMB KEYBOARDNAME VKBD.KNOWN-KEYBOARDS)) - - (* |;;| "Gave a keyboard, use it to indicate keyboard name for new configuration") - - (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARDNAME))) - - (* |;;| "Find keyboard of default type if current type doesn't exist and CONFIGURATIONNAME wasn't given--PROCESS.KEYBOARD won't switch this in. Note that a keyboard that has a NIL configuration is declared to go with anything,but we look for an explicit match first") - - (IF (FIND KB IN VKBD.KNOWN-KEYBOARDS - SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - (EQ KBTYPE (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF KB)))) - ELSEIF (FIND KB IN VKBD.KNOWN-KEYBOARDS - SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - (NULL (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF KB)))) - ELSEIF (OR (NOT CONFIGURATIONNAME) - (EQ CONFIGURATIONNAME KBTYPE)) - THEN (OR (FOR C IN (CDR (ASSOC KBTYPE KEYBOARDCONFIGCOERCIONS)) - WHEN (SETQ C (FINDVIRTUALKEYBOARD KEYBOARDNAME C)) - DO (RETURN C)) - (AND DEFAULTVIRTUALKEYBOARDTYPE (NEQ DEFAULTVIRTUALKEYBOARDTYPE KBTYPE) - (FOR KB IN VKBD.KNOWN-KEYBOARDS - WHEN (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD - KEYBOARDNAME) - OF KB)) - (EQ DEFAULTVIRTUALKEYBOARDTYPE (FETCH - (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF KB))) - DO (RETURN KB)))))))) (PROCESS.KEYBOARD (LAMBDA (PROCESS/WINDOW KEYBOARD) (* \; "Edited 23-May-95 17:00 by rmk:") (* |;;;| "Get/set the keyboard just for this process/window. Value is previous keyboard.") (PROG (KEYACTIONTABLE FOUND (PROCESS (COND ((NULL PROCESS/WINDOW) (TTY.PROCESS)) ((PROCESSP PROCESS/WINDOW) PROCESS/WINDOW) ((AND (WINDOWP PROCESS/WINDOW) (WINDOWPROP PROCESS/WINDOW 'PROCESS))) (T (THIS.PROCESS))))) (COND ((SETQ KEYACTIONTABLE (IF (AND KEYBOARD (SETQ FOUND (FINDVIRTUALKEYBOARD KEYBOARD))) THEN (* |;;| "We believe in whatever FINDVIRTUALKEYBOARD returns, even though it might not have the configuration we expect.") (* \;  "Get/create the KEYACTIONTABLE for the FOUND") (VKBD.CREATE-KEYACTION-TABLE FOUND))) (* \;  "Make sure to copy the current interrupt list.") (REPLACE (KEYACTION INTERRUPTLIST) OF KEYACTIONTABLE WITH (COPY (FETCH (KEYACTION INTERRUPTLIST) OF (OR (PROCESSPROP PROCESS 'KEYACTION) \\DEFAULTKEYACTION)))) (PROCESSPROP PROCESS 'KEYACTION KEYACTIONTABLE) (COND ((TTY.PROCESSP PROCESS) (* \; "install the key action table") (* \;  "Hack--wait until dangerous shifts are up") (|while| (OR (SHIFTDOWNP 'META) (SHIFTDOWNP 'CTRL))) (SETQ \\CURRENTKEYACTION (OR KEYACTIONTABLE (KEYACTIONTABLE))))) (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD KEYBOARD) 'DEFAULT))) (T (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD) 'DEFAULT))))))) (VKBD.CREATE-KEYACTION-TABLE - (LAMBDA (NEW-KEYBOARD OLDTABLE) (* \; "Edited 29-Feb-96 12:32 by rmk") - (PROG (KEYBOARDNAME FOUND KEYACTION-TABLE CONFIG) - (CL:UNLESS (COND - ((AND (ATOM NEW-KEYBOARD) - (SETQ FOUND (FINDVIRTUALKEYBOARD NEW-KEYBOARD))) - (SETQ NEW-KEYBOARD FOUND)) - ((MEMB NEW-KEYBOARD VKBD.KNOWN-KEYBOARDS))) - - (* |;;| "Use FOUND to preserve NEW-KEYBOARD for error") - - (ERROR "INVALID KEYBOARD" NEW-KEYBOARD)) - (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF NEW-KEYBOARD)) - (COND - (OLDTABLE (SETQ KEYACTION-TABLE (RESETKEYACTION OLDTABLE))) - ((SETQ KEYACTION-TABLE (GETPROP KEYBOARDNAME 'KEYACTIONTABLE)) - (RETURN KEYACTION-TABLE)) - (T (SETQ KEYACTION-TABLE (KEYACTIONTABLE)))) - (SETQ NEW-KEYBOARD (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD)) - (SETQ CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF NEW-KEYBOARD))) - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF NEW-KEYBOARD) DO (OLDKEYACTION (CAR - KEY-ASSIGNMENT - ) - (CDR KEY-ASSIGNMENT) - KEYACTION-TABLE)) - (PUTPROP KEYBOARDNAME 'KEYACTIONTABLE KEYACTION-TABLE) - (RETURN KEYACTION-TABLE)))) (vkbd.windowmenufn - (lambda (w) (* \; "Edited 15-Dec-87 16:27 by Snow") - - (let (keyboard) - (setq keyboard (vkbd.pop-up-keyboards-menu)) - (and keyboard (process.keyboard w keyboard))))) (vkbd.windowmenuinit - (lambda nil (* \; "Edited 15-Dec-87 16:28 by Snow") - - (setq |WindowMenuCommands| (remove (sassoc '|Keyboard| |WindowMenuCommands|) - |WindowMenuCommands|)) - (nconc1 |WindowMenuCommands| `(|Keyboard| (function (lambda (w) - (switchkeyboards t nil w))) - "Changes the keyboard associated with this window." - ,vkbd.window-menu-subitems)) - (setq |WindowMenu| nil))) ) (DEFINEQ (LOADKEYBOARDDISPLAYFONTS (LAMBDA (FONT) (* \; "Edited 13-Dec-96 17:40 by rmk:") (* \; "Edited 7-Mar-96 12:30 by rmk") (* |;;| "Insures that all the characters on virtual keycaps have been instantiated in FONT (or at least on the keycaps). Saves the needed charsets in VKBD.CACHEDCHARSETS. This means that we don't have to parse all the keyboards every time. In order to make use of the cache, we instantiate all the charsets in all the fonts that are specified in any of the keyboards or configurations.") (DECLARE (GLOBALVARS VKBD.CACHEDCHARSETS)) (CL:UNLESS VKBD.CACHEDCHARSETS (FOR K IN VKBD.KNOWN-KEYBOARDS DO (* |;;| "Ignore errorful transitions in this background function, fail when the user actually asks for the keyboard. Accumulate 0th character in each charset (presumably very few), saving them in the cache.") (FOR A TRANS CHARSETS IN (FETCH KEYASSIGNMENTS OF K) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A NIL T))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (FOR CONFIG COMMON IN VKBD.CONFIGURATIONS DO (* |;;| "We aren't letting the configs assignment override the VKBD.COMMONDEFAULTASSIGNMENT on the same key. Thus, in principle we could be instantiating a font that isn't actually needed, but this is unlikely, harmless, and not worth the bother to keep track. VKBD.COMPLETE-KEYBOARD does it right.") (FOR A TRANS IN (APPEND (FETCH DEFAULTASSIGNMENT OF CONFIG) VKBD.COMMONDEFAULTASSIGNMENT) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A CONFIG))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (SETQ VKBD.CACHEDCHARSETS (DREMOVE 0 VKBD.CACHEDCHARSETS))) (IF FONT THEN (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY)) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C FONT)) ELSE (LET (DONEFONTS) (FOR K F IN VKBD.KNOWN-KEYBOARDS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (VIRTUALKEYBOARD KEYBOARDDISPLAYFONT ) OF K) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))) (FOR CONFIG F IN VKBD.CONFIGURATIONS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) OF CONFIG) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))))))) ) (RPAQ? VKBD.CACHEDCHARSETS NIL) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.CACHEDCHARSETS) ) (DEFINEQ (DEFINEKEYBOARD - (LAMBDA (KEYBOARD-OBJECT) (* \; "Edited 28-Feb-96 11:41 by rmk") - (* \; "Edited 15-Dec-87 16:29 by Snow") - - (* |;;| - "Checks assignments before it installs, returns a copy unless the object is already known.") - - (FOR KEY-ASSIGNMENT (CONFIGURATION _ (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF - KEYBOARD-OBJECT - ))) - IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD-OBJECT) - DO (VKBD.PARSE-KEY-ASSIGNMENT KEY-ASSIGNMENT CONFIGURATION)) - (OR (FINDVIRTUALKEYBOARD KEYBOARD-OBJECT) - (CAR (PUSH VKBD.KNOWN-KEYBOARDS (COPY KEYBOARD-OBJECT)))))) ) (DEFINEQ (vkbd.add-item-to-background-menu - (lambda (label command message subitemlist) (* \; "Edited 15-Dec-87 16:29 by Snow") - - (setq |BackgroundMenuCommands| (remove (sassoc label |BackgroundMenuCommands|) - |BackgroundMenuCommands|)) - (nconc1 |BackgroundMenuCommands| (list label command message subitemlist)) - (setq |BackgroundMenu| nil))) (VKBD.INIT (LAMBDA NIL (* \; "Edited 14-Jun-2017 14:22 by kaplan") (* \; "Edited 16-Jun-92 11:14 by kaplan") (* |;;| "Reads virtual keyboard file for current type (or default type), if it can be found. Keyboards that don't match current keyboard can be displayed but not installed (via PROCESS.KEYBOARD)") (CL:UNLESS \\ORIGINALDEFAULTKEYACTION (SETQ \\ORIGINALDEFAULTKEYACTION (KEYACTIONTABLE \\DEFAULTKEYACTION))) (SETQ VKBD.COMMONCODELABELS (FOR X IN VKBD.COMMONCHARLABELS COLLECT (IF (LISTP X) THEN (IF (SMALLP (CAR X)) THEN X ELSE (LIST (CHARCODE.DECODE (CAR X)) (CADR X))) ELSE (LIST (CHARCODE.DECODE X) X)))) (VKBD.ADD-ITEM-TO-BACKGROUND-MENU "Keyboard" ''(SWITCHKEYBOARDS T NIL) "Displays a menu for switching keyboards" VKBD.BACKGROUND-MENU-SUBITEMS) (VKBD.WINDOWMENUINIT) (LET (FILE (KT (KEYBOARDTYPE))) (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION KT)) (COND ((SETQ FILE (COND ((AND KT (FINDFILE (PACK* KT "KEYBOARDS") T))) (T (FINDFILE (PACK* DEFAULTVIRTUALKEYBOARDTYPE "KEYBOARDS") T)))) (VKBD.LOAD-KEYBOARD-FILE FILE) (* |;;| "Loading a keyboard file may change our notion of KEYBOARDTYPE, because of new coercion paths. The default keyboard will be added for the new type") (VKBD.ADD-DEFAULT-KEYBOARD)) (T (* |;;| "Special printing here to avoid file-not-found error in case where user calls VKBD.LOAD-KEYBOARD-FILE directly") (PROMPTPRINT "Note: virtual keyboard file for type " (OR (KEYBOARDTYPE) DEFAULTVIRTUALKEYBOARDTYPE) " keyboards not found")))))) (VKBD.CREATE-DEFAULT-KEYBOARD - (LAMBDA (CONFIGURATION) (* \; "Edited 27-Feb-96 20:51 by rmk") - - (* |;;| "Don't bother copying in the default keyassignments, since they will always be inserted by VKBD.COMPLETE-KEYBOARD") - - (CL:WHEN (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) - (CREATE VIRTUALKEYBOARD - KEYBOARDNAME _ 'DEFAULT - KEYBOARDCONFIGURATION _ (FETCH (KEYBOARDCONFIGURATION CONFIGURATIONNAME) - OF CONFIGURATION))))) (VKBD.ADD-DEFAULT-KEYBOARD (LAMBDA (KEYBOARDTYPE) (* \; "Edited 23-May-95 17:04 by rmk:") (* |;;;| "It is useful practice to be able to switch back to the original key assignments. Thus the program is adding one special keyboard with the name DEFAULT which is the current keyboardtype's default keyboard.") (SETQ KEYBOARDTYPE (OR KEYBOARDTYPE (KEYBOARDTYPE))) (BIND DEFAULT WHILE (SETQ DEFAULT (FINDVIRTUALKEYBOARD 'DEFAULT KEYBOARDTYPE)) DO (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE DEFAULT VKBD.KNOWN-KEYBOARDS))) (SETQ VKBD.KNOWN-KEYBOARDS (CONS (VKBD.CREATE-DEFAULT-KEYBOARD KEYBOARDTYPE) VKBD.KNOWN-KEYBOARDS)) (COND ((EQ KEYBOARDTYPE (KEYBOARDTYPE)) (VKBD.CREATE-KEYACTION-TABLE 'DEFAULT \\DEFAULTKEYACTION))))) ) (DEFINEQ (VKBD.LOAD-FILE-COMMAND - (LAMBDA (REDEFINE? DELETE-FIRST?) (* \; "Edited 3-Mar-96 18:16 by rmk") - (* \; "Edited 15-Dec-87 16:30 by Snow") - (LET (F) - (SETQ F (MKATOM (PROMPTFORWORD "Keyboard file name: " NIL NIL PROMPTWINDOW NIL 'TTY))) - (IF F - THEN (VKBD.LOAD-KEYBOARD-FILE F REDEFINE? DELETE-FIRST? T))))) (VKBD.LOAD-KEYBOARD-FILE - (LAMBDA (FILENAME REDEFINE? DELETE-CURRENT-DEFINITIONS? PROMPTPRINT) - (* \; "Edited 4-Mar-96 10:53 by rmk") - - (* |;;| "Note: Can't switch to READFILE, since it uses OLD-INTERLISP readtable which doesn't honor vertical bars around numeric atoms.") - - (LET ((NEWKEYBOARDS (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :INPUT) - (BIND KB DATE (*PACKAGE* _ *INTERLISP-PACKAGE*) - (RDTBL _ (FIND-READTABLE "INTERLISP")) - FIRST (SETQ DATE (READ STREAM RDTBL)) - (CL:UNLESS (LISTP DATE) - (CL:WHEN (STRINGP DATE) - (SETQ DATE (CONCAT "Keyboards from " (FULLNAME STREAM - ) - " [" DATE "]")) - (IF PROMPTPRINT - THEN (PROMPTPRINT DATE) - ELSE (PRINTOUT T DATE T))) - (SETQ DATE NIL)) WHILE (SKIPSEPRCODES STREAM RDTBL) - UNTIL (EQ 'STOP (SETQ KB (READ STREAM RDTBL))) COLLECT - KB - FINALLY (CL:WHEN DATE - - (* |;;| - "Was a LISTP date, must have been a keyboard") - - (PUSH DATE $$VAL)))))) - (COND - (DELETE-CURRENT-DEFINITIONS? (SETQ VKBD.KNOWN-KEYBOARDS NEWKEYBOARDS) - (VKBD.ADD-DEFAULT-KEYBOARD)) - (T (FOR NEWKEYBOARD KN KC IN NEWKEYBOARDS - DO - - (* |;;| -"To make sure that COMPLETEDASSIGNMENTS cell (or any other new cells) exist--backward compatibility") - - (SETQ NEWKEYBOARD (CREATE VIRTUALKEYBOARD USING NEWKEYBOARD)) - (SETQ KN (FETCH KEYBOARDNAME OF NEWKEYBOARD)) - (SETQ KC (FETCH KEYBOARDCONFIGURATION OF NEWKEYBOARD)) - (FOR TAIL OLDKEYBOARD ON VKBD.KNOWN-KEYBOARDS - WHEN (AND (EQ KN (FETCH KEYBOARDNAME OF (SETQ OLDKEYBOARD - (CAR TAIL)))) - (EQ KC (FETCH KEYBOARDCONFIGURATION OF OLDKEYBOARD)) - ) DO - - (* |;;| "If REDEFINE?, then replace one with same name and configuration. Otherwise, keep the old one instead of installing the new one.") - - (COND - (REDEFINE? (RPLACA TAIL NEWKEYBOARD)) - (T (RETURN))) FINALLY (SETQ - VKBD.KNOWN-KEYBOARDS - (NCONC1 - VKBD.KNOWN-KEYBOARDS - NEWKEYBOARD)))) - ))))) (vkbd.store-file-command - (lambda (f) (* \; "Edited 15-Dec-87 16:31 by Snow") - - (setq f (promptforword "ENTER FILE NAME: " nil nil promptwindow nil 'tty)) - (|if| f - |then| (vkbd.store-keyboard-file (mkatom f)) - |else| (promptprint "FILE NOT FOUND")))) (VKBD.STORE-KEYBOARD-FILE - (LAMBDA (FILENAME CONFIGURATIONNAME) (* \; "Edited 4-Mar-96 13:38 by rmk") - - (* |;;| "COMPLETEDKEYASSIGNMENTS are in a separate hasharray, don't get printed. Can't use WRITEFILE because of vertical-bar problems") - - (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) - (LET ((RDTBL (FIND-READTABLE "INTERLISP"))) - (PRINT (DATE) - STREAM RDTBL) - (IF CONFIGURATIONNAME - THEN (FOR KB IN VKBD.KNOWN-KEYBOARDS - WHEN (EQ CONFIGURATIONNAME (FETCH (VIRTUALKEYBOARD - KEYBOARDCONFIGURATION - ) OF KB)) - UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - DO (PRINT KB STREAM RDTBL)) - ELSE (* \; - "Don't print DEFAULT keyboards, since they are reconstructed from configuration") - (FOR KB IN VKBD.KNOWN-KEYBOARDS - UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) DO (PRINT KB STREAM RDTBL)))) - (PROMPTPRINT (CONCAT "Current known keyboards are stored in " FILENAME)) - (FULLNAME STREAM)))) ) (DEFINEQ (SWITCHKEYBOARDS - (LAMBDA (SWITCH-FLG DISPLAY-FLG PROCESS NEW-KEYBOARD DISPLAY-POSITION) - (* \; "Edited 27-Feb-96 12:35 by rmk") - (* \; "Edited 15-Dec-87 16:32 by Snow") - -(* |;;;| "This is the main function of the package. SWITCH-FLG and DISPLAY-FLG will produce the 3 logical combinations of switching a keyboard. The 4th comb NIl & NIL is NOOP. Any change of the KEYACTION handeling should be reflected here.") - - (PROG (WINDOW) - (COND - ((NULL NEW-KEYBOARD) - (SETQ NEW-KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU)))) - (COND - ((LITATOM NEW-KEYBOARD) - (SETQ NEW-KEYBOARD (FINDVIRTUALKEYBOARD NEW-KEYBOARD)))) - (COND - ((NULL NEW-KEYBOARD) - (RETURN NIL))) - (COND - (SWITCH-FLG (PROCESS.KEYBOARD PROCESS NEW-KEYBOARD))) - (COND - (DISPLAY-FLG (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD) - - (* |;;| "This is necessary to enable the menu to generate the right characters for the keys that are defaulted") - - (* |;;| "(RETURN OLD-KEYACTIONS)") - - (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY NEW-KEYBOARD DISPLAY-POSITION - (FUNCTION VKBD.SEND-CHARACTER)))))))) (vkbd.pop-menu-and-switch-keyboards - (lambda (process switch-flg display-flg) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (prog (keyboard) - (setq keyboard (vkbd.pop-up-keyboards-menu "Select an alternative keyboard")) - (|if| keyboard - |then| (switchkeyboards keyboard switch-flg display-flg))))) (VKBD.POP-UP-KEYBOARDS-MENU - (LAMBDA (PROMPT-STRING) (* \; "Edited 27-Feb-96 13:22 by rmk") - (* \; "Edited 16-Jun-92 11:35 by kaplan") - (COND - (PROMPT-STRING (PROMPTPRINT PROMPT-STRING) - (FLASHWINDOW PROMPTWINDOW 1))) - (LET ((KEYBOARDTYPES `(NIL ,(KEYBOARDTYPE) - ,@(CDR (ASSOC (KEYBOARDTYPE) - KEYBOARDCONFIGCOERCIONS)) - ,DEFAULTVIRTUALKEYBOARDTYPE))) - (MENU (CREATE MENU - ITEMS _ (CONS '(|Quit| NIL) - (SORT (FOR K IN VKBD.KNOWN-KEYBOARDS - WHEN (MEMB (FETCH KEYBOARDCONFIGURATION - OF K) - KEYBOARDTYPES) - UNLESS (MEMB (FETCH KEYBOARDNAME OF K) - $$VAL) - COLLECT (FETCH KEYBOARDNAME OF K)) - (FUNCTION UALPHORDER))) - MENUFONT _ BIGFONT))))) (VKBD.GET-CONFIGURATION - (LAMBDA (CONFNAME/WINDOW) (* \; "Edited 27-Feb-96 11:13 by rmk") - - (* |;;| "NIL means use the CURRENTKEYBOARDCONFIG, if it exists") - - (COND - ((WINDOWP CONFNAME/WINDOW) - (SETQ CONFNAME/WINDOW (|fetch| (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - |of| (WINDOWPROP CONFNAME/WINDOW 'VKBD.KEYBOARD))))) - (COND - ((AND CONFNAME/WINDOW (|type?| KEYBOARDCONFIGURATION CONFNAME/WINDOW)) - CONFNAME/WINDOW) - ((AND (NULL CONFNAME/WINDOW) - CURRENTKEYBOARDCONFIG)) - ((FASSOC (OR CONFNAME/WINDOW VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) - VKBD.CONFIGURATIONS)) - (T (FOR C IN (CDR (ASSOC CONFNAME/WINDOW KEYBOARDCONFIGCOERCIONS)) - WHEN (SETQ C (FASSOC C VKBD.CONFIGURATIONS)) DO (RETURN C)))))) (VKBD.SUBCONFIGURATION (LAMBDA (FULL NEWNAME LOWERLEFTKEY UPPERRIGHTKEY SCALE MARGIN) (* \; "Edited 8-Oct-96 12:28 by rmk:") (* |;;| "Returns a sub-configuration of FULL, including only keys that lie completely within the region enclosed by the bounding box of LOWERLEFTKEY and UPPERRIGHTKEY. Translates regions so that origin is the lower-left corner of the lower-left key.") (SETQ FULL (VKBD.GET-CONFIGURATION FULL)) (CL:UNLESS MARGIN (SETQ MARGIN 0)) (LET (NEWREGIONS (LEFT 65535) (BOTTOM 65535) (TOP 0) (RIGHT 0)) (CL:UNLESS NEWNAME (SETQ NEWNAME (FETCH CONFIGURATIONNAME OF FULL))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC LOWERLEFTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" LOWERLEFTKEY)) DO (CL:WHEN (ILESSP (FETCH LEFT OF R) LEFT) (SETQ LEFT (FETCH LEFT OF R))) (CL:WHEN (ILESSP (FETCH BOTTOM OF R) BOTTOM) (SETQ BOTTOM (FETCH BOTTOM OF R)))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC UPPERRIGHTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" UPPERRIGHTKEY)) DO (CL:WHEN (IGREATERP (FETCH RIGHT OF R) RIGHT) (SETQ RIGHT (FETCH RIGHT OF R))) (CL:WHEN (IGREATERP (FETCH TOP OF R) TOP) (SETQ TOP (FETCH TOP OF R)))) (SETQ NEWREGIONS (FOR KR IN (FETCH KEYREGIONS OF FULL) WHEN (FOR R IN (CDR KR) ALWAYS (AND (IGEQ (FETCH LEFT OF R) LEFT) (IGEQ (FETCH BOTTOM OF R) BOTTOM) (ILEQ (FETCH TOP OF R) TOP) (ILEQ (FETCH RIGHT OF R) RIGHT))) COLLECT (CONS (CAR KR) (FOR R IN (CDR KR) COLLECT (IF SCALE THEN (CREATE REGION LEFT _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH LEFT OF R) LEFT)))) BOTTOM _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))) WIDTH _ (FIXR (TIMES SCALE (FETCH WIDTH OF R))) HEIGHT _ (FIXR (TIMES SCALE (FETCH HEIGHT OF R)))) ELSE (CREATE REGION USING R LEFT _ (+ MARGIN (- (FETCH LEFT OF R) LEFT)) BOTTOM _ (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))))))) (CREATE KEYBOARDCONFIGURATION COPYING FULL CONFIGURATIONNAME _ NEWNAME KEYREGIONS _ NEWREGIONS DEFAULTASSIGNMENT _ (FOR A IN (FETCH DEFAULTASSIGNMENT OF FULL) WHEN (VKBD.KEY-ASSOC (CAR A) NEWREGIONS FULL) COLLECT (COPY A)))))) ) (DEFINEQ (vkbd.buttoneventfn - (lambda (window) (* \; "Edited 15-Dec-87 16:32 by Snow") - -(* |;;;| "This is a general 'menu' function for the keyboard when used as a menu --- it is used for all such uses: When displaying a virtual keyboard, when editing one and when editing a default assignments for a configuration. The only difference is what will be the action taken when a KEY was selected. This will be determined by the property VKBD.MENUFN which specify the name of the function that should be called. This function will get 3 arguments : The KEYID, the WINDOW and the mouse key; In the regular keyboard display this function will send a character to the system buffer. In the Editor it will make the key the CURRENT key. In the configuration info window it will display information about the key") - - (prog (mouse-position shaded-key last-mouse-key current-key-and-regions shift-is-down) - (setq mouse-position (cursorposition nil window)) - (totopw window) (* \; - "This should be checked if changes to the keyboard handling is done") - - (setq shift-is-down (or (keydownp 'rshift) - (keydownp 'lshift))) - (setq shaded-key (windowprop window 'vkbd.shaded-key)) - (setq last-mouse-key (windowprop window 'vkbd.mouse-button)) - (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position - mouse-position window)) - (cond - ((mousestate up) - (cond - ((and shaded-key (eq shaded-key (car current-key-and-regions))) - (apply (windowprop window 'vkbd.menufn) - (list (windowprop window 'vkbd.shaded-key) - window - (windowprop window 'vkbd.last-mouse-state))) - (vkbd.reset-keyboard-window window)))) - ((or (mousestate (only left)) - (mousestate (only middle))) - (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) - (|for| region |in| (cdr current-key-and-regions) |do| (vkbd.invert-region - region window)) - (windowprop window 'vkbd.last-mouse-state (cond - ((lastmousestate (only left)) - 'left) - (t 'middle))) - (cond - ((or shift-is-down (lastmousestate (only middle))) - (vkbd.invert-shift-keys window) - (windowprop window 'vkbd.shift-down t)))))))) (vkbd.center-bitmap-in-region - (lambda (bm region window allignment) (* \; "Edited 15-Dec-87 16:32 by Snow") - - (bitblt bm 0 0 window (iplus (|fetch| (region left) |of| region) - (iquotient (idifference (|fetch| (region width) |of| region) - (bitmapwidth bm)) - 2)) - (cond - ((greaterp (bitmapheight bm) - (|fetch| (region height) |of| region)) - (cond - ((eq allignment 'top) - (idifference (|fetch| (region bottom) |of| region) - (idifference (bitmapheight bm) - (|fetch| (region height) |of| region)))) - ((eq allignment 'bottom) - (|fetch| (region bottom) |of| region)) - (t (iplus (|fetch| (region bottom) |of| region) - (iquotient (idifference (|fetch| (region height) |of| region) - (bitmapheight bm)) - 2))))) - (t (iplus (|fetch| (region bottom) |of| region) - (iquotient (idifference (|fetch| (region height) |of| region) - (bitmapheight bm)) - 2)))) - nil nil 'input 'paint))) (VKBD.CLEAR-KEY-DISPLAY - (LAMBDA (KEY-REGIONS VKBD-WINDOW) (* \; "Edited 27-Feb-96 13:50 by rmk") - (FOR REGION LEFT BOTTOM WIDTH HEIGHT IN KEY-REGIONS - DO (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)) - (BITBLT NIL NIL NIL VKBD-WINDOW (ADD1 LEFT) - (ADD1 BOTTOM) - (IDIFFERENCE WIDTH 2) - (IDIFFERENCE HEIGHT 2) - 'TEXTURE - 'REPLACE WHITESHADE) - (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (ADD1 BOTTOM) - (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - BOTTOM) - (BITMAPBIT VKBD-WINDOW LEFT (ADD1 BOTTOM)))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (ADD1 BOTTOM) - (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - BOTTOM) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) - (ADD1 BOTTOM)))) - (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) - (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (IPLUS BOTTOM (ADD1 HEIGHT))) - (BITMAPBIT VKBD-WINDOW LEFT (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) - (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (IPLUS BOTTOM (SUB1 HEIGHT)))))))) (VKBD.CREATE-KEYBOARD-BITMAP - (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:45 by rmk") - (* \; "Edited 15-Dec-87 16:35 by Snow") - (LET (BM KEYS-REGION BM-WIDTH BM-HEIGHT MAX-REGION) - (COND - ((ATOM CONFIGURATION) - (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)))) - (SETQ MAX-REGION (VKBD.UNION-REGIONS CONFIGURATION)) - (SETQ BM-WIDTH (IPLUS (ITIMES 2 (FETCH (REGION LEFT) OF MAX-REGION)) - (FETCH (REGION WIDTH) OF MAX-REGION))) - (SETQ BM-HEIGHT (IPLUS (ITIMES 2 (FETCH (REGION BOTTOM) OF MAX-REGION)) - (FETCH (REGION HEIGHT) OF MAX-REGION))) - (SETQ BM (BITMAPCREATE BM-WIDTH BM-HEIGHT)) - (BITBLT NIL NIL NIL BM 0 0 BM-WIDTH BM-HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM 1 1 (IDIFFERENCE BM-WIDTH 2) - (IDIFFERENCE BM-HEIGHT 2) - 'TEXTURE - 'REPLACE - (FETCH (KEYBOARDCONFIGURATION BACKGROUNDSHADE) OF CONFIGURATION)) - (FOR KEY-AND-REGIONS IN (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF - CONFIGURATION - ) DO - - (* |;;| - "CDR cause odd-shaped keys (like ENTER) are described by multiple regions") - - (VKBD.DISPLAY-EMPTY-KEY-CAP (CDR - KEY-AND-REGIONS - ) - BM)) - BM))) (VKBD.CREATE-KEYBOARD-DISPLAY - (LAMBDA (KEYBOARD MENU-POSITION MENU-FUNCTION BM SHOWCONFIG) - (* \; "Edited 28-Feb-96 12:02 by rmk") - (* \; "Edited 25-May-95 11:33 by rmk:") - (* \; "Edited 20-Apr-89 13:26 by atm") - (LET (WINDOW WINDOW-WIDTH WINDOW-HEIGHT KEYBOARD-BITMAP CONFIGURATION) - (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION (|fetch| KEYBOARDCONFIGURATION - |of| KEYBOARD))) - (SETQ KEYBOARD-BITMAP (OR BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIGURATION))) - (SETQ WINDOW-WIDTH (IPLUS 8 (BITMAPWIDTH KEYBOARD-BITMAP))) - (SETQ WINDOW-HEIGHT (IPLUS 18 (BITMAPHEIGHT KEYBOARD-BITMAP))) - (CL:UNLESS MENU-POSITION - (SETQ MENU-POSITION (GETBOXPOSITION WINDOW-WIDTH WINDOW-HEIGHT))) - (SETQ WINDOW (CREATEW (CREATEREGION (|fetch| (POSITION XCOORD) |of| MENU-POSITION) - (|fetch| (POSITION YCOORD) |of| MENU-POSITION) - WINDOW-WIDTH WINDOW-HEIGHT) - (CONCAT "Virtual Keyboard : " (|fetch| (VIRTUALKEYBOARD KEYBOARDNAME - ) |of| KEYBOARD) - (CL:IF SHOWCONFIG - (CONCAT " for " (|fetch| (VIRTUALKEYBOARD - KEYBOARDCONFIGURATION) - |of| KEYBOARD)) - "")))) - (WINDOWPROP WINDOW 'VKBD.KEYBOARD KEYBOARD) - (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION VKBD.BUTTONEVENTFN)) - (WINDOWPROP WINDOW 'CURSORMOVEDFN (FUNCTION VKBD.CURSORMOVEDFN)) - (WINDOWPROP WINDOW 'CURSOROUTFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) - (WINDOWPROP WINDOW 'CURSORINFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) - (WINDOWPROP WINDOW 'VKBD.MENUFN MENU-FUNCTION) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION VKBD.KEYBOARD-WINDOW-REPAINTFN)) - (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 0 (BITMAPWIDTH KEYBOARD-BITMAP) - (BITMAPHEIGHT KEYBOARD-BITMAP))) - (WINDOWPROP WINDOW 'ICONFN (FUNCTION VKBD.ICONFN)) - (WINDOWPROP WINDOW 'VKBD.KEYBOARDDISPLAYFONT (OR (|fetch| (VIRTUALKEYBOARD - KEYBOARDDISPLAYFONT) - |of| KEYBOARD) - DEFAULTKEYBOARDDISPLAYFONT)) - (REDISPLAYW WINDOW) - WINDOW))) (vkbd.cursormovedfn - (lambda (window) (* \; "Edited 15-Dec-87 16:41 by Snow") - - (prog (mouse-position shaded-key current-key-and-regions shift-is-down) - (setq mouse-position (cursorposition nil window)) - (setq shaded-key (windowprop window 'vkbd.shaded-key)) - (setq shift-is-down (or (keydownp 'lshift) - (keydownp 'rshift))) - (cond - (shaded-key (cond - ((not (vkbd.position-is-in-key-region shaded-key mouse-position - window)) - (vkbd.reset-keyboard-window window)) - (t (return t))))) - (cond - ((mousestate (or (only left) - (only middle))) - (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position - mouse-position window)) - (cond - (current-key-and-regions (|for| region |in| (cdr current-key-and-regions) - |do| (vkbd.invert-region region window)) - (cond - ((or shift-is-down (lastmousestate (only middle))) - (vkbd.invert-shift-keys window) - (windowprop window 'vkbd.shift-down t))) - (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) - (windowprop window 'vkbd.last-mouse-state (cond - ((lastmousestate (only left)) - 'left) - (t 'middle)))))))))) (VKBD.DISPLAY-CHARACTER - (LAMBDA (CHAR REGION CHARLABELS WINDOW CONF ALLIGNMENT)(* \; "Edited 7-Mar-96 02:14 by rmk") - (* \; "Edited 17-Feb-95 12:58 by rmk:") - (LET (CHARLABEL) - (SETQ REGION (VKBD.EXTEND-REGION REGION -1)) - (COND - ((SETQ CHARLABEL (CADR (OR (FASSOC CHAR CHARLABELS) - (FASSOC CHAR VKBD.COMMONCODELABELS)))) - (DSPFONT (OR (|fetch| (KEYBOARDCONFIGURATION KEYLABELSFONT) |of| CONF) - DEFAULTKEYBOARDLABELSFONT) - WINDOW) - (CENTERPRINTINREGION CHARLABEL REGION WINDOW)) - (T (VKBD.CENTER-BITMAP-IN-REGION (GETCHARBITMAP CHAR - (FONTCREATE (OR (WINDOWPROP WINDOW - - ' - VKBD.KEYBOARDDISPLAYFONT - ) - (|fetch| ( - KEYBOARDCONFIGURATION - - KEYBOARDDISPLAYFONT - ) |of| - CONF) - DEFAULTKEYBOARDDISPLAYFONT))) - REGION WINDOW ALLIGNMENT)))))) (VKBD.DISPLAY-EMPTY-KEY-CAP - (LAMBDA (KEY-REGIONS BM) (* \; "Edited 27-Feb-96 13:32 by rmk") - (LET (LEFT BOTTOM WIDTH HEIGHT) - (FOR REGION IN KEY-REGIONS - DO (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)) - (BITBLT NIL NIL NIL BM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM (ADD1 LEFT) - (ADD1 BOTTOM) - (IDIFFERENCE WIDTH 2) - (IDIFFERENCE HEIGHT 2) - 'TEXTURE - 'REPLACE WHITESHADE) - (BITMAPBIT BM LEFT BOTTOM 0) - (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) - BOTTOM 0) - (BITMAPBIT BM LEFT (IPLUS BOTTOM (SUB1 HEIGHT)) - 0) - (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) - (IPLUS BOTTOM (SUB1 HEIGHT)) - 0)) - (COND - ((CDR KEY-REGIONS) - (FOR REGION1 IN KEY-REGIONS - DO (FOR REGION2 IN KEY-REGIONS BIND INTERSECT - DO (COND - ((NOT (EQUAL REGION1 REGION2)) - (SETQ INTERSECT (INTERSECTREGIONS - (CREATEREGION (SUB1 (FETCH (REGION LEFT) - OF REGION1)) - (SUB1 (FETCH (REGION BOTTOM) - OF REGION1)) - (IPLUS (FETCH (REGION WIDTH) - OF REGION1) - 2) - (IPLUS (FETCH (REGION HEIGHT) - OF REGION1) - 2)) - (CREATEREGION (SUB1 (FETCH (REGION LEFT) - OF REGION2)) - (SUB1 (FETCH (REGION BOTTOM) - OF REGION2)) - (IPLUS (FETCH (REGION WIDTH) - OF REGION2) - 2) - (IPLUS (FETCH (REGION HEIGHT) - OF REGION2) - 2)))) - (COND - (INTERSECT (COND - ((GREATERP (FETCH (REGION HEIGHT) - OF INTERSECT) - (FETCH (REGION WIDTH) OF - INTERSECT - )) - (SETQ INTERSECT - (CREATEREGION (FETCH (REGION LEFT) - OF INTERSECT) - (ADD1 (FETCH (REGION BOTTOM) - OF INTERSECT)) - (FETCH (REGION WIDTH) OF - INTERSECT) - (IDIFFERENCE (FETCH (REGION HEIGHT - ) - OF INTERSECT) - 2))) - (BITBLT NIL NIL NIL BM (FETCH (REGION - LEFT) - OF INTERSECT) - (FETCH (REGION BOTTOM) OF - INTERSECT) - (FETCH (REGION WIDTH) OF - INTERSECT - ) - (FETCH (REGION HEIGHT) OF - INTERSECT) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM (FETCH (REGION - LEFT) - OF INTERSECT) - (ADD1 (FETCH (REGION BOTTOM) - OF INTERSECT)) - (FETCH (REGION WIDTH) OF - INTERSECT - ) - (IDIFFERENCE (FETCH (REGION HEIGHT) - OF INTERSECT) - 2) - 'TEXTURE - 'REPLACE WHITESHADE)) - (T (SETQ INTERSECT - (CREATEREGION (ADD1 (FETCH (REGION - LEFT) - OF INTERSECT)) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (IDIFFERENCE (FETCH (REGION - WIDTH) - OF INTERSECT) - 2) - (FETCH (REGION HEIGHT) - OF INTERSECT))) - (BITBLT NIL NIL NIL BM (FETCH - (REGION LEFT) - OF INTERSECT) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (FETCH (REGION WIDTH) - OF INTERSECT) - (FETCH (REGION HEIGHT) - OF INTERSECT) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM - (ADD1 (FETCH (REGION LEFT) - OF INTERSECT)) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (IDIFFERENCE (FETCH (REGION - WIDTH) - OF INTERSECT) - 2) - (FETCH (REGION HEIGHT) - OF INTERSECT) - 'TEXTURE - 'REPLACE WHITESHADE)))))))))))))) (VKBD.DISPLAY-KEY - (LAMBDA (KEYID WINDOW CONFIG KEYLABELS CHARLABELS KEYREGIONS) - (* \; "Edited 7-Mar-96 01:53 by rmk") - (* \; "Edited 15-Dec-87 17:40 by Snow") - (SETQ KEYID (VKBD.TRANSLATE-KEY-ID KEYID CONFIG)) - (LET (KEY-ASSIGNMENT LABEL-STRING KEYREGIONS) - (CL:WHEN (OR KEYREGIONS (SETQ KEYREGIONS (CDR (VKBD.KEY-ASSOC KEYID (FETCH - ( - KEYBOARDCONFIGURATION - KEYREGIONS) - OF CONFIG) - CONFIG)))) - - (* |;;| "If the REGION doesn't exist, we can't display it. E.g., our picture doesn't include the F1 keys. CAR because some keys (e.g. for ENTER) are defined by two rectangles") - - (VKBD.CLEAR-KEY-DISPLAY KEYREGIONS WINDOW) - (SETQ KEYLABELS (OR KEYLABELS (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG - ))) - (COND - ((SETQ LABEL-STRING (CADR (VKBD.KEY-ASSOC KEYID KEYLABELS CONFIG)))) - (T (SETQ KEY-ASSIGNMENT (VKBD.KEY-ASSOC KEYID (FETCH (VIRTUALKEYBOARD - COMPLETEKEYASSIGNMENTS - ) - OF (WINDOWPROP WINDOW - 'VKBD.KEYBOARD)) - CONFIG)) - (SETQ LABEL-STRING (VKBD.GET-NON-CHAR-LABEL KEY-ASSIGNMENT)))) - (COND - (LABEL-STRING (DSPFONT (OR (FETCH (KEYBOARDCONFIGURATION KEYLABELSFONT) - OF CONFIG) - DEFAULTKEYBOARDLABELSFONT) - WINDOW) - (COND - ((AND (LISTP LABEL-STRING) - (CDR LABEL-STRING)) - (CENTERPRINTINREGION (CAR LABEL-STRING) - (VKBD.UPPER-HALF-REGION (CAR KEYREGIONS)) - WINDOW) - (CENTERPRINTINREGION (CADR LABEL-STRING) - (VKBD.LOWER-HALF-REGION (CAR KEYREGIONS)) - WINDOW)) - (T (CENTERPRINTINREGION LABEL-STRING (CAR KEYREGIONS) - WINDOW)))) - (T (VKBD.DISPLAY-KEY-CHARACTERS KEY-ASSIGNMENT (CAR KEYREGIONS) - WINDOW CONFIG CHARLABELS))))))) (VKBD.DISPLAY-KEY-CHARACTERS - (LAMBDA (KEY-ASSIGNMENT KEY-REGION WINDOW CONFIG CHARLABELS) - (* \; "Edited 7-Mar-96 01:15 by rmk") - (LET (SHIFTED-CHAR UNSHIFTED-CHAR) - (COND - ((AND KEY-ASSIGNMENT (LISTP (CADR KEY-ASSIGNMENT))) - (CL:WHEN KEY-REGION - (SETQ SHIFTED-CHAR (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) - (SETQ UNSHIFTED-CHAR (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)) - (COND - ((EQ SHIFTED-CHAR UNSHIFTED-CHAR) - (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR KEY-REGION CHARLABELS WINDOW CONFIG)) - (T (VKBD.DISPLAY-CHARACTER UNSHIFTED-CHAR (VKBD.LOWER-HALF-REGION - KEY-REGION) - CHARLABELS WINDOW CONFIG 'BOTTOM) - (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR (VKBD.UPPER-HALF-REGION - KEY-REGION) - CHARLABELS WINDOW CONFIG 'TOP))))))))) (VKBD.DRAW-KEY-CAPS - (LAMBDA (LIST-OF-REGIONS BITMAP) (* \; "Edited 13-Jun-90 01:10 by mitani") - (|for| REGION |in| LIST-OF-REGIONS |do| (BITBLT NIL NIL NIL BITMAP - (|fetch| (REGION LEFT) - |of| REGION) - (|fetch| (REGION BOTTOM) - |of| REGION) - (|fetch| (REGION WIDTH) - |of| REGION) - (|fetch| (REGION HEIGHT) - |of| REGION) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BITMAP - (ADD1 (|fetch| (REGION LEFT) - |of| REGION)) - (ADD1 (|fetch| (REGION BOTTOM) - |of| REGION)) - (IDIFFERENCE (|fetch| (REGION WIDTH) - |of| REGION) - 2) - (IDIFFERENCE (|fetch| (REGION HEIGHT) - |of| REGION) - 2) - 'TEXTURE - 'REPLACE WHITESHADE)))) (vkbd.erase-frame - (lambda (key window framesize) (* \; "Edited 15-Dec-87 16:42 by Snow") - - (vkbd.frame-key key window (|fetch| (keyboardconfiguration backgroundshade) - |of| (vkbd.get-configuration window)) - framesize))) (vkbd.extend-region - (lambda (region nbits) (* \; "Edited 15-Dec-87 16:42 by Snow") - - (cond - ((null nbits) - (setq nbits 1))) - (createregion (idifference (|fetch| (region left) |of| region) - nbits) - (idifference (|fetch| (region bottom) |of| region) - nbits) - (iplus (|fetch| (region width) |of| region) - (itimes nbits 2)) - (iplus (|fetch| (region height) |of| region) - (itimes nbits 2))))) (vkbd.get-key-and-regions-of-cursor-position - (lambda (cursor-position window) (* \; "Edited 15-Dec-87 16:43 by Snow") - - (|for| key-regions |in| (|fetch| (keyboardconfiguration keyregions) - |of| (vkbd.get-configuration window)) - |thereis| (|for| region |in| (cdr key-regions) |thereis| (insidep region - cursor-position - ))))) (VKBD.GET-KEY-REGIONS - (LAMBDA (KEY-ID CONFIG) (* \; "Edited 27-Feb-96 21:18 by rmk") - (CDR (VKBD.KEY-ASSOC KEY-ID (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF CONFIG) - CONFIG)))) (VKBD.INVERT-KEY - (LAMBDA (KEY-ID VKBD-WINDOW) (* \; "Edited 27-Feb-96 21:14 by rmk") - (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY-ID (VKBD.GET-CONFIGURATION VKBD-WINDOW)) - DO (VKBD.INVERT-REGION REGION VKBD-WINDOW)))) (vkbd.invert-region - (lambda (region window) (* \; "Edited 15-Dec-87 16:46 by Snow") - - (|if| region - |then| (bitblt window (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - window - (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - (|fetch| (region width) |of| region) - (|fetch| (region height) |of| region) - 'invert - 'replace)))) (VKBD.KEYBOARD-WINDOW-REPAINTFN - (LAMBDA (WINDOW) (* \; "Edited 7-Mar-96 13:38 by rmk") - (LET (BM KEYLABELS CHARLABELS (CONFIG (VKBD.GET-CONFIGURATION WINDOW)) - (KEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD))) - (SETQ KEYLABELS (FOR K IN (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG - ) COLLECT (LIST (VKBD.TRANSLATE-KEY-ID - (CAR K) - CONFIG) - (CADR K)))) - - (* |;;| "Build this up each time, so that the keyids are specialized to this keyboard. But the internal search will be much faster. ") - - (FOR K TR IN VKBD.COMMONKEYLABELS WHEN (SETQ TR (VKBD.TRANSLATE-KEY-ID - (CAR K) - CONFIG)) - UNLESS (ASSOC TR KEYLABELS) DO (PUSH KEYLABELS (LIST TR (CADR K)))) - (SETQ CHARLABELS (FETCH (KEYBOARDCONFIGURATION CHARLABELS) OF CONFIG)) - (SETQ BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIG)) - (BITBLT BM 0 0 WINDOW) - - (* |;;| "Display all the keys") - - (FOR R IN (FETCH KEYREGIONS OF CONFIG) - DO (VKBD.DISPLAY-KEY (VKBD.TRANSLATE-KEY-ID (CAR R) - CONFIG) - WINDOW CONFIG KEYLABELS CHARLABELS (CDR R))) - (COND - ((WINDOWPROP WINDOW 'VKBD.LOCKED) - (VKBD.INVERT-LOCK-KEYS WINDOW))) - (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL) - (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (vkbd.lower-half-region - (lambda (region) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (createregion (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - (|fetch| (region width) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)))) (VKBD.POSITION-IS-IN-KEY-REGION - (LAMBDA (KEY POSITION WINDOW) (* \; "Edited 27-Feb-96 21:21 by rmk") - (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY (VKBD.GET-CONFIGURATION WINDOW)) - THEREIS (INSIDEP REGION POSITION)))) (vkbd.remove-keyboard-command - (lambda nil (* \; "Edited 15-Dec-87 16:49 by Snow") - - (prog (k) - (setq k (vkbd.pop-up-keyboards-menu "Select keyboard to be removed .")) - (|if| k - |then| (vkbd.undefine-keyboard k) - (printout promptwindow "Keyboard " k - " was removed from the list of known keyboards. "))))) (VKBD.UNION-REGIONS - (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:47 by rmk") - - (* |;;| "Don't let too many arguments pile up on the stack.") - - (LET ((KEYREGS (FETCH KEYREGIONS OF CONFIGURATION))) - (APPLY 'UNIONREGIONS (WHILE KEYREGS - COLLECT (APPLY 'UNIONREGIONS - (WHILE KEYREGS FOR I VAL FROM 1 - TO 50 - DO - - (* |;;| - "CDR because odd-shaped keys (e.g. ENTER) have multiple regions") - - (FOR R - IN (CDR (POP KEYREGS)) - DO (PUSH VAL R)) - FINALLY (RETURN VAL)))))))) (vkbd.upper-half-region - (lambda (region) (* |sm| "13-Aug-85 10:38") - (createregion (|fetch| (region left) |of| region) - (iplus 1 (|fetch| (region bottom) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)) - (|fetch| (region width) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)))) ) (DEFINEQ (VKBD.KEY-ASSOC (LAMBDA (KEY ALIST CONFIG) (* \; "Edited 5-Oct-96 16:59 by rmk:") (* \; "Edited 27-Feb-96 21:07 by rmk") (CL:WHEN (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (FIND C IN ALIST SUCHTHAT (EQ (VKBD.TRANSLATE-KEY-ID (CAR C) CONFIG) KEY))))) (VKBD.CHAR-ASSIGNMENTP - (LAMBDA (ASSIGNMENT) (* \; "Edited 26-Feb-96 16:49 by rmk") - (LISTP (CADR ASSIGNMENT)))) (VKBD.COMPLETE-KEYBOARD - (LAMBDA (KEYBOARD) (* \; "Edited 7-Mar-96 13:25 by rmk") - - (* |;;| "Fill in keys that aren't mentioned in the new keyboard, using the configuration's default. Put the parsed results in the COMPLETEKEYASSIGNMENTS field, for future use. This field is not written out by the STORE-KEYBOARD function.") - - (CL:UNLESS (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - (LET (COMPLETE-ASSIGNMENTS (CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF KEYBOARD) - ))) - - (* |;;| "The assignment comes from the keyboard (PARTIAL), the configuration default, or the common default assignments.") - - (FOR K A CA IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD) - DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) - (IF (NULL (SETQ CA (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS))) - THEN (PUSH COMPLETE-ASSIGNMENTS A) - ELSEIF (EQUAL A CA) - ELSE (ERROR "INCOMPATIBLE ASSIGNMENTS OF KEY NUMBER" - (LIST K A CA)))) - (FOR K A IN (FETCH (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) OF CONFIG) - DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) - (CL:UNLESS (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS) - (PUSH COMPLETE-ASSIGNMENTS A))) - - (* |;;| "The configs defaultassignment can override the VKBD.COMMONDEFAULTASSIGNMENT") - - (FOR K A IN VKBD.COMMONDEFAULTASSIGNMENT WHEN (SETQ A ( - VKBD.PARSE-KEY-ASSIGNMENT - K CONFIG T)) - DO (CL:UNLESS (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS) - (PUSH COMPLETE-ASSIGNMENTS A))) - (REPLACE COMPLETEKEYASSIGNMENTS OF KEYBOARD WITH COMPLETE-ASSIGNMENTS))) - KEYBOARD)) (vkbd.ctrl-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:33 by Snow") - - (and (eq (cadr assignment) - 'ctrldown) - (eq (cddr assignment) - 'ctrlup)))) (vkbd.event-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") - - (and (eq (cadr assignment) - 'event) - (eq (cddr assignment) - 'event)))) (vkbd.meta-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") - - (and (eq (cadr assignment) - 'metadown) - (eq (cddr assignment) - 'metaup)))) (VKBD.FRAME-KEY - (LAMBDA (KEY WINDOW SHADE BITS) (* \; "Edited 29-Feb-96 11:06 by rmk") - (LET ((CONFIG (VKBD.GET-CONFIGURATION WINDOW)) - KEY-REGIONS) - (SETQ KEY-REGIONS (VKBD.GET-KEY-REGIONS KEY CONFIG)) - (FOR REGION EXTENDED-REGION IN KEY-REGIONS DO (SETQ EXTENDED-REGION - (VKBD.EXTEND-REGION REGION - BITS)) - (BITBLT NIL NIL NIL WINDOW - (FETCH (REGION LEFT) - OF EXTENDED-REGION) - (FETCH (REGION BOTTOM) - OF EXTENDED-REGION) - (FETCH (REGION WIDTH) - OF EXTENDED-REGION) - (FETCH (REGION HEIGHT) - OF EXTENDED-REGION) - 'TEXTURE - 'REPLACE SHADE)) - (VKBD.DISPLAY-EMPTY-KEY-CAP KEY-REGIONS WINDOW) - (VKBD.DISPLAY-KEY KEY WINDOW CONFIG) - (IF (EQ (WINDOWPROP WINDOW 'VKBD.SHADED-KEY) - KEY) - THEN (VKBD.INVERT-KEY KEY WINDOW))))) (VKBD.GET-CURRENT-KEY-ASSIGNMENT - (LAMBDA (KEY WINDOW/CONFIGURATION) (* \; "Edited 7-Mar-96 12:33 by rmk") - (* \; "Edited 15-Dec-87 16:43 by Snow") - (CONS KEY (KEYACTION (OR (VKBD.TRANSLATE-KEY-ID KEY WINDOW/CONFIGURATION) - KEY))))) (vkbd.get-non-char-label - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:44 by Snow") - - (cond - ((vkbd.shift-assignmentp key-assignment) - "SHIFT") - ((vkbd.lock-assignmentp key-assignment) - "LOCK") - ((vkbd.ctrl-assignmentp key-assignment) - "CTRL") - ((vkbd.lockup-assignmentp key-assignment) - '("LOCK" "UP")) - ((vkbd.lockdown-assignmentp key-assignment) - '("LOCK" "DOWN")) - ((vkbd.meta-assignmentp key-assignment) - "META") - ((vkbd.event-assignmentp key-assignment) - " ") - (t nil)))) (vkbd.iconfn - (lambda (window icon) (* \; "Edited 15-Dec-87 16:44 by Snow") - - (cond - ((null icon) - (setq icon (titlediconw (|create| titledicon - icon _ vkbd.icon - mask _ vkbd.mask - titlereg _ (createregion 5 15 80 50)) - (|fetch| (virtualkeyboard keyboardname) |of| (windowprop - window - 'vkbd.keyboard)) - (fontcreate 'gacha 8))))) - icon)) (VKBD.INVERT-LOCK-KEYS - (LAMBDA (WINDOW) (* \; "Edited 26-Feb-96 17:04 by rmk") - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) - WHEN (VKBD.LOCK-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR - KEY-ASSIGNMENT - ) - WINDOW)))) (VKBD.INVERT-SHIFT-KEYS - (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:13 by rmk") - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) - WHEN (VKBD.SHIFT-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR - KEY-ASSIGNMENT - ) - WINDOW)))) (VKBD.TRANSLATE-KEY-ID - (LAMBDA (KEY-ID CONFIG) (* \; "Edited 7-Mar-96 12:28 by rmk") - - (* |;;| "Assumes that KEY-ID's that look like key numbers ARE key numbers. Thus, integers in the range [0,\\NKEYS) can't be used as ID's. Returns NIL if the KEY-ID doesn't exist") - - (OR (KEYNUMBERP KEY-ID) - (LET ((NUM (CADR (ASSOC KEY-ID (FETCH KEYNAMESMAPPING OF CONFIG))))) - - (* |;;| - "If result is not a keynumber, then try recursing. Introduces a synonym facility") - - (OR (KEYNUMBERP NUM) - (AND NUM (VKBD.TRANSLATE-KEY-ID NUM CONFIG))))))) (vkbd.key-id-to-key-names - (lambda (key-id window/configuration) (* \; "Edited 15-Dec-87 16:46 by Snow") - - (setq window/configuration (vkbd.get-configuration window/configuration)) - (|for| name-id-pair |in| (|fetch| (keyboardconfiguration keynamesmapping) - |of| window/configuration) - |when| (eq (cadr name-id-pair) - key-id) |collect| (car name-id-pair)))) (VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD (LAMBDA (KEYBOARD) (* \; "Edited 24-May-95 15:25 by rmk:") (* |;;| "T if this keyboard is configured for the current physical keyboardtype.") (MEMB (FETCH (KEYBOARDCONFIGURATION KEYBOARDTYPE) OF (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KEYBOARD))) (ASSOC (KEYBOARDTYPE) KEYBOARDCONFIGCOERCIONS)))) (VKBD.LOCK-ASSIGNMENTP - (LAMBDA (ASSIGNMENT) (* \; "Edited 28-Feb-96 14:33 by rmk") - (* \; "Edited 15-Dec-87 16:47 by Snow") - (SELECTQ (CADR ASSIGNMENT) - (LOCKDOWN (EQ (CDDR ASSIGNMENT) - 'LOCKUP)) - (LOCKTOGGLE (MEMB (CDDR ASSIGNMENT) - '(NIL IGNORE))) - NIL))) (VKBD.LOCK-KEYP - (LAMBDA (KEY WINDOW) (* \; "Edited 26-Feb-96 17:05 by rmk") - (VKBD.LOCK-ASSIGNMENTP (FASSOC KEY (|fetch| (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - |of| (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))))) (vkbd.lock/nolock - (lambda (key-action) (* \; "Edited 15-Dec-87 16:47 by Snow") - - (caddr (cadr key-action)))) (vkbd.lockdown-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:47 by Snow") - - (and (eq (cadr assignment) - 'lockdown) - (or (null (cddr assignment)) - (eq (cddr assignment) - 'ignore))))) (vkbd.lockup-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (and (eq (cadr assignment) - 'lockup) - (or (null (cddr assignment)) - (eq (cddr assignment) - 'ignore))))) (VKBD.PARSE-CHAR-CODE - (LAMBDA (CHARSPEC) (* \; "Edited 29-Feb-96 10:29 by rmk") - - (* |;;| - "Does the coercion to a character code, causing error if not possible. NIL is passed through.") - - (COND - ((AND (SMALLP CHARSPEC) - (IGEQ CHARSPEC 0) - (ILEQ CHARSPEC 65535)) - CHARSPEC) - ((CHARCODE.DECODE CHARSPEC T)) - (CHARSPEC (ERROR "ILLEGAL CHARACTER SPECIFICATION" CHARSPEC))))) (VKBD.PARSE-KEY-ASSIGNMENT (LAMBDA (KEY-ASSIGNMENT CONFIG UNKNOWNOK) (* \; "Edited 27-Mar-2018 12:03 by rmk:") (* \; "Edited 27-Mar-2018 12:02 by rmk:") (* \; "Edited 27-Mar-2018 12:00 by rmk:") (* \; "Edited 13-Dec-96 17:26 by rmk:") (* \; "Edited 7-Mar-96 12:29 by rmk") (* |;;| "Parses a key assignment using information in CONFIG. Value returned is an image of the key assignment with the key coerced to a keynumber and also the character specifications coerced to codes. This is what goes into the COMPLETEKEYASSIGNMENTS field. If UNKNOWNOK, returns NIL as the keyid if it isn't found in the CONFIG (or if the CONFIG isn't given (on calls from LOADKEYBOARDDISPLAYFONTS).") (PROG (KEY TRKEY UNSHIFTED-CHAR SHIFTED-CHAR LOCK/NOLOCK DOWN UP) (CL:UNLESS (CDR (LISTP KEY-ASSIGNMENT)) (ERROR "ILLEGAL KEY ASSIGNMENT" KEY-ASSIGNMENT)) (SETQ KEY (CAR KEY-ASSIGNMENT)) (CL:UNLESS (SETQ TRKEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (CL:UNLESS UNKNOWNOK (ERROR (CONCAT "KEY NOT KNOWN IN CONFIGURATION " (FETCH CONFIGURATIONNAME OF CONFIG)) KEY-ASSIGNMENT))) (OR T (CL:UNLESS (VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) (* |;;| "Not sure what else it should be. Perhaps cause an error?") (RETURN NIL))) (CL:WHEN (LISTP (SETQ DOWN (CADR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR DOWN))) (* \;  "RMK: LOCKSHIFT is in CADDDR not CADDR") (SETQ DOWN (LIST (VKBD.PARSE-CHAR-CODE (CAR DOWN)) (IF (CADR DOWN) THEN (VKBD.PARSE-CHAR-CODE (CADR DOWN)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDDR DOWN) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (CL:WHEN (LISTP (SETQ UP (CDDR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR UP))) (SETQ UP (LIST (VKBD.PARSE-CHAR-CODE (CAR UP)) (IF (CADR UP) THEN (VKBD.PARSE-CHAR-CODE (CADR UP)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR UP) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (RETURN `(,TRKEY ,DOWN ,@UP))))) (VKBD.RESET-KEYBOARD-WINDOW - (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:22 by rmk") - (LET (SHADED-KEY) - (IF (SETQ SHADED-KEY (WINDOWPROP WINDOW 'VKBD.SHADED-KEY)) - THEN (VKBD.INVERT-KEY SHADED-KEY WINDOW) - (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL)) - (IF (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) - THEN (VKBD.INVERT-SHIFT-KEYS WINDOW) - (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN NIL)) - (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (VKBD.SEND-CHARACTER - (LAMBDA (KEY WINDOW) (* \; "Edited 28-Feb-96 14:35 by rmk") - (LET (KEY-ASSIGNMENT CHAR-CODE (CONFIG (VKBD.GET-CONFIGURATION WINDOW))) - (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) - (COND - ((VKBD.LOCK-KEYP KEY WINDOW) - (WINDOWPROP WINDOW 'VKBD.LOCKED (NOT (WINDOWPROP WINDOW 'VKBD.LOCKED))) - (VKBD.INVERT-LOCK-KEYS WINDOW)) - (T (SETQ KEY-ASSIGNMENT (FASSOC KEY (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))) - (COND - ((VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) - (SETQ CHAR-CODE (COND - ((OR (KEYDOWNP 'RSHIFT) - (KEYDOWNP 'LSHIFT) - (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) - (AND (EQ (VKBD.LOCK/NOLOCK KEY-ASSIGNMENT) - 'LOCKSHIFT) - (WINDOWPROP WINDOW 'VKBD.LOCKED))) - (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) - (T (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)))) - (COND - (CHAR-CODE (BKSYSBUF (CHARACTER CHAR-CODE))))))))))) (vkbd.shift-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (or (and (eq (cadr assignment) - '1shiftdown) - (eq (cddr assignment) - '1shiftup)) - (and (eq (cadr assignment) - '2shiftdown) - (eq (cddr assignment) - '2shiftup))))) (vkbd.shifted-char - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (cadadr key-assignment))) (VKBD.UNDEFINE-KEYBOARD (LAMBDA (KEYBOARD-NAME) (* \; "Edited 25-May-95 11:45 by rmk:") (IF (EQ KEYBOARD-NAME 'DEFAULT) THEN (PROMPTPRINT "Cannot delete the default keyboard. ") ELSE (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE (FINDVIRTUALKEYBOARD KEYBOARD-NAME) VKBD.KNOWN-KEYBOARDS))))) (vkbd.unshifted-char - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (caadr key-assignment))) ) (ADDTOVAR CHARACTERNAMES (BREAK 2) (HOME 524) (PGUP 525) (END 527) (PGDN 528) (INS 529) (HELP 517) (SCRL 521) (NUMLK 522) (CLEAR 523) (DOIT 555) (CENTER 577) (NOTCENTER 609) (BOLD 578) (NOTBOLD 610) (ITALIC 579) (NOTITALIC 611) (UCASE 580) (LCASE 612) (STRIKEOUT 581) (NOTSTRIKEOUT 613) (UNDERLINE 582) (NOTUNDERLINE 614) (SUBSCRIPT 583) (SUPERSCRIPT 615) (SMALLER 584) (LARGER 616) (MARGINS 585) (NOTMARGINS 617) (LOOKS 587) (NOTLOOKS 619) (F11 588) (NOTF11 620) (F12 589) (NOTF12 621)) (DECLARE\: EVAL@COMPILE (RECORD KEYBOARDCONFIGURATION (CONFIGURATIONNAME KBCDUMMY1 KEYREGIONS KBCDUMMY2 DEFAULTASSIGNMENT KEYNAMESMAPPING KEYBOARDTYPE KEYLABELS KEYLABELSFONT BACKGROUNDSHADE KEYBOARDDISPLAYFONT CHARLABELS) (* |;;| "Dummy fields so length test still works") (TYPE? (EQLENGTH DATUM (CONSTANT (LENGTH (RECORDFIELDNAMES ' KEYBOARDCONFIGURATION ))))) KEYBOARDTYPE _ (KEYBOARDTYPE) KEYLABELSFONT _ DEFAULTKEYBOARDLABELSFONT BACKGROUNDSHADE _ 23130 KEYBOARDDISPLAYFONT _ DEFAULTKEYBOARDDISPLAYFONT) (RECORD VIRTUALKEYBOARD (KEYBOARDNAME KEYASSIGNMENTS KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) (HASHLINK VIRTUALKEYBOARD (COMPLETEKEYASSIGNMENTS VKBDHASHARRAY 20))) ) (DECLARE\: EVAL@COMPILE (GLOBALVARS VKBDHASHARRAY)) (SETUPHASHARRAY 'VKBDHASHARRAY 20) (RPAQ? VKBD.KNOWN-KEYBOARDS NIL) (FILESLOAD (SOURCE) KEYBOARDCONFIGS) (RPAQQ VKBD.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" '(ADD.PROCESS '(SWITCHKEYBOARDS T)) "Switches the key actions of the keyborad.") ("Switch and display" '(ADD.PROCESS '(SWITCHKEYBOARDS T T)) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" '(ADD.PROCESS '(SWITCHKEYBOARDS NIL T)) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" '(ADD.PROCESS '(VKBD.STORE-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Stores the current known keyboards") ("Load keyboards file" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL T) 'WINDOW PROMPTWINDOW) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL NIL) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND T NIL) 'WINDOW PROMPTWINDOW) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" '(ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)) "Removes a keyboard from the list of known keyboards") ("Edit" (ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" (SUBITEMS ("New Keyboard, default initial" '(ADD.PROCESS '( VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" ) ("New keyboard, other initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will pop up a menu of the current known keyboards. The selected one will be used as the initial keyboard" ) ("Existing keyboard" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND)) "Will let you select a keyboard from list of the known keyboards, and will calls the keyboard editor on the selected keyboard." ))))) (RPAQQ VKBD.NON-CHAR-ASSIGNMENTS-LABELS ((SHIFT SHIFT) (CTRL CTRL) (META META) (LOCK LOCK) (LOCKUP LOCKUP) (LOCKDOWN LOCKDOWN))) (RPAQQ VKBD.WINDOW-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T NIL W))) "Switches the key actions of the keyborad.") ("Switch and display" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T T W))) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS NIL T W))) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION (VKBD.STORE-FILE-COMMAND)) 'WINDOW PROMPTWINDOW))) "Stores the current known keyboards") ("Load keyboards file" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION (VKBD.LOAD-FILE-COMMAND) ) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND NIL T)) 'WINDOW PROMPTWINDOW))) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND )) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND T NIL)) 'WINDOW PROMPTWINDOW))) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" (FUNCTION (LAMBDA (W) (ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)))) "Removes a keyboard from the list of known keyboards"))) (RPAQQ VKBD.ICON #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HDNGAHLG@HDBA@HDBA@HDBA@HD@GAHLGOOOOOOOOOOOOOOOOOOOOAHLG@BA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBAFGAHLG@BA@HDBA@HDBA@HDBA@GAHLGOOOOOOOOOOOOOOOOOOHGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HHGAHLGOOOOOOOOOOOOOOOOOOOOAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (RPAQQ VKBD.MASK #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) ) (DECLARE\: FIRST (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN) ) (RPAQ? \\ORIGINALDEFAULTKEYACTION ) (DEFINEQ (VKBD.\\KEYBOARDEVENTFN - (LAMBDA (FDEV EVENT EXTRA) (* \; "Edited 1-Mar-96 23:27 by rmk") - - (* |;;| "call the old keyboard event function, then make sure to reset the Virtual keyboard keyaction tables. ") - - (\\OLDKEYBOARDEVENTFN FDEV EVENT EXTRA) - (SELECTQ EVENT - ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) - (SETQ \\VKBD.KEYBOARD.BEFORETYPE (KEYBOARDTYPE))) - ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) - (CL:UNLESS (EQ (KEYBOARDTYPE) - \\VKBD.KEYBOARD.BEFORETYPE) - (SETQ VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) - (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION (KEYBOARDTYPE))) - - (* |;;| "If keyboardtype has changed, we start by setting default keyaction table to the settings it had at the time that virtualkeyboards was originally loaded.") - - (RESETKEYACTION \\DEFAULTKEYACTION \\ORIGINALDEFAULTKEYACTION T) - (VKBD.ADD-DEFAULT-KEYBOARD VKBD.DEFAULT-CONFIGURATION-NAME) - (VKBD.RESETKEYACTIONTABLES))) - NIL))) (VKBD.RESETKEYACTIONTABLES - (LAMBDA NIL (* \; "Edited 4-Mar-96 13:49 by rmk") - (* \; "Edited 16-Feb-95 18:23 by rmk:") - - (* |;;| "Reinstantiate/recomplete all keyboards that were previously operational, and insure that there is a DEFAULT for the new type. Probably should also redraw any open keyboard windows...later.") - - (CL:UNLESS (FINDVIRTUALKEYBOARD 'DEFAULT) - - (* |;;| "This will look for new keyboard files whenever real keyboard changes.") - - (VKBD.INIT)) - (CLRHASH VKBDHASHARRAY) - - (* |;;| "Throw away any cached information, including COMPLETEKEYASSIGNMENTS") - - (FOR KEYBOARD TABLE IN VKBD.KNOWN-KEYBOARDS - DO (CL:WHEN (SETQ TABLE (GETPROP (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARD - ) - 'KEYACTIONTABLE)) - (VKBD.CREATE-KEYACTION-TABLE (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KEYBOARD) - TABLE))))) ) (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN) (DECLARE\: FIRST (MOVD? 'KEYACTION 'OLDKEYACTION) ) (DEFINEQ (NEWKEYACTION - (LAMBDA (KEYNAME ACTIONS TABLE) (* \; "Edited 7-Mar-96 11:10 by rmk") - - (* |;;| "\\NKEYS is a constant from LLKEY.") - - (PROG (KEYBOARD (KEYNUM (OR (VKBD.TRANSLATE-KEY-ID KEYNAME CURRENTKEYBOARDCONFIG) - (\\KEYNAMETONUMBER KEYNAME)))) - - (* |;;| "Handle the NIL-TABLE cases.") - - (COND - ((AND (NULL TABLE) - (LISTP ACTIONS) - (OR (FMEMB (CAR ACTIONS) - MODEACTIONS) - (FMEMB (CDR ACTIONS) - MODEACTIONS))) - - (* |;;| "If we are setting a mode (as opposed to a character) key, assume that it is intended to be set in all keyboards where that key is still an appropriate mode") - - (FOR KEYBOARD KEYACTION (ORIGKEYACTION _ (CDR (FASSOC KEYNUM \\ORIGKEYACTIONS))) - (MODEACTION _ (CDR (FASSOC KEYNUM MODEKEYS))) IN VKBD.KNOWN-KEYBOARDS - DO (SETQ KEYACTION (CDR (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS - OF KEYBOARD)))) - (COND - ((EQUAL KEYACTION ACTIONS)) - ((OR (NULL KEYACTION) - (EQUAL KEYACTION ORIGKEYACTION) - (EQUAL KEYACTION MODEACTION)) - (NEWKEYACTION KEYNAME ACTIONS KEYBOARD))) - FINALLY (RPLACD (OR (FASSOC KEYNUM MODEKEYS) - (CAR (PUSH MODEKEYS (CONS KEYNUM)))) - ACTIONS)) - (RETURN T) (* \; - "This will cause an error if we try to pass it back in. What else can we do?") - )) - -(* |;;;| "get the keyboard or key action table.") - - (COND - ((NULL TABLE) - (SETQ TABLE \\CURRENTKEYACTION)) - ((LITATOM TABLE) - (COND - ((SETQ KEYBOARD (FASSOC TABLE VKBD.KNOWN-KEYBOARDS)) - (SETQ TABLE (GETPROP TABLE 'KEYACTIONTABLE))) - (T (ERROR TABLE "is not a defined keyboard.")))) - ((LISTP TABLE) - (COND - ((FMEMB TABLE VKBD.KNOWN-KEYBOARDS) - (SETQ KEYBOARD TABLE) - (SETQ TABLE (GETPROP (FETCH KEYBOARDNAME OF TABLE) - 'KEYACTIONTABLE))) - (T (ERROR TABLE "is not a defined keyboard.")))) - (T (FOR VKBD IN VKBD.KNOWN-KEYBOARDS - WHEN (EQ TABLE (GETPROP (FETCH KEYBOARDNAME OF VKBD) - 'KEYACTIONTABLE)) DO (SETQ KEYBOARD VKBD)))) - - (* |;;| "If TABLE is NIL, means that we are setting a virtual keyboard for which a keyaction table hasn't yet been created.") - - (RETURN - (PROG1 - (COND - (TABLE (OLDKEYACTION KEYNUM ACTIONS TABLE)) - (KEYBOARD (* \; - "virtual keyboard package allows incomplete keyboards with defaults from \\ORIGKEYACTIONS.") - (CDR (IF (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - THEN (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS - OF KEYBOARD)) - ELSE (LET (A) - (IF (SETQ A (OR (VKBD.KEY-ASSOC KEYNAME - (FETCH KEYASSIGNMENTS - OF KEYBOARD) - CURRENTKEYBOARDCONFIG) - (VKBD.KEY-ASSOC KEYNAME - (FETCH DEFAULTASSIGNMENT - OF - CURRENTKEYBOARDCONFIG - ) - CURRENTKEYBOARDCONFIG) - (VKBD.KEY-ASSOC KEYNAME - VKBD.COMMONDEFAULTASSIGNMENT - CURRENTKEYBOARDCONFIG))) - THEN (VKBD.PARSE-KEY-ASSIGNMENT A - CURRENTKEYBOARDCONFIG) - ELSE (FASSOC KEYNUM \\ORIGKEYACTIONS)))))) - (T (SHOULDNT))) - (COND - ((AND KEYBOARD ACTIONS) - - (* |;;| -"Set the keyaction in the virtual keyboard, which keeps it consistent with the corresponding table.") - - (CL:WHEN (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - (PUTASSOC KEYNUM (CDR (VKBD.PARSE-KEY-ASSIGNMENT (CONS KEYNUM ACTIONS) - CURRENTKEYBOARDCONFIG)) - (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD))) - (IF (FETCH KEYASSIGNMENTS OF KEYBOARD) - THEN (PUTASSOC KEYNAME ACTIONS (FETCH KEYASSIGNMENTS OF KEYBOARD)) - ELSE (PUSH (FETCH KEYASSIGNMENTS OF KEYBOARD) - (CONS KEYNAME ACTIONS)))))))))) ) (MOVD 'NEWKEYACTION 'KEYACTION) (RPAQ? MODEKEYS ) (RPAQQ MODEACTIONS (EVENT CTRLUP CTRLDOWN 1SHIFTUP 1SHIFTDOWN 2SHIFTUP 2SHIFTDOWN LOCKUP LOCKDOWN LOCKTOGGLE METAUP METADOWN FONTUP FONTDOWN FONTTOGGLE USERMODE1UP USERMODE1DOWN USERMODE1TOGGLE USERMODE2UP USERMODE2DOWN USERMODE2TOGGLE USERMODE3UP USERMODE3DOWN USERMODE3TOGGLE)) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MODEKEYS MODEACTIONS) ) (DEFINEQ (METASHIFT - (LAMBDA FLG (* \; "Edited 16-Jun-92 08:44 by rmk:") - - (* |;;| "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting. Returns previous setting. This differs from LLKEY version in that it changes the \\DORADOKEYACTIONS and \\DEFAULTKEYACTION table to insure that the metashift remains in effect across keyboard switches.") - - (PROG* ((METASTATUS '(METADOWN . METAUP)) - (ARGUMENT (AND (IGREATERP FLG 0) - (COND - ((EQ (ARG FLG 1) - T) - METASTATUS) - (T (OR (ARG FLG 1) - (CDR (ASSOC 'BLANK-BOTTOM \\ORIGKEYACTIONS))))))) - OLDSETTING) - (SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM ARGUMENT)) - - (* |;;| - "Update \\doradokeyactions table so we don't lose the change when we repalce the keyaction table.") - - (AND (EQ (MACHINETYPE) - 'DORADO) - (COND - (ARGUMENT (PUTASSOC 'BLANK-BOTTOM ARGUMENT \\DORADOKEYACTIONS) - (KEYACTION 'BLANK-BOTTOM ARGUMENT \\DEFAULTKEYACTION)) - (T (SETQ \\DORADOKEYACTIONS (|for| X |in| \\DORADOKEYACTIONS - |join| (AND (NEQ (CAR X) - 'BLANK-BOTTOM) - (LIST X)))) - (KEYACTION 'BLANK-BOTTOM NIL \\DEFAULTKEYACTION)))) - (RETURN (COND - ((EQUAL OLDSETTING METASTATUS) - T) - (T OLDSETTING)))))) ) (* \; "Call new definition if the old one had been called") (AND (EQ (MACHINETYPE) 'DORADO) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)) (ADDTOVAR BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT)) (DEFINEQ (FIXKEYBOARD - (LAMBDA (KBD) (* \; "Edited 28-Feb-96 13:36 by rmk") - - (* |;;| "This is a function use to coerce existing keyboards into a more reasonable format. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") - - (LET ((KC (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KBD)))) - - (* |;;| "Fix keyassignments and then remove duplicates of default keyassignments") - - (REPLACE KEYASSIGNMENTS OF KBD - WITH (SORT (FOR KA (DEF _ (FETCH DEFAULTASSIGNMENT OF KC)) - IN (FIXKEYASSIGNMENTS (FETCH KEYASSIGNMENTS OF KBD) - KC) UNLESS (MEMBER KA DEF) COLLECT KA) - T))))) (FIXKEYBOARDCONFIG - (LAMBDA (CONFIG) (* \; "Edited 29-Feb-96 13:27 by rmk") - - (* |;;| "Makes sure that CONFIG obeys keynaming conventions that force all reference to be by name and insure that names are not digits.") - - (LET (KEYNUMBERTONAME) - (FOR KN NAME FNAME FOUND IN (FETCH KEYNAMESMAPPING OF CONFIG) - DO (SETQ NAME (IF (AND (SMALLP (CAR KN)) - (IGEQ (CAR KN) - 0) - (ILEQ (CAR KN) - 9)) - THEN (CL:INTERN (CONCAT (CAR KN)) - 'INTERLISP) - ELSE (CAR KN))) - (IF (NULL (SETQ FOUND (ASSOC (CADR KN) - KEYNUMBERTONAME))) - THEN (PUSH KEYNUMBERTONAME (LIST (CADR KN) - NAME)) - ELSEIF (OR (EQ NAME (SETQ FNAME (CADR FOUND))) - (AND (EQ 1 (NCHARS FNAME)) - (OR (AND (IGEQ (CHCON1 FNAME) - (CHARCODE 0)) - (ILEQ (CHCON1 FNAME) - (CHARCODE 9))) - (EQ FNAME (U-CASE NAME))))) - ELSE - - (* |;;| - "This is the preferred name. We prefer digit-names and upper-case equivalents") - - (RPLACA (CDR FOUND) - NAME))) - - (* |;;| "Coerce digit keynames to atoms") - - (FOR K IN (FETCH KEYNAMESMAPPING OF CONFIG) - WHEN (AND (SMALLP (CAR K)) - (IGEQ (CAR K) - 0) - (ILEQ (CAR K) - 9)) DO (RPLACA K (CL:INTERN (CONCAT (CAR K)) - 'INTERLISP))) - - (* |;;| "Introduce ZERO, ONE... synonyms for digit keys") - - (NCONC (FETCH KEYNAMESMAPPING OF CONFIG) - (FOR I FROM 0 AS N - IN '(ZERO ONE TWO THREE FOUR FIVE SIX SEVEN EIGHT NINE) - UNLESS (ASSOC N (FETCH KEYNAMESMAPPING OF CONFIG)) - COLLECT (LIST N (CL:INTERN (CONCAT I) - 'INTERLISP)))) - (REPLACE KEYREGIONS OF CONFIG - WITH (IF (FOR K IN (FETCH KEYREGIONS OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH KEYREGIONS OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH KEYREGIONS OF CONFIG) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K))))) - (REPLACE DEFAULTASSIGNMENT OF CONFIG - WITH (SORT (IF (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH DEFAULTASSIGNMENT OF CONFIG - ) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K)))) - T)) - - (* |;;| "Convert char-codes to characters, more or less.") - - (FIXKEYASSIGNMENTS (FETCH DEFAULTASSIGNMENT OF CONFIG) - CONFIG) - (REPLACE KEYLABELS OF CONFIG - WITH (SORT (IF (FOR K IN (FETCH KEYLABELS OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH KEYLABELS OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH KEYLABELS OF CONFIG) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K)))) - T))) - CONFIG)) (FIXKEYASSIGNMENTS - (LAMBDA (KALIST CONFIG) (* \; "Edited 7-Mar-96 11:20 by rmk") - - (* |;;| "Fix keynames and convert char-codes to characters, more or less. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") - - (* |;;| "NOTE: This uses names and character labels from CONFIG, so it should only be run with key assignments that are already CONFIG compatible.") - - (FOR KA CODE LAB (CHARLABELS _ (APPEND (FETCH CHARLABELS OF CONFIG) - VKBD.COMMONCHARLABELS)) - (KNM _ (FETCH KEYNAMESMAPPING OF CONFIG)) IN KALIST - DO - - (* |;;| "First make keynames be the ones that are used in he keymapping") - - (RPLACA KA (FOR KN FOUND IN KNM - DO - - (* |;;| "Give preference to digit-labels") - - (IF (NEQ (CAR KA) - (CADR KN)) - ELSEIF (AND (SMALLP (CAR KN)) - (IGEQ (CAR KN) - 0) - (ILEQ (CAR KN) - 9)) - THEN (RETURN (CL:INTERN (CONCAT (CAR KN) - 'INTERLISP))) - ELSEIF (AND (EQ 1 (NCHARS (CAR KN))) - (SMALLP (NTHCHAR (CAR KN) - 1))) - THEN (RETURN (CAR KN)) - ELSEIF (NOT FOUND) - THEN (SETQ FOUND (CAR KN))) - FINALLY (RETURN (OR FOUND (CAR KA))))) - - (* |;;| "Shift to actions") - - (SETQ KA (CDR KA)) - - (* |;;| "Get rid of gratuitous uptransition ignores") - - (CL:WHEN (EQ 'IGNORE (CDR KA)) - (RPLACD KA)) - - (* |;;| "Shift to down transition") - - (SETQ KA (CAR KA)) - - (* |;;| - "Make keyactions use characters in the ascii range instead of codes. 241 is Latin rendering") - - (CL:WHEN (LISTP KA) - - (* |;;| "Eliminate unnecessary NOLOCKSHIFT when lower and upper are the same") - - (IF (AND (EQ (CAR KA) - (CADR KA)) - (MEMB (CADDR KA) - '(NOLOCKSHIFT NLS))) - THEN (RPLACD (CDR KA)) - ELSE - - (* |;;| "Introduce a shorter abbreviation") - - (SELECTQ (CADDR KA) - (LOCKSHIFT (RPLACD (CDR KA) - 'LS)) - (NOLOCKSHIFT (RPLACD (CDR KA) - 'NLS)) - NIL)) - (SETQ CODE (CAR KA)) - (IF (SMALLP CODE) - THEN (RPLACA KA (IF (SMALLP CODE) - THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) - )) - ELSEIF (OR (AND (IGREATERP CODE 32) - (ILESSP CODE 255)) - (EQ (LRSH CODE 8) - 241)) - THEN (SETQ LAB (CHARACTER CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE (MKATOM (CHARCODESTRING CODE))) - ELSEIF (STRINGP CODE) - THEN (SETQ LAB (MKATOM CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE CODE))) - - (* |;;| "Shift to shift code") - - (SETQ KA (CDR KA)) - (SETQ CODE (CAR KA)) - (IF (SMALLP CODE) - THEN (RPLACA KA (IF (SMALLP CODE) - THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) - )) - ELSEIF (OR (AND (IGREATERP CODE 32) - (ILESSP CODE 255)) - (EQ (LRSH CODE 8) - 241)) - THEN (SETQ LAB (CHARACTER CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE - - (* |;;| - "Coerce to octal cset,ccode format") - - (MKATOM (CHARCODESTRING CODE))) - ELSEIF (STRINGP CODE) - THEN (SETQ LAB (MKATOM CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE CODE))))) - - (* |;;| "Remove duplicates, leaving the head of the list unchanged, and keeping first occurrences of duplicates") - - (RPLACD KALIST (FOR XTAIL X ON (CDR KALIST) EACHTIME (SETQ X (CAR XTAIL)) - UNLESS (THEREIS YTAIL ON KALIST UNTIL (EQ YTAIL XTAIL) - SUCHTHAT (EQUAL X (CAR YTAIL))) COLLECT (CAR XTAIL))) - KALIST)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (VKBD.INIT) ) (FILESLOAD ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA METASHIFT) ) (PUTPROPS VIRTUALKEYBOARDS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993 1995 1996 2017 2018)) STOP \ No newline at end of file diff --git a/library/VIRTUALKEYBOARDS.~8~ b/library/VIRTUALKEYBOARDS.~8~ deleted file mode 100644 index 67bb65b5..00000000 --- a/library/VIRTUALKEYBOARDS.~8~ +++ /dev/null @@ -1,1489 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL" BASE 10) (FILECREATED "27-Apr-2018 22:39:20"  |{DSK}kaplan>Local>medley3.5>lispcore>library>VIRTUALKEYBOARDS.;8| 141571 |changes| |to:| (VARS VIRTUALKEYBOARDSCOMS) (FNS VKBD.PARSE-KEY-ASSIGNMENT) |previous| |date:| "27-Apr-2018 22:24:46" |{DSK}kaplan>Local>medley3.5>lispcore>library>VIRTUALKEYBOARDS.;7|) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993, 1995, 1996, 2017, 2018 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT VIRTUALKEYBOARDSCOMS) (RPAQQ VIRTUALKEYBOARDSCOMS ((FNS FINDVIRTUALKEYBOARD PROCESS.KEYBOARD VKBD.CREATE-KEYACTION-TABLE VKBD.WINDOWMENUFN VKBD.WINDOWMENUINIT) (COMS (FNS LOADKEYBOARDDISPLAYFONTS) (INITVARS VKBD.CACHEDCHARSETS) (GLOBALVARS VKBD.CACHEDCHARSETS)) (FNS DEFINEKEYBOARD) (FNS VKBD.ADD-ITEM-TO-BACKGROUND-MENU VKBD.INIT VKBD.CREATE-DEFAULT-KEYBOARD VKBD.ADD-DEFAULT-KEYBOARD) (FNS VKBD.LOAD-FILE-COMMAND VKBD.LOAD-KEYBOARD-FILE VKBD.STORE-FILE-COMMAND VKBD.STORE-KEYBOARD-FILE) (FNS SWITCHKEYBOARDS VKBD.POP-MENU-AND-SWITCH-KEYBOARDS VKBD.POP-UP-KEYBOARDS-MENU VKBD.GET-CONFIGURATION VKBD.SUBCONFIGURATION) (FNS VKBD.BUTTONEVENTFN VKBD.CENTER-BITMAP-IN-REGION VKBD.CLEAR-KEY-DISPLAY VKBD.CREATE-KEYBOARD-BITMAP VKBD.CREATE-KEYBOARD-DISPLAY VKBD.CURSORMOVEDFN VKBD.DISPLAY-CHARACTER VKBD.DISPLAY-EMPTY-KEY-CAP VKBD.DISPLAY-KEY VKBD.DISPLAY-KEY-CHARACTERS VKBD.DRAW-KEY-CAPS VKBD.ERASE-FRAME VKBD.EXTEND-REGION VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION VKBD.GET-KEY-REGIONS VKBD.INVERT-KEY VKBD.INVERT-REGION VKBD.KEYBOARD-WINDOW-REPAINTFN VKBD.LOWER-HALF-REGION VKBD.POSITION-IS-IN-KEY-REGION VKBD.REMOVE-KEYBOARD-COMMAND VKBD.UNION-REGIONS VKBD.UPPER-HALF-REGION) (FNS VKBD.KEY-ASSOC VKBD.CHAR-ASSIGNMENTP VKBD.COMPLETE-KEYBOARD VKBD.CTRL-ASSIGNMENTP VKBD.EVENT-ASSIGNMENTP VKBD.META-ASSIGNMENTP VKBD.FRAME-KEY VKBD.GET-CURRENT-KEY-ASSIGNMENT VKBD.GET-NON-CHAR-LABEL VKBD.ICONFN VKBD.INVERT-LOCK-KEYS VKBD.INVERT-SHIFT-KEYS VKBD.TRANSLATE-KEY-ID VKBD.KEY-ID-TO-KEY-NAMES VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD VKBD.LOCK-ASSIGNMENTP VKBD.LOCK-KEYP VKBD.LOCK/NOLOCK VKBD.LOCKDOWN-ASSIGNMENTP VKBD.LOCKUP-ASSIGNMENTP VKBD.PARSE-CHAR-CODE VKBD.PARSE-KEY-ASSIGNMENT VKBD.RESET-KEYBOARD-WINDOW VKBD.SEND-CHARACTER VKBD.SHIFT-ASSIGNMENTP VKBD.SHIFTED-CHAR VKBD.UNDEFINE-KEYBOARD VKBD.UNSHIFTED-CHAR) (ALISTS (CHARACTERNAMES BREAK HOME PGUP END PGDN INS HELP SCRL NUMLK CLEAR DOIT CENTER NOTCENTER BOLD NOTBOLD ITALIC NOTITALIC UCASE LCASE STRIKEOUT NOTSTRIKEOUT UNDERLINE NOTUNDERLINE SUBSCRIPT SUPERSCRIPT SMALLER LARGER MARGINS NOTMARGINS LOOKS NOTLOOKS F11 NOTF11 F12 NOTF12)) (RECORDS KEYBOARDCONFIGURATION VIRTUALKEYBOARD) (INITVARS (VKBD.KNOWN-KEYBOARDS NIL)) (FILES (SOURCE) KEYBOARDCONFIGS) (VARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.WINDOW-MENU-SUBITEMS) (BITMAPS VKBD.ICON VKBD.MASK) (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) (COMS (DECLARE\: FIRST (P (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN))) (INITVARS (\\ORIGINALDEFAULTKEYACTION)) (FNS VKBD.\\KEYBOARDEVENTFN VKBD.RESETKEYACTIONTABLES) (P (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN))) (COMS (DECLARE\: FIRST (P (MOVD? 'KEYACTION 'OLDKEYACTION))) (FNS NEWKEYACTION) (P (MOVD 'NEWKEYACTION 'KEYACTION)) (INITVARS (MODEKEYS)) (VARS MODEACTIONS) (GLOBALVARS MODEKEYS MODEACTIONS)) (COMS (FNS METASHIFT) (* \;  "Call new definition if the old one had been called") (P (AND (EQ (MACHINETYPE) 'DORADO) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)))) (ADDVARS (BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT))) (FNS FIXKEYBOARD FIXKEYBOARDCONFIG FIXKEYASSIGNMENTS) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (VKBD.INIT))) (FILES ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA METASHIFT))))) (DEFINEQ (FINDVIRTUALKEYBOARD - (LAMBDA (KEYBOARDNAME CONFIGURATIONNAME) (* \; "Edited 27-Feb-96 10:27 by rmk") - (LET ((KBTYPE (COND - (CONFIGURATIONNAME) - ((LISTP KEYBOARDNAME) - (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) OF KEYBOARDNAME)) - ((KEYBOARDTYPE)) - (T DEFAULTVIRTUALKEYBOARDTYPE)))) - (CL:WHEN (AND (LISTP KEYBOARDNAME) - (MEMB KEYBOARDNAME VKBD.KNOWN-KEYBOARDS)) - - (* |;;| "Gave a keyboard, use it to indicate keyboard name for new configuration") - - (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARDNAME))) - - (* |;;| "Find keyboard of default type if current type doesn't exist and CONFIGURATIONNAME wasn't given--PROCESS.KEYBOARD won't switch this in. Note that a keyboard that has a NIL configuration is declared to go with anything,but we look for an explicit match first") - - (IF (FIND KB IN VKBD.KNOWN-KEYBOARDS - SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - (EQ KBTYPE (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF KB)))) - ELSEIF (FIND KB IN VKBD.KNOWN-KEYBOARDS - SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - (NULL (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF KB)))) - ELSEIF (OR (NOT CONFIGURATIONNAME) - (EQ CONFIGURATIONNAME KBTYPE)) - THEN (OR (FOR C IN (CDR (ASSOC KBTYPE KEYBOARDCONFIGCOERCIONS)) - WHEN (SETQ C (FINDVIRTUALKEYBOARD KEYBOARDNAME C)) - DO (RETURN C)) - (AND DEFAULTVIRTUALKEYBOARDTYPE (NEQ DEFAULTVIRTUALKEYBOARDTYPE KBTYPE) - (FOR KB IN VKBD.KNOWN-KEYBOARDS - WHEN (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD - KEYBOARDNAME) - OF KB)) - (EQ DEFAULTVIRTUALKEYBOARDTYPE (FETCH - (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF KB))) - DO (RETURN KB)))))))) (PROCESS.KEYBOARD (LAMBDA (PROCESS/WINDOW KEYBOARD) (* \; "Edited 23-May-95 17:00 by rmk:") (* |;;;| "Get/set the keyboard just for this process/window. Value is previous keyboard.") (PROG (KEYACTIONTABLE FOUND (PROCESS (COND ((NULL PROCESS/WINDOW) (TTY.PROCESS)) ((PROCESSP PROCESS/WINDOW) PROCESS/WINDOW) ((AND (WINDOWP PROCESS/WINDOW) (WINDOWPROP PROCESS/WINDOW 'PROCESS))) (T (THIS.PROCESS))))) (COND ((SETQ KEYACTIONTABLE (IF (AND KEYBOARD (SETQ FOUND (FINDVIRTUALKEYBOARD KEYBOARD))) THEN (* |;;| "We believe in whatever FINDVIRTUALKEYBOARD returns, even though it might not have the configuration we expect.") (* \;  "Get/create the KEYACTIONTABLE for the FOUND") (VKBD.CREATE-KEYACTION-TABLE FOUND))) (* \;  "Make sure to copy the current interrupt list.") (REPLACE (KEYACTION INTERRUPTLIST) OF KEYACTIONTABLE WITH (COPY (FETCH (KEYACTION INTERRUPTLIST) OF (OR (PROCESSPROP PROCESS 'KEYACTION) \\DEFAULTKEYACTION)))) (PROCESSPROP PROCESS 'KEYACTION KEYACTIONTABLE) (COND ((TTY.PROCESSP PROCESS) (* \; "install the key action table") (* \;  "Hack--wait until dangerous shifts are up") (|while| (OR (SHIFTDOWNP 'META) (SHIFTDOWNP 'CTRL))) (SETQ \\CURRENTKEYACTION (OR KEYACTIONTABLE (KEYACTIONTABLE))))) (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD KEYBOARD) 'DEFAULT))) (T (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD) 'DEFAULT))))))) (VKBD.CREATE-KEYACTION-TABLE - (LAMBDA (NEW-KEYBOARD OLDTABLE) (* \; "Edited 29-Feb-96 12:32 by rmk") - (PROG (KEYBOARDNAME FOUND KEYACTION-TABLE CONFIG) - (CL:UNLESS (COND - ((AND (ATOM NEW-KEYBOARD) - (SETQ FOUND (FINDVIRTUALKEYBOARD NEW-KEYBOARD))) - (SETQ NEW-KEYBOARD FOUND)) - ((MEMB NEW-KEYBOARD VKBD.KNOWN-KEYBOARDS))) - - (* |;;| "Use FOUND to preserve NEW-KEYBOARD for error") - - (ERROR "INVALID KEYBOARD" NEW-KEYBOARD)) - (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF NEW-KEYBOARD)) - (COND - (OLDTABLE (SETQ KEYACTION-TABLE (RESETKEYACTION OLDTABLE))) - ((SETQ KEYACTION-TABLE (GETPROP KEYBOARDNAME 'KEYACTIONTABLE)) - (RETURN KEYACTION-TABLE)) - (T (SETQ KEYACTION-TABLE (KEYACTIONTABLE)))) - (SETQ NEW-KEYBOARD (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD)) - (SETQ CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - OF NEW-KEYBOARD))) - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF NEW-KEYBOARD) DO (OLDKEYACTION (CAR - KEY-ASSIGNMENT - ) - (CDR KEY-ASSIGNMENT) - KEYACTION-TABLE)) - (PUTPROP KEYBOARDNAME 'KEYACTIONTABLE KEYACTION-TABLE) - (RETURN KEYACTION-TABLE)))) (vkbd.windowmenufn - (lambda (w) (* \; "Edited 15-Dec-87 16:27 by Snow") - - (let (keyboard) - (setq keyboard (vkbd.pop-up-keyboards-menu)) - (and keyboard (process.keyboard w keyboard))))) (vkbd.windowmenuinit - (lambda nil (* \; "Edited 15-Dec-87 16:28 by Snow") - - (setq |WindowMenuCommands| (remove (sassoc '|Keyboard| |WindowMenuCommands|) - |WindowMenuCommands|)) - (nconc1 |WindowMenuCommands| `(|Keyboard| (function (lambda (w) - (switchkeyboards t nil w))) - "Changes the keyboard associated with this window." - ,vkbd.window-menu-subitems)) - (setq |WindowMenu| nil))) ) (DEFINEQ (LOADKEYBOARDDISPLAYFONTS (LAMBDA (FONT) (* \; "Edited 13-Dec-96 17:40 by rmk:") (* \; "Edited 7-Mar-96 12:30 by rmk") (* |;;| "Insures that all the characters on virtual keycaps have been instantiated in FONT (or at least on the keycaps). Saves the needed charsets in VKBD.CACHEDCHARSETS. This means that we don't have to parse all the keyboards every time. In order to make use of the cache, we instantiate all the charsets in all the fonts that are specified in any of the keyboards or configurations.") (DECLARE (GLOBALVARS VKBD.CACHEDCHARSETS)) (CL:UNLESS VKBD.CACHEDCHARSETS (FOR K IN VKBD.KNOWN-KEYBOARDS DO (* |;;| "Ignore errorful transitions in this background function, fail when the user actually asks for the keyboard. Accumulate 0th character in each charset (presumably very few), saving them in the cache.") (FOR A TRANS CHARSETS IN (FETCH KEYASSIGNMENTS OF K) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A NIL T))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (FOR CONFIG COMMON IN VKBD.CONFIGURATIONS DO (* |;;| "We aren't letting the configs assignment override the VKBD.COMMONDEFAULTASSIGNMENT on the same key. Thus, in principle we could be instantiating a font that isn't actually needed, but this is unlikely, harmless, and not worth the bother to keep track. VKBD.COMPLETE-KEYBOARD does it right.") (FOR A TRANS IN (APPEND (FETCH DEFAULTASSIGNMENT OF CONFIG) VKBD.COMMONDEFAULTASSIGNMENT) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A CONFIG))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (SETQ VKBD.CACHEDCHARSETS (DREMOVE 0 VKBD.CACHEDCHARSETS))) (IF FONT THEN (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY)) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C FONT)) ELSE (LET (DONEFONTS) (FOR K F IN VKBD.KNOWN-KEYBOARDS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (VIRTUALKEYBOARD KEYBOARDDISPLAYFONT ) OF K) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))) (FOR CONFIG F IN VKBD.CONFIGURATIONS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) OF CONFIG) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))))))) ) (RPAQ? VKBD.CACHEDCHARSETS NIL) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.CACHEDCHARSETS) ) (DEFINEQ (DEFINEKEYBOARD - (LAMBDA (KEYBOARD-OBJECT) (* \; "Edited 28-Feb-96 11:41 by rmk") - (* \; "Edited 15-Dec-87 16:29 by Snow") - - (* |;;| - "Checks assignments before it installs, returns a copy unless the object is already known.") - - (FOR KEY-ASSIGNMENT (CONFIGURATION _ (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF - KEYBOARD-OBJECT - ))) - IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD-OBJECT) - DO (VKBD.PARSE-KEY-ASSIGNMENT KEY-ASSIGNMENT CONFIGURATION)) - (OR (FINDVIRTUALKEYBOARD KEYBOARD-OBJECT) - (CAR (PUSH VKBD.KNOWN-KEYBOARDS (COPY KEYBOARD-OBJECT)))))) ) (DEFINEQ (vkbd.add-item-to-background-menu - (lambda (label command message subitemlist) (* \; "Edited 15-Dec-87 16:29 by Snow") - - (setq |BackgroundMenuCommands| (remove (sassoc label |BackgroundMenuCommands|) - |BackgroundMenuCommands|)) - (nconc1 |BackgroundMenuCommands| (list label command message subitemlist)) - (setq |BackgroundMenu| nil))) (VKBD.INIT (LAMBDA NIL (* \; "Edited 14-Jun-2017 14:22 by kaplan") (* \; "Edited 16-Jun-92 11:14 by kaplan") (* |;;| "Reads virtual keyboard file for current type (or default type), if it can be found. Keyboards that don't match current keyboard can be displayed but not installed (via PROCESS.KEYBOARD)") (CL:UNLESS \\ORIGINALDEFAULTKEYACTION (SETQ \\ORIGINALDEFAULTKEYACTION (KEYACTIONTABLE \\DEFAULTKEYACTION))) (SETQ VKBD.COMMONCODELABELS (FOR X IN VKBD.COMMONCHARLABELS COLLECT (IF (LISTP X) THEN (IF (SMALLP (CAR X)) THEN X ELSE (LIST (CHARCODE.DECODE (CAR X)) (CADR X))) ELSE (LIST (CHARCODE.DECODE X) X)))) (VKBD.ADD-ITEM-TO-BACKGROUND-MENU "Keyboard" ''(SWITCHKEYBOARDS T NIL) "Displays a menu for switching keyboards" VKBD.BACKGROUND-MENU-SUBITEMS) (VKBD.WINDOWMENUINIT) (LET (FILE (KT (KEYBOARDTYPE))) (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION KT)) (COND ((SETQ FILE (COND ((AND KT (FINDFILE (PACK* KT "KEYBOARDS") T))) (T (FINDFILE (PACK* DEFAULTVIRTUALKEYBOARDTYPE "KEYBOARDS") T)))) (VKBD.LOAD-KEYBOARD-FILE FILE) (* |;;| "Loading a keyboard file may change our notion of KEYBOARDTYPE, because of new coercion paths. The default keyboard will be added for the new type") (VKBD.ADD-DEFAULT-KEYBOARD)) (T (* |;;| "Special printing here to avoid file-not-found error in case where user calls VKBD.LOAD-KEYBOARD-FILE directly") (PROMPTPRINT "Note: virtual keyboard file for type " (OR (KEYBOARDTYPE) DEFAULTVIRTUALKEYBOARDTYPE) " keyboards not found")))))) (VKBD.CREATE-DEFAULT-KEYBOARD - (LAMBDA (CONFIGURATION) (* \; "Edited 27-Feb-96 20:51 by rmk") - - (* |;;| "Don't bother copying in the default keyassignments, since they will always be inserted by VKBD.COMPLETE-KEYBOARD") - - (CL:WHEN (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) - (CREATE VIRTUALKEYBOARD - KEYBOARDNAME _ 'DEFAULT - KEYBOARDCONFIGURATION _ (FETCH (KEYBOARDCONFIGURATION CONFIGURATIONNAME) - OF CONFIGURATION))))) (VKBD.ADD-DEFAULT-KEYBOARD (LAMBDA (KEYBOARDTYPE) (* \; "Edited 23-May-95 17:04 by rmk:") (* |;;;| "It is useful practice to be able to switch back to the original key assignments. Thus the program is adding one special keyboard with the name DEFAULT which is the current keyboardtype's default keyboard.") (SETQ KEYBOARDTYPE (OR KEYBOARDTYPE (KEYBOARDTYPE))) (BIND DEFAULT WHILE (SETQ DEFAULT (FINDVIRTUALKEYBOARD 'DEFAULT KEYBOARDTYPE)) DO (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE DEFAULT VKBD.KNOWN-KEYBOARDS))) (SETQ VKBD.KNOWN-KEYBOARDS (CONS (VKBD.CREATE-DEFAULT-KEYBOARD KEYBOARDTYPE) VKBD.KNOWN-KEYBOARDS)) (COND ((EQ KEYBOARDTYPE (KEYBOARDTYPE)) (VKBD.CREATE-KEYACTION-TABLE 'DEFAULT \\DEFAULTKEYACTION))))) ) (DEFINEQ (VKBD.LOAD-FILE-COMMAND - (LAMBDA (REDEFINE? DELETE-FIRST?) (* \; "Edited 3-Mar-96 18:16 by rmk") - (* \; "Edited 15-Dec-87 16:30 by Snow") - (LET (F) - (SETQ F (MKATOM (PROMPTFORWORD "Keyboard file name: " NIL NIL PROMPTWINDOW NIL 'TTY))) - (IF F - THEN (VKBD.LOAD-KEYBOARD-FILE F REDEFINE? DELETE-FIRST? T))))) (VKBD.LOAD-KEYBOARD-FILE - (LAMBDA (FILENAME REDEFINE? DELETE-CURRENT-DEFINITIONS? PROMPTPRINT) - (* \; "Edited 4-Mar-96 10:53 by rmk") - - (* |;;| "Note: Can't switch to READFILE, since it uses OLD-INTERLISP readtable which doesn't honor vertical bars around numeric atoms.") - - (LET ((NEWKEYBOARDS (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :INPUT) - (BIND KB DATE (*PACKAGE* _ *INTERLISP-PACKAGE*) - (RDTBL _ (FIND-READTABLE "INTERLISP")) - FIRST (SETQ DATE (READ STREAM RDTBL)) - (CL:UNLESS (LISTP DATE) - (CL:WHEN (STRINGP DATE) - (SETQ DATE (CONCAT "Keyboards from " (FULLNAME STREAM - ) - " [" DATE "]")) - (IF PROMPTPRINT - THEN (PROMPTPRINT DATE) - ELSE (PRINTOUT T DATE T))) - (SETQ DATE NIL)) WHILE (SKIPSEPRCODES STREAM RDTBL) - UNTIL (EQ 'STOP (SETQ KB (READ STREAM RDTBL))) COLLECT - KB - FINALLY (CL:WHEN DATE - - (* |;;| - "Was a LISTP date, must have been a keyboard") - - (PUSH DATE $$VAL)))))) - (COND - (DELETE-CURRENT-DEFINITIONS? (SETQ VKBD.KNOWN-KEYBOARDS NEWKEYBOARDS) - (VKBD.ADD-DEFAULT-KEYBOARD)) - (T (FOR NEWKEYBOARD KN KC IN NEWKEYBOARDS - DO - - (* |;;| -"To make sure that COMPLETEDASSIGNMENTS cell (or any other new cells) exist--backward compatibility") - - (SETQ NEWKEYBOARD (CREATE VIRTUALKEYBOARD USING NEWKEYBOARD)) - (SETQ KN (FETCH KEYBOARDNAME OF NEWKEYBOARD)) - (SETQ KC (FETCH KEYBOARDCONFIGURATION OF NEWKEYBOARD)) - (FOR TAIL OLDKEYBOARD ON VKBD.KNOWN-KEYBOARDS - WHEN (AND (EQ KN (FETCH KEYBOARDNAME OF (SETQ OLDKEYBOARD - (CAR TAIL)))) - (EQ KC (FETCH KEYBOARDCONFIGURATION OF OLDKEYBOARD)) - ) DO - - (* |;;| "If REDEFINE?, then replace one with same name and configuration. Otherwise, keep the old one instead of installing the new one.") - - (COND - (REDEFINE? (RPLACA TAIL NEWKEYBOARD)) - (T (RETURN))) FINALLY (SETQ - VKBD.KNOWN-KEYBOARDS - (NCONC1 - VKBD.KNOWN-KEYBOARDS - NEWKEYBOARD)))) - ))))) (vkbd.store-file-command - (lambda (f) (* \; "Edited 15-Dec-87 16:31 by Snow") - - (setq f (promptforword "ENTER FILE NAME: " nil nil promptwindow nil 'tty)) - (|if| f - |then| (vkbd.store-keyboard-file (mkatom f)) - |else| (promptprint "FILE NOT FOUND")))) (VKBD.STORE-KEYBOARD-FILE - (LAMBDA (FILENAME CONFIGURATIONNAME) (* \; "Edited 4-Mar-96 13:38 by rmk") - - (* |;;| "COMPLETEDKEYASSIGNMENTS are in a separate hasharray, don't get printed. Can't use WRITEFILE because of vertical-bar problems") - - (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) - (LET ((RDTBL (FIND-READTABLE "INTERLISP"))) - (PRINT (DATE) - STREAM RDTBL) - (IF CONFIGURATIONNAME - THEN (FOR KB IN VKBD.KNOWN-KEYBOARDS - WHEN (EQ CONFIGURATIONNAME (FETCH (VIRTUALKEYBOARD - KEYBOARDCONFIGURATION - ) OF KB)) - UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) - DO (PRINT KB STREAM RDTBL)) - ELSE (* \; - "Don't print DEFAULT keyboards, since they are reconstructed from configuration") - (FOR KB IN VKBD.KNOWN-KEYBOARDS - UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KB)) DO (PRINT KB STREAM RDTBL)))) - (PROMPTPRINT (CONCAT "Current known keyboards are stored in " FILENAME)) - (FULLNAME STREAM)))) ) (DEFINEQ (SWITCHKEYBOARDS - (LAMBDA (SWITCH-FLG DISPLAY-FLG PROCESS NEW-KEYBOARD DISPLAY-POSITION) - (* \; "Edited 27-Feb-96 12:35 by rmk") - (* \; "Edited 15-Dec-87 16:32 by Snow") - -(* |;;;| "This is the main function of the package. SWITCH-FLG and DISPLAY-FLG will produce the 3 logical combinations of switching a keyboard. The 4th comb NIl & NIL is NOOP. Any change of the KEYACTION handeling should be reflected here.") - - (PROG (WINDOW) - (COND - ((NULL NEW-KEYBOARD) - (SETQ NEW-KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU)))) - (COND - ((LITATOM NEW-KEYBOARD) - (SETQ NEW-KEYBOARD (FINDVIRTUALKEYBOARD NEW-KEYBOARD)))) - (COND - ((NULL NEW-KEYBOARD) - (RETURN NIL))) - (COND - (SWITCH-FLG (PROCESS.KEYBOARD PROCESS NEW-KEYBOARD))) - (COND - (DISPLAY-FLG (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD) - - (* |;;| "This is necessary to enable the menu to generate the right characters for the keys that are defaulted") - - (* |;;| "(RETURN OLD-KEYACTIONS)") - - (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY NEW-KEYBOARD DISPLAY-POSITION - (FUNCTION VKBD.SEND-CHARACTER)))))))) (vkbd.pop-menu-and-switch-keyboards - (lambda (process switch-flg display-flg) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (prog (keyboard) - (setq keyboard (vkbd.pop-up-keyboards-menu "Select an alternative keyboard")) - (|if| keyboard - |then| (switchkeyboards keyboard switch-flg display-flg))))) (VKBD.POP-UP-KEYBOARDS-MENU - (LAMBDA (PROMPT-STRING) (* \; "Edited 27-Feb-96 13:22 by rmk") - (* \; "Edited 16-Jun-92 11:35 by kaplan") - (COND - (PROMPT-STRING (PROMPTPRINT PROMPT-STRING) - (FLASHWINDOW PROMPTWINDOW 1))) - (LET ((KEYBOARDTYPES `(NIL ,(KEYBOARDTYPE) - ,@(CDR (ASSOC (KEYBOARDTYPE) - KEYBOARDCONFIGCOERCIONS)) - ,DEFAULTVIRTUALKEYBOARDTYPE))) - (MENU (CREATE MENU - ITEMS _ (CONS '(|Quit| NIL) - (SORT (FOR K IN VKBD.KNOWN-KEYBOARDS - WHEN (MEMB (FETCH KEYBOARDCONFIGURATION - OF K) - KEYBOARDTYPES) - UNLESS (MEMB (FETCH KEYBOARDNAME OF K) - $$VAL) - COLLECT (FETCH KEYBOARDNAME OF K)) - (FUNCTION UALPHORDER))) - MENUFONT _ BIGFONT))))) (VKBD.GET-CONFIGURATION - (LAMBDA (CONFNAME/WINDOW) (* \; "Edited 27-Feb-96 11:13 by rmk") - - (* |;;| "NIL means use the CURRENTKEYBOARDCONFIG, if it exists") - - (COND - ((WINDOWP CONFNAME/WINDOW) - (SETQ CONFNAME/WINDOW (|fetch| (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) - |of| (WINDOWPROP CONFNAME/WINDOW 'VKBD.KEYBOARD))))) - (COND - ((AND CONFNAME/WINDOW (|type?| KEYBOARDCONFIGURATION CONFNAME/WINDOW)) - CONFNAME/WINDOW) - ((AND (NULL CONFNAME/WINDOW) - CURRENTKEYBOARDCONFIG)) - ((FASSOC (OR CONFNAME/WINDOW VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) - VKBD.CONFIGURATIONS)) - (T (FOR C IN (CDR (ASSOC CONFNAME/WINDOW KEYBOARDCONFIGCOERCIONS)) - WHEN (SETQ C (FASSOC C VKBD.CONFIGURATIONS)) DO (RETURN C)))))) (VKBD.SUBCONFIGURATION (LAMBDA (FULL NEWNAME LOWERLEFTKEY UPPERRIGHTKEY SCALE MARGIN) (* \; "Edited 8-Oct-96 12:28 by rmk:") (* |;;| "Returns a sub-configuration of FULL, including only keys that lie completely within the region enclosed by the bounding box of LOWERLEFTKEY and UPPERRIGHTKEY. Translates regions so that origin is the lower-left corner of the lower-left key.") (SETQ FULL (VKBD.GET-CONFIGURATION FULL)) (CL:UNLESS MARGIN (SETQ MARGIN 0)) (LET (NEWREGIONS (LEFT 65535) (BOTTOM 65535) (TOP 0) (RIGHT 0)) (CL:UNLESS NEWNAME (SETQ NEWNAME (FETCH CONFIGURATIONNAME OF FULL))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC LOWERLEFTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" LOWERLEFTKEY)) DO (CL:WHEN (ILESSP (FETCH LEFT OF R) LEFT) (SETQ LEFT (FETCH LEFT OF R))) (CL:WHEN (ILESSP (FETCH BOTTOM OF R) BOTTOM) (SETQ BOTTOM (FETCH BOTTOM OF R)))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC UPPERRIGHTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" UPPERRIGHTKEY)) DO (CL:WHEN (IGREATERP (FETCH RIGHT OF R) RIGHT) (SETQ RIGHT (FETCH RIGHT OF R))) (CL:WHEN (IGREATERP (FETCH TOP OF R) TOP) (SETQ TOP (FETCH TOP OF R)))) (SETQ NEWREGIONS (FOR KR IN (FETCH KEYREGIONS OF FULL) WHEN (FOR R IN (CDR KR) ALWAYS (AND (IGEQ (FETCH LEFT OF R) LEFT) (IGEQ (FETCH BOTTOM OF R) BOTTOM) (ILEQ (FETCH TOP OF R) TOP) (ILEQ (FETCH RIGHT OF R) RIGHT))) COLLECT (CONS (CAR KR) (FOR R IN (CDR KR) COLLECT (IF SCALE THEN (CREATE REGION LEFT _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH LEFT OF R) LEFT)))) BOTTOM _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))) WIDTH _ (FIXR (TIMES SCALE (FETCH WIDTH OF R))) HEIGHT _ (FIXR (TIMES SCALE (FETCH HEIGHT OF R)))) ELSE (CREATE REGION USING R LEFT _ (+ MARGIN (- (FETCH LEFT OF R) LEFT)) BOTTOM _ (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))))))) (CREATE KEYBOARDCONFIGURATION COPYING FULL CONFIGURATIONNAME _ NEWNAME KEYREGIONS _ NEWREGIONS DEFAULTASSIGNMENT _ (FOR A IN (FETCH DEFAULTASSIGNMENT OF FULL) WHEN (VKBD.KEY-ASSOC (CAR A) NEWREGIONS FULL) COLLECT (COPY A)))))) ) (DEFINEQ (vkbd.buttoneventfn - (lambda (window) (* \; "Edited 15-Dec-87 16:32 by Snow") - -(* |;;;| "This is a general 'menu' function for the keyboard when used as a menu --- it is used for all such uses: When displaying a virtual keyboard, when editing one and when editing a default assignments for a configuration. The only difference is what will be the action taken when a KEY was selected. This will be determined by the property VKBD.MENUFN which specify the name of the function that should be called. This function will get 3 arguments : The KEYID, the WINDOW and the mouse key; In the regular keyboard display this function will send a character to the system buffer. In the Editor it will make the key the CURRENT key. In the configuration info window it will display information about the key") - - (prog (mouse-position shaded-key last-mouse-key current-key-and-regions shift-is-down) - (setq mouse-position (cursorposition nil window)) - (totopw window) (* \; - "This should be checked if changes to the keyboard handling is done") - - (setq shift-is-down (or (keydownp 'rshift) - (keydownp 'lshift))) - (setq shaded-key (windowprop window 'vkbd.shaded-key)) - (setq last-mouse-key (windowprop window 'vkbd.mouse-button)) - (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position - mouse-position window)) - (cond - ((mousestate up) - (cond - ((and shaded-key (eq shaded-key (car current-key-and-regions))) - (apply (windowprop window 'vkbd.menufn) - (list (windowprop window 'vkbd.shaded-key) - window - (windowprop window 'vkbd.last-mouse-state))) - (vkbd.reset-keyboard-window window)))) - ((or (mousestate (only left)) - (mousestate (only middle))) - (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) - (|for| region |in| (cdr current-key-and-regions) |do| (vkbd.invert-region - region window)) - (windowprop window 'vkbd.last-mouse-state (cond - ((lastmousestate (only left)) - 'left) - (t 'middle))) - (cond - ((or shift-is-down (lastmousestate (only middle))) - (vkbd.invert-shift-keys window) - (windowprop window 'vkbd.shift-down t)))))))) (vkbd.center-bitmap-in-region - (lambda (bm region window allignment) (* \; "Edited 15-Dec-87 16:32 by Snow") - - (bitblt bm 0 0 window (iplus (|fetch| (region left) |of| region) - (iquotient (idifference (|fetch| (region width) |of| region) - (bitmapwidth bm)) - 2)) - (cond - ((greaterp (bitmapheight bm) - (|fetch| (region height) |of| region)) - (cond - ((eq allignment 'top) - (idifference (|fetch| (region bottom) |of| region) - (idifference (bitmapheight bm) - (|fetch| (region height) |of| region)))) - ((eq allignment 'bottom) - (|fetch| (region bottom) |of| region)) - (t (iplus (|fetch| (region bottom) |of| region) - (iquotient (idifference (|fetch| (region height) |of| region) - (bitmapheight bm)) - 2))))) - (t (iplus (|fetch| (region bottom) |of| region) - (iquotient (idifference (|fetch| (region height) |of| region) - (bitmapheight bm)) - 2)))) - nil nil 'input 'paint))) (VKBD.CLEAR-KEY-DISPLAY - (LAMBDA (KEY-REGIONS VKBD-WINDOW) (* \; "Edited 27-Feb-96 13:50 by rmk") - (FOR REGION LEFT BOTTOM WIDTH HEIGHT IN KEY-REGIONS - DO (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)) - (BITBLT NIL NIL NIL VKBD-WINDOW (ADD1 LEFT) - (ADD1 BOTTOM) - (IDIFFERENCE WIDTH 2) - (IDIFFERENCE HEIGHT 2) - 'TEXTURE - 'REPLACE WHITESHADE) - (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (ADD1 BOTTOM) - (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - BOTTOM) - (BITMAPBIT VKBD-WINDOW LEFT (ADD1 BOTTOM)))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (ADD1 BOTTOM) - (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - BOTTOM) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) - (ADD1 BOTTOM)))) - (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) - (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) - (IPLUS BOTTOM (ADD1 HEIGHT))) - (BITMAPBIT VKBD-WINDOW LEFT (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) - (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) - (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))) - (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) - (IPLUS BOTTOM (SUB1 HEIGHT)))))))) (VKBD.CREATE-KEYBOARD-BITMAP - (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:45 by rmk") - (* \; "Edited 15-Dec-87 16:35 by Snow") - (LET (BM KEYS-REGION BM-WIDTH BM-HEIGHT MAX-REGION) - (COND - ((ATOM CONFIGURATION) - (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)))) - (SETQ MAX-REGION (VKBD.UNION-REGIONS CONFIGURATION)) - (SETQ BM-WIDTH (IPLUS (ITIMES 2 (FETCH (REGION LEFT) OF MAX-REGION)) - (FETCH (REGION WIDTH) OF MAX-REGION))) - (SETQ BM-HEIGHT (IPLUS (ITIMES 2 (FETCH (REGION BOTTOM) OF MAX-REGION)) - (FETCH (REGION HEIGHT) OF MAX-REGION))) - (SETQ BM (BITMAPCREATE BM-WIDTH BM-HEIGHT)) - (BITBLT NIL NIL NIL BM 0 0 BM-WIDTH BM-HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM 1 1 (IDIFFERENCE BM-WIDTH 2) - (IDIFFERENCE BM-HEIGHT 2) - 'TEXTURE - 'REPLACE - (FETCH (KEYBOARDCONFIGURATION BACKGROUNDSHADE) OF CONFIGURATION)) - (FOR KEY-AND-REGIONS IN (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF - CONFIGURATION - ) DO - - (* |;;| - "CDR cause odd-shaped keys (like ENTER) are described by multiple regions") - - (VKBD.DISPLAY-EMPTY-KEY-CAP (CDR - KEY-AND-REGIONS - ) - BM)) - BM))) (VKBD.CREATE-KEYBOARD-DISPLAY - (LAMBDA (KEYBOARD MENU-POSITION MENU-FUNCTION BM SHOWCONFIG) - (* \; "Edited 28-Feb-96 12:02 by rmk") - (* \; "Edited 25-May-95 11:33 by rmk:") - (* \; "Edited 20-Apr-89 13:26 by atm") - (LET (WINDOW WINDOW-WIDTH WINDOW-HEIGHT KEYBOARD-BITMAP CONFIGURATION) - (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION (|fetch| KEYBOARDCONFIGURATION - |of| KEYBOARD))) - (SETQ KEYBOARD-BITMAP (OR BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIGURATION))) - (SETQ WINDOW-WIDTH (IPLUS 8 (BITMAPWIDTH KEYBOARD-BITMAP))) - (SETQ WINDOW-HEIGHT (IPLUS 18 (BITMAPHEIGHT KEYBOARD-BITMAP))) - (CL:UNLESS MENU-POSITION - (SETQ MENU-POSITION (GETBOXPOSITION WINDOW-WIDTH WINDOW-HEIGHT))) - (SETQ WINDOW (CREATEW (CREATEREGION (|fetch| (POSITION XCOORD) |of| MENU-POSITION) - (|fetch| (POSITION YCOORD) |of| MENU-POSITION) - WINDOW-WIDTH WINDOW-HEIGHT) - (CONCAT "Virtual Keyboard : " (|fetch| (VIRTUALKEYBOARD KEYBOARDNAME - ) |of| KEYBOARD) - (CL:IF SHOWCONFIG - (CONCAT " for " (|fetch| (VIRTUALKEYBOARD - KEYBOARDCONFIGURATION) - |of| KEYBOARD)) - "")))) - (WINDOWPROP WINDOW 'VKBD.KEYBOARD KEYBOARD) - (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION VKBD.BUTTONEVENTFN)) - (WINDOWPROP WINDOW 'CURSORMOVEDFN (FUNCTION VKBD.CURSORMOVEDFN)) - (WINDOWPROP WINDOW 'CURSOROUTFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) - (WINDOWPROP WINDOW 'CURSORINFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) - (WINDOWPROP WINDOW 'VKBD.MENUFN MENU-FUNCTION) - (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION VKBD.KEYBOARD-WINDOW-REPAINTFN)) - (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) - (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) - (WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 0 (BITMAPWIDTH KEYBOARD-BITMAP) - (BITMAPHEIGHT KEYBOARD-BITMAP))) - (WINDOWPROP WINDOW 'ICONFN (FUNCTION VKBD.ICONFN)) - (WINDOWPROP WINDOW 'VKBD.KEYBOARDDISPLAYFONT (OR (|fetch| (VIRTUALKEYBOARD - KEYBOARDDISPLAYFONT) - |of| KEYBOARD) - DEFAULTKEYBOARDDISPLAYFONT)) - (REDISPLAYW WINDOW) - WINDOW))) (vkbd.cursormovedfn - (lambda (window) (* \; "Edited 15-Dec-87 16:41 by Snow") - - (prog (mouse-position shaded-key current-key-and-regions shift-is-down) - (setq mouse-position (cursorposition nil window)) - (setq shaded-key (windowprop window 'vkbd.shaded-key)) - (setq shift-is-down (or (keydownp 'lshift) - (keydownp 'rshift))) - (cond - (shaded-key (cond - ((not (vkbd.position-is-in-key-region shaded-key mouse-position - window)) - (vkbd.reset-keyboard-window window)) - (t (return t))))) - (cond - ((mousestate (or (only left) - (only middle))) - (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position - mouse-position window)) - (cond - (current-key-and-regions (|for| region |in| (cdr current-key-and-regions) - |do| (vkbd.invert-region region window)) - (cond - ((or shift-is-down (lastmousestate (only middle))) - (vkbd.invert-shift-keys window) - (windowprop window 'vkbd.shift-down t))) - (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) - (windowprop window 'vkbd.last-mouse-state (cond - ((lastmousestate (only left)) - 'left) - (t 'middle)))))))))) (VKBD.DISPLAY-CHARACTER - (LAMBDA (CHAR REGION CHARLABELS WINDOW CONF ALLIGNMENT)(* \; "Edited 7-Mar-96 02:14 by rmk") - (* \; "Edited 17-Feb-95 12:58 by rmk:") - (LET (CHARLABEL) - (SETQ REGION (VKBD.EXTEND-REGION REGION -1)) - (COND - ((SETQ CHARLABEL (CADR (OR (FASSOC CHAR CHARLABELS) - (FASSOC CHAR VKBD.COMMONCODELABELS)))) - (DSPFONT (OR (|fetch| (KEYBOARDCONFIGURATION KEYLABELSFONT) |of| CONF) - DEFAULTKEYBOARDLABELSFONT) - WINDOW) - (CENTERPRINTINREGION CHARLABEL REGION WINDOW)) - (T (VKBD.CENTER-BITMAP-IN-REGION (GETCHARBITMAP CHAR - (FONTCREATE (OR (WINDOWPROP WINDOW - - ' - VKBD.KEYBOARDDISPLAYFONT - ) - (|fetch| ( - KEYBOARDCONFIGURATION - - KEYBOARDDISPLAYFONT - ) |of| - CONF) - DEFAULTKEYBOARDDISPLAYFONT))) - REGION WINDOW ALLIGNMENT)))))) (VKBD.DISPLAY-EMPTY-KEY-CAP - (LAMBDA (KEY-REGIONS BM) (* \; "Edited 27-Feb-96 13:32 by rmk") - (LET (LEFT BOTTOM WIDTH HEIGHT) - (FOR REGION IN KEY-REGIONS - DO (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)) - (BITBLT NIL NIL NIL BM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM (ADD1 LEFT) - (ADD1 BOTTOM) - (IDIFFERENCE WIDTH 2) - (IDIFFERENCE HEIGHT 2) - 'TEXTURE - 'REPLACE WHITESHADE) - (BITMAPBIT BM LEFT BOTTOM 0) - (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) - BOTTOM 0) - (BITMAPBIT BM LEFT (IPLUS BOTTOM (SUB1 HEIGHT)) - 0) - (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) - (IPLUS BOTTOM (SUB1 HEIGHT)) - 0)) - (COND - ((CDR KEY-REGIONS) - (FOR REGION1 IN KEY-REGIONS - DO (FOR REGION2 IN KEY-REGIONS BIND INTERSECT - DO (COND - ((NOT (EQUAL REGION1 REGION2)) - (SETQ INTERSECT (INTERSECTREGIONS - (CREATEREGION (SUB1 (FETCH (REGION LEFT) - OF REGION1)) - (SUB1 (FETCH (REGION BOTTOM) - OF REGION1)) - (IPLUS (FETCH (REGION WIDTH) - OF REGION1) - 2) - (IPLUS (FETCH (REGION HEIGHT) - OF REGION1) - 2)) - (CREATEREGION (SUB1 (FETCH (REGION LEFT) - OF REGION2)) - (SUB1 (FETCH (REGION BOTTOM) - OF REGION2)) - (IPLUS (FETCH (REGION WIDTH) - OF REGION2) - 2) - (IPLUS (FETCH (REGION HEIGHT) - OF REGION2) - 2)))) - (COND - (INTERSECT (COND - ((GREATERP (FETCH (REGION HEIGHT) - OF INTERSECT) - (FETCH (REGION WIDTH) OF - INTERSECT - )) - (SETQ INTERSECT - (CREATEREGION (FETCH (REGION LEFT) - OF INTERSECT) - (ADD1 (FETCH (REGION BOTTOM) - OF INTERSECT)) - (FETCH (REGION WIDTH) OF - INTERSECT) - (IDIFFERENCE (FETCH (REGION HEIGHT - ) - OF INTERSECT) - 2))) - (BITBLT NIL NIL NIL BM (FETCH (REGION - LEFT) - OF INTERSECT) - (FETCH (REGION BOTTOM) OF - INTERSECT) - (FETCH (REGION WIDTH) OF - INTERSECT - ) - (FETCH (REGION HEIGHT) OF - INTERSECT) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM (FETCH (REGION - LEFT) - OF INTERSECT) - (ADD1 (FETCH (REGION BOTTOM) - OF INTERSECT)) - (FETCH (REGION WIDTH) OF - INTERSECT - ) - (IDIFFERENCE (FETCH (REGION HEIGHT) - OF INTERSECT) - 2) - 'TEXTURE - 'REPLACE WHITESHADE)) - (T (SETQ INTERSECT - (CREATEREGION (ADD1 (FETCH (REGION - LEFT) - OF INTERSECT)) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (IDIFFERENCE (FETCH (REGION - WIDTH) - OF INTERSECT) - 2) - (FETCH (REGION HEIGHT) - OF INTERSECT))) - (BITBLT NIL NIL NIL BM (FETCH - (REGION LEFT) - OF INTERSECT) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (FETCH (REGION WIDTH) - OF INTERSECT) - (FETCH (REGION HEIGHT) - OF INTERSECT) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BM - (ADD1 (FETCH (REGION LEFT) - OF INTERSECT)) - (FETCH (REGION BOTTOM) - OF INTERSECT) - (IDIFFERENCE (FETCH (REGION - WIDTH) - OF INTERSECT) - 2) - (FETCH (REGION HEIGHT) - OF INTERSECT) - 'TEXTURE - 'REPLACE WHITESHADE)))))))))))))) (VKBD.DISPLAY-KEY - (LAMBDA (KEYID WINDOW CONFIG KEYLABELS CHARLABELS KEYREGIONS) - (* \; "Edited 7-Mar-96 01:53 by rmk") - (* \; "Edited 15-Dec-87 17:40 by Snow") - (SETQ KEYID (VKBD.TRANSLATE-KEY-ID KEYID CONFIG)) - (LET (KEY-ASSIGNMENT LABEL-STRING KEYREGIONS) - (CL:WHEN (OR KEYREGIONS (SETQ KEYREGIONS (CDR (VKBD.KEY-ASSOC KEYID (FETCH - ( - KEYBOARDCONFIGURATION - KEYREGIONS) - OF CONFIG) - CONFIG)))) - - (* |;;| "If the REGION doesn't exist, we can't display it. E.g., our picture doesn't include the F1 keys. CAR because some keys (e.g. for ENTER) are defined by two rectangles") - - (VKBD.CLEAR-KEY-DISPLAY KEYREGIONS WINDOW) - (SETQ KEYLABELS (OR KEYLABELS (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG - ))) - (COND - ((SETQ LABEL-STRING (CADR (VKBD.KEY-ASSOC KEYID KEYLABELS CONFIG)))) - (T (SETQ KEY-ASSIGNMENT (VKBD.KEY-ASSOC KEYID (FETCH (VIRTUALKEYBOARD - COMPLETEKEYASSIGNMENTS - ) - OF (WINDOWPROP WINDOW - 'VKBD.KEYBOARD)) - CONFIG)) - (SETQ LABEL-STRING (VKBD.GET-NON-CHAR-LABEL KEY-ASSIGNMENT)))) - (COND - (LABEL-STRING (DSPFONT (OR (FETCH (KEYBOARDCONFIGURATION KEYLABELSFONT) - OF CONFIG) - DEFAULTKEYBOARDLABELSFONT) - WINDOW) - (COND - ((AND (LISTP LABEL-STRING) - (CDR LABEL-STRING)) - (CENTERPRINTINREGION (CAR LABEL-STRING) - (VKBD.UPPER-HALF-REGION (CAR KEYREGIONS)) - WINDOW) - (CENTERPRINTINREGION (CADR LABEL-STRING) - (VKBD.LOWER-HALF-REGION (CAR KEYREGIONS)) - WINDOW)) - (T (CENTERPRINTINREGION LABEL-STRING (CAR KEYREGIONS) - WINDOW)))) - (T (VKBD.DISPLAY-KEY-CHARACTERS KEY-ASSIGNMENT (CAR KEYREGIONS) - WINDOW CONFIG CHARLABELS))))))) (VKBD.DISPLAY-KEY-CHARACTERS - (LAMBDA (KEY-ASSIGNMENT KEY-REGION WINDOW CONFIG CHARLABELS) - (* \; "Edited 7-Mar-96 01:15 by rmk") - (LET (SHIFTED-CHAR UNSHIFTED-CHAR) - (COND - ((AND KEY-ASSIGNMENT (LISTP (CADR KEY-ASSIGNMENT))) - (CL:WHEN KEY-REGION - (SETQ SHIFTED-CHAR (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) - (SETQ UNSHIFTED-CHAR (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)) - (COND - ((EQ SHIFTED-CHAR UNSHIFTED-CHAR) - (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR KEY-REGION CHARLABELS WINDOW CONFIG)) - (T (VKBD.DISPLAY-CHARACTER UNSHIFTED-CHAR (VKBD.LOWER-HALF-REGION - KEY-REGION) - CHARLABELS WINDOW CONFIG 'BOTTOM) - (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR (VKBD.UPPER-HALF-REGION - KEY-REGION) - CHARLABELS WINDOW CONFIG 'TOP))))))))) (VKBD.DRAW-KEY-CAPS - (LAMBDA (LIST-OF-REGIONS BITMAP) (* \; "Edited 13-Jun-90 01:10 by mitani") - (|for| REGION |in| LIST-OF-REGIONS |do| (BITBLT NIL NIL NIL BITMAP - (|fetch| (REGION LEFT) - |of| REGION) - (|fetch| (REGION BOTTOM) - |of| REGION) - (|fetch| (REGION WIDTH) - |of| REGION) - (|fetch| (REGION HEIGHT) - |of| REGION) - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL NIL NIL BITMAP - (ADD1 (|fetch| (REGION LEFT) - |of| REGION)) - (ADD1 (|fetch| (REGION BOTTOM) - |of| REGION)) - (IDIFFERENCE (|fetch| (REGION WIDTH) - |of| REGION) - 2) - (IDIFFERENCE (|fetch| (REGION HEIGHT) - |of| REGION) - 2) - 'TEXTURE - 'REPLACE WHITESHADE)))) (vkbd.erase-frame - (lambda (key window framesize) (* \; "Edited 15-Dec-87 16:42 by Snow") - - (vkbd.frame-key key window (|fetch| (keyboardconfiguration backgroundshade) - |of| (vkbd.get-configuration window)) - framesize))) (vkbd.extend-region - (lambda (region nbits) (* \; "Edited 15-Dec-87 16:42 by Snow") - - (cond - ((null nbits) - (setq nbits 1))) - (createregion (idifference (|fetch| (region left) |of| region) - nbits) - (idifference (|fetch| (region bottom) |of| region) - nbits) - (iplus (|fetch| (region width) |of| region) - (itimes nbits 2)) - (iplus (|fetch| (region height) |of| region) - (itimes nbits 2))))) (vkbd.get-key-and-regions-of-cursor-position - (lambda (cursor-position window) (* \; "Edited 15-Dec-87 16:43 by Snow") - - (|for| key-regions |in| (|fetch| (keyboardconfiguration keyregions) - |of| (vkbd.get-configuration window)) - |thereis| (|for| region |in| (cdr key-regions) |thereis| (insidep region - cursor-position - ))))) (VKBD.GET-KEY-REGIONS - (LAMBDA (KEY-ID CONFIG) (* \; "Edited 27-Feb-96 21:18 by rmk") - (CDR (VKBD.KEY-ASSOC KEY-ID (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF CONFIG) - CONFIG)))) (VKBD.INVERT-KEY - (LAMBDA (KEY-ID VKBD-WINDOW) (* \; "Edited 27-Feb-96 21:14 by rmk") - (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY-ID (VKBD.GET-CONFIGURATION VKBD-WINDOW)) - DO (VKBD.INVERT-REGION REGION VKBD-WINDOW)))) (vkbd.invert-region - (lambda (region window) (* \; "Edited 15-Dec-87 16:46 by Snow") - - (|if| region - |then| (bitblt window (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - window - (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - (|fetch| (region width) |of| region) - (|fetch| (region height) |of| region) - 'invert - 'replace)))) (VKBD.KEYBOARD-WINDOW-REPAINTFN - (LAMBDA (WINDOW) (* \; "Edited 7-Mar-96 13:38 by rmk") - (LET (BM KEYLABELS CHARLABELS (CONFIG (VKBD.GET-CONFIGURATION WINDOW)) - (KEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD))) - (SETQ KEYLABELS (FOR K IN (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG - ) COLLECT (LIST (VKBD.TRANSLATE-KEY-ID - (CAR K) - CONFIG) - (CADR K)))) - - (* |;;| "Build this up each time, so that the keyids are specialized to this keyboard. But the internal search will be much faster. ") - - (FOR K TR IN VKBD.COMMONKEYLABELS WHEN (SETQ TR (VKBD.TRANSLATE-KEY-ID - (CAR K) - CONFIG)) - UNLESS (ASSOC TR KEYLABELS) DO (PUSH KEYLABELS (LIST TR (CADR K)))) - (SETQ CHARLABELS (FETCH (KEYBOARDCONFIGURATION CHARLABELS) OF CONFIG)) - (SETQ BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIG)) - (BITBLT BM 0 0 WINDOW) - - (* |;;| "Display all the keys") - - (FOR R IN (FETCH KEYREGIONS OF CONFIG) - DO (VKBD.DISPLAY-KEY (VKBD.TRANSLATE-KEY-ID (CAR R) - CONFIG) - WINDOW CONFIG KEYLABELS CHARLABELS (CDR R))) - (COND - ((WINDOWPROP WINDOW 'VKBD.LOCKED) - (VKBD.INVERT-LOCK-KEYS WINDOW))) - (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL) - (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (vkbd.lower-half-region - (lambda (region) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (createregion (|fetch| (region left) |of| region) - (|fetch| (region bottom) |of| region) - (|fetch| (region width) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)))) (VKBD.POSITION-IS-IN-KEY-REGION - (LAMBDA (KEY POSITION WINDOW) (* \; "Edited 27-Feb-96 21:21 by rmk") - (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY (VKBD.GET-CONFIGURATION WINDOW)) - THEREIS (INSIDEP REGION POSITION)))) (vkbd.remove-keyboard-command - (lambda nil (* \; "Edited 15-Dec-87 16:49 by Snow") - - (prog (k) - (setq k (vkbd.pop-up-keyboards-menu "Select keyboard to be removed .")) - (|if| k - |then| (vkbd.undefine-keyboard k) - (printout promptwindow "Keyboard " k - " was removed from the list of known keyboards. "))))) (VKBD.UNION-REGIONS - (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:47 by rmk") - - (* |;;| "Don't let too many arguments pile up on the stack.") - - (LET ((KEYREGS (FETCH KEYREGIONS OF CONFIGURATION))) - (APPLY 'UNIONREGIONS (WHILE KEYREGS - COLLECT (APPLY 'UNIONREGIONS - (WHILE KEYREGS FOR I VAL FROM 1 - TO 50 - DO - - (* |;;| - "CDR because odd-shaped keys (e.g. ENTER) have multiple regions") - - (FOR R - IN (CDR (POP KEYREGS)) - DO (PUSH VAL R)) - FINALLY (RETURN VAL)))))))) (vkbd.upper-half-region - (lambda (region) (* |sm| "13-Aug-85 10:38") - (createregion (|fetch| (region left) |of| region) - (iplus 1 (|fetch| (region bottom) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)) - (|fetch| (region width) |of| region) - (iquotient (|fetch| (region height) |of| region) - 2)))) ) (DEFINEQ (VKBD.KEY-ASSOC (LAMBDA (KEY ALIST CONFIG) (* \; "Edited 5-Oct-96 16:59 by rmk:") (* \; "Edited 27-Feb-96 21:07 by rmk") (CL:WHEN (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (FIND C IN ALIST SUCHTHAT (EQ (VKBD.TRANSLATE-KEY-ID (CAR C) CONFIG) KEY))))) (VKBD.CHAR-ASSIGNMENTP - (LAMBDA (ASSIGNMENT) (* \; "Edited 26-Feb-96 16:49 by rmk") - (LISTP (CADR ASSIGNMENT)))) (VKBD.COMPLETE-KEYBOARD - (LAMBDA (KEYBOARD) (* \; "Edited 7-Mar-96 13:25 by rmk") - - (* |;;| "Fill in keys that aren't mentioned in the new keyboard, using the configuration's default. Put the parsed results in the COMPLETEKEYASSIGNMENTS field, for future use. This field is not written out by the STORE-KEYBOARD function.") - - (CL:UNLESS (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - (LET (COMPLETE-ASSIGNMENTS (CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD - - KEYBOARDCONFIGURATION - ) OF KEYBOARD) - ))) - - (* |;;| "The assignment comes from the keyboard (PARTIAL), the configuration default, or the common default assignments.") - - (FOR K A CA IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD) - DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) - (IF (NULL (SETQ CA (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS))) - THEN (PUSH COMPLETE-ASSIGNMENTS A) - ELSEIF (EQUAL A CA) - ELSE (ERROR "INCOMPATIBLE ASSIGNMENTS OF KEY NUMBER" - (LIST K A CA)))) - (FOR K A IN (FETCH (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) OF CONFIG) - DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) - (CL:UNLESS (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS) - (PUSH COMPLETE-ASSIGNMENTS A))) - - (* |;;| "The configs defaultassignment can override the VKBD.COMMONDEFAULTASSIGNMENT") - - (FOR K A IN VKBD.COMMONDEFAULTASSIGNMENT WHEN (SETQ A ( - VKBD.PARSE-KEY-ASSIGNMENT - K CONFIG T)) - DO (CL:UNLESS (ASSOC (CAR A) - COMPLETE-ASSIGNMENTS) - (PUSH COMPLETE-ASSIGNMENTS A))) - (REPLACE COMPLETEKEYASSIGNMENTS OF KEYBOARD WITH COMPLETE-ASSIGNMENTS))) - KEYBOARD)) (vkbd.ctrl-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:33 by Snow") - - (and (eq (cadr assignment) - 'ctrldown) - (eq (cddr assignment) - 'ctrlup)))) (vkbd.event-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") - - (and (eq (cadr assignment) - 'event) - (eq (cddr assignment) - 'event)))) (vkbd.meta-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") - - (and (eq (cadr assignment) - 'metadown) - (eq (cddr assignment) - 'metaup)))) (VKBD.FRAME-KEY - (LAMBDA (KEY WINDOW SHADE BITS) (* \; "Edited 29-Feb-96 11:06 by rmk") - (LET ((CONFIG (VKBD.GET-CONFIGURATION WINDOW)) - KEY-REGIONS) - (SETQ KEY-REGIONS (VKBD.GET-KEY-REGIONS KEY CONFIG)) - (FOR REGION EXTENDED-REGION IN KEY-REGIONS DO (SETQ EXTENDED-REGION - (VKBD.EXTEND-REGION REGION - BITS)) - (BITBLT NIL NIL NIL WINDOW - (FETCH (REGION LEFT) - OF EXTENDED-REGION) - (FETCH (REGION BOTTOM) - OF EXTENDED-REGION) - (FETCH (REGION WIDTH) - OF EXTENDED-REGION) - (FETCH (REGION HEIGHT) - OF EXTENDED-REGION) - 'TEXTURE - 'REPLACE SHADE)) - (VKBD.DISPLAY-EMPTY-KEY-CAP KEY-REGIONS WINDOW) - (VKBD.DISPLAY-KEY KEY WINDOW CONFIG) - (IF (EQ (WINDOWPROP WINDOW 'VKBD.SHADED-KEY) - KEY) - THEN (VKBD.INVERT-KEY KEY WINDOW))))) (VKBD.GET-CURRENT-KEY-ASSIGNMENT - (LAMBDA (KEY WINDOW/CONFIGURATION) (* \; "Edited 7-Mar-96 12:33 by rmk") - (* \; "Edited 15-Dec-87 16:43 by Snow") - (CONS KEY (KEYACTION (OR (VKBD.TRANSLATE-KEY-ID KEY WINDOW/CONFIGURATION) - KEY))))) (vkbd.get-non-char-label - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:44 by Snow") - - (cond - ((vkbd.shift-assignmentp key-assignment) - "SHIFT") - ((vkbd.lock-assignmentp key-assignment) - "LOCK") - ((vkbd.ctrl-assignmentp key-assignment) - "CTRL") - ((vkbd.lockup-assignmentp key-assignment) - '("LOCK" "UP")) - ((vkbd.lockdown-assignmentp key-assignment) - '("LOCK" "DOWN")) - ((vkbd.meta-assignmentp key-assignment) - "META") - ((vkbd.event-assignmentp key-assignment) - " ") - (t nil)))) (vkbd.iconfn - (lambda (window icon) (* \; "Edited 15-Dec-87 16:44 by Snow") - - (cond - ((null icon) - (setq icon (titlediconw (|create| titledicon - icon _ vkbd.icon - mask _ vkbd.mask - titlereg _ (createregion 5 15 80 50)) - (|fetch| (virtualkeyboard keyboardname) |of| (windowprop - window - 'vkbd.keyboard)) - (fontcreate 'gacha 8))))) - icon)) (VKBD.INVERT-LOCK-KEYS - (LAMBDA (WINDOW) (* \; "Edited 26-Feb-96 17:04 by rmk") - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) - WHEN (VKBD.LOCK-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR - KEY-ASSIGNMENT - ) - WINDOW)))) (VKBD.INVERT-SHIFT-KEYS - (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:13 by rmk") - (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) - WHEN (VKBD.SHIFT-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR - KEY-ASSIGNMENT - ) - WINDOW)))) (VKBD.TRANSLATE-KEY-ID - (LAMBDA (KEY-ID CONFIG) (* \; "Edited 7-Mar-96 12:28 by rmk") - - (* |;;| "Assumes that KEY-ID's that look like key numbers ARE key numbers. Thus, integers in the range [0,\\NKEYS) can't be used as ID's. Returns NIL if the KEY-ID doesn't exist") - - (OR (KEYNUMBERP KEY-ID) - (LET ((NUM (CADR (ASSOC KEY-ID (FETCH KEYNAMESMAPPING OF CONFIG))))) - - (* |;;| - "If result is not a keynumber, then try recursing. Introduces a synonym facility") - - (OR (KEYNUMBERP NUM) - (AND NUM (VKBD.TRANSLATE-KEY-ID NUM CONFIG))))))) (vkbd.key-id-to-key-names - (lambda (key-id window/configuration) (* \; "Edited 15-Dec-87 16:46 by Snow") - - (setq window/configuration (vkbd.get-configuration window/configuration)) - (|for| name-id-pair |in| (|fetch| (keyboardconfiguration keynamesmapping) - |of| window/configuration) - |when| (eq (cadr name-id-pair) - key-id) |collect| (car name-id-pair)))) (VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD (LAMBDA (KEYBOARD) (* \; "Edited 24-May-95 15:25 by rmk:") (* |;;| "T if this keyboard is configured for the current physical keyboardtype.") (MEMB (FETCH (KEYBOARDCONFIGURATION KEYBOARDTYPE) OF (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KEYBOARD))) (ASSOC (KEYBOARDTYPE) KEYBOARDCONFIGCOERCIONS)))) (VKBD.LOCK-ASSIGNMENTP - (LAMBDA (ASSIGNMENT) (* \; "Edited 28-Feb-96 14:33 by rmk") - (* \; "Edited 15-Dec-87 16:47 by Snow") - (SELECTQ (CADR ASSIGNMENT) - (LOCKDOWN (EQ (CDDR ASSIGNMENT) - 'LOCKUP)) - (LOCKTOGGLE (MEMB (CDDR ASSIGNMENT) - '(NIL IGNORE))) - NIL))) (VKBD.LOCK-KEYP - (LAMBDA (KEY WINDOW) (* \; "Edited 26-Feb-96 17:05 by rmk") - (VKBD.LOCK-ASSIGNMENTP (FASSOC KEY (|fetch| (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - |of| (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))))) (vkbd.lock/nolock - (lambda (key-action) (* \; "Edited 15-Dec-87 16:47 by Snow") - - (caddr (cadr key-action)))) (vkbd.lockdown-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:47 by Snow") - - (and (eq (cadr assignment) - 'lockdown) - (or (null (cddr assignment)) - (eq (cddr assignment) - 'ignore))))) (vkbd.lockup-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:48 by Snow") - - (and (eq (cadr assignment) - 'lockup) - (or (null (cddr assignment)) - (eq (cddr assignment) - 'ignore))))) (VKBD.PARSE-CHAR-CODE - (LAMBDA (CHARSPEC) (* \; "Edited 29-Feb-96 10:29 by rmk") - - (* |;;| - "Does the coercion to a character code, causing error if not possible. NIL is passed through.") - - (COND - ((AND (SMALLP CHARSPEC) - (IGEQ CHARSPEC 0) - (ILEQ CHARSPEC 65535)) - CHARSPEC) - ((CHARCODE.DECODE CHARSPEC T)) - (CHARSPEC (ERROR "ILLEGAL CHARACTER SPECIFICATION" CHARSPEC))))) (VKBD.PARSE-KEY-ASSIGNMENT (LAMBDA (KEY-ASSIGNMENT CONFIG UNKNOWNOK) (* \; "Edited 27-Apr-2018 22:38 by rmk:") (* \; "Edited 27-Mar-2018 12:02 by rmk:") (* \; "Edited 27-Mar-2018 12:00 by rmk:") (* \; "Edited 13-Dec-96 17:26 by rmk:") (* \; "Edited 7-Mar-96 12:29 by rmk") (* |;;| "Parses a key assignment using information in CONFIG. Value returned is an image of the key assignment with the key coerced to a keynumber and also the character specifications coerced to codes. This is what goes into the COMPLETEKEYASSIGNMENTS field. If UNKNOWNOK, returns NIL as the keyid if it isn't found in the CONFIG (or if the CONFIG isn't given (on calls from LOADKEYBOARDDISPLAYFONTS).") (PROG (KEY TRKEY UNSHIFTED-CHAR SHIFTED-CHAR LOCK/NOLOCK DOWN UP) (CL:UNLESS (CDR (LISTP KEY-ASSIGNMENT)) (ERROR "ILLEGAL KEY ASSIGNMENT" KEY-ASSIGNMENT)) (SETQ KEY (CAR KEY-ASSIGNMENT)) (CL:UNLESS (SETQ TRKEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (CL:UNLESS UNKNOWNOK (ERROR (CONCAT "KEY NOT KNOWN IN CONFIGURATION " (FETCH CONFIGURATIONNAME OF CONFIG)) KEY-ASSIGNMENT))) (OR T (CL:UNLESS (VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) (* |;;| "Not sure what else it should be. Perhaps cause an error?") (RETURN NIL))) (CL:WHEN (LISTP (SETQ DOWN (CADR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR DOWN))) (* \;  "RMK: LOCKSHIFT is in CADDDR not CADDR") (SETQ DOWN (LIST (VKBD.PARSE-CHAR-CODE (CAR DOWN)) (IF (CADR DOWN) THEN (VKBD.PARSE-CHAR-CODE (CADR DOWN)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR DOWN) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (CL:WHEN (LISTP (SETQ UP (CDDR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR UP))) (SETQ UP (LIST (VKBD.PARSE-CHAR-CODE (CAR UP)) (IF (CADR UP) THEN (VKBD.PARSE-CHAR-CODE (CADR UP)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR UP) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (RETURN `(,TRKEY ,DOWN ,@UP))))) (VKBD.RESET-KEYBOARD-WINDOW - (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:22 by rmk") - (LET (SHADED-KEY) - (IF (SETQ SHADED-KEY (WINDOWPROP WINDOW 'VKBD.SHADED-KEY)) - THEN (VKBD.INVERT-KEY SHADED-KEY WINDOW) - (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL)) - (IF (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) - THEN (VKBD.INVERT-SHIFT-KEYS WINDOW) - (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN NIL)) - (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (VKBD.SEND-CHARACTER - (LAMBDA (KEY WINDOW) (* \; "Edited 28-Feb-96 14:35 by rmk") - (LET (KEY-ASSIGNMENT CHAR-CODE (CONFIG (VKBD.GET-CONFIGURATION WINDOW))) - (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) - (COND - ((VKBD.LOCK-KEYP KEY WINDOW) - (WINDOWPROP WINDOW 'VKBD.LOCKED (NOT (WINDOWPROP WINDOW 'VKBD.LOCKED))) - (VKBD.INVERT-LOCK-KEYS WINDOW)) - (T (SETQ KEY-ASSIGNMENT (FASSOC KEY (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) - OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))) - (COND - ((VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) - (SETQ CHAR-CODE (COND - ((OR (KEYDOWNP 'RSHIFT) - (KEYDOWNP 'LSHIFT) - (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) - (AND (EQ (VKBD.LOCK/NOLOCK KEY-ASSIGNMENT) - 'LOCKSHIFT) - (WINDOWPROP WINDOW 'VKBD.LOCKED))) - (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) - (T (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)))) - (COND - (CHAR-CODE (BKSYSBUF (CHARACTER CHAR-CODE))))))))))) (vkbd.shift-assignmentp - (lambda (assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (or (and (eq (cadr assignment) - '1shiftdown) - (eq (cddr assignment) - '1shiftup)) - (and (eq (cadr assignment) - '2shiftdown) - (eq (cddr assignment) - '2shiftup))))) (vkbd.shifted-char - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (cadadr key-assignment))) (VKBD.UNDEFINE-KEYBOARD (LAMBDA (KEYBOARD-NAME) (* \; "Edited 25-May-95 11:45 by rmk:") (IF (EQ KEYBOARD-NAME 'DEFAULT) THEN (PROMPTPRINT "Cannot delete the default keyboard. ") ELSE (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE (FINDVIRTUALKEYBOARD KEYBOARD-NAME) VKBD.KNOWN-KEYBOARDS))))) (vkbd.unshifted-char - (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") - - (caadr key-assignment))) ) (ADDTOVAR CHARACTERNAMES (BREAK 2) (HOME 524) (PGUP 525) (END 527) (PGDN 528) (INS 529) (HELP 517) (SCRL 521) (NUMLK 522) (CLEAR 523) (DOIT 555) (CENTER 577) (NOTCENTER 609) (BOLD 578) (NOTBOLD 610) (ITALIC 579) (NOTITALIC 611) (UCASE 580) (LCASE 612) (STRIKEOUT 581) (NOTSTRIKEOUT 613) (UNDERLINE 582) (NOTUNDERLINE 614) (SUBSCRIPT 583) (SUPERSCRIPT 615) (SMALLER 584) (LARGER 616) (MARGINS 585) (NOTMARGINS 617) (LOOKS 587) (NOTLOOKS 619) (F11 588) (NOTF11 620) (F12 589) (NOTF12 621)) (DECLARE\: EVAL@COMPILE (RECORD KEYBOARDCONFIGURATION (CONFIGURATIONNAME KBCDUMMY1 KEYREGIONS KBCDUMMY2 DEFAULTASSIGNMENT KEYNAMESMAPPING KEYBOARDTYPE KEYLABELS KEYLABELSFONT BACKGROUNDSHADE KEYBOARDDISPLAYFONT CHARLABELS) (* |;;| "Dummy fields so length test still works") (TYPE? (EQLENGTH DATUM (CONSTANT (LENGTH (RECORDFIELDNAMES ' KEYBOARDCONFIGURATION ))))) KEYBOARDTYPE _ (KEYBOARDTYPE) KEYLABELSFONT _ DEFAULTKEYBOARDLABELSFONT BACKGROUNDSHADE _ 23130 KEYBOARDDISPLAYFONT _ DEFAULTKEYBOARDDISPLAYFONT) (RECORD VIRTUALKEYBOARD (KEYBOARDNAME KEYASSIGNMENTS KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) (HASHLINK VIRTUALKEYBOARD (COMPLETEKEYASSIGNMENTS VKBDHASHARRAY 20))) ) (DECLARE\: EVAL@COMPILE (GLOBALVARS VKBDHASHARRAY)) (SETUPHASHARRAY 'VKBDHASHARRAY 20) (RPAQ? VKBD.KNOWN-KEYBOARDS NIL) (FILESLOAD (SOURCE) KEYBOARDCONFIGS) (RPAQQ VKBD.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" '(ADD.PROCESS '(SWITCHKEYBOARDS T)) "Switches the key actions of the keyborad.") ("Switch and display" '(ADD.PROCESS '(SWITCHKEYBOARDS T T)) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" '(ADD.PROCESS '(SWITCHKEYBOARDS NIL T)) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" '(ADD.PROCESS '(VKBD.STORE-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Stores the current known keyboards") ("Load keyboards file" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL T) 'WINDOW PROMPTWINDOW) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL NIL) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND T NIL) 'WINDOW PROMPTWINDOW) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" '(ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)) "Removes a keyboard from the list of known keyboards") ("Edit" (ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" (SUBITEMS ("New Keyboard, default initial" '(ADD.PROCESS '( VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" ) ("New keyboard, other initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will pop up a menu of the current known keyboards. The selected one will be used as the initial keyboard" ) ("Existing keyboard" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND)) "Will let you select a keyboard from list of the known keyboards, and will calls the keyboard editor on the selected keyboard." ))))) (RPAQQ VKBD.NON-CHAR-ASSIGNMENTS-LABELS ((SHIFT SHIFT) (CTRL CTRL) (META META) (LOCK LOCK) (LOCKUP LOCKUP) (LOCKDOWN LOCKDOWN))) (RPAQQ VKBD.WINDOW-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T NIL W))) "Switches the key actions of the keyborad.") ("Switch and display" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T T W))) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS NIL T W))) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION (VKBD.STORE-FILE-COMMAND)) 'WINDOW PROMPTWINDOW))) "Stores the current known keyboards") ("Load keyboards file" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION (VKBD.LOAD-FILE-COMMAND) ) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND NIL T)) 'WINDOW PROMPTWINDOW))) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND )) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND T NIL)) 'WINDOW PROMPTWINDOW))) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" (FUNCTION (LAMBDA (W) (ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)))) "Removes a keyboard from the list of known keyboards"))) (RPAQQ VKBD.ICON #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HDNGAHLG@HDBA@HDBA@HDBA@HD@GAHLGOOOOOOOOOOOOOOOOOOOOAHLG@BA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBAFGAHLG@BA@HDBA@HDBA@HDBA@GAHLGOOOOOOOOOOOOOOOOOOHGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HHGAHLGOOOOOOOOOOOOOOOOOOOOAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (RPAQQ VKBD.MASK #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) ) (DECLARE\: FIRST (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN) ) (RPAQ? \\ORIGINALDEFAULTKEYACTION ) (DEFINEQ (VKBD.\\KEYBOARDEVENTFN - (LAMBDA (FDEV EVENT EXTRA) (* \; "Edited 1-Mar-96 23:27 by rmk") - - (* |;;| "call the old keyboard event function, then make sure to reset the Virtual keyboard keyaction tables. ") - - (\\OLDKEYBOARDEVENTFN FDEV EVENT EXTRA) - (SELECTQ EVENT - ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) - (SETQ \\VKBD.KEYBOARD.BEFORETYPE (KEYBOARDTYPE))) - ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) - (CL:UNLESS (EQ (KEYBOARDTYPE) - \\VKBD.KEYBOARD.BEFORETYPE) - (SETQ VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) - (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION (KEYBOARDTYPE))) - - (* |;;| "If keyboardtype has changed, we start by setting default keyaction table to the settings it had at the time that virtualkeyboards was originally loaded.") - - (RESETKEYACTION \\DEFAULTKEYACTION \\ORIGINALDEFAULTKEYACTION T) - (VKBD.ADD-DEFAULT-KEYBOARD VKBD.DEFAULT-CONFIGURATION-NAME) - (VKBD.RESETKEYACTIONTABLES))) - NIL))) (VKBD.RESETKEYACTIONTABLES - (LAMBDA NIL (* \; "Edited 4-Mar-96 13:49 by rmk") - (* \; "Edited 16-Feb-95 18:23 by rmk:") - - (* |;;| "Reinstantiate/recomplete all keyboards that were previously operational, and insure that there is a DEFAULT for the new type. Probably should also redraw any open keyboard windows...later.") - - (CL:UNLESS (FINDVIRTUALKEYBOARD 'DEFAULT) - - (* |;;| "This will look for new keyboard files whenever real keyboard changes.") - - (VKBD.INIT)) - (CLRHASH VKBDHASHARRAY) - - (* |;;| "Throw away any cached information, including COMPLETEKEYASSIGNMENTS") - - (FOR KEYBOARD TABLE IN VKBD.KNOWN-KEYBOARDS - DO (CL:WHEN (SETQ TABLE (GETPROP (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARD - ) - 'KEYACTIONTABLE)) - (VKBD.CREATE-KEYACTION-TABLE (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) - OF KEYBOARD) - TABLE))))) ) (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN) (DECLARE\: FIRST (MOVD? 'KEYACTION 'OLDKEYACTION) ) (DEFINEQ (NEWKEYACTION - (LAMBDA (KEYNAME ACTIONS TABLE) (* \; "Edited 7-Mar-96 11:10 by rmk") - - (* |;;| "\\NKEYS is a constant from LLKEY.") - - (PROG (KEYBOARD (KEYNUM (OR (VKBD.TRANSLATE-KEY-ID KEYNAME CURRENTKEYBOARDCONFIG) - (\\KEYNAMETONUMBER KEYNAME)))) - - (* |;;| "Handle the NIL-TABLE cases.") - - (COND - ((AND (NULL TABLE) - (LISTP ACTIONS) - (OR (FMEMB (CAR ACTIONS) - MODEACTIONS) - (FMEMB (CDR ACTIONS) - MODEACTIONS))) - - (* |;;| "If we are setting a mode (as opposed to a character) key, assume that it is intended to be set in all keyboards where that key is still an appropriate mode") - - (FOR KEYBOARD KEYACTION (ORIGKEYACTION _ (CDR (FASSOC KEYNUM \\ORIGKEYACTIONS))) - (MODEACTION _ (CDR (FASSOC KEYNUM MODEKEYS))) IN VKBD.KNOWN-KEYBOARDS - DO (SETQ KEYACTION (CDR (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS - OF KEYBOARD)))) - (COND - ((EQUAL KEYACTION ACTIONS)) - ((OR (NULL KEYACTION) - (EQUAL KEYACTION ORIGKEYACTION) - (EQUAL KEYACTION MODEACTION)) - (NEWKEYACTION KEYNAME ACTIONS KEYBOARD))) - FINALLY (RPLACD (OR (FASSOC KEYNUM MODEKEYS) - (CAR (PUSH MODEKEYS (CONS KEYNUM)))) - ACTIONS)) - (RETURN T) (* \; - "This will cause an error if we try to pass it back in. What else can we do?") - )) - -(* |;;;| "get the keyboard or key action table.") - - (COND - ((NULL TABLE) - (SETQ TABLE \\CURRENTKEYACTION)) - ((LITATOM TABLE) - (COND - ((SETQ KEYBOARD (FASSOC TABLE VKBD.KNOWN-KEYBOARDS)) - (SETQ TABLE (GETPROP TABLE 'KEYACTIONTABLE))) - (T (ERROR TABLE "is not a defined keyboard.")))) - ((LISTP TABLE) - (COND - ((FMEMB TABLE VKBD.KNOWN-KEYBOARDS) - (SETQ KEYBOARD TABLE) - (SETQ TABLE (GETPROP (FETCH KEYBOARDNAME OF TABLE) - 'KEYACTIONTABLE))) - (T (ERROR TABLE "is not a defined keyboard.")))) - (T (FOR VKBD IN VKBD.KNOWN-KEYBOARDS - WHEN (EQ TABLE (GETPROP (FETCH KEYBOARDNAME OF VKBD) - 'KEYACTIONTABLE)) DO (SETQ KEYBOARD VKBD)))) - - (* |;;| "If TABLE is NIL, means that we are setting a virtual keyboard for which a keyaction table hasn't yet been created.") - - (RETURN - (PROG1 - (COND - (TABLE (OLDKEYACTION KEYNUM ACTIONS TABLE)) - (KEYBOARD (* \; - "virtual keyboard package allows incomplete keyboards with defaults from \\ORIGKEYACTIONS.") - (CDR (IF (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - THEN (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS - OF KEYBOARD)) - ELSE (LET (A) - (IF (SETQ A (OR (VKBD.KEY-ASSOC KEYNAME - (FETCH KEYASSIGNMENTS - OF KEYBOARD) - CURRENTKEYBOARDCONFIG) - (VKBD.KEY-ASSOC KEYNAME - (FETCH DEFAULTASSIGNMENT - OF - CURRENTKEYBOARDCONFIG - ) - CURRENTKEYBOARDCONFIG) - (VKBD.KEY-ASSOC KEYNAME - VKBD.COMMONDEFAULTASSIGNMENT - CURRENTKEYBOARDCONFIG))) - THEN (VKBD.PARSE-KEY-ASSIGNMENT A - CURRENTKEYBOARDCONFIG) - ELSE (FASSOC KEYNUM \\ORIGKEYACTIONS)))))) - (T (SHOULDNT))) - (COND - ((AND KEYBOARD ACTIONS) - - (* |;;| -"Set the keyaction in the virtual keyboard, which keeps it consistent with the corresponding table.") - - (CL:WHEN (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) - (PUTASSOC KEYNUM (CDR (VKBD.PARSE-KEY-ASSIGNMENT (CONS KEYNUM ACTIONS) - CURRENTKEYBOARDCONFIG)) - (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD))) - (IF (FETCH KEYASSIGNMENTS OF KEYBOARD) - THEN (PUTASSOC KEYNAME ACTIONS (FETCH KEYASSIGNMENTS OF KEYBOARD)) - ELSE (PUSH (FETCH KEYASSIGNMENTS OF KEYBOARD) - (CONS KEYNAME ACTIONS)))))))))) ) (MOVD 'NEWKEYACTION 'KEYACTION) (RPAQ? MODEKEYS ) (RPAQQ MODEACTIONS (EVENT CTRLUP CTRLDOWN 1SHIFTUP 1SHIFTDOWN 2SHIFTUP 2SHIFTDOWN LOCKUP LOCKDOWN LOCKTOGGLE METAUP METADOWN FONTUP FONTDOWN FONTTOGGLE USERMODE1UP USERMODE1DOWN USERMODE1TOGGLE USERMODE2UP USERMODE2DOWN USERMODE2TOGGLE USERMODE3UP USERMODE3DOWN USERMODE3TOGGLE)) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MODEKEYS MODEACTIONS) ) (DEFINEQ (METASHIFT - (LAMBDA FLG (* \; "Edited 16-Jun-92 08:44 by rmk:") - - (* |;;| "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting. Returns previous setting. This differs from LLKEY version in that it changes the \\DORADOKEYACTIONS and \\DEFAULTKEYACTION table to insure that the metashift remains in effect across keyboard switches.") - - (PROG* ((METASTATUS '(METADOWN . METAUP)) - (ARGUMENT (AND (IGREATERP FLG 0) - (COND - ((EQ (ARG FLG 1) - T) - METASTATUS) - (T (OR (ARG FLG 1) - (CDR (ASSOC 'BLANK-BOTTOM \\ORIGKEYACTIONS))))))) - OLDSETTING) - (SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM ARGUMENT)) - - (* |;;| - "Update \\doradokeyactions table so we don't lose the change when we repalce the keyaction table.") - - (AND (EQ (MACHINETYPE) - 'DORADO) - (COND - (ARGUMENT (PUTASSOC 'BLANK-BOTTOM ARGUMENT \\DORADOKEYACTIONS) - (KEYACTION 'BLANK-BOTTOM ARGUMENT \\DEFAULTKEYACTION)) - (T (SETQ \\DORADOKEYACTIONS (|for| X |in| \\DORADOKEYACTIONS - |join| (AND (NEQ (CAR X) - 'BLANK-BOTTOM) - (LIST X)))) - (KEYACTION 'BLANK-BOTTOM NIL \\DEFAULTKEYACTION)))) - (RETURN (COND - ((EQUAL OLDSETTING METASTATUS) - T) - (T OLDSETTING)))))) ) (* \; "Call new definition if the old one had been called") (AND (EQ (MACHINETYPE) 'DORADO) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)) (ADDTOVAR BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT)) (DEFINEQ (FIXKEYBOARD - (LAMBDA (KBD) (* \; "Edited 28-Feb-96 13:36 by rmk") - - (* |;;| "This is a function use to coerce existing keyboards into a more reasonable format. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") - - (LET ((KC (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KBD)))) - - (* |;;| "Fix keyassignments and then remove duplicates of default keyassignments") - - (REPLACE KEYASSIGNMENTS OF KBD - WITH (SORT (FOR KA (DEF _ (FETCH DEFAULTASSIGNMENT OF KC)) - IN (FIXKEYASSIGNMENTS (FETCH KEYASSIGNMENTS OF KBD) - KC) UNLESS (MEMBER KA DEF) COLLECT KA) - T))))) (FIXKEYBOARDCONFIG - (LAMBDA (CONFIG) (* \; "Edited 29-Feb-96 13:27 by rmk") - - (* |;;| "Makes sure that CONFIG obeys keynaming conventions that force all reference to be by name and insure that names are not digits.") - - (LET (KEYNUMBERTONAME) - (FOR KN NAME FNAME FOUND IN (FETCH KEYNAMESMAPPING OF CONFIG) - DO (SETQ NAME (IF (AND (SMALLP (CAR KN)) - (IGEQ (CAR KN) - 0) - (ILEQ (CAR KN) - 9)) - THEN (CL:INTERN (CONCAT (CAR KN)) - 'INTERLISP) - ELSE (CAR KN))) - (IF (NULL (SETQ FOUND (ASSOC (CADR KN) - KEYNUMBERTONAME))) - THEN (PUSH KEYNUMBERTONAME (LIST (CADR KN) - NAME)) - ELSEIF (OR (EQ NAME (SETQ FNAME (CADR FOUND))) - (AND (EQ 1 (NCHARS FNAME)) - (OR (AND (IGEQ (CHCON1 FNAME) - (CHARCODE 0)) - (ILEQ (CHCON1 FNAME) - (CHARCODE 9))) - (EQ FNAME (U-CASE NAME))))) - ELSE - - (* |;;| - "This is the preferred name. We prefer digit-names and upper-case equivalents") - - (RPLACA (CDR FOUND) - NAME))) - - (* |;;| "Coerce digit keynames to atoms") - - (FOR K IN (FETCH KEYNAMESMAPPING OF CONFIG) - WHEN (AND (SMALLP (CAR K)) - (IGEQ (CAR K) - 0) - (ILEQ (CAR K) - 9)) DO (RPLACA K (CL:INTERN (CONCAT (CAR K)) - 'INTERLISP))) - - (* |;;| "Introduce ZERO, ONE... synonyms for digit keys") - - (NCONC (FETCH KEYNAMESMAPPING OF CONFIG) - (FOR I FROM 0 AS N - IN '(ZERO ONE TWO THREE FOUR FIVE SIX SEVEN EIGHT NINE) - UNLESS (ASSOC N (FETCH KEYNAMESMAPPING OF CONFIG)) - COLLECT (LIST N (CL:INTERN (CONCAT I) - 'INTERLISP)))) - (REPLACE KEYREGIONS OF CONFIG - WITH (IF (FOR K IN (FETCH KEYREGIONS OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH KEYREGIONS OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH KEYREGIONS OF CONFIG) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K))))) - (REPLACE DEFAULTASSIGNMENT OF CONFIG - WITH (SORT (IF (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH DEFAULTASSIGNMENT OF CONFIG - ) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K)))) - T)) - - (* |;;| "Convert char-codes to characters, more or less.") - - (FIXKEYASSIGNMENTS (FETCH DEFAULTASSIGNMENT OF CONFIG) - CONFIG) - (REPLACE KEYLABELS OF CONFIG - WITH (SORT (IF (FOR K IN (FETCH KEYLABELS OF CONFIG) - ALWAYS (KEYNUMBERP (CAR K))) - THEN (FOR K IN (FETCH KEYLABELS OF CONFIG) - COLLECT (CONS (OR (CADR (ASSOC (CAR K) - KEYNUMBERTONAME)) - (HELP "UNNAMED KEYREGION KEY" K)) - (CDR K))) - ELSE (FOR K KN IN (FETCH KEYLABELS OF CONFIG) - COLLECT (SETQ KN (CAR K)) - (CONS (IF (AND (SMALLP KN) - (IGEQ KN 0) - (ILEQ KN 9)) - THEN (CL:INTERN (CONCAT KN) - 'INTERLISP) - ELSE KN) - (CDR K)))) - T))) - CONFIG)) (FIXKEYASSIGNMENTS - (LAMBDA (KALIST CONFIG) (* \; "Edited 7-Mar-96 11:20 by rmk") - - (* |;;| "Fix keynames and convert char-codes to characters, more or less. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") - - (* |;;| "NOTE: This uses names and character labels from CONFIG, so it should only be run with key assignments that are already CONFIG compatible.") - - (FOR KA CODE LAB (CHARLABELS _ (APPEND (FETCH CHARLABELS OF CONFIG) - VKBD.COMMONCHARLABELS)) - (KNM _ (FETCH KEYNAMESMAPPING OF CONFIG)) IN KALIST - DO - - (* |;;| "First make keynames be the ones that are used in he keymapping") - - (RPLACA KA (FOR KN FOUND IN KNM - DO - - (* |;;| "Give preference to digit-labels") - - (IF (NEQ (CAR KA) - (CADR KN)) - ELSEIF (AND (SMALLP (CAR KN)) - (IGEQ (CAR KN) - 0) - (ILEQ (CAR KN) - 9)) - THEN (RETURN (CL:INTERN (CONCAT (CAR KN) - 'INTERLISP))) - ELSEIF (AND (EQ 1 (NCHARS (CAR KN))) - (SMALLP (NTHCHAR (CAR KN) - 1))) - THEN (RETURN (CAR KN)) - ELSEIF (NOT FOUND) - THEN (SETQ FOUND (CAR KN))) - FINALLY (RETURN (OR FOUND (CAR KA))))) - - (* |;;| "Shift to actions") - - (SETQ KA (CDR KA)) - - (* |;;| "Get rid of gratuitous uptransition ignores") - - (CL:WHEN (EQ 'IGNORE (CDR KA)) - (RPLACD KA)) - - (* |;;| "Shift to down transition") - - (SETQ KA (CAR KA)) - - (* |;;| - "Make keyactions use characters in the ascii range instead of codes. 241 is Latin rendering") - - (CL:WHEN (LISTP KA) - - (* |;;| "Eliminate unnecessary NOLOCKSHIFT when lower and upper are the same") - - (IF (AND (EQ (CAR KA) - (CADR KA)) - (MEMB (CADDR KA) - '(NOLOCKSHIFT NLS))) - THEN (RPLACD (CDR KA)) - ELSE - - (* |;;| "Introduce a shorter abbreviation") - - (SELECTQ (CADDR KA) - (LOCKSHIFT (RPLACD (CDR KA) - 'LS)) - (NOLOCKSHIFT (RPLACD (CDR KA) - 'NLS)) - NIL)) - (SETQ CODE (CAR KA)) - (IF (SMALLP CODE) - THEN (RPLACA KA (IF (SMALLP CODE) - THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) - )) - ELSEIF (OR (AND (IGREATERP CODE 32) - (ILESSP CODE 255)) - (EQ (LRSH CODE 8) - 241)) - THEN (SETQ LAB (CHARACTER CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE (MKATOM (CHARCODESTRING CODE))) - ELSEIF (STRINGP CODE) - THEN (SETQ LAB (MKATOM CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE CODE))) - - (* |;;| "Shift to shift code") - - (SETQ KA (CDR KA)) - (SETQ CODE (CAR KA)) - (IF (SMALLP CODE) - THEN (RPLACA KA (IF (SMALLP CODE) - THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) - )) - ELSEIF (OR (AND (IGREATERP CODE 32) - (ILESSP CODE 255)) - (EQ (LRSH CODE 8) - 241)) - THEN (SETQ LAB (CHARACTER CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE - - (* |;;| - "Coerce to octal cset,ccode format") - - (MKATOM (CHARCODESTRING CODE))) - ELSEIF (STRINGP CODE) - THEN (SETQ LAB (MKATOM CODE)) - (CL:IF (SMALLP LAB) - (CL:INTERN (CONCAT LAB) - 'INTERLISP) - LAB) - ELSE CODE))))) - - (* |;;| "Remove duplicates, leaving the head of the list unchanged, and keeping first occurrences of duplicates") - - (RPLACD KALIST (FOR XTAIL X ON (CDR KALIST) EACHTIME (SETQ X (CAR XTAIL)) - UNLESS (THEREIS YTAIL ON KALIST UNTIL (EQ YTAIL XTAIL) - SUCHTHAT (EQUAL X (CAR YTAIL))) COLLECT (CAR XTAIL))) - KALIST)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (VKBD.INIT) ) (FILESLOAD ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA METASHIFT) ) (PUTPROPS VIRTUALKEYBOARDS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993 1995 1996 2017 2018)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5276 13932 (FINDVIRTUALKEYBOARD 5286 . 8440) (PROCESS.KEYBOARD 8442 . 11118) ( VKBD.CREATE-KEYACTION-TABLE 11120 . 13036) (VKBD.WINDOWMENUFN 13038 . 13305) (VKBD.WINDOWMENUINIT 13307 . 13930)) (13933 19294 (LOADKEYBOARDDISPLAYFONTS 13943 . 19292)) (19403 20627 (DEFINEKEYBOARD 19413 . 20625)) (20628 25046 (VKBD.ADD-ITEM-TO-BACKGROUND-MENU 20638 . 21046) (VKBD.INIT 21048 . 23586 ) (VKBD.CREATE-DEFAULT-KEYBOARD 23588 . 24180) (VKBD.ADD-DEFAULT-KEYBOARD 24182 . 25044)) (25047 31387 (VKBD.LOAD-FILE-COMMAND 25057 . 25511) (VKBD.LOAD-KEYBOARD-FILE 25513 . 29348) ( VKBD.STORE-FILE-COMMAND 29350 . 29691) (VKBD.STORE-KEYBOARD-FILE 29693 . 31385)) (31388 40689 ( SWITCHKEYBOARDS 31398 . 32876) (VKBD.POP-MENU-AND-SWITCH-KEYBOARDS 32878 . 33248) ( VKBD.POP-UP-KEYBOARDS-MENU 33250 . 34632) (VKBD.GET-CONFIGURATION 34634 . 35552) ( VKBD.SUBCONFIGURATION 35554 . 40687)) (40690 80975 (VKBD.BUTTONEVENTFN 40700 . 43607) ( VKBD.CENTER-BITMAP-IN-REGION 43609 . 45133) (VKBD.CLEAR-KEY-DISPLAY 45135 . 47266) ( VKBD.CREATE-KEYBOARD-BITMAP 47268 . 49312) (VKBD.CREATE-KEYBOARD-DISPLAY 49314 . 52443) ( VKBD.CURSORMOVEDFN 52445 . 54349) (VKBD.DISPLAY-CHARACTER 54351 . 56309) (VKBD.DISPLAY-EMPTY-KEY-CAP 56311 . 66849) (VKBD.DISPLAY-KEY 66851 . 70058) (VKBD.DISPLAY-KEY-CHARACTERS 70060 . 71253) ( VKBD.DRAW-KEY-CAPS 71255 . 73443) (VKBD.ERASE-FRAME 73445 . 73768) (VKBD.EXTEND-REGION 73770 . 74359) (VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION 74361 . 74976) (VKBD.GET-KEY-REGIONS 74978 . 75234) ( VKBD.INVERT-KEY 75236 . 75526) (VKBD.INVERT-REGION 75528 . 76219) (VKBD.KEYBOARD-WINDOW-REPAINTFN 76221 . 78178) (VKBD.LOWER-HALF-REGION 78180 . 78580) (VKBD.POSITION-IS-IN-KEY-REGION 78582 . 78866) ( VKBD.REMOVE-KEYBOARD-COMMAND 78868 . 79325) (VKBD.UNION-REGIONS 79327 . 80472) (VKBD.UPPER-HALF-REGION 80474 . 80973)) (80976 100534 (VKBD.KEY-ASSOC 80986 . 81486) (VKBD.CHAR-ASSIGNMENTP 81488 . 81652) ( VKBD.COMPLETE-KEYBOARD 81654 . 84313) (VKBD.CTRL-ASSIGNMENTP 84315 . 84558) (VKBD.EVENT-ASSIGNMENTP 84560 . 84800) (VKBD.META-ASSIGNMENTP 84802 . 85045) (VKBD.FRAME-KEY 85047 . 86924) ( VKBD.GET-CURRENT-KEY-ASSIGNMENT 86926 . 87295) (VKBD.GET-NON-CHAR-LABEL 87297 . 87952) (VKBD.ICONFN 87954 . 88690) (VKBD.INVERT-LOCK-KEYS 88692 . 89370) (VKBD.INVERT-SHIFT-KEYS 89372 . 90054) ( VKBD.TRANSLATE-KEY-ID 90056 . 90735) (VKBD.KEY-ID-TO-KEY-NAMES 90737 . 91223) ( VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD 91225 . 91823) (VKBD.LOCK-ASSIGNMENTP 91825 . 92272) ( VKBD.LOCK-KEYP 92274 . 92592) (VKBD.LOCK/NOLOCK 92594 . 92753) (VKBD.LOCKDOWN-ASSIGNMENTP 92755 . 93049) (VKBD.LOCKUP-ASSIGNMENTP 93051 . 93341) (VKBD.PARSE-CHAR-CODE 93343 . 93842) ( VKBD.PARSE-KEY-ASSIGNMENT 93844 . 97300) (VKBD.RESET-KEYBOARD-WINDOW 97302 . 97895) ( VKBD.SEND-CHARACTER 97897 . 99406) (VKBD.SHIFT-ASSIGNMENTP 99408 . 99802) (VKBD.SHIFTED-CHAR 99804 . 99962) (VKBD.UNDEFINE-KEYBOARD 99964 . 100371) (VKBD.UNSHIFTED-CHAR 100373 . 100532)) (113602 116048 ( VKBD.\\KEYBOARDEVENTFN 113612 . 114815) (VKBD.RESETKEYACTIONTABLES 114817 . 116046)) (116154 122305 ( NEWKEYACTION 116164 . 122303)) (122810 124666 (METASHIFT 122820 . 124664)) (125023 141211 (FIXKEYBOARD 125033 . 126153) (FIXKEYBOARDCONFIG 126155 . 133379) (FIXKEYASSIGNMENTS 133381 . 141209))))) STOP \ No newline at end of file diff --git a/library/lafite/LAFITE.~1~ b/library/lafite/LAFITE.~1~ deleted file mode 100644 index f02d90c5..00000000 --- a/library/lafite/LAFITE.~1~ +++ /dev/null @@ -1,500 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 6-Aug-93 15:49:08" {DSK}lafite>sources>lafite.;20 63548 - - changes to%: (VARS LAFITEFILES LAFITESUBQUITMENUITEMS LAFITECOMS) (FNS \LAFITE.OPEN.FOLDER LAFITE.COMPUTE.CACHED.VARS) - - previous date%: " 9-Nov-89 12:21:33" {DSK}lafite>sources>lafite.;18) - - -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1993 by Xerox Corporation and Bolt Beranek and Newman Inc.. All rights reserved. -") - -(PRETTYCOMPRINT LAFITECOMS) - -(RPAQQ LAFITECOMS ((COMS (E (SETQ LAFITESYSTEMDATE (DATE))) (VARS LAFITEVERSION# LAFITESYSTEMDATE)) (COMS (FNS LAFITE LAFITE.ON.FROM.BACKGROUND \LAFITE.OFF \LAFITE.START.PROC LAFITE.COMPUTE.CACHED.VARS \LAFITE.PROCESS \LAFITE.START.ABORT \LAFITE.QUIT \LAFITE.RESTART \LAFITE.SUBQUIT \LAFITE.QUIT.PROC \LAFITEDEFAULTHOST&DIR LAFITEDEFAULTHOST&DIR MAKELAFITECOMMANDWINDOW EXTRACTMENUCOMMAND DOMAINLAFITECOMMAND LAFITE.TOGGLE.SERVER.TRACE) (PROP ARGNAMES LAFITE) (FNS LAFITEMODE \LAFITE.INFER.MODE \LAFITE.SHOW.MODE \LAFITE.MODE.TITLE LAFITE.SHOW.MODE.P LAFITE.ALL.MODES.P SET.LAFITE.MODE.INTERACTIVELY \LAFITE.COMPUTE.MODE.COMMANDS) (PROP VARTYPE LAFITEMODELST) (ADDVARS (LAFITEMODELST)) (INITVARS (\LAFITEMODE) (\LAFITE.AUTHENTICATION.FAILURE) (LAFITE.BACKGROUND.ITEM (QUOTE ("Mail" (QUOTE (\LAFITE.MESSAGEFORM NIL NIL (QUOTE LEFT))) "Send an ordinary message. See subcommands for other operations." (SUBITEMS ("Turn Lafite on" (QUOTE (LAFITE.ON.FROM.BACKGROUND)) "Turn on Lafite, bringing up status window and browsing default folder.") ("Send Mail" (QUOTE (\LAFITE.MESSAGEFORM)) "Send a message. Prompts for type of message.") ("Set Lafite Mode" (QUOTE (SET.LAFITE.MODE.INTERACTIVELY)) "Set or change Lafite's mail protocol mode.")))))) (FNS \LAFITE.LOGIN \LAFITE.LOGIN.NORESTART LAFITE.PROMPT.FOR.LOGIN \LAFITE.REAUTHENTICATE)) (INITVARS * LAFITEPROFILEVARS) (INITVARS * LAFITERANDOMGLOBALS) (VARS * LAFITEMARKS) (VARS LAFITECOMMANDMENUITEMS LAFITEUPDATEMENUITEMS LAFITESUBQUITMENUITEMS ANOTHERFOLDERMENUITEM) (INITVARS (LAFITESTATUSWINDOW) (\ACTIVELAFITEFOLDERS) (\LAFITE.TEMPFILES) (\LAFITE.MODE.CHOICES) (LAFITESUBQUITMENU)) (ADDVARS (LAFITEMENUVARS LAFITESUBQUITMENU)) (COMS (INITVARS (\LAFITE.ACTIVE) (\LAFITE.READY) (\LAFITEDEFAULTHOST&DIR) (\LAFITE.ACTIVE.MODES) (\LAFITE.CURRENT.USER) (LAFITE.USER.INFO) (*LAFITE-WELL-KNOWN-MODES*) (*LAFITE-LOGGING-IN*)) (ADDVARS (\SYSTEMCACHEVARS \LAFITE.READY \LAFITE.ACTIVE.MODES) (LAFITE.PERSONAL.VARS LAFITEDEFAULTHOST&DIR LAFITE.SIGNATURE)) (FNS LAFITE.AROUNDEXIT \LAFITE.MARK.FOLDERS.OBSOLETE \LAFITE.CHECK.FOLDERS \LAFITE.ASSURE.FOLDER.READY \LAFITE.AFTERLOGIN)) (COMS (* ; "misc utilities") (FNS LA.RESETSHADE LA.MENU.ITEM NTHMESSAGE \LAFITE.MAKE.MSGARRAY \LAFITE.ADDMESSAGES.TO.ARRAY \MAILFOLDER.DEFPRINT \LAFITEMSG.DEFPRINT LA.POSITION.FROM.REGION MAILFOLDERBUSY) (CURSORS LA.CROSSCURSOR) (* ; "Low level file functions") (FNS TOCFILENAME DELETEMAILFOLDER \LAFITE.OPEN.FOLDER \LAFITE.REPORT.FILE.WONT.OPEN \LAFITE.FOLDER.CHANGED \LAFITE.REBROWSE.FOLDER \LAFITE.FOLDER.CHANGED.MENU \LAFITE.SET.FOLDER.STREAM \LAFITE.OPENSTREAM \LAFITE.CREATE.MENU \LAFITE.EOF \LAFITE.CLOSE.FOLDER) (FNS \LAFITE.DESCRIBE.FOLDER)) (COMS (* ; "Make is easy to load new versions of Lafite") (FNS LOAD-LAFITE) (VARS LAFITEFILES)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T) (GLOBALVARS TEDIT.DEFAULT.MENU LAFITEFILES *COMPILED-EXTENSIONS*) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAFITE-LOGGING-IN*))))) (INITRECORDS MAILFOLDER LAFITEMSG) (SYSRECORDS MAILFOLDER LAFITEMSG) (COMS (FNS \LAFITE.GLOBAL.INIT) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITESEND LAFITEMAIL LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE) (P * (PROGN LAFITE.PROCLAMATIONS)) (* ; "Proclaim user interface variables. Value is on LAFITEDECLS") (P (\LAFITE.GLOBAL.INIT) (COND ((EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSCHARPATCH) (* ; "Patch to horrid Lyric NS chars bug") (MOVD? (QUOTE PROMPTFORWORD) (QUOTE TTYINPROMPTFORWORD) NIL T)))))) (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAFITE))))) - -(RPAQQ LAFITEVERSION# 10) - -(RPAQQ LAFITESYSTEMDATE " 6-Aug-93 15:49:09") -(DEFINEQ - -(LAFITE -(LAMBDA X (* ; "Edited 13-Jun-88 10:47 by bvm") (* ;;; "The first argument should be :ON or :OFF. The second argument, if supplied, is the name of the mailfile Lafite should browse unless the second argument is NIL in which case no mailfile will be browsed. If there is no second argument then default to DEFAULTMAILFOLDERNAME mailfile -- currently ACTIVE") (PROG ((CMD (COND ((< X 1) (* ; "Lafite called with no args") :ON) (T (ARG X 1)))) OPTIONS) RETRY (RETURN (CASE CMD ((:ON ON) (COND (\LAFITE.ACTIVE (* ; "Already on!") (TOTOPW LAFITESTATUSWINDOW) :ON) (T (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.START.PROC)) (QUOTE (\, (COND ((OR (<= X 1) (EQ (ARG X 2) T)) DEFAULTMAILFOLDERNAME) (T (ARG X 2))))) (QUOTE (\, (for I from 3 to X collect (LET ((OP (ARG X I))) (if (CL:KEYWORDP OP) then OP elseif (CL:SYMBOLP OP) then (* ; "Old interface wasn't with keywords, so help out") (CL:INTERN (CL:SYMBOL-NAME OP) *KEYWORD-PACKAGE*) else (\ILLEGAL.ARG OP)))))))) (QUOTE LAFITE)) (QUOTE :ON)))) ((:OFF OFF RESTART) (if (\LAFITE.OFF) then (* ; "Successfully turned Lafite off") (COND ((EQ CMD (QUOTE RESTART)) (APPLY (FUNCTION LAFITE) (CONS :ON (for I from 2 to X collect (ARG X I))))) (T :OFF)))) (T (if (NEQ CMD (SETQ CMD (U-CASE CMD))) then (GO RETRY) else (LISPERROR "ILLEGAL ARG" CMD))))))) -) - -(LAFITE.ON.FROM.BACKGROUND -(LAMBDA NIL (* ; "Edited 13-Jun-88 11:18 by bvm") (* ;; "Called from background menu to turn lafite on.") (COND (\LAFITE.ACTIVE (* ; "Already on!") (TOTOPW LAFITESTATUSWINDOW) (PROMPTPRINT "Lafite is already on.")) (T (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.START.PROC)) (QUOTE (\, DEFAULTMAILFOLDERNAME)) NIL)) (QUOTE LAFITE))))) -) - -(\LAFITE.OFF -(LAMBDA NIL (* ; "Edited 6-Jun-88 19:53 by bvm") (* ;; "If Lafite is on, turn it off. Returns T if successfully off") (OR (NULL \LAFITE.ACTIVE) (PROGN (* ; "Lafite was on") (COND ((EQ \LAFITE.ACTIVE (QUOTE INIT)) (* ; "Zap the initializer") (DEL.PROCESS (QUOTE LAFITE)))) (\LAFITE.QUIT.PROC (LA.MENU.ITEM (FUNCTION \LAFITE.QUIT) LAFITEMAINMENU) LAFITEMAINMENU)))) -) - -(\LAFITE.START.PROC -(LAMBDA (MAILFILE OPTIONS) (* ; "Edited 10-Aug-89 17:21 by bvm") (RESETSAVE NIL (LIST (FUNCTION \LAFITE.START.ABORT))) (SETQ \LAFITE.ACTIVE (QUOTE INIT)) (COND ((NOT (WINDOWP LAFITESTATUSWINDOW)) (MAKELAFITECOMMANDWINDOW))) (\LAFITE.REINITIALIZING T) (\LAFITEDEFAULTHOST&DIR (OR LAFITEDEFAULTHOST&DIR LOGINHOST/DIR)) (SETQ \LAFITE.BROWSELOCK (CREATE.MONITORLOCK "Lafite Browser Control")) (* ; "Used by anyone creating browsers or otherwise concerned with changes to \ACTIVELAFITEFOLDERS") (SETQ \LAFITE.MAINLOCK (CREATE.MONITORLOCK "Lafite Main")) (* ; "Used by \LAFITE.CLOSE.OTHER.FOLDERS or anyone who needs access to multiple arbitrary folders") (SETQ \LAFITE.PROFILELOCK (CREATE.MONITORLOCK "Lafite Profile")) (SETQ \LAFITE.HARDCOPYLOCK (CREATE.MONITORLOCK "Lafite hardcopy")) (* ; "Used by anyone reading or writing the Lafite profile") (SETQ LAFITE.FOLDER.STRUCTURE (SETQ LAFITEMAILFOLDERS (SETQ LAFITEFORMFILES NIL))) (SETQ LAFITE.UPDATE.MENU.HASH (HASHARRAY 5)) (\LAFITE.READ.PROFILE) (LAFITE.COMPUTE.CACHED.VARS) (SETQ \LAFITE.READY T) (pushnew \AFTERLOGINFNS (FUNCTION \LAFITE.AFTERLOGIN)) (pushnew AROUNDEXITFNS (FUNCTION LAFITE.AROUNDEXIT)) (SETQ \LAFITE.ACTIVE T) (ADD.PROCESS (CONSTANT (LIST (FUNCTION LAFITEMAILWATCH))) (QUOTE RESTARTABLE) (QUOTE HARDRESET) (QUOTE AFTEREXIT) (QUOTE SUSPEND)) (* ; "Finally, enable menu") (replace (MENU WHENSELECTEDFN) of LAFITEMAINMENU with (FUNCTION DOMAINLAFITECOMMAND)) (COND ((OR MAILFILE (AND (MEMB :SHRINK OPTIONS) (SETQ MAILFILE DEFAULTMAILFOLDERNAME))) (\LAFITE.BROWSE.PROC (LA.MENU.ITEM (FUNCTION \LAFITE.BROWSE) LAFITEMAINMENU) LAFITEMAINMENU MAILFILE (if (AND MAILFILE (NLISTP MAILFILE)) then (* ; "Make it the %"active%" folder as well") (CONS :ACTIVE (MKLIST OPTIONS)) else OPTIONS))))) -) - -(LAFITE.COMPUTE.CACHED.VARS -(LAMBDA NIL (* ; "Edited 3-Jun-92 17:46 by bvm") (* ;; "Clears or recomputes all cached information that is based on some possibly user-settable variable.") (SETQ \LAFITE.DISPLAY.COMMANDS (APPEND (for CMD in (fetch (MENU ITEMS) of TEDIT.DEFAULT.MENU) when (CL:MEMBER (if (LISTP CMD) then (CAR CMD) else CMD) (QUOTE ("put" "find" "Expanded Menu")) :TEST (QUOTE STRING-EQUAL)) collect CMD) (for CMD in LAFITE.EXTRA.DISPLAY.COMMANDS collect (if (STRING-EQUAL (CAR CMD) "looks") then (* ; "Add subcommands, so user can easily add more functions to do Looks.") (LIST (CAR CMD) (CADR CMD) (CADDR CMD) (CONS (QUOTE SUBITEMS) (APPEND (CDR (CADDDR CMD)) LAFITE.LOOKS.SUBCOMMANDS))) else CMD)))) (for USERVAR in (QUOTE (LAFITE.DONT.DISPLAY.HEADERS LAFITE.DONT.FORWARD.HEADERS LAFITE.DONT.HARDCOPY.HEADERS)) as IVAR in (QUOTE (\LAPARSE.DONT.DISPLAY.HEADERS \LAPARSE.DONT.FORWARD.HEADERS \LAPARSE.DONT.HARDCOPY.HEADERS)) do (* ; "Make parse tables out of user vars that list fields to omit from headers") (SET IVAR (AND (EVALV USERVAR) (for FIELD in (EVALV USERVAR) collect (if (STRING-EQUAL FIELD "GV") then (* ; "Kludge! Designed to eat GVGV nonsense that comes AFTER the header") (LIST (QUOTE % -) (FUNCTION LAFITE.EAT.GVGV)) elseif (EQ FIELD :ORIGINAL) then (LIST "Original-" (FUNCTION LAFITE.HANDLE.ORIGINAL.FIELD)) else (LIST FIELD (FUNCTION LAFITE.EAT.UNDESIRABLE.FIELD))))))) (for VAR in LAFITEMENUVARS do (* ; "Clear cached menus") (SET VAR NIL)) (for FOLDER in \ACTIVELAFITEFOLDERS do (for W in (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER) when (WINDOWP W) do (WINDOWPROP W (QUOTE TEDIT.MENU.COMMANDS) \LAFITE.DISPLAY.COMMANDS) (WINDOWPROP W (QUOTE TEDIT.MENU) NIL))) (LET ((OLDABBREVS \LAFITE.PSEUDO.DEVICES) (NEWABBREVS (DREMOVE NIL (for PAIR in LAFITE.HOST.ABBREVS bind FIELDS NAMES collect (if (AND (for STR in (SETQ NAMES (if (LISTP (SETQ NAMES (CAR PAIR))) then (APPEND NAMES) else (LIST NAMES))) always (AND (STRINGP STR) (EQ (NTHCHARCODE STR -1) (CHARCODE ":")))) (for TAIL on (SETQ FIELDS (UNPACKFILENAME.STRING (CADR PAIR))) by (CDDR TAIL) always (FMEMB (CAR TAIL) (QUOTE (HOST DIRECTORY DEVICE))))) then (* ; "CAR is list of pseudo-devices (must be strings ending in colon), CDR is unpacked fields") (CONS NAMES FIELDS) else (PRINTOUT PROMPTWINDOW T "Bad host abbreviation: " PAIR) NIL))))) (if (NOT (PROG1 (EQUAL (CDR \LAFITE.PSEUDO.DEVICES) NEWABBREVS) (SETQ \LAFITE.PSEUDO.DEVICES (AND NEWABBREVS (CONS (CONS NIL (fetch UNPACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR)) NEWABBREVS))))) then (\LAFITE.RECOMPUTE.FOLDER.NAMES OLDABBREVS))) (* ;; "Finally, reauthenticate user, in case there is any mode-specific caching we care about.") (LAFITECLEARCACHE)) -) - -(\LAFITE.PROCESS -(LAMBDA (FORM NAME ALLOWLOGOUT RESTARTABLE) (* bvm%: "25-Mar-84 17:16") (* ;;; "Creates a process running FORM which by default is not restartable and will not permit LOGOUT while it is running") (ADD.PROCESS FORM (QUOTE NAME) NAME (QUOTE RESTARTABLE) (OR RESTARTABLE (QUOTE NO)) (QUOTE BEFOREEXIT) (COND (ALLOWLOGOUT NIL) (T (QUOTE DON'T))))) -) - -(\LAFITE.START.ABORT -(LAMBDA NIL (* bvm%: "25-Mar-84 16:44") (COND ((AND RESETSTATE (NEQ \LAFITE.ACTIVE T)) (CLOSEW LAFITESTATUSWINDOW) (SETQ LAFITESTATUSWINDOW (SETQ \LAFITE.ACTIVE))))) -) - -(\LAFITE.QUIT -(LAMBDA (ITEM MENU BUTTON) (* bvm%: " 7-Nov-84 11:48") (COND ((EQ BUTTON (QUOTE MIDDLE)) (\LAFITE.SUBQUIT ITEM MENU)) (T (\LAFITE.PROCESS (LIST (FUNCTION \LAFITE.QUIT.PROC) (KWOTE ITEM) (KWOTE MENU)) (QUOTE LAFITEQUIT))))) -) - -(\LAFITE.RESTART -(LAMBDA (ITEM MENU) (* ; "Edited 8-Jun-88 12:08 by bvm") (COND ((\LAFITE.QUIT.PROC ITEM MENU) (LAFITE :ON)))) -) - -(\LAFITE.SUBQUIT -(LAMBDA (ITEM MENU) (* ; "Edited 13-Jun-88 10:49 by bvm") (PROG ((MODES (\LAFITE.COMPUTE.MODE.COMMANDS)) (ITEMS LAFITESUBQUITMENUITEMS) COMMAND LOGINS LOGINITEM) (COND ((OR (NOT (EQUAL \LAFITE.MODE.CHOICES (SETQ \LAFITE.MODE.CHOICES MODES))) (NULL LAFITESUBQUITMENU)) (* ; "Recompute menu") (if (CDR MODES) then (* ; "Only include modes if there's more than one--boring otherwise") (SETQ ITEMS (APPEND ITEMS MODES))) (if (AND (SETQ LOGINITEM (LA.MENU.ITEM (FUNCTION \LAFITE.LOGIN) ITEMS)) (SETQ LOGINS (for MODE in LAFITEMODELST bind FN when (AND (LISTP (CDR MODE)) (SETQ FN (fetch (LAFITEOPS LOGIN) of MODE))) collect (BQUOTE ((\, (CONCAT (CAR MODE) " Login")) (QUOTE (\, FN)) (\, (CONCAT "Change the name and/or password for " (CAR MODE) " operation."))))))) then (* ; "Add subitems for logging in for specific modes.") (SETQ ITEMS (DSUBST (LIST (CAR LOGINITEM) (CADR LOGINITEM) (CADDR LOGINITEM) (APPEND (CADDDR LOGINITEM) LOGINS)) LOGINITEM ITEMS))) (SETQ LAFITESUBQUITMENU (\LAFITE.CREATE.MENU ITEMS "Mode Change")))) (COND ((LISTP (SETQ COMMAND (MENU LAFITESUBQUITMENU))) (* ; "Change mode command") (LAFITEMODE (CAR COMMAND))) (COMMAND (* ; "Arbitrary other command") (\LAFITE.PROCESS (BQUOTE ((\, COMMAND) (QUOTE (\, ITEM)) (QUOTE (\, MENU)))) (QUOTE LAFITEQUIT)))))) -) - -(\LAFITE.QUIT.PROC -(LAMBDA (ITEM MENU) (* ; "Edited 3-May-89 19:19 by bvm") (RESETLST (LA.RESETSHADE ITEM MENU) (OBTAIN.MONITORLOCK \LAFITE.BROWSELOCK NIL T) (OBTAIN.MONITORLOCK \LAFITE.MAINLOCK NIL T) (PROG ((HOW? 0) MENUREG) (OR \LAFITE.ACTIVE (RETURN T)) (COND ((for WINDOW in LAFITECURRENTEDITORWINDOWS do (COND ((OPENWP WINDOW) (SETQ $$VAL (TOTOPW WINDOW))) ((WINDOWP (SETQ WINDOW (WINDOWPROP WINDOW (QUOTE ICONWINDOW)))) (SETQ $$VAL (EXPANDW WINDOW))))) (printout PROMPTWINDOW T "There are open/undelivered message composition windows -- can't quit") (RETURN))) (for FOLDER in \ACTIVELAFITEFOLDERS when (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) do (SETQ HOW? (LOGOR HOW? (LAB.UPDATE.NEEDED? FOLDER)))) (COND ((EQ HOW? 0) (* ; "Nothing to do but close them") (SETQ HOW? (FUNCTION \LAFITE.FINISH.UPDATE))) (T (* ;; "Determine what to do with open browsers. Essentially same as the CLOSEFN for a browser, but we offer a single menu that offers all the choices that the most particular window might need") (SETQ HOW? (\LAFITE.CREATE.MENU (APPEND (fetch (MENU ITEMS) of (LAB.CHOOSE.UPDATE.MENU HOW? :CLOSE)) (QUOTE (("Don't Quit" NIL "Abort the Quit command")))) "How should browsers be closed?" T)) (SETQ MENUREG (WINDOWPROP (WFROMMENU MENU) (QUOTE REGION))) (SETQ HOW? (OR (MENU HOW? (create POSITION XCOORD _ (- (fetch (REGION RIGHT) of MENUREG) (fetch (MENU IMAGEWIDTH) of HOW?)) YCOORD _ (- (fetch (REGION BOTTOM) of MENUREG) (fetch (MENU IMAGEHEIGHT) of HOW?))) T) (RETURN NIL))))) (for FOLDER in (APPEND \ACTIVELAFITEFOLDERS) bind BROWSERWINDOW do (COND ((NOT (SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (\LAFITE.CLOSE.FOLDER FOLDER T)) (T (CL:FUNCALL HOW? BROWSERWINDOW FOLDER :EXIT)))) (SETQ \ACTIVELAFITEFOLDERS) (AND \LAFITE.OUTBOX (CLOSEW (fetch OBWINDOW of \LAFITE.OUTBOX))) (COND (\LAFITEPROFILECHANGED (\LAFITE.WRITE.PROFILE))) (SETQ AROUNDEXITFNS (REMOVE (FUNCTION LAFITE.AROUNDEXIT) AROUNDEXITFNS)) (if NIL then (* ; "Currently these are all on {SCRATCH}, so gc gets them") (for FILE in \LAFITE.TEMPFILES do (* ; "delete any temp files laying around") (CLOSEF? FILE) (DELFILE FILE)) (SETQ \LAFITE.TEMPFILES)) (SETQ \LAFITE.ACTIVE NIL) (DEL.PROCESS (FUNCTION LAFITEMAILWATCH)) (* (* ; "Don't remove this, since it continues to look at login changes") (SETQ \AFTERLOGINFNS (REMOVE (QUOTE \LAFITE.AFTERLOGIN) \AFTERLOGINFNS)) (LAFITECLEARCACHE)) (COND ((OPENWP LAFITESTATUSWINDOW) (CLOSEW LAFITESTATUSWINDOW))) (SETQ \LAFITE.MODE.CHOICES (SETQ LAFITEFORMFILES (SETQ \LAFITE.LAST.STATUS (SETQ \LAFITEDEFAULTHOST&DIR (SETQ LAFITE.UPDATE.MENU.HASH (SETQ LAFITEMAINMENU (SETQ LAFITESTATUSWINDOW NIL))))))) (for VAR in LAFITEMENUVARS do (* ; "Clear cached menus") (SET VAR NIL)) (RETURN T)))) -) - -(\LAFITEDEFAULTHOST&DIR -(LAMBDA (HOST&DIR) (* ; "Edited 10-Feb-89 12:53 by bvm") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (OLDHOST&DIR (fetch PACKEDHOST&DIR of \LAFITEDEFAULTHOST&DIR)) UNPACKED CANONICAL) (COND ((OR (NULL HOST&DIR) (STRING-EQUAL OLDHOST&DIR HOST&DIR)) (* ; "User wants the value, or there is no change") (RETURN HOST&DIR))) (* ; "now make sure its a legitimate HOST&DIR") (COND ((NULL (SETQ CANONICAL (DIRECTORYNAME HOST&DIR))) (printout PROMPTWINDOW T "Warning: " HOST&DIR " not a recognized directory")) (T (SETQ HOST&DIR CANONICAL))) (* ; "set both the visible and invisble variables") (SETQ UNPACKED (UNPACKFILENAME.STRING HOST&DIR)) (SETQ \LAFITEDEFAULTHOST&DIR (create DEFAULTHOST&DIR PACKEDHOST&DIR _ (PACKFILENAME.STRING UNPACKED) UNPACKEDHOST&DIR _ UNPACKED)) (RETURN OLDHOST&DIR))) -) - -(LAFITEDEFAULTHOST&DIR -(LAMBDA (HOST&DIR) (* bvm%: "22-Feb-84 16:27") (* ;;; "Temporary definition until we can do it right") (SETQ LAFITEDEFAULTHOST&DIR HOST&DIR)) -) - -(MAKELAFITECOMMANDWINDOW -(LAMBDA NIL (* bvm%: " 5-May-86 16:23") (PROG ((FONTHEIGHT (FONTPROP LAFITEMENUFONT (QUOTE HEIGHT))) MENUW MENUWREGION POSITION HEIGHT WIDTH STATUSWINDOW) (SETQ MENUW (MENUWINDOW (SETQ LAFITEMAINMENU (create MENU ITEMS _ LAFITECOMMANDMENUITEMS WHENSELECTEDFN _ (FUNCTION NILL) CENTERFLG _ T TITLE _ (OR (\LAFITE.MODE.TITLE) "L a f i t e") MENUFONT _ LAFITEMENUFONT MENUTITLEFONT _ LAFITETITLEFONT)))) (SETQ WIDTH (IMAX (fetch (REGION WIDTH) of (SETQ MENUWREGION (WINDOWPROP MENUW (QUOTE REGION)))) LAFITESTATUSWINDOWMINWIDTH)) (SETQ HEIGHT (HEIGHTIFWINDOW (FIX (FTIMES FONTHEIGHT 1.5)))) (SETQ POSITION (OR LAFITESTATUSWINDOWPOSITION (GETBOXPOSITION WIDTH (IPLUS HEIGHT (fetch (REGION HEIGHT) of MENUWREGION)) NIL NIL NIL "Specify position of the Lafite Command Menu."))) (SETQ STATUSWINDOW (CREATEW (MAKEWITHINREGION (create REGION LEFT _ (fetch (POSITION XCOORD) of POSITION) BOTTOM _ (IPLUS (fetch (POSITION YCOORD) of POSITION) (fetch (REGION HEIGHT) of MENUWREGION)) WIDTH _ WIDTH HEIGHT _ HEIGHT)))) (DSPFONT LAFITEMENUFONT STATUSWINDOW) (ATTACHWINDOW MENUW STATUSWINDOW (QUOTE BOTTOM)) (WINDOWPROP STATUSWINDOW (QUOTE BUTTONEVENTFN) (FUNCTION (LAMBDA (WINDOW) (COND ((LASTMOUSESTATE (NOT UP)) (SETQ \LAFITE.LAST.STATUS) (\LAFITE.WAKE.WATCHER)))))) (WINDOWPROP STATUSWINDOW (QUOTE MAINWINDOWMINSIZE) (CONS 0 HEIGHT)) (WINDOWPROP STATUSWINDOW (QUOTE MAINWINDOWMAXSIZE) (CONS MAX.SMALLP HEIGHT)) (OPENW STATUSWINDOW) (CLEARW STATUSWINDOW) (WINDOWPROP STATUSWINDOW (QUOTE YPOS) (IDIFFERENCE (DSPYPOSITION NIL STATUSWINDOW) (FIXR (FTIMES FONTHEIGHT 0.2)))) (RETURN (SETQ LAFITESTATUSWINDOW STATUSWINDOW)))) -) - -(EXTRACTMENUCOMMAND -(LAMBDA (ITEM) (* ; "Edited 3-Sep-87 15:28 by bvm:") (* ;; "Extract the %"command%" from a menu item. ITEM is in form (label form helpstring)") (COND ((NLISTP ITEM) ITEM) ((CADR ITEM) (EVAL (CADR ITEM))) (T (CAR ITEM)))) -) - -(DOMAINLAFITECOMMAND -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 3-Sep-87 18:00 by bvm:") (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) ITEM MENU BUTTON)) -) - -(LAFITE.TOGGLE.SERVER.TRACE -(LAMBDA NIL (* ; "Edited 24-Jul-92 15:14 by bvm") (LET ((CHOICE (MENU (create MENU ITEMS _ (QUOTE (("Quiet" 0 "Don't report server") ("Report" T "Just report server in prompt window") ("Require Confirmation" :ASK "Require approval for posting server choice"))) CENTERFLG _ T TITLE _ "Trace Posting Server?")))) (if CHOICE then (PRINTOUT PROMPTWINDOW T "*NSMAIL-TRACE-SERVERS* = " (SETQ *NSMAIL-TRACE-SERVERS* (AND (NEQ CHOICE 0) CHOICE)))))) -) -) - -(PUTPROPS LAFITE ARGNAMES (NIL (ON/OFF MAILFILE . OPTIONS) . U)) -(DEFINEQ - -(LAFITEMODE -(LAMBDA (MODE) (* ; "Edited 9-May-88 15:53 by bvm") (PROG1 (fetch LAFITEMODE of \LAFITEMODE) (COND (MODE (while (LITATOM (CDR (SETQ MODE (OR (ASSOC MODE LAFITEMODELST) (\ILLEGAL.ARG MODE))))) do (SETQ MODE (CDR MODE))) (COND ((NEQ (fetch LAFITEMODE of \LAFITEMODE) (fetch LAFITEMODE of (SETQ \LAFITEMODE MODE))) (* ; "Mode changed, kick mailwatcher") (COND (\LAFITE.ACTIVE (\LAFITE.SHOW.MODE) (WITH.MONITOR \LAFITE.MAILSERVERLOCK (\LAFITE.WAKE.WATCHER)))))))))) -) - -(\LAFITE.INFER.MODE -(LAMBDA NIL (* bvm%: "21-Dec-84 22:43") (COND ((SETQ \LAFITEMODE (OR (AND LAFITEMODEDEFAULT (ASSOC LAFITEMODEDEFAULT LAFITEMODELST)) (PROG ((CHOICES (for X in LAFITEMODELST collect X when (LISTP (CDR X))))) (RETURN (AND CHOICES (NULL (CDR CHOICES)) (CAR CHOICES)))))) (AND LAFITESTATUSWINDOW (\LAFITE.SHOW.MODE)) \LAFITEMODE))) -) - -(\LAFITE.SHOW.MODE -(LAMBDA NIL (* bvm%: "30-Oct-84 16:53") (PROG ((TITLE (\LAFITE.MODE.TITLE)) (MENU LAFITEMAINMENU)) (COND (TITLE (replace (MENU TITLE) of MENU with TITLE) (UPDATE/MENU/IMAGE MENU) (REDISPLAYW (WFROMMENU MENU)))))) -) - -(\LAFITE.MODE.TITLE -(LAMBDA NIL (* ; "Edited 5-May-88 12:24 by bvm") (* ;;; "If user wants mode shown in Lafite status window, this returns a suitable title for that window") (AND \LAFITEMODE (LAFITE.SHOW.MODE.P) (CONCAT "L a f i t e (" (fetch LAFITEMODE of \LAFITEMODE) ")"))) -) - -(LAFITE.SHOW.MODE.P -(LAMBDA NIL (* ; "Edited 5-May-88 12:02 by bvm") (* ;; "True if the current mode should be displayed.") (SELECTQ LAFITESHOWMODEFLG (ALWAYS T) (NIL NIL) (> (for X in LAFITEMODELST count (LISTP (CDR (LISTP X)))) 1))) -) - -(LAFITE.ALL.MODES.P -(LAMBDA (OP) (* ; "Edited 9-May-88 17:15 by bvm") (* ;; "True if we should use all modes for the operation designated by OP. Currently known ops are :POLL, :GETMAIL, :ANSWER.") (if (LISTP LAFITE.USE.ALL.MODES) then (FMEMB OP LAFITE.USE.ALL.MODES) else (OR (EQ LAFITE.USE.ALL.MODES T) (EQ LAFITE.USE.ALL.MODES OP)))) -) - -(SET.LAFITE.MODE.INTERACTIVELY -(LAMBDA NIL (* ; "Edited 13-Jun-88 10:36 by bvm") (* ;; "Called from background menu to set Lafite's mode.") (LET ((*PRINT-CASE* :UPCASE) CHOICE) (CL:FORMAT PROMPTWINDOW "~2%%Lafite's current mode is ~A. -Use menu to specify the new mode.~@[ -Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITEMODE then (fetch (LAFITEOPS LAFITEMODE) of \LAFITEMODE) else "not set") (EQ LAFITE.USE.ALL.MODES T)) (AND (SETQ CHOICE (MENU (\LAFITE.CREATE.MENU (\LAFITE.COMPUTE.MODE.COMMANDS) "Mode choices"))) (LAFITEMODE (CAR CHOICE))))) -) - -(\LAFITE.COMPUTE.MODE.COMMANDS -(LAMBDA NIL (* ; "Edited 13-Jun-88 10:27 by bvm") (* ;; "Returns a list of menu items %"xx Mode%" for changing Lafite's mode. The result of calling MENU on this is a list whose car is the desired mode.") (for MODE in LAFITEMODELST when (LISTP (CDR MODE)) collect (BQUOTE ((\, (CONCAT (CAR MODE) " Mode")) (QUOTE ((\, (CAR MODE)))) "Change to this mode of mail sending/retrieving")))) -) -) - -(PUTPROPS LAFITEMODELST VARTYPE ALIST) - -(ADDTOVAR LAFITEMODELST) - -(RPAQ? \LAFITEMODE) - -(RPAQ? \LAFITE.AUTHENTICATION.FAILURE) - -(RPAQ? LAFITE.BACKGROUND.ITEM (QUOTE ("Mail" (QUOTE (\LAFITE.MESSAGEFORM NIL NIL (QUOTE LEFT))) "Send an ordinary message. See subcommands for other operations." (SUBITEMS ("Turn Lafite on" (QUOTE (LAFITE.ON.FROM.BACKGROUND)) "Turn on Lafite, bringing up status window and browsing default folder.") ("Send Mail" (QUOTE (\LAFITE.MESSAGEFORM)) "Send a message. Prompts for type of message.") ("Set Lafite Mode" (QUOTE (SET.LAFITE.MODE.INTERACTIVELY)) "Set or change Lafite's mail protocol mode."))))) -(DEFINEQ - -(\LAFITE.LOGIN -(LAMBDA NIL (* ; "Edited 8-Jun-88 12:50 by bvm") (if (AND (\LAFITE.OFF) (LAFITE.PROMPT.FOR.LOGIN NIL (FUNCTION (LAMBDA NIL (SETQ LAFITEDEFAULTHOST&DIR (TTYINPROMPTFORWORD "Host&dir for mail files: " (OR LAFITEDEFAULTHOST&DIR LOGINHOST/DIR) "Specify, in form {host} the location of the mail files for the user you just logged in.")))))) then (LAFITE :ON))) -) - -(\LAFITE.LOGIN.NORESTART -(LAMBDA NIL (* ; "Edited 7-Jun-88 19:33 by bvm") (LAFITE.PROMPT.FOR.LOGIN))) - -(LAFITE.PROMPT.FOR.LOGIN -(LAMBDA (HOST AFTERLOGINFN) (* ; "Edited 8-Jun-88 12:42 by bvm") (* ;; "Prompt for login to HOST in a little window near the status window. If login is successful, then apply AFTERLOGINFN to HOST while the ttydisplaystream is still in the interaction window.") (RESETLST (LET* ((TOPLEFT (OR LAFITESTATUSWINDOWPOSITION (CURSORPOSITION))) (HEIGHT (HEIGHTIFWINDOW (TIMES 5 (FONTPROP DEFAULTFONT (QUOTE HEIGHT))) NIL 8)) (W (CREATEW (MAKEWITHINREGION (create REGION LEFT _ (fetch XCOORD of TOPLEFT) BOTTOM _ (- (fetch YCOORD of TOPLEFT) HEIGHT) WIDTH _ 400 HEIGHT _ HEIGHT)) NIL 8))) (RESETSAVE NIL (LIST (QUOTE CLOSEW) W)) (RESETSAVE (TTYDISPLAYSTREAM W)) (WINDOWADDPROP W (QUOTE CLOSEFN) (FUNCTION (LAMBDA (WINDOW) (\CARET.DOWN) (LET ((P (WINDOWPROP WINDOW (QUOTE PROCESS)))) (if (AND P (NEQ P (THIS.PROCESS))) then (* ; "user explicit close--kill the process") (DEL.PROCESS P))))))) (RESETSAVE (TTY.PROCESS T)) (AND (LOGIN HOST) (OR (NULL AFTERLOGINFN) (CL:FUNCALL AFTERLOGINFN HOST))))) -) - -(\LAFITE.REAUTHENTICATE -(LAMBDA (ITEM MENU) (DECLARE (IGNORE ITEM MENU)) (* ; "Edited 18-Jul-88 12:25 by bvm") (* ;; "Reauthenticate using the current login, rather than prompting for anything new.") (\LAFITE.AFTERLOGIN NIL)) -) -) - -(RPAQQ LAFITEPROFILEVARS ((LAFITEDEFAULTHOST&DIR NIL) (LAFITE.SIGNATURE NIL) (LAFITEBUFFERSIZE 20) (LAFITEIFFROMMETHENSEENFLG T) (LAFITEMENUFONT (FONTCREATE (QUOTE (HELVETICA 10 BOLD)))) (LAFITETITLEFONT (FONTCREATE (QUOTE (HELVETICA 12 BOLD)))) (LAFITEDISPLAYFONT (FONTCREATE (QUOTE (TIMESROMAN 10)))) (LAFITEFIXEDWIDTHFONT (COND ((EQ (CHARWIDTH (CHARCODE "i") DEFAULTFONT) (CHARWIDTH (CHARCODE "W") DEFAULTFONT)) (* ; "Yes, user has not changed default to a variable width font") DEFAULTFONT) (T (FONTCREATE (QUOTE (GACHA 10)))))) (LAFITEHARDCOPYFONT LAFITEDISPLAYFONT) (LAFITEBROWSERFONT (FONTCREATE (QUOTE (GACHA 10)))) (LAFITEMSGICONFONT (FONTCREATE (QUOTE (HELVETICA 8)))) (LAFITE.FOLDER.MENU.FONT NIL) (LAFITEINFO.NAME "Lafite.info") (DEFAULTMAILFOLDERNAME "Active.mail") (LAFITEMAIL.EXT "mail") (LAFITESTATUSWINDOWMINWIDTH 200) (LAFITESTATUSWINDOWPOSITION (QUOTE (735 . 650))) (LAFITE.DONT.DISPLAY.HEADERS NIL) (LAFITE.DONT.FORWARD.HEADERS NIL) (LAFITE.DONT.HARDCOPY.HEADERS NIL) (LAFITEDEBUGFLG NIL) (LAFITEMODEDEFAULT NIL) (LAFITESHOWMODEFLG T) (LAFITE.USE.ALL.MODES T))) - -(RPAQ? LAFITEDEFAULTHOST&DIR NIL) - -(RPAQ? LAFITE.SIGNATURE NIL) - -(RPAQ? LAFITEBUFFERSIZE 20) - -(RPAQ? LAFITEIFFROMMETHENSEENFLG T) - -(RPAQ? LAFITEMENUFONT (FONTCREATE (QUOTE (HELVETICA 10 BOLD)))) - -(RPAQ? LAFITETITLEFONT (FONTCREATE (QUOTE (HELVETICA 12 BOLD)))) - -(RPAQ? LAFITEDISPLAYFONT (FONTCREATE (QUOTE (TIMESROMAN 10)))) - -(RPAQ? LAFITEFIXEDWIDTHFONT (COND ((EQ (CHARWIDTH (CHARCODE "i") DEFAULTFONT) (CHARWIDTH (CHARCODE "W") DEFAULTFONT)) (* ; "Yes, user has not changed default to a variable width font") DEFAULTFONT) (T (FONTCREATE (QUOTE (GACHA 10)))))) - -(RPAQ? LAFITEHARDCOPYFONT LAFITEDISPLAYFONT) - -(RPAQ? LAFITEBROWSERFONT (FONTCREATE (QUOTE (GACHA 10)))) - -(RPAQ? LAFITEMSGICONFONT (FONTCREATE (QUOTE (HELVETICA 8)))) - -(RPAQ? LAFITE.FOLDER.MENU.FONT NIL) - -(RPAQ? LAFITEINFO.NAME "Lafite.info") - -(RPAQ? DEFAULTMAILFOLDERNAME "Active.mail") - -(RPAQ? LAFITEMAIL.EXT "mail") - -(RPAQ? LAFITESTATUSWINDOWMINWIDTH 200) - -(RPAQ? LAFITESTATUSWINDOWPOSITION (QUOTE (735 . 650))) - -(RPAQ? LAFITE.DONT.DISPLAY.HEADERS NIL) - -(RPAQ? LAFITE.DONT.FORWARD.HEADERS NIL) - -(RPAQ? LAFITE.DONT.HARDCOPY.HEADERS NIL) - -(RPAQ? LAFITEDEBUGFLG NIL) - -(RPAQ? LAFITEMODEDEFAULT NIL) - -(RPAQ? LAFITESHOWMODEFLG T) - -(RPAQ? LAFITE.USE.ALL.MODES T) - -(RPAQQ LAFITERANDOMGLOBALS ((UNSUPPLIEDFIELDSTR "---") (LAFITEBUSYWAITTIME 1000) (LAFITEITEMBUSYSHADE 43605) (LAFITEEOL " -"))) - -(RPAQ? UNSUPPLIEDFIELDSTR "---") - -(RPAQ? LAFITEBUSYWAITTIME 1000) - -(RPAQ? LAFITEITEMBUSYSHADE 43605) - -(RPAQ? LAFITEEOL " -") - -(RPAQQ LAFITEMARKS ((SEENMARK (CHARCODE SP)) (UNSEENMARK (CHARCODE ?)) (MOVETOMARK (CHARCODE m)) (FORWARDMARK (CHARCODE f)) (ANSWERMARK (CHARCODE a)) (HARDCOPYBATCHMARK (CHARCODE H)) (HARDCOPYMARK (CHARCODE h)) (HEARDMARK (CHARCODE @)))) - -(RPAQ SEENMARK (CHARCODE SP)) - -(RPAQ UNSEENMARK (CHARCODE ?)) - -(RPAQ MOVETOMARK (CHARCODE m)) - -(RPAQ FORWARDMARK (CHARCODE f)) - -(RPAQ ANSWERMARK (CHARCODE a)) - -(RPAQ HARDCOPYBATCHMARK (CHARCODE H)) - -(RPAQ HARDCOPYMARK (CHARCODE h)) - -(RPAQ HEARDMARK (CHARCODE @)) - -(RPAQQ LAFITECOMMANDMENUITEMS (("Browse" (QUOTE \LAFITE.BROWSE) "Browse a mail file; MIDDLE for subcommands") ("Send Mail" (QUOTE \LAFITE.MESSAGEFORM) "Open a message composition window; MIDDLE for choice of forms") ("Quit" (QUOTE \LAFITE.QUIT) "Update and close all mail files and stop Lafite"))) - -(RPAQQ LAFITEUPDATEMENUITEMS (("Do Hardcopy Only" (QUOTE \LAFITE.HARDCOPYONLY.PROC) "Will print batched hardcopy but not update file") ("Write out changes only" (QUOTE \LAFITE.UPDATE.PROC) "Will update physical file to reflect new marks and deletions") ("Update table of contents only" (FUNCTION \LAFITE.UPDATE.PROC) "Write table of contents file to speed next browse of this folder") ("Expunge deleted messages" (QUOTE \LAFITE.EXPUNGE.PROC) "Will rewrite mail file, expunging all deleted messages") ("Write changes in sorted order" (QUOTE \LAFITE.EXPUNGE.PROC) "Will rewrite mail file so that the messages are permanently stored in the order in which they now appear in the browser.") ("Expunge & Write out changes (sorted)" (QUOTE \LAFITE.EXPUNGE.PROC) "Will rewrite mail file, expunging deleted messages and writing writing the rest in the order in which they now appear in the browser.") ("Just close" (QUOTE \LAFITE.FINISH.UPDATE) "Just close the window - don't touch the mail file.") ("Just shrink" (QUOTE \LAFITE.FINISH.UPDATE) "Just shrink the window - don't touch the mail file."))) - -(RPAQQ LAFITESUBQUITMENUITEMS (("Quit" (QUOTE \LAFITE.QUIT) "Turn Lafite off") ("Restart" (QUOTE \LAFITE.RESTART) "Turn Lafite off then back on") ("Login" (QUOTE \LAFITE.LOGIN) "Change the global username/password and restart Lafite with the new user." (SUBITEMS ("Just re-authenticate" (QUOTE \LAFITE.REAUTHENTICATE) "Re-authenticate currently logged-in user.") ("Login without restarting" (QUOTE \LAFITE.LOGIN.NORESTART) "Change the global login but don't restart Lafite (keep the same folders open, etc)") ("NS Login" (QUOTE \NSMAIL.LOGIN) "Change the name and/or password for NS operation."))) ("Recache" (QUOTE LAFITE.COMPUTE.CACHED.VARS) "Make Lafite recompute cached information based on current variable settings") ("Server trace" (QUOTE LAFITE.TOGGLE.SERVER.TRACE) "Change setting of *NSMAIL-TRACE-SERVERS*"))) - -(RPAQQ ANOTHERFOLDERMENUITEM ("** Other Folder **" (QUOTE %##ANOTHERFILE##) "You will be asked to specify another mail filename")) - -(RPAQ? LAFITESTATUSWINDOW) - -(RPAQ? \ACTIVELAFITEFOLDERS) - -(RPAQ? \LAFITE.TEMPFILES) - -(RPAQ? \LAFITE.MODE.CHOICES) - -(RPAQ? LAFITESUBQUITMENU) - -(ADDTOVAR LAFITEMENUVARS LAFITESUBQUITMENU) - -(RPAQ? \LAFITE.ACTIVE) - -(RPAQ? \LAFITE.READY) - -(RPAQ? \LAFITEDEFAULTHOST&DIR) - -(RPAQ? \LAFITE.ACTIVE.MODES) - -(RPAQ? \LAFITE.CURRENT.USER) - -(RPAQ? LAFITE.USER.INFO) - -(RPAQ? *LAFITE-WELL-KNOWN-MODES*) - -(RPAQ? *LAFITE-LOGGING-IN*) - -(ADDTOVAR \SYSTEMCACHEVARS \LAFITE.READY \LAFITE.ACTIVE.MODES) - -(ADDTOVAR LAFITE.PERSONAL.VARS LAFITEDEFAULTHOST&DIR LAFITE.SIGNATURE) -(DEFINEQ - -(LAFITE.AROUNDEXIT -(LAMBDA (EVENT) (* ; "Edited 9-May-88 15:57 by bvm") (SELECTQ EVENT ((BEFORELOGOUT) (RESETLST (for FOLDER in \ACTIVELAFITEFOLDERS when (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) do (\LAFITE.CLOSE.FOLDER FOLDER T))) (SETQ \LAFITE.ACTIVE.MODES NIL)) ((AFTERLOGOUT AFTERSAVEVM AFTERSYSOUT AFTERMAKESYS) (COND ((EQ \LAFITE.ACTIVE T) (\LAFITE.REINITIALIZING) (\LAFITE.AFTERLOGIN) (* ; "Check for changed user") (RESTART.PROCESS (QUOTE LAFITEMAILWATCH)) (\LAFITE.MARK.FOLDERS.OBSOLETE)))) NIL)) -) - -(\LAFITE.MARK.FOLDERS.OBSOLETE -(LAMBDA NIL (* ; "Edited 7-Jun-88 16:14 by bvm") (* ;;; "On returning from LOGOUT check to see that all the mailfiles are in a consistence state -- the user might have run Laurel and screwed up Lafite's data, or run Lafite from another machine") (COND ((AND \ACTIVELAFITEFOLDERS (NOT \LAFITE.READY)) (WITH.MONITOR \LAFITE.BROWSELOCK (COND ((NOT \LAFITE.READY) (SETQ \ACTIVELAFITEFOLDERS (for FOLDER in \ACTIVELAFITEFOLDERS when (COND ((NULL (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (\LAFITE.CLOSE.FOLDER FOLDER T) (* ; "Not really active, forget it") NIL) (T (* ; "Mark all folders as needing checking") (if (EQ (fetch (MAILFOLDER BROWSERSTATUS) of FOLDER) LAS.READY) then (replace (MAILFOLDER BROWSERSTATUS) of FOLDER with LAS.LOGGED.OUT)) T)) collect FOLDER)) (\LAFITE.PROCESS (LIST (FUNCTION \LAFITE.CHECK.FOLDERS)) (QUOTE LAFITE.CHECK) T T)))) (SETQ \LAFITE.READY T)))) -) - -(\LAFITE.CHECK.FOLDERS -(LAMBDA NIL (* ; "Edited 15-Dec-87 17:48 by bvm:") (* ;; "Background task that goes around checking that everyone's ok.") (\LAFITE.READ.PROFILE T) (* ; "Get any changes to profile that happened while logged out.") (for FOLDER in \ACTIVELAFITEFOLDERS when (EQ (fetch (MAILFOLDER BROWSERSTATUS) of FOLDER) LAS.LOGGED.OUT) do (ERSETQ (\LAFITE.ASSURE.FOLDER.READY FOLDER)))) -) - -(\LAFITE.ASSURE.FOLDER.READY -(LAMBDA (FOLDER) (* ; "Edited 15-Oct-87 14:57 by bvm:") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (if (EQ (fetch (MAILFOLDER BROWSERSTATUS) of FOLDER) LAS.LOGGED.OUT) then (* ; "Open and close the file. The opening code will take care of interesting conditions.") (PROG1 (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) NIL) (\LAFITE.CLOSE.FOLDER FOLDER T)) else T))) -) - -(\LAFITE.AFTERLOGIN -(LAMBDA (HOST USER) (* ; "Edited 22-Aug-88 16:38 by bvm") (* ;; "Called when LOGIN gets new info. If HOST = NIL, this is the global login, which means we should get new data") (COND ((AND (NULL HOST) (NOT *LAFITE-LOGGING-IN*)) (LAFITECLEARCACHE) (LET ((*LAFITE-LOGGING-IN* T) (OLDUSER (CAR \LAFITE.CURRENT.USER)) NEWUSER OLDDATA NEWDATA) (* ; "Compute new current user") (if (NOT (STRING-EQUAL OLDUSER (SETQ NEWUSER (LAFITE.USER.NAME.FROM.LOGIN NIL T)))) then (* ; "Logged in user changed. Clear all those %"personal%" variables that would be affected") (SETQ OLDDATA (CDR (CL:ASSOC OLDUSER LAFITE.USER.INFO :TEST (QUOTE STRING-EQUAL)))) (for VAR in LAFITE.PERSONAL.VARS bind VALUE when (SETQ VALUE (EVALV VAR)) do (if OLDDATA then (LISTPUT OLDDATA VAR VALUE) else (push NEWDATA VAR VALUE)) (SET VAR NIL)) (if NEWDATA then (push LAFITE.USER.INFO (CONS OLDUSER NEWDATA))) (* ;; "Now restore any saved data for new user") (if (SETQ NEWDATA (CL:ASSOC NEWUSER LAFITE.USER.INFO :TEST (QUOTE STRING-EQUAL))) then (for TAIL on (CDR NEWDATA) by (CDDR TAIL) do (SET (CAR TAIL) (CADR TAIL)))))) (AND \LAFITE.ACTIVE (\LAFITE.WAKE.WATCHER))))) -) -) - - - -(* ; "misc utilities") - -(DEFINEQ - -(LA.RESETSHADE -(LAMBDA (ITEM MENU OLDSHADE) (* ; "Edited 23-Aug-88 12:40 by bvm") (* ;;; "Shades ITEM in MENU to indicate Lafite is busy, leaves something on resetlst to unshade it") (if ITEM then (* ; "Don't do when some program calls without an item") (RESETSAVE (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (LIST (FUNCTION SHADEITEM) ITEM MENU (OR OLDSHADE WHITESHADE))))) -) - -(LA.MENU.ITEM -(LAMBDA (FN MENU) (* ; "Edited 7-Jun-88 19:15 by bvm") (* ;; "Returns the menu item executed by FN in MENU. This beats searching by the label because someone might want to change the label. Menu items are assumed to be of the form (label 'fn --). MENU can also be just a list of items.") (find ITEM in (OR (LISTP MENU) (fetch (MENU ITEMS) of MENU)) suchthat (EQ FN (CADR (LISTP (CADR ITEM)))))) -) - -(NTHMESSAGE -(LAMBDA (MESSAGES N) (* bvm%: " 3-Jan-84 12:11") (ELT MESSAGES N))) - -(\LAFITE.MAKE.MSGARRAY -(LAMBDA (SIZE OLDARRAY OLDSIZE) (* bvm%: " 3-Jan-84 11:07") (* ;;; "Creates an array at least large enough to hold SIZE message descriptors. If OLDARRAY is given, its elements up to OLDSIZE are copied into the new array") (PROG ((NEWARRAY (ARRAY (IMAX (+ SIZE 32) (CEIL SIZE 64)) (QUOTE POINTER)))) (COND (OLDARRAY (for I from 1 to OLDSIZE do (SETA NEWARRAY I (ELT OLDARRAY I))))) (RETURN NEWARRAY))) -) - -(\LAFITE.ADDMESSAGES.TO.ARRAY -(LAMBDA (MSGARRAY MESSAGELIST FIRSTMSG# LASTMSG#) (* bvm%: " 3-Jan-84 11:26") (* ;;; "Adds to MSGARRAY the messages from MESSAGELIST, which should be numbered FIRSTMSG# thru LASTMSG# --- returns a new array if MSGARRAY wasn't large enough") (COND ((OR (NULL MSGARRAY) (> LASTMSG# (ARRAYSIZE MSGARRAY))) (SETQ MSGARRAY (\LAFITE.MAKE.MSGARRAY LASTMSG# MSGARRAY (SUB1 FIRSTMSG#))))) (COND ((NEQ (fetch (LAFITEMSG %#) of (CAR MESSAGELIST)) FIRSTMSG#) (SHOULDNT))) (for MSG in MESSAGELIST as MSG# from FIRSTMSG# do (SETA MSGARRAY MSG# MSG)) MSGARRAY) -) - -(\MAILFOLDER.DEFPRINT -(LAMBDA (FOLDER STREAM) (* ; "Edited 11-Dec-87 17:22 by bvm:") (\DEFPRINT.BY.NAME FOLDER STREAM (OR (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER) (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER)) "Mail Folder on")) -) - -(\LAFITEMSG.DEFPRINT -(LAMBDA (MSG STREAM) (* ; "Edited 21-Apr-89 16:07 by bvm") (\DEFPRINT.BY.NAME MSG STREAM (fetch (LAFITEMSG %#) of MSG) "Lafite msg #")) -) - -(LA.POSITION.FROM.REGION -(LAMBDA (REG XOFFSET YOFFSET) (* ; "Edited 18-Apr-89 14:43 by bvm") (* ;; "Returns a POSITION at the lower left corner of REG, optionally offset by XOFFSET and YOFFSET (T means entire window dimension).") (create POSITION XCOORD _ (+ (fetch (REGION LEFT) of REG) (SELECTQ XOFFSET (NIL 0) (T (fetch (REGION WIDTH) of REG)) XOFFSET)) YCOORD _ (+ (fetch (REGION BOTTOM) of REG) (SELECTQ YOFFSET (NIL 0) (T (fetch (REGION HEIGHT) of REG)) YOFFSET)))) -) - -(MAILFOLDERBUSY -(LAMBDA (MAILFOLDER) (* bvm%: "29-Dec-83 18:11") (RESETFORM (CURSOR LA.CROSSCURSOR) (BLOCK LAFITEBUSYWAITTIME))) -) -) -(RPAQ LA.CROSSCURSOR (CURSORCREATE (QUOTE #*(16 16)L@@CN@@GG@@NCHALALCH@NG@@GN@@CL@@CL@@GN@@NG@ALCHCHALG@@NN@@GL@@C -) (QUOTE NIL) 8 8)) - - - -(* ; "Low level file functions") - -(DEFINEQ - -(TOCFILENAME -(LAMBDA (FOLDER) (* ; "Edited 1-May-89 12:58 by bvm") (* ;; "Return the name of the toc file corresponding to mail file FOLDER (a folder object or full file name).") (if FOLDER then (if (type? MAILFOLDER FOLDER) then (SETQ FOLDER (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER))) (PACKFILENAME.STRING (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDER (QUOTE EXTENSION)) LAFITETOC.EXT) (QUOTE BODY) FOLDER))) -) - -(DELETEMAILFOLDER -(LAMBDA (FOLDER) (* ; "Edited 30-Sep-87 15:48 by bvm:") (* ;;; "deletes the associated files and tells Lafite to forget about that mail file") (PROG ((FULL (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER)) STREAM) (if FULL then (if (AND (SETQ STREAM (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER)) (OPENP STREAM)) then (SETQ FULL (CLOSEF STREAM))) (DELFILE FULL) (DELFILE (TOCFILENAME FULL)) (FORGETMAILFILE (OR (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER) (LA.SHORTFILENAME FULL LAFITEMAIL.EXT)))))) -) - -(\LAFITE.OPEN.FOLDER -(LAMBDA (FOLDER ACCESS IFCHANGED PROMPTFOLDER) (* ; "Edited 5-Aug-93 19:48 by bvm") (* ;;; "For Interlisp-D it's too inefficient to keep opening and closing the mail file so we will keep it open --- If the file wants to be open for INPUT do just that -- it may want to be a read-only mail file -- otherwise open it for BOTH --- FILE is always a fully qualified file name") (* ;;; "IFCHANGED controls what to do if the stream has changed since we last used it. :IGNORE means don't bother checking, since I don't care. :OK means rebrowse as necessary, but return the stream. NIL means return NIL if there was a change, after rebrowsing.") (* ;;; "If PROMPTFOLDER is given, will prompt to confirm creating file if it doesn't exist") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (STREAM (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER)) (DESIREDACCESS (COND ((EQ ACCESS (QUOTE INPUT)) ACCESS) (T (QUOTE BOTH)))) (RECOG (AND PROMPTFOLDER (QUOTE OLD))) NEWLENGTH NEWDATE NEWESTDATE CHANGED WASOPEN CONDITION) RETRY (COND ((OR (NOT STREAM) (NOT (OPENP STREAM DESIREDACCESS))) (if STREAM then (* ;; "Have to close file to reopen for BOTH. We do this before date fussing in the hopes that this will force the device to really talk to the server. It might not help, though--the device's GETFILEINFO might still choose to give us an old cached date.") (COND ((OPENP STREAM) (CLOSEF STREAM))) (replace (MAILFOLDER FOLDERSTREAM) of FOLDER with (SETQ STREAM NIL))) (if (EQ (fetch (MAILFOLDER BROWSERSTATUS) of FOLDER) LAS.OUT.OF.DATE) then (* ; "Shouldn't happen--leftover from rebrowse folder. Get out of here") (ERROR!)) (CL:MULTIPLE-VALUE-SETQ (STREAM CONDITION) (IGNORE-ERRORS (if (AND (EQ DESIREDACCESS (QUOTE BOTH)) (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER) (NEQ IFCHANGED :IGNORE)) then (* ;; "Opening for output in general changes the creationdate, so we won't be able to check from the new stream whether the creationdate matches. So we have to obtain the current creation date without opening for write--hope GETFILEINFO works well enough. We further assume that nobody changed the file in the brief interval between getting this info and opening for write. This can be a faulty assumption for devices that are willing to keep a file open even though the server connection went away, but it seems the best we can do.") (SETQ NEWDATE (GETFILEINFO (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) (QUOTE ICREATIONDATE)))) (* ;; "Finally open it. Ask for big buffers if there's a browser for it.") (\LAFITE.OPENSTREAM (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) DESIREDACCESS NIL (FUNCTION \LAFITE.EOF) (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE LAFITE)))) (if CONDITION then (* ; "Failed to open") (if (AND (EQ RECOG (QUOTE OLD)) (TYPEP CONDITION (QUOTE XCL:FILE-NOT-FOUND))) then (* ; "Just couldn't find it, so maybe create it. If RECOG was NEW, we normally shouldn't be getting this error") (if (LAB.MOUSECONFIRM PROMPTFOLDER "Click LEFT to confirm creating ~A" (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER)) then (SETQ RECOG (QUOTE NEW)) (SETQ ACCESS (QUOTE BOTH)) (GO RETRY) else (* ; "Disconfirmed the create request."))) (* ; "Some problem opening file. Avoid break window--just abort.") (\LAFITE.REPORT.FILE.WONT.OPEN FOLDER CONDITION) (ERROR!)) (if (EQ DESIREDACCESS (QUOTE BOTH)) then (* ;; "So that LA.PRINTCOUNT won't introduce CR's. Would be nice if PRINTNUM could be given a PRIN3 mode") (LINELENGTH MAX.SMALLP STREAM)) (SETQ NEWLENGTH (GETEOFPTR STREAM)) (SETQ NEWESTDATE (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) (if (OR (EQ IFCHANGED :IGNORE) (NULL (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) (NULL (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) then (* ; "first time opened, just store the info") (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with NEWLENGTH) elseif (OR (NOT (EQL NEWLENGTH (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER))) (AND (OR NEWDATE (SETQ NEWDATE NEWESTDATE)) (NOT (EQL NEWDATE (fetch (MAILFOLDER FOLDERCREATIONDATE) of FOLDER))))) then (* ; "Folder has changed since we last touched it. (Use eql instead of = to work around as yet unknown problem where the folder's field is NIL).") (RETURN (\LAFITE.FOLDER.CHANGED FOLDER STREAM DESIREDACCESS IFCHANGED))) (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with (OR NEWESTDATE 0)) (if (EQ (fetch (MAILFOLDER BROWSERSTATUS) of FOLDER) LAS.LOGGED.OUT) then (* ; "We hadn't gotten around to verifying this one after logout yet--well, it's ok now.") (replace (MAILFOLDER BROWSERSTATUS) of FOLDER with LAS.READY)) (replace (MAILFOLDER FOLDERSTREAM) of FOLDER with STREAM))) (RETURN STREAM))) -) - -(\LAFITE.REPORT.FILE.WONT.OPEN -(LAMBDA (FOLDER C FILENAME) (* ; "Edited 22-Aug-88 19:25 by bvm") (* ;; "Called to report an error involved in trying to open FILENAME belonging to FOLDER. C is the condition. FOLDER can be NIL.") (LAB.FORMAT FOLDER T "Failed~@[ to open ~A because~]: ~A" (if (OR (TYPEP C (QUOTE XCL:FILE-WONT-OPEN)) (TYPEP C (QUOTE XCL:PATHNAME-ERROR)) (TYPEP C (QUOTE XCL:FILE-NOT-FOUND))) then (* ;; "Report handler includes the name already (In Lyric, file-not-found is a subtype of pathname-error, but not in Medley, where we might instead want to replace both file-wont-open and file-not-found with parent file-error)") NIL elseif FILENAME else (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER)) C)) -) - -(\LAFITE.FOLDER.CHANGED -(LAMBDA (FOLDER STREAM DESIREDACCESS IFCHANGED) (* ; "Edited 7-Jun-88 17:17 by bvm") (* ;; "Called by LAFITE.OPEN.FOLDER when changed detected.") (if (AND LAFITEDEBUGFLG (EQ (fetch (MAILFOLDER BROWSERSTATUS) of FOLDER) LAS.READY)) then (* ; "This is only funny if it didn't happen after logout.") (HELP "Folder has changed--RETURN to proceed.")) (LET* ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (WASOPEN (OPENWP BROWSERWINDOW)) (OLDEOF (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) (NEWEOF (GETEOFPTR STREAM)) MSG LEN ASKFLG HOW) (ALLOW.BUTTON.EVENTS) (* ; "Don't hoard mouse if we got called directly from mouse proc.") (replace (MAILFOLDER BROWSERSTATUS) of FOLDER with LAS.OUT.OF.DATE) (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with NEWEOF) (replace (MAILFOLDER FOLDERSTREAM) of FOLDER with STREAM) (if (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER) then (* ;; "Want to do something more careful here if folder has changes.") (SETQ HOW (if (AND (>= (GETEOFPTR STREAM) (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) (PROGN (* ; "Stream is not shorter than we remember. See if our current last message is still at the start of a message.") (SETFILEPTR STREAM (fetch (LAFITEMSG BEGIN) of (SETQ MSG (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))))) (LA.READSTAMP STREAM)) (SETQ LEN (LA.READCOUNT STREAM)) (= LEN (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) then (* ;; "Folder contains changes, and folder has apparently only been appended to, or had changes written but not expunge. Offer to write out current changes before proceeding.") (SETQ ASKFLG T) "but apparently not expunged. However, you have unsaved changes." else (* ;; "There are unsaved changes, but folder looks expunged--too bad.") "apparently by one or more Expunges, so you can't save your changes."))) (COND ((NOT WASOPEN) (* ; "Want the messages we print to be noticed.") (if (NOT ASKFLG) then (* ; "If we were shrunk, don't bother redisplaying when we expand.") (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with NIL)) (OPENW BROWSERWINDOW))) (LAB.FORMAT FOLDER "~&Folder has changed since you last accessed it...~@[~A~]" HOW) (\LAFITE.REBROWSE.FOLDER FOLDER STREAM ASKFLG (NOT WASOPEN) DESIREDACCESS IFCHANGED))) -) - -(\LAFITE.REBROWSE.FOLDER -(LAMBDA (FOLDER STREAM ASK CLOSEFLG DESIREDACCESS IFCHANGED DELETE-TOC) (* ; "Edited 13-Sep-88 18:41 by bvm") (* ;; "Rebrowses FOLDER because something changed. STREAM is current stream open on folder. If ASK is true, then we put up a menu asking whether to save current changes (caller verifies that this is interesting to do). If CLOSEFLG, then folder is shrunk at end. If DELETE-TOC is true, the TOC is deleted before rebrowsing. DESIREDACCESS and IFCHANGED are per the change action desired of \LAFITE.OPEN.FOLDER.") (LET ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) TOCFILE) (if ASK then (* ; "Offer to write out current changes before proceeding.") (PROG NIL RETRY (LAB.FORMAT FOLDER "~%%Do you want to save the changes before fetching the new contents? ") (CASE (\LAFITE.FOLDER.CHANGED.MENU FOLDER) (:CLOSE (\LAFITE.FINISH.UPDATE BROWSERWINDOW FOLDER :EXIT) (ERROR!)) ((NIL) (* ; "Don't try to save anything")) (T (* ; "Try doing an Update changes only") (if (NOT (OPENP STREAM (QUOTE OUTPUT))) then (CLOSEF STREAM) (CL:MULTIPLE-VALUE-BIND (NEWSTREAM CONDITION) (IGNORE-ERRORS (\LAFITE.OPENSTREAM (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) (QUOTE BOTH) NIL (FUNCTION \LAFITE.EOF) T (QUOTE LAFITE))) (if CONDITION then (* ; "Failed to open for output") (\LAFITE.REPORT.FILE.WONT.OPEN FOLDER CONDITION) (GO RETRY)) (replace (MAILFOLDER FOLDERSTREAM) of FOLDER with (SETQ STREAM NEWSTREAM)) (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with (GETEOFPTR STREAM)))) (LAB.FORMAT FOLDER "~%%") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LAFITEVERIFYFLG T) (*LAFITE-VERIFY-ACTION* (FUNCTION (LAMBDA (MSG FOLDER STREAM) (* ; "This message not where we expected, so punt it") (LAB.FORMAT FOLDER " (Failed on #~D)" (fetch (LAFITEMSG %#) of MSG)) (RETFROM (FUNCTION WRITEFOLDERMARKBYTES))))) (MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (LA.RESETSHADE (LA.MENU.ITEM (FUNCTION \LAFITE.UPDATE) MENU) MENU) (\LAFITE.UPDATE.FOLDER FOLDER))) (* ; "Take the conservative approach--flush the toc and reparse.") (SETQ DELETE-TOC T))))) (if (AND DELETE-TOC (SETQ TOCFILE (INFILEP (TOCFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER))))) then (DELFILE TOCFILE)) (LAB.PROMPTPRINT FOLDER " Rebrowsing...") (CLEARW BROWSERWINDOW) (* ;; "It might be nice to restore the old selection if possible...(save current selection, then call LOADMAILFOLDER, select the same numbered messages, then call LAB.DISPLAYFOLDER)") (if (LAB.LOADFOLDER FOLDER) then (* ; "Succeeded") (COND (CLOSEFLG (\LAFITE.FINISH.UPDATE BROWSERWINDOW FOLDER :SHRINK))) (CASE IFCHANGED (:OK (* ; "Return (possibly new) stream after rebrowse") (\LAFITE.OPEN.FOLDER FOLDER DESIREDACCESS)) ((NIL) (* ; "Return NIL to indicate change") NIL) (T (* ; "Abort operation.") (ERROR!))) else (* ; "Failed. Don't let anything more happen here") (ERROR!)))) -) - -(\LAFITE.FOLDER.CHANGED.MENU -(LAMBDA (FOLDER) (* ; "Edited 20-Apr-89 19:35 by bvm") (* ;; "Put up a menu asking whether to save changes before rebrowsing folder. Returns one of T (save), NIL (don't), or :CLOSE (forget it altogether).") (LET ((REG (WINDOWPROP (fetch (MAILFOLDER BROWSERMENUWINDOW) of FOLDER) (QUOTE REGION))) (ITEMS (QUOTE (("Save current changes first" T "Attempt to write out the unsaved new marks and deletions before rebrowsing the folder.") ("Just rebrowse" NIL "Forget any changes I have made to the browser--just get the new contents.") ("Close Browser" :CLOSE "Close the browser now, forgetting any changes."))))) (MENU (create MENU ITEMS _ ITEMS MENUFONT _ LAFITEMENUFONT CENTERFLG _ T MENUROWS _ 1 ITEMWIDTH _ (MAX (QUOTIENT (fetch (REGION WIDTH) of REG) 3) (STRINGWIDTH (CAAR ITEMS) LAFITEMENUFONT))) (PROGN (* ; "Position menu over the browser's menu") (LA.POSITION.FROM.REGION REG)) T))) -) - -(\LAFITE.SET.FOLDER.STREAM -(LAMBDA (FOLDER STREAM) (* ; "Edited 30-Sep-87 16:45 by bvm:") (* ;; "Called from the few places that open/create a stream without going thru lafite.open.folder--stores in FOLDER all the info you like to cache about STREAM. Returns STREAM") (LET ((FULL (FULLNAME STREAM))) (replace (MAILFOLDER FULLFOLDERNAME) of FOLDER with FULL) (replace (MAILFOLDER SHORTFOLDERNAME) of FOLDER with (LA.SHORTFILENAME FULL LAFITEMAIL.EXT)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with (GETEOFPTR STREAM)) (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) (replace (MAILFOLDER FOLDERSTREAM) of FOLDER with STREAM) STREAM)) -) - -(\LAFITE.OPENSTREAM -(LAMBDA (FILE ACCESS RECOG EOFFN BIGBUFS TYPE) (* ; "Edited 8-Sep-88 14:27 by bvm") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (S (OPENSTREAM FILE ACCESS RECOG (BQUOTE ((\,@ (AND EOFFN (BQUOTE ((ENDOFSTREAMOP (\, EOFFN)))))) (\,@ (AND BIGBUFS (BQUOTE ((BUFFERS (\, LAFITEBUFFERSIZE)))))) (\,@ (AND TYPE (BQUOTE ((TYPE (\, TYPE))))))))))) (if (AND TYPE (NEQ TYPE (QUOTE TEXT))) then (* ; "Force the stupid device to have eol CR, no matter what it thought (take that, Maiko)") (SETFILEINFO S (QUOTE EOL) (QUOTE CR))) S)) -) - -(\LAFITE.CREATE.MENU -(LAMBDA (ITEMS TITLE DONTCHANGEOFFSET) (* ; "Edited 23-Aug-88 18:30 by bvm") (* ;; "Create a Lafite menu using its font. Optional title. DONTCHANGEOFFSET inhibits setting the CHANGEOFFSETFLG field. ") (create MENU ITEMS _ ITEMS MENUFONT _ LAFITEMENUFONT TITLE _ TITLE CENTERFLG _ T CHANGEOFFSETFLG _ (NOT DONTCHANGEOFFSET))) -) - -(\LAFITE.EOF -(LAMBDA (STREAM) (* ; "Edited 15-Sep-87 18:26 by bvm:") (* ;; "End of stream op for Lafite mail folders. Return endless CR's so that parses eventually stop") (if (NEQ (ACCESS-CHARSET STREAM) 0) then (* ;; "We're in another char set, so just returning CR won't do, since it will be interpreted in the wrong char set. Also, can't just smash CHARSET to 0, since some readers cache the charset.") (LET ((STATE (STREAMPROP STREAM (QUOTE EOFDATA)))) (SELECTQ STATE (NIL (STREAMPROP STREAM (QUOTE EOFDATA) 1) (* ; "First return charset shift byte") NSCHARSETSHIFT) (1 (STREAMPROP STREAM (QUOTE EOFDATA) 2) (* ; "Then charset zero.") 0) (PROGN (* ; "Eek, shouldn't happen. Maybe somebody is stupidly reading bytes, so try a cr") (STREAMPROP STREAM (QUOTE EOFDATA) NIL) (CHARCODE CR)))) else (CHARCODE CR))) -) - -(\LAFITE.CLOSE.FOLDER -(LAMBDA (MAILFOLDER REALLYP) (* ; "Edited 14-Oct-87 20:18 by bvm:") (* ;;; "If MAILFOLDER is open for output, make sure it is completely written out. If REALLYP then actually close the file") (LET ((STREAM (fetch (MAILFOLDER FOLDERSTREAM) of MAILFOLDER))) (COND ((AND STREAM (COND ((OPENP STREAM (QUOTE OUTPUT)) (FORCEOUTPUT STREAM T) (* ; "Due to Leaf bug, best to do the FORCEOUTPUT first even if we're really closing it") (replace (MAILFOLDER FOLDERCREATIONDATE) of MAILFOLDER with (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) (* ; "Update creation date in case it's a device where writing to it affects it (always true over savevm for some devices)") REALLYP) (T (AND REALLYP (OPENP STREAM))))) (* ; "Yes, close it for real") (PROG1 (CLOSEF STREAM) (replace (MAILFOLDER FOLDERSTREAM) of MAILFOLDER with NIL)))))) -) -) -(DEFINEQ - -(\LAFITE.DESCRIBE.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 7-Sep-88 18:55 by bvm") (LAB.FORMAT FOLDER "File ~A contains ~D messages ~@[(~D deleted) ~]in ~D pages." (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) (AND (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) (for I from 1 to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) count (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE MESSAGES I)))) (FOLDHI (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER) BYTESPERPAGE))) -) -) - - - -(* ; "Make is easy to load new versions of Lafite") - -(DEFINEQ - -(LOAD-LAFITE -(LAMBDA (DIR SOURCEP) (* ; "Edited 3-May-89 18:39 by bvm") (* ;; "Load Lafite from a specified directory (or the dir where we find the first file). If SOURCEP true we load the sources PROP, else the compiled files SYSLOAD. When loading compiled, we only load files that are noted as already loaded, since those are the only ones that won't be automatically loaded by the FILES command in file LAFITE (which must have been loaded if this function is defined).") (SETQ DIR (MKLIST DIR)) (for FILE in (if SOURCEP then LAFITEFILES else (REMOVE (QUOTE LAFITEDECLS) LAFITEFILES)) bind F when (OR SOURCEP (GET FILE (QUOTE FILEDATES))) collect (if (SETQ F (if SOURCEP then (FINDFILE FILE T DIR) else (FINDFILE-WITH-EXTENSIONS FILE DIR *COMPILED-EXTENSIONS*))) then (SETQ F (LOAD F (COND ((NOT SOURCEP) (QUOTE SYSLOAD)) ((EQ F (QUOTE LAFITEDECLS)) T) (T (QUOTE PROP))))) (if (NULL DIR) then (* ; "Fix dir for subsequent loading") (SETQ DIR (LIST (PACKFILENAME.STRING (QUOTE NAME) NIL (QUOTE EXTENSION) NIL (QUOTE VERSION) NIL (QUOTE BODY) F)))) F else (CONCAT FILE " not found")))) -) -) - -(RPAQQ LAFITEFILES (LAFITEDECLS LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITEMAIL LAFITESEND LAFITESORT LAFITETEDIT NSMAIL OLDNSMAIL NEWNSMAIL LAFITEFIND MAILSCAVENGE LAFITE)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(FILESLOAD (SOURCE) LAFITEDECLS) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.DEFAULT.MENU LAFITEFILES *COMPILED-EXTENSIONS*) -) - - -(CL:PROCLAIM (QUOTE (CL:SPECIAL *LAFITE-LOGGING-IN*))) -) - -(/DECLAREDATATYPE (QUOTE MAILFOLDER) (QUOTE (FLAG FLAG FLAG FLAG FLAG (BITS 3) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((MAILFOLDER 0 (FLAGBITS . 0)) (MAILFOLDER 0 (FLAGBITS . 16)) (MAILFOLDER 0 (FLAGBITS . 32)) (MAILFOLDER 0 (FLAGBITS . 48)) (MAILFOLDER 0 (FLAGBITS . 64)) (MAILFOLDER 0 (BITS . 82)) (MAILFOLDER 0 POINTER) (MAILFOLDER 2 (FLAGBITS . 0)) (MAILFOLDER 2 (FLAGBITS . 16)) (MAILFOLDER 2 (FLAGBITS . 32)) (MAILFOLDER 2 (FLAGBITS . 48)) (MAILFOLDER 2 (FLAGBITS . 64)) (MAILFOLDER 2 (FLAGBITS . 80)) (MAILFOLDER 2 (FLAGBITS . 96)) (MAILFOLDER 2 (FLAGBITS . 112)) (MAILFOLDER 2 POINTER) (MAILFOLDER 4 POINTER) (MAILFOLDER 6 POINTER) (MAILFOLDER 8 POINTER) (MAILFOLDER 10 POINTER) (MAILFOLDER 12 (BITS . 15)) (MAILFOLDER 13 (BITS . 15)) (MAILFOLDER 14 (BITS . 15)) (MAILFOLDER 15 (BITS . 15)) (MAILFOLDER 16 (BITS . 15)) (MAILFOLDER 17 (BITS . 15)) (MAILFOLDER 18 (BITS . 15)) (MAILFOLDER 19 (BITS . 15)) (MAILFOLDER 20 (BITS . 15)) (MAILFOLDER 21 (BITS . 15)) (MAILFOLDER 22 (BITS . 15)) (MAILFOLDER 23 (BITS . 15)) (MAILFOLDER 24 (BITS . 15)) (MAILFOLDER 25 (BITS . 15)) (MAILFOLDER 26 (BITS . 15)) (MAILFOLDER 27 (BITS . 15)) (MAILFOLDER 28 POINTER) (MAILFOLDER 30 POINTER) (MAILFOLDER 32 POINTER) (MAILFOLDER 34 POINTER) (MAILFOLDER 36 POINTER) (MAILFOLDER 38 POINTER) (MAILFOLDER 40 POINTER) (MAILFOLDER 42 POINTER) (MAILFOLDER 44 POINTER) (MAILFOLDER 46 POINTER) (MAILFOLDER 48 POINTER) (MAILFOLDER 50 POINTER) (MAILFOLDER 52 POINTER) (MAILFOLDER 54 POINTER) (MAILFOLDER 56 POINTER) (MAILFOLDER 58 POINTER) (MAILFOLDER 60 POINTER) (MAILFOLDER 62 POINTER))) (QUOTE 64)) - -(/DECLAREDATATYPE (QUOTE LAFITEMSG) (QUOTE (FLAG FLAG FLAG FLAG FLAG (BITS 3) POINTER BYTE POINTER WORD WORD WORD WORD FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER FIXP)) (QUOTE ((LAFITEMSG 0 (FLAGBITS . 0)) (LAFITEMSG 0 (FLAGBITS . 16)) (LAFITEMSG 0 (FLAGBITS . 32)) (LAFITEMSG 0 (FLAGBITS . 48)) (LAFITEMSG 0 (FLAGBITS . 64)) (LAFITEMSG 0 (BITS . 82)) (LAFITEMSG 0 POINTER) (LAFITEMSG 2 (BITS . 7)) (LAFITEMSG 2 POINTER) (LAFITEMSG 4 (BITS . 15)) (LAFITEMSG 5 (BITS . 15)) (LAFITEMSG 6 (BITS . 15)) (LAFITEMSG 7 (BITS . 15)) (LAFITEMSG 8 (FLAGBITS . 0)) (LAFITEMSG 8 (FLAGBITS . 16)) (LAFITEMSG 8 (FLAGBITS . 32)) (LAFITEMSG 8 (FLAGBITS . 48)) (LAFITEMSG 8 (FLAGBITS . 64)) (LAFITEMSG 8 (FLAGBITS . 80)) (LAFITEMSG 8 (FLAGBITS . 96)) (LAFITEMSG 8 (FLAGBITS . 112)) (LAFITEMSG 8 POINTER) (LAFITEMSG 10 POINTER) (LAFITEMSG 12 POINTER) (LAFITEMSG 14 POINTER) (LAFITEMSG 16 FIXP))) (QUOTE 18)) -(ADDTOVAR SYSTEMRECLST - -(DATATYPE MAILFOLDER ((BROWSERPROMPTDIRTY FLAG) (BROWSERPROMPTGREW FLAG) (FOLDERNEEDSUPDATE FLAG) (FOLDERNEEDSEXPUNGE FLAG) (FOLDERBEINGUPDATED FLAG) (BROWSERSTATUS BITS 3) (FULLFOLDERNAME POINTER) (FOLDEROKTOSHRINK FLAG) (FOLDERGETSMAIL FLAG) (FOLDEROUTOFORDER FLAG) (NIL 5 FLAG) (VERSIONLESSFOLDERNAME POINTER) (SHORTFOLDERNAME POINTER) (FOLDERSTREAM POINTER) (MESSAGEDESCRIPTORS POINTER) (FOLDERLOCK POINTER) (%#OFMESSAGES WORD) (TOCLASTMESSAGE# WORD) (BROWSERFONTHEIGHT WORD) (BROWSERFONTASCENT WORD) (BROWSERFONTDESCENT WORD) (BROWSERMAXXPOS WORD) (ORDINALXPOS WORD) (DATEXPOS WORD) (FROMXPOS WORD) (FROMMAXXPOS WORD) (SUBJECTXPOS WORD) (BROWSERDIGITWIDTH WORD) (FIRSTSELECTEDMESSAGE WORD) (LASTSELECTEDMESSAGE WORD) (FIRSTCHANGEDMESSAGE WORD) (CURRENTPROMPTLINE WORD) (CURRENTDISPLAYEDSTREAM POINTER) (BROWSEREXTENT POINTER) (BROWSERORIGIN POINTER) (FOLDERDISPLAYREGION POINTER) (BROWSERWINDOW POINTER) (BROWSERMENU POINTER) (BROWSERMENUWINDOW POINTER) (BROWSERPROMPTWINDOW POINTER) (ORIGINALBROWSERTITLE POINTER) (FOLDERDISPLAYWINDOWS POINTER) (FOLDEREOFPTR POINTER) (DEFAULTMOVETOFILE POINTER) (CURRENTDISPLAYEDMESSAGE POINTER) (BROWSERUPDATEFROMHERE POINTER) (BROWSERLAYOUT POINTER) (FOLDERCREATIONDATE POINTER) (HARDCOPYMESSAGES POINTER) (HARDCOPYSTREAM POINTER)) -) - -(DATATYPE LAFITEMSG ((PARSED? FLAG) (DELETED? FLAG) (SEEN? FLAG) (DATEKNOWN? FLAG) (DATEFETCHED? FLAG) (MODEBITS BITS 3) (BEGIN POINTER) (MARKCHAR BYTE) (MESSAGELENGTH POINTER) (%# WORD) (STAMPLENGTH WORD) (TOCLENGTH WORD) (NIL WORD) (MESSAGELENGTHCHANGED? FLAG) (NIL FLAG) (SELECTED? FLAG) (MSGFROMMECHECKED? FLAG) (MSGFROMMETRUTH FLAG) (MARKSCHANGEDINFILE? FLAG) (MARKSCHANGEDINTOC? FLAG) (NIL FLAG) (DATE POINTER) (FROM POINTER) (SUBJECT POINTER) (TO POINTER) (IDATE FIXP)) -) -) -(DEFINEQ - -(\LAFITE.GLOBAL.INIT -(LAMBDA NIL (* ; "Edited 21-Apr-89 16:10 by bvm") (* ; "need to do this so you can send a message without 'starting' lafite") (DECLARE (GLOBALVARS BackgroundMenu BackgroundMenuCommands)) (LET ((OLDITEM (OR (CL:ASSOC "SendMail" BackgroundMenuCommands :TEST (QUOTE STRING-EQUAL)) (CL:ASSOC "Mail" BackgroundMenuCommands :TEST (QUOTE STRING-EQUAL)))) (NEWITEM LAFITE.BACKGROUND.ITEM)) (SETQ BackgroundMenuCommands (if OLDITEM then (SUBST NEWITEM OLDITEM BackgroundMenuCommands) else (APPEND BackgroundMenuCommands (LIST NEWITEM)))) (SETQ BackgroundMenu NIL)) (LAFITE.INIT.PARSETABLES) (SETQ \LAFITE.MAILSERVERLOCK (CREATE.MONITORLOCK "Lafite Mail Servers")) (* ; "Used by anyone who calls \LAFITE.GET.USER.DATA or otherwise tries to muck with \LAFITEUSERDATA") (SETQ LAFITEPROFILERDTBL (COPYREADTABLE (QUOTE ORIG))) (* ; "For reading and writing the profile") (DEFPRINT (QUOTE MAILFOLDER) (FUNCTION \MAILFOLDER.DEFPRINT)) (DEFPRINT (QUOTE LAFITEMSG) (FUNCTION \LAFITEMSG.DEFPRINT)) (if \LAFITEMODE then (* ; "There was a mode enabled on entry. Reset it in case of incompatible mode records") (SETQ \LAFITEMODE (ASSOC (CAR \LAFITEMODE) LAFITEMODELST))) (for MODE in LAFITEMODELST when (LISTP (CDR MODE)) do (\LAFITE.REGISTER.MODE MODE)) NIL) -) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(FILESLOAD LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITESEND LAFITEMAIL LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE) - - -(CL:PROCLAIM (QUOTE (GLOBAL ANSWERMARK BROWSERMARKXPOSITION DEFAULTMAILFOLDERNAME LAFITE.2COLUMN.MENU.MIN.ITEMS LAFITE.AUTO.MOVE.MENU LAFITE.BACKGROUND.ITEM LAFITE.BROWSER.ICON.PREFERENCE LAFITE.BROWSER.LAYOUTS LAFITE.DISPLAY.SIZE LAFITE.DONT.DISPLAY.HEADERS LAFITE.DONT.FORWARD.HEADERS LAFITE.DONT.HARDCOPY.HEADERS LAFITE.DUMMY.HALF.SHADE LAFITE.DUMMY.SHADE LAFITE.EDITOR.LAYOUTS LAFITE.EDITOR.SIZE LAFITE.EXTRA.DISPLAY.COMMANDS LAFITE.EXTRA.MOVE.ITEMS LAFITE.FOLDER.ICON LAFITE.FOLDER.MENU.FONT LAFITE.HOST.ABBREVS LAFITE.LOOKS.SUBCOMMANDS LAFITE.MIDDLE.UPDATE LAFITE.PROFILE.VARS LAFITE.SIGNATURE LAFITE.USE.ALL.MODES LAFITEBROWSERFONT LAFITEBROWSERICONMENU LAFITEBROWSERICONMENUITEMS LAFITEBROWSERMENUITEMS LAFITEBROWSERREGION LAFITEBUFFERSIZE LAFITEBUSYWAITTIME LAFITECLOSEITEM LAFITECOMMANDMENUITEMS LAFITEDEFAULTHOST&DIR LAFITEDELETEDLINEHEIGHT LAFITEDISPLAYAFTERDELETEFLG LAFITEDISPLAYFONT LAFITEDISPLAYREGION LAFITEDL.EXT LAFITEDLDIRECTORIES LAFITEENDOFMESSAGEFONT LAFITEENDOFMESSAGESTR LAFITEEXTRAMENUFLG LAFITEEXTRAMENUITEMS LAFITEFIXEDWIDTHFONT LAFITEFORM.EXT LAFITEFORMFILES LAFITEFROMFRACTION LAFITEHARDCOPY.MIN.TOC LAFITEHARDCOPYBATCHFLG LAFITEHARDCOPYBATCHSHADE LAFITEHARDCOPYFONT LAFITEHARDCOPYSEPARATOR LAFITEIFFROMMETHENSEENFLG LAFITEINFO.NAME LAFITEMAIL.EXT LAFITEMENUFONT LAFITEMENUVARS LAFITEMINFROMCHARS LAFITEMODEDEFAULT LAFITEMODELST LAFITEMOVETOCONFIRMFLG LAFITEMSGICONFONT LAFITENEWPAGEFLG LAFITESHOWMODEFLG LAFITESTATUSWINDOWMINWIDTH LAFITESTATUSWINDOWPOSITION LAFITESUBBROWSEMENUITEMS LAFITESUBQUITMENUITEMS LAFITETITLEFONT LAFITETOC.EXT LAFITEUPDATEMENUITEMS MOVETOMARK))) - -(CL:PROCLAIM (QUOTE (CL:SPECIAL LAFITEVERIFYFLG))) - - -(\LAFITE.GLOBAL.INIT) - -(COND ((EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSCHARPATCH) (* ; "Patch to horrid Lyric NS chars bug") (MOVD? (QUOTE PROMPTFORWORD) (QUOTE TTYINPROMPTFORWORD) NIL T))) -) -(DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA) - -(ADDTOVAR NLAML) - -(ADDTOVAR LAMA LAFITE) -) -(PUTPROPS LAFITE COPYRIGHT ("Xerox Corporation and Bolt Beranek and Newman Inc." 1982 1983 1984 1985 -1986 1987 1988 1989 1993)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (4282 19328 (LAFITE 4292 . 5603) (LAFITE.ON.FROM.BACKGROUND 5605 . 5976) (\LAFITE.OFF -5978 . 6362) (\LAFITE.START.PROC 6364 . 8140) (LAFITE.COMPUTE.CACHED.VARS 8142 . 10844) ( -\LAFITE.PROCESS 10846 . 11212) (\LAFITE.START.ABORT 11214 . 11406) (\LAFITE.QUIT 11408 . 11650) ( -\LAFITE.RESTART 11652 . 11785) (\LAFITE.SUBQUIT 11787 . 13085) (\LAFITE.QUIT.PROC 13087 . 15823) ( -\LAFITEDEFAULTHOST&DIR 15825 . 16635) (LAFITEDEFAULTHOST&DIR 16637 . 16807) (MAKELAFITECOMMANDWINDOW -16809 . 18448) (EXTRACTMENUCOMMAND 18450 . 18698) (DOMAINLAFITECOMMAND 18700 . 18849) ( -LAFITE.TOGGLE.SERVER.TRACE 18851 . 19326)) (19395 22363 (LAFITEMODE 19405 . 19885) (\LAFITE.INFER.MODE - 19887 . 20240) (\LAFITE.SHOW.MODE 20242 . 20479) (\LAFITE.MODE.TITLE 20481 . 20766) ( -LAFITE.SHOW.MODE.P 20768 . 21009) (LAFITE.ALL.MODES.P 21011 . 21354) (SET.LAFITE.MODE.INTERACTIVELY -21356 . 21938) (\LAFITE.COMPUTE.MODE.COMMANDS 21940 . 22361)) (22994 24750 (\LAFITE.LOGIN 23004 . -23386) (\LAFITE.LOGIN.NORESTART 23388 . 23494) (LAFITE.PROMPT.FOR.LOGIN 23496 . 24515) ( -\LAFITE.REAUTHENTICATE 24517 . 24748)) (30709 34151 (LAFITE.AROUNDEXIT 30719 . 31257) ( -\LAFITE.MARK.FOLDERS.OBSOLETE 31259 . 32175) (\LAFITE.CHECK.FOLDERS 32177 . 32576) ( -\LAFITE.ASSURE.FOLDER.READY 32578 . 32988) (\LAFITE.AFTERLOGIN 32990 . 34149)) (34183 37121 ( -LA.RESETSHADE 34193 . 34571) (LA.MENU.ITEM 34573 . 34991) (NTHMESSAGE 34993 . 35076) ( -\LAFITE.MAKE.MSGARRAY 35078 . 35508) (\LAFITE.ADDMESSAGES.TO.ARRAY 35510 . 36091) ( -\MAILFOLDER.DEFPRINT 36093 . 36340) (\LAFITEMSG.DEFPRINT 36342 . 36504) (LA.POSITION.FROM.REGION 36506 - . 36983) (MAILFOLDERBUSY 36985 . 37119)) (37299 53165 (TOCFILENAME 37309 . 37740) (DELETEMAILFOLDER -37742 . 38262) (\LAFITE.OPEN.FOLDER 38264 . 42879) (\LAFITE.REPORT.FILE.WONT.OPEN 42881 . 43605) ( -\LAFITE.FOLDER.CHANGED 43607 . 46011) (\LAFITE.REBROWSE.FOLDER 46013 . 48978) ( -\LAFITE.FOLDER.CHANGED.MENU 48980 . 49903) (\LAFITE.SET.FOLDER.STREAM 49905 . 50599) ( -\LAFITE.OPENSTREAM 50601 . 51140) (\LAFITE.CREATE.MENU 51142 . 51495) (\LAFITE.EOF 51497 . 52317) ( -\LAFITE.CLOSE.FOLDER 52319 . 53163)) (53166 53750 (\LAFITE.DESCRIBE.FOLDER 53176 . 53748)) (53811 -54917 (LOAD-LAFITE 53821 . 54915)) (59961 61238 (\LAFITE.GLOBAL.INIT 59971 . 61236))))) -STOP diff --git a/library/lafite/LAFITEBROWSE.LCOM.~1~ b/library/lafite/LAFITEBROWSE.LCOM.~1~ deleted file mode 100644 index fc64254d253e03961d4b61217730221c60b2c0bc..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 52039 zcmeHwdvILWc^`HGQ8F#S3lgGbh?Z|4nF3V-!Y%*;r2N=j?1H<%Vi(+92n0om0?U>mhzA6L=}4Bdoum&^Q&w$4DU#i35+`Y!{8KP& zGo5B6_4j?>IrpA>_ky&nOs0Q`BVq47=iKx7&Ue1^z0P-f6Up&(HrY3x&LsQN+3}op z_jGJ*GIlg+^`x`KWImHFO!ruK=aaESF&58wlH;*L(h3h8Z11HC#!#x5OjtdUNMG#S zlYNJWtnlEG!GR;g;U25EXQ6)PY_(P{S@mVB$7=saiNfShePpS+{N%^VKXJCcvi7lB zb@l8*eWm=d+WZsMwerW#&aW(>l8WL1}~_MWM7sa8I3IR*Rs`+Ka?{2JPKe?B;TByzaNI|OUAFI#`AZ}hMg zjvN_2bR;s+WA*%_v-NuA!R4R&2>t3_uGY`3ER*czo>R!cn4($X4# zvIYOPI|D7LU*pG5@?ZWFt#o(uLkth8%J$~1bt>GgQg_o!sHOMNprzZM&gaIGg#zF_ zJgNYox-)plIyRFlCauVbeu&tgsadD5t?(f`*@m4pY)z#TiA)j|Tf+lZZ#IpQNqxOX z#&X&5bRI)G=m5d_RKuZZ_zz!ysUs|<>G$cIfgQM2T*z|NVn}}E=HWV?2 zsp;Z)E-zmnY{wM0_c{}*Py_{zCW|(5H;w85O={(F>MZx1=C8ET#SOr(BxL zVY_t~0uESCXF%`>d^E8Rx@Ka9q8epC1J|j@n?=(&2!uVNJ8mOuyKA|s>S6-}17R5* zS6oORIdcC@b~c?&^r2J5@NS_0G0O&?>JH42Xtg!s9be=j`)T3ENvDo;+w@<}zXc`Gu2 zR{Ar!>`~evxZ||?`}4^{vRFvP5(K~SutM{xSUS_6JYGcF!5x7Rc_%>73xMFD(8+3f zwk6mSIJS#MbNTiPlQkZiO4@yKZJHCezd7ByaR)z6@Bh5yF1;KKHI6YsP=&rdU25I1 z8midF9jcZCoWPI^sgmECZr!|7mD_xuF2{9+h@ymt!d4-bPiH4*vB}b!iT5XR{bRYQ zsaQ5)9U`#B0o+(Zt*h{;m5Uc+>1_X0E}Jgq@|oP&BmsDE$RgP4Vv!;1h*S*fGw3`6 z!SqC8DbW`e_Hg6NQGBR#Mu3g_dDvBIXxKUu8!M(CPFiSKKcZ2iCNw*nE~a!xiHzGF z+;RG4=BH7Zk(`l8VfZw#mJ?~n$wZ$5!2Q;=joo;RSb}&(@F{o&cxe^6>jB1s=Q*BA z7m8R<=rnDOY1Bd_84nS?I`B-So7WI6Jb^Cb__&4H(zRd}#dZZ+Zh5%#$AUcDJj48l zDQx53U4cEFf!4{*yF0C0b}BImgcu&-4y&>C$?CU;L4KwlMsr1LXhf|fH(@2(5wRkJ z{56kOeF}uppJGCGBs-Xpp@?78quv^M>NE~b=Uv3$9a1m{?mh%drU8)txnOHc;Bi{Y z#zHPIP%C*R@130i(EWK??g!?!MpE*4+g5kVEVucwRFRkKdW4g?Ql<-y>iVDa^nEtX zKflcR`ThS=UK`cT))Xz@$gq_>K8>Y{~NUs7cQ{8w4|}))@e= zXT>uTMslnIwb(pWfEo%wT%KHE1Ao{91lJCK-}nwleKppQ!tL*OujwBgfmomR#m*7apT@A9!s0cD48 z+y$a`F5)+0#m0!)$ETy9xMR7acsgvw2EvC%F(c!xw+36P(avC?7@XGC-eCngu95%BNB&g?+XVp8wvz? z5(L``;<8Z@*k}d~(9$-fSs2=V1k3>GUxHHI5*0!g+}f?4+B$#y)-i?@AUdWYIz|wk z`)YjiR?d2%(qP`Vv-3T+_lclBm;G*K>fS)`)7e}o7+})4 zhl`);2z)2k5e%H%cx*yGyckVi{Ah;1+89n91AG9ePi%cKTH?G*9gEwW=|;55ST15xlq*UH18-d4_}+vR3#1`O2Wmm7 z=u+s_KYGP}l!hDY-!7%KR2l}N7{kawaaX`dN3Gep-1s=wfpr*Q2Hl1F?w^ZY3w}tyOD~qafK*M0 z1?D}O0gE2ypFtr&P`)M<=#z!q0`(ej<~bc?25)#>@f4ERCPAF|hpB zThd)DFyIsr3Bvi&V#?O75MW(=sIDbq71Kqifo;i0?@y?^^}!IS4ZjiHdVmrCbX%iy zyQ4GozQ@sK%ZEz*)791}Rl9C)M8C-N{ug;+t-s1Ir$UWVF4VQJp^D;_)4MGFu)ncb zTK<{0N?_u;yHD*w@jYF;8z)L!%N+l`yz8+NR@F&vP1f0N&UiGo)%vp+0@pcX>jD1R zi15#;yIUzQI9lEKF;1w+Uo>($_{)`3`x~daxkTXmu|Vso4laCmW~%m{S1Y9w4>r#0 zTX>XH9az`c5z&pQEd9Ou%AL6mDe*{plE=hr)p~lS<1jplD{S9e2DjyoXkOV0=*>#{HPwB4v)zd^*uX;*#J)oXq7**H3`laiL zs@&*VQv;F^3kG)Rzz!eyS6OAynXNXba66Ns>h`ZyP6sc%nP%9Y>T2D(<-(f}1xm61 z^;?ZxS8)A*Qsx5zOtMV+sXH5|_O))^Ub)zl+fR9+z^OYKkuD#}?ce^j+?`*muKz`D zUvT|%ZP0BnZ5i>j)5klo6ERzd=Ia3vavz z4i?l{guPfI0V+Lh9U2_*rhql^l!2}W;+Z7!SHqCrJSku~JSotSds3k4^rV1-yHkd+ z#duP{D7#Yz4|~fDj)pyb9t8b&k795L{{}XH3;SgThKVz zIBZfwR;*Zzjipp(Wb}}wD3%q0i2)zSbH`4+G)H3ga=AOdm}Z)8p#XFexz8 z*}_adX{U&qRJ}q5CW6S6uOCb%_CKQ2!>*lg1pB75)mS6g`A&)!OsKgq83pUm2<@+A z(b8Jdei37l#qvp0q_!vIZF>Ig|n@qSO)5%h*YC&~2nA=$?~<*?UzQlLLdV+O#G zupnyrGQvkltSrJGR&_Y2kufJD} zwOS})#uLZfn%C*T2VZOsLl|;(M1R2AXL=vz~PeV;@g`rn+)xyI8X2Luj zo5>VO2b)S}5||T6Zey9e&;@IRfKH820saOnALb!Q`l1|Hx^jHS_+|`@zMu~wun$^4 z+15($#kuL^JwHkOW&|dxp2FGkLiLIB)=K%wDs0wI)K_4)K5X?Q&Yd}P-V*cMisC{| z+F-C;j%4vgL$VlxWT9BkAhRaV^Cp+x|3Z3cf_JUT2bif4ar!>qmzckJPNn<;e=xym zsf}(ftn`?>_=RivBtP;WX@JYm31jiuhNvsWeg{S{43Sb3Nhp#b)CsAB&S*MajAcke z7>3?t1_^~E^iJSmQ3wXR%p5B?)yLR}>|{`UJRd2fr=}s?s``@0W=Iz^U}aed1^j2S zuBt$kSum zICBEp-8K_mQ3oob>HmlZ%wVik8jNml>~F;4-%yLC7cxpr7;|WzJ}HYanu^88YPX~b za?r{9Kn_}Y7%{0^{X|2caq}nR#m=w3mocDqBf_+fUwA5c zsch`$gvTnUx*DhUuo%~}p5^=(MMJ~Ic)4-v2@>yG{!eC;#Koui;}40DN5U(=cR@5I zDfY(lDFoTvKFFtB>$4XE_h&YTxrfzKiRG6~u?lCL&NB8oD9nvP{^-)ONvLtEqjjsV zlI!A%(o0w8xc5x&PvpAN{4jfG_rje}-Uctcg^xp8cL?QzGS>Svejt-u5sbbf2Uf=a@mVr6O*Dwd9;+_lrJ~jfD7lf1)C#J%cM%RHfz^r!w6qFT8miwox#NTItJ*Ek>Arg)!hE9ox3xWIqu! zl@G&!@UbqP$IvKtL6I7U;K_uIjEv2YA%-BJ8E<6SPEN(4>>t9`pgZB$3XJ$v5?b5C zMg@c5S$zmGSZkkDf1(Y+!0AwA)TBJn@wq_}!N%z2F`++(_#|VEU~v;+j}^vXZaNBw zz6ePEgU|Qy{@{b1zJfu} zRS8h%`e3EX_F*H!j3}j4?~t2NlCbHJI%^OTmH7(kgJlUYmLy=BS#BqU!2#EY5wIk_ zOm4(x9-BlqvNf&G`FAVvvna2%7D0i4#Vm&-uF7X~Np4CD< zJ2U~|c88qsj^EfB!oT(tIEf1yB0X$j9)6Z(&Hoa^1FeGcMq6Pn`KM#na-DXApZ@TN zk&T(`nX8|(D)Zox=4&uCl+MFTbD?&w1aHi>%KVxoZj&qbVJBgxySe~lM17enXvcCH zvU-XrhkR6Q&087v5Y?YqPgj>q^`{@K!kF=pwYGBJntyV>Dqllu0DdfAUPA&gWVQM8 z^>b_FBzkVOY@I$2dxvy0GCb1mGq^Cd?Qb$!Ew8b~M8K=2R?G4*t*lkbXyU2)+PU&7 z_(g1Dy}h%pw3n!@3D#p;UhbaPOetKPl^X4L>aQFSXi;D59l|1M4u?Hl$RIE zR(*vv;>%WfexahPLaO~p5V4-F)X|THb1V30O#=W>0N7S5WCK!j@sPE^rXjR(dVXQ) z$(8!KWz0|AdV+gJli5zJPEVq4nV+vPaA~;KPbciAT@$&=ALzL!MEE$d#yhbJFmsWQ zDmkgS_x+Z55N>>V;_OQLQl_X8_q$H?S<3CIpA=!65Bg{ikZ0Q{Ex(cP{ zTDNw=7#j+lkWm=>@z!1D%dT{A{i+)2->Ba|WlmO&^AK%5GIqbgL3C~&F;pY!8!RW= zN=hEYJ1~2I3?S=<4Ct!^8F+Z^^zmVQ?D&fKY@}L15T#Ol3UZWCDv}L|_5EFP`Vc|r zi_sQkEQ-rCEIq{=2cMJT`- z!HV#F>;Fwyo`Jc*=h9+tzr5>HF-g3a8{B$n{i~42NsxwS4yI$UHg5eS6or^0N5M%} zIBll`{vl86VX$>OyDj!jRSLQ({lshrs&Y1H%uE{Yf77BTCF&#Zv*`pZ+9J~{R)`d< zVjsi~L8fHDCp%Ehe5jr7)y^rpvgyRX=J=A8?1I?+UB05`Nto#R_=(U5;d&l`OaleGKu^-DlmFn?~lKp0RWojvK~Xacp0J`9#h z@tfg+!=8_zgml*e?ITU)Y(KjUlT#e)+Y+2emQ__%lQ9E!6V*DQ7kFGZK_ZnGRI!=Z z7&uwBuCvf8g`_Rw#RR*!NmeqF3!g#Apr@pcxHaBjf87btoog&5Z>;`QEHkdhqjjiG z6ON0#!Ge(zGm*>QS0wq{*82mG^%!h_Kw|`q(!l*5#WN*bXbkoZ){UMt@d-*-C5C^E zp(ck6${P3@P|5L-c;-Dq=orbEcCkNwNlccu?Q;3PkTPO2nd8#@bZPgADbBz&jU#bq0!JSQ+gj4ft+xOSiqAi4)sbRN?EDRyesEKGcYr|n1 z1y^k5U~&XOh;o}5ZZSFxL6YXlH0Xe)HxDihqpeX5z~lK0TuJj+a9}b%LT^1ELAl-h z5tJv!M{GCsZ1v>q+5DYH?=PxpHz9W@qoal{wh&e1^;r?m8pU985|fxO7|dpf*L10N z>tED@+s`$mYzVJQ+neoXIk@LgFX8`|>z{$Sq)>oKwlD|7FE#>c9@>0zD)K1=o)BDP zIssb^CXCJ>v8DzLC4pJJ9fxUy7M$C$3(iI2u8y^4`y;U;Tp^ZY&;XLyl?kA*c*NT5 za)3fjwxZt{$~)BzD_Z~@j3X8Z$P9E(>PS--azHqM;{eB);PU=JhrZYzaIsri0B*0A zczQN>A4}zHtpz#DcgV+qo(vy0ZPWG=j0%*&Ks8?k^2{D%5GDotHa6SB4}TiP7$Uj< z!WKdYPXrGD0a!zgLnn8)23lGRFg5b<84>vp%O`Z`1gd|?3Z#nXe(Z22#EW}8VHmdm z*$=m0reT_JETN|%!7C18@#UZek1m+4WZPPNxkbN=k@D+mZES|4%$4#aN?BPnTWYVp z)Pbp8N?m_u=@Y3vSN4Kk$K1ZB8Ef>S!K}QlbyN&~FIA^Tn zN$f^Coy=A6svKiyVp6Q!CNAkY(hTDtp+I?$2lMWE07MneAf4>I65) zxOU(3@>}7R)esi(g~}t}otW+78T{G=f3P*oHGily+tn3plqO(ak&IIvu$*+jzH)N* z&e`tSeN{11KUTUJ4b3VW$Hu=U^^Z8*UT#wrKYQV=CmLy$7<3YkHJ}H&@K*fyL8n{3 zdZFcaxStjNn-S4F$l{WE*#$1^R7mXW7bCe4clXha4`!;||HhQ=1-YmLB(G0}Q1=8+9yzaWb@vgN}}7hNufu-n9*bT>V>x+n(fX`ZULG+bHqXp zlUKa#lkiLObEY4LFNrPzF=#xK2D_C#+7GvMy^4k)BIzRR@|rx3<7!k$EwdqPb5K+G zI|{%&;%DC{xjCEe*@44?AQQUT)zee;Vh$j4Zr;K7^nhTv&a<(bt#)q z1WFZMYKP%Rz}MJCNb{zL9RVw*Gkm)pVO^a+Tq5Mm*X%X{^9&nUd|^qf;7(u&L$RYf zv%^5b;FWcerlSv_EKn-3Z8}i^dNsPMblp~p??DK-+P(=zvU6%oK zI;BIB*~3X0rjP=hXdsTpI2!C=rSP8iVM0ZfTsx;$tG~UIgyyL#&-pFqm=*I{(n;D^ z!Cih3TDrCyA0;HvH6JB(>(Kqip}8!-6Td)WN4e;`q8t%L!JQ-r?lgLR5WNoYrev5= zWOHc~+2u3ot=4LYEGK^k7Lhc?z7z=kz#KZWO|CsY6YA>j4unN_7>9f_35_dSsn1*t zyv35UicP^F&SM{Mjc-0Byx`>n-&99$F7Mu$6kiG6vgK$S4^}pAL$T77#~h|pwi=Sn zKI$a#*33uqNodL^r*b&s9yVMH*hZqMJLFsPrU_dhSMmV)S{|_M{GndW-OT6evJxVYXix2|{h;T=;=fbP*rqMoU9wY4glf1fI^ ztU}?vYMp^fd>KaB(`7s^SI?fSagZGtb?Y!uBIpj}^By|2qpg3Z%VdWYyC)om=qP4S z%qmr%V5{buuGy+Tp*51Wx9mIQi#1yeQHh*x`2-WWNg@2hv@8HE4SsIAQaZ+*RcM+K ziQJ@2o}Q&}ma6TuY3e){qG$NUVDOa-?SUDBl2R(*=qKrQ4f#+gi6>eC1b;2^8HYtV zG=Va?(D7co3|3B}EzlA)bPOaC^Wf>!8u-Fq5s>k8cd_%wTA49r5b&SdTJTQ^kHBWH z@Cby{#z9uAkuSS)%u}?_hdT5@o^%mBgXZ=ktx}WBCH(kN6ZaCvDP7#vd$48G_3p z9Gg)S0@0@Et9x+m?KcFH-WlJ%*1-b?AQy<=9OD?EbrTIl+uwx-!Zpz#MLXyoAk*6} z^6wBQC_D)VVBl~#nM8UDp8PO0(_wgQQ8w}T$yO+s>Pk&i#NJj33A%0kr$(VT!ykhzk$aFDwTVVy_VD)* zC+tY}Sy6DLqy!Ob4=id3lvOA`oGzph2W$qnZ!US0-qI<3GtYQo{(^>L&;5^%>db#A!bzMTrdrSZP4N8hMAK%EfU)<6 zh|Zh_6o8s@8qj6~wSRzEwS!a#3`$SPB4>N~;|Ilph*lt*aEc8{+qUS`{-afEHzBHD zv)y;NK;e_X0RdssQtK3k0jAL}2Pm8q?_07K^#*rYlV>P^ennz7eMv3G2ZURct?#!} zdH!(geOyWDTl^zBp!Ms=N*jAi)$MN$hPK|z8OLBvgmb<-F@?l@X|u~!GLJ+yJvyC} zsvoCaRl49|LM0y)2OmP=7{g%0gk|KI0$St*AIBj#;Iqo^muwZmA>LGu^bIr934}ai zk9CR{q+B*2VT$hs;w1Vl^c|LI1ZEsDLx-UuaWjx~7Q^I7$-1P<@=-C;bxLR0;4W@% zbO291L3bffPzcF)u$${KLe@zaQfe@C#K)irH)Iz$3WM#U2wwE`xz+OzSPS#Z_pQO{ zt-e}Twr>+be{?DW!6kE)H%2dxHf!jEe;50s+3lN?4hc#$o_)tFP$}=o^x_&QXwM8U zLd8^zrjj=-73FLcTxXtfoBzn!T`Z!W#qH0^%KU|6sY*%deH-#srE8SHK{RmPVL^`_XaGRz zQ<=FU)n-Bq-rsPj_ZHVSudP|+#5X_@8<{k2i4wiSWSNCAsYYx`#o=`H z)uN(gVyBEf%tr8OB1qIq@1j+fNJgKbu#t4`G?P->xNj$svp|95Dn8_5Cp-Hm2h-48 zlpd%(Hb`ni*8MOg;Y1wBvIMESpOl7uiUFe}1b$+k%uEYg_p4et^wR)dZDkupb%H)d z`UD*c&U^BP*!Hz9oRu;7fX-|0>kNe)p>Gq8w4(TVR3+YZszW_>KbD$O?5X@dqIS&P zbE-twsr|y&PKibCRJZ){a=$p5S=|1**sTK^K9aM zNJ_4++vN~v)zbGOIJ_bn>%pr;(=UG?p_|P@a`|QA+pD_jrBifI=1+7Td1-AhkMhx zJzRzpmnc!HmA|2;lYcWu}9b4WtTj$g>sZbhA0yuB{M!)z}TP_{z7`4K(- zH^VXq;&gQ?l-slY1p(hafc;IOyaJ-roL;I0{{j(BPBgfW8}DzV^eDM{ZtGKv+v-eW zIu~LHsIUkOri*u^auVK2I#z4F5WH*gLh$`Em2Ig0;zu%=jeR~bC8TLHLCsw8-_1y_iY> zK9m!K*o6T6u&zIw3;mNt1a+XfV>nz0L@;q11DM!ch(7|vX$Bb-7Xn>~m_=Xx?Ba`< zSox&oEi|=jdn17skbChinPDl&)vI!Ul%-0)jUGAewftVLgR>ip7h1M}6B{3u4qtqK zRyRaFP*r>eo&Fta#!mU!tX;wS8lJCTJd2g2rk4TF*nx9r7<Oo21BFPw*E01 z)5hLhh*4F|`7P`BQTgoEA6)+p?yu@)ZPzcMxN5yoyY-|Hf>Zk%Xcd~Kwp<9r;lkfO z4@Q@qkZ`y%L28+DpL7RIp02$Y({9$(8X{zQh^Dj-c9ELT|uM(EnnkpIP z@Qt3~jWQS1T$a6YJY`29C!o1P3Szu7^brXB6r^Z`m3JPvj39=C&nNIDq)!eBz&#Zn zLO(f|orszSeMk<{dOw1n9)Bb=>&YEPWHrhihP@5lanIc_Sq7ViHB9H9=@T4oHl}|V z!Up*zQm8DotKNfyf;11dtJDxeYN0~eP7O$r6%pxhd1Jg0936rxn_4%M1UJkiI?d!M zH3+jCb#M@-1o|bb+{y71Nji`nL8pl=gIglj0XYTY3=VN>o}q_v3N9`NSF9lYHQ8jF zi=tE7GmMTU8RI1vJ^S^z1=B3lj_fujZc2>2&3Ynu^7*Kb=x9unXW32+Wmr|sjcG?R zSU%twP|Rl#0gM!v;;KDjyZlj9u@M4Zo^B!-ft|$eysqL9WK{j(A($VfD8<-mE(*A) zY&$*%wJ;1JR#!31zIF;fbQ{BT{DOKp%+u}39RgB<*@GbAQfUvu`P|{&;BcxrPik_| z_Dy(d3#ENu^+OnG}l6cyo`z zV@!7WVEV`gE~Iw2WT$$P0{#{D7Te)m%zc--I-lLG+`u0V22SmnLZB^*v-R4Uw_ZCH z5++i3p~skUc;ouT?ri!xcof;zI&yp7xc*zY4s2mx$ZYObktHkQmPzbs7x;|cTo>5R zyK)`E8=simzWBAw#@(v$`ul}{`ax#%C7txIt0x=LiAQ8-zVOyR#BL_^D4hiXDI(w= z!X@CO4HP#_0@$MrW=+oE$VB$C<@hBC&gc0K2LPHVR+uSPQ(11=reiS7*zh zHJk^URw|?!GCbO!X=H~U#~-0w=Dfx%-No*O+nAY2(R~%}Bnf`P3OT!&oR6U|ox;&{ zO3gplv?!ivW(Wnwun9Rt!>IR2%>u%WOxAwp`o*yNTFD5LTzLEI>h~*4pJ10q5gjI9 zZut}&msQ9{LYIP~`-le$+I14M#$iKfjl=d_%t4DLzP6%uBNZY1xOvOyk7rDjBbP*P zY)Gu-VsTDsO|**#NMwc%LPelb6Je5x4mO4q0zo3`CUzi-6Eu@8B$HY7s^v~9N?t<# z7y>a#)UM{2{tV@18E(SD2tMa)i8W3g6b?^ zPxN(py43ladI){Lw0P|+OCj~zfe^^4Qu^Ajq(d!ysRj54b6hTSh&%k02>@0*G|lY} zJ;ek$e)`nq{Vhh9bw3rI4Ser))ic+21h-M6n@wH8RJl24-4$?(h&q-YPk=$9i-L&J zFBEy{6Zde>LAJSi6d^u~OmMGmS#DRJ`_;MiDl- zG#rF0p&2o_y%7JV5y10{4~ws)NHP?9V*M(-ADPGWaG=09Ss}o4jn0m<7RT@;b4L@m ztHIzmY$$sO7LKlmtk2EE1}GfJlfnm~xotRL*x_Is@UN7|u=7!j{ws|Fa7>0>RO5E! zYKpfpxBllXy{z)|3Io_{WSCfO%oQp1R+E77_b{%pA7WgF&gQpxjGy$5^bath%no}d z)E+75jPQSuHSL)t6i}>}hJeY=>(S#=7jg?*eGibFS!2R-XX6l;`%pZYDIRxas6}h7`xKlpq#kMx$FAo?eZAEa#tm!)OOz) z`=*3g;V8AAmuFU5O)Xu0l#UsTIE9fp=V+OTvml^Z&ZaXs&QR$1rSXRC$ateo$Dxxq zryFj0N`v;Mp!_@(;jOXwwP!E1{Hnm<@@^=@pGaTd__z(d?Trb^kH(i?(}3e8 zzoky#A^5b4YI+F@9;oqRDRBdLbbu2}S5K^e!-o6z=7&_Bf`OO1V@f->)w)De0XC4? zIkHec3>RWg$X|-^O+p{*J>t#zG&SxGkAylCtPnbkS3BAWO{3?Kf@^<)>#Xq^top_q zj0MIUWJKppEdrmO+Q#UcPFRE{EUu;nbJa?u`QnErgfcUzS*!S)?1{)^3b#wa8IeJS z9)Jehs}hj}e0t{(>mM4WxQ8({$=t(Knl_J}x_IWTtIx0hSM-pz6X+p`$_;zy5#PCE zbWc+=(TCFCyEkCFaLfmwCAYT#pz4yQ#f3INiZ?Eg3d;!Z+^o^iknxbIKmf{VC4V{O zNiQrC*)E~x(YAr9}> z-rT-Q_o*)E0ih|pdMdR3Vs767C?MDWdUEM^znh)9esOdn%Ur+l^@mc~>!0Q7Q@@xk zrLTWUoH_-K8rh|*kF8%yEp2}$y|jJtp$T;?+4=t0rFd$++lzRc9bBsUFDDe;Sc$K#5dwm0YPliJ&yl zGpOW`S=7n{Fr%-jC^u(TpLC+YX=8d*SXl?hYP((f62}F{|%exW8S-xzf<@Z#F`jrFUo4a%BNcwl77>7>3x^Cs5 z<-Yz|?#Vi^5ijPwhrc^fnu7Hvlij}f;fc>hQCVzXDYcAF&M>PkMSOTX8Zyk~+>S?zY3%)qMzJ}jRW?3F$J zQh*Uw#Z$XYUNlPtE84dkiVtWTAeFngCH{u_O~?8^^L6*ut=vhT6f@&?mC?>aT$d1d z+n>`duNN{5!tIUtMFvTQLP_92`4=geB4EQq~J>??NhWzRiS9l2i5ED^}VX5J9Q(spAe%Z6oO+_+!gZ66N(Osdax!Z zJlk(=!9Qa8vE-nDQ$b{4@{wa+DxLzkL`6X;l%Jc@U@AR&I+6e=$P8+o?QQvT*ramUH=Dy$fgo)(@&`;D$tOT25Rw>o&6OiQ2U{kVUORE^ zw=1^v2^I5G+)TXhl()* zxf%>})1)?sx?Rcw;8?Hb(&R&Z3g78;nsbQk=98mt;3Z*I77-w(&+6e3yP7Y2`NA^v z5kMWlF`Aa?&Awwyzw=iOtEVyf-vxq z&y^CQl4GZhZ6|O$m6)<>yQ8Hq$o3}A>7Dnq@g~QR;y)7`|3KvL$txdhWH_mz4*ZK2 zTXGqO2=_sV1Z%oGU=#GAUJ%lOJna&yd=GB0PQmur@%ua+3NLzwJoqL9`B-Gt&e@XVRQ&H5?K-JxlfjxIWxttZO0!z6c2{jIfWgh=t@zx^(QSEXouE znxD6J?S(pp=K*kp|KDG8ymUwrGVMAJ48_zzqPdVjXfS9M_8wga>tq7KZ>Qh-n`94IeN&dk`_kV0NbIaz#)APlQacwQfuYW8+SMf!uQu5GvIB zn}OBjL19c>74lo{I{<-dI!*amJkZB4dL}Q=fLFLDK}?0*_w*)mrQN-dbtu`m?p*KV5G9A5#>% zXYtjm62Njwex&&2+qQ;vn^0a{wB$wp*2Gzq(eAOX+Zx$VRMcjT+vHTscjQ8~AomDN zVr?MTaqVk}*mwBaR~A2!Rt-YwC{5~b_NgAY#0b?3ml$EOZbW@71ul1NeL#)`v`T5(8n5gE=4TUMlw_;KGiq&1TV281MAjz;4$QE7-tRW6j zUeh9Z)wvhr5L{BAiE!fG4PomMmS>2!aAJOjXi+m8#Mh0<6V{*W!$FFTR+x?>GRh2H zXTsqJoq9=XS9P%G8?CYa@g(j}Cec6%seG)7T8xMfC)S4614T&XV0JVDVM;2Dz&hc| zqC;ERVu}I^j^z^YVTHTtQ4)#5eTVRZ_!l5>#4I32BiIKQljo`kMKxsE{{dPnJDwsL z+{6_G`e(1?NV*)MBmENA3L_yghvHa)N(@8)qwSo-e41TLa>D?Q&Y>H(95HYRvMf$K zP?)tLci{aYbkm?nL)0I~_&4NI_6&j?`{-f@U7B!;<7m`C>KF4BItafiTy87mQR(!Z z)H22!ZUZyk+}&*=^SJn^S-V96WSuI+MOlMTym0I{7kJq@OJ}+L_gvDrxwl}x_(rlG z_FGwfv=%@!^IUPWfgng8b+9*=e6Dxg7Jsx19NxTsp zRkVYh3d4G7&sF=j+V7KWp1SsxRA`C#bSSL6Zl8o~CdcDFz30+jnFV<-BTbs;X!1>m zG)b;FG7kHq*QTKbwPmaG6?-sCuU}Q4g}!e%=urFzzhQZh-i@)YH(-DRbvS96Z$3lz zoZZ#~rr1-E|2R4XMX&&SOW<)i8aQ0ym!Xf+7lR+@oZmI}HRU(ih>r2(KCgaXP*cA9 zJF%^N{MRPp*Pn^Mkl6UB2E~hZ09}=`=atOFtFIu$Z)PI>%F=7E^1;?c-bf_!bYmjT zcDv72La@PqJNEqgHzvh^7nO@##6E{${9!OQL_%>pRe>%qE+}?|I6T&bgS`XjIfyjd z)S9pXlCB@#gB18p841yvxOqGq%z3cfG5y@iEwiA)Q9e3{g9K_6Hn#=7-*mcaT6~k> zodBbK?c&}E@Y;F>rr)@>*_~R{NwwhjUt3JS{u=MmO3Ev6XbdwT zfNV~lFrOr7H7gr^$0j~6bW5?CBzt_e{0c%c1qM&8smq$%>t1?Y;mlodYawI)#I5w^gm z_s*guQkWpQO7~a&Dz_Z%s6ZD*rzLDC{C#B@jQGMOvAe?e$@GN&HnTpA(%5W}=W=%; z5{aR*C;Qv5`W|eTvH4(~v-yJFn9$eDrC_vDyC)tDY_gnDq+1R>@?s-}H`?B=l+}@yKii?=a zuov?$`!})HNaj!eDl2hd4jw+~E8Qt#S;^Mp9UAbBRJAw;Ypi7)7w|(OV4>Lh`Iv~_ z(A{w?JX#SV*SetLK*;AbbUIii2Pxs>XMe%KBo@#++oX6Wzg(qCA{qmE4)8n&c(w`v z;_xq4PmdFPx4#~jUvfjHoi0t`SJQh)-R2VAE+1g=N(*}`VEd(jh!dAb$;I$9aNyaz zT~bo&pf(vD1-jfhaC0i$0K=Uwpf?4kl68CZ+KJ9De3N7LyB0|s(< z!1x4M-v{&#>X2{;WYC(3$Og;w8r+M0{i&R8bNS5E40(1(y8lR4Jj6b2kaO{MCMT27zVCAqb@-YrlFLr$_WTl}oR|Ku+0gUXHM2x2?E(5!?NAs>-oUGqM zW41LCn5T`A=o8LmIp8Aqd0%gRjMOOQ-eGaMg+yPWuzkvz2+?Uw(Nhf z$^``3nu$x-P(Xwsd#-QB7!G0Ztvs~FlEUEwi%l>%^S4(kVjGXQGfR)v3T;Y!5|{R1 z(g|aI004APXQ6|k&@bjRyC$7aDcNJ_ms@~%fJ|UzZP-I=-h3$3x8iJxV%Cgot`mWcL&gX-BWIN89@XJMHPy zEI4vvY#D%^z2DL;#m?3OgSJu5C8!(Q48uooM|Vh1elvtViUBAHVbmenE?k>0k_RL? z7S+U@i5Dy0h>0OomhHh-yJ60oHaGMO+6ql^J$~9QB=8OfXKeYz#?6P5H76YU!;5y8 zY4VwUV*`N1d{@36QDNYCJkgkJJrdL-#L^6@SU6CbH;y~@BtNmy;Ja;rs8dp|-JSqq zGu-B+V`hyd;f2NyozZh_N<#%hmgrbgOW5DrxdqUIxAS|eKd-!<_Yj}U5KEC}e2&l{ zO{^I)uHeaK7lOIL=qd=igSu`bn$M;h=X)J>WSWfCEAh_Ym;y2^^qF>?-z1LQaL{C4 zkgv%7=SC`e`#5m9CAIY+Yo{wl-qtv0DF>e4){Z;L|D#3Xll z7q|2&b$?q&wZdpGd)k~-;z(UMLWK*SylQ3AAedK0$z7WLT6rpWz^Zs}bd8DEh(vQw zODkWb$ln}@7Hu?}r9c^)6S4CM6e-d`b3V{7%o<3U2Ng|^gXv*TNGBq$b#@A55RN}i zm%Yg}+gFX!{ZsI3NscGs*Fcw9u@@q9%Mb#wZi<%sG8*W$V}(haowkn9FILh`YD7<| z5e+#ajOq*Flo^+rqV(|vU2<7BX)mFr{P@R}w-|TXJwj&*@ppuLB@h%rEROwA=nP>G z;aO*7ah@2DUJ4S;=@rZ7)?P*`6=u>*&l!Pw4P*d`@fl_#W>LjrEU#KPlm)8vh~ZJT!O#3@Lg}pmc7NRB!UWXSH6#{LB0n8FcC0A_SC~@1)qB775H5XXCa?!LmyTx( zw&#$f+OP0vR4Mk2c=Aq;SYviEm4;3Oe5zfA-#VbOo&$6q){Laae#@@6IVL?3Yr2y} ziF5So4iZKwd_f;#%N5hHjNz_JSu)+SjN8$xct4Yqe(~nx1m`Lou001|U07SQ3C?V~ ztzE&&@9Ilu96ncG>ajOpCWspO24b}wjjP`*oI)fTpe}%RZk)p>G+h3ySJzC4q9EO` zVukk}&E(>-441n>v33_utkj=g#gW?j+42fs;=8KxgTN!>?l3M$@J3v*`wW0Lohy+! zX>yatHyBR_q~gOzto9`CE{_8K({zUiVoMgO9;HL{)gv)r+vEvV+S9R6W0|fw+eFLsu$w+06*ddV3P()rFNR?syol*Kp@N zZm4gUIK7%sNKlEmzS`&@Zi!bH&92tZl&zI=t^CwHuAi?iKf&QO_~amt7e1luLw8kU z?LFybx;=i)X-wLJw;V_^@WU=Zcg`DZaA|&R9>~6OZei`*O4*uUU9B%v`8tZHt82LG zzCxjYg+GB5A|zHosL{k!XIi6#OQQ55GUu>{S`&tBY$%!=&YfPZ*UD>%C2XRL8?BVA z*(-dddV|Ih{|zG|dn7y{y>j-gL~e(Ti#FwAEL$vC_gn4o=izfkw71`UNAq!ImS#!5 z#Bd6^nfw@TxDjNazEHjGh%Tm>!G5e#q?o6B z2nLtyYX#W1|DlV)@c&%uMzCA>cpUZif>DmKMs_6+gpKXS>LutxvoR7m7|p4F1S`+K zn9jo#c>j&*gp7W0ehC%$pZ%Z{fD6$CW)uJH3e3E5N%hT3CZnmNasTg<2#6KmAuo}R z;~yAS*FWku^<^x(b6z}tbj&+E`OfLH`E=7fR}YLA>WlH}dZavWCsd;Zrg!rcFpQsf z;bH*8czhQw1~81rcj00H!+3lbE(S1+$9Dpk@f*33wc zGbi;9_j+BQPv4K~yexIZ{ZD5}C;vY4oR;Z{y6sMJ-u}MxXuh1*Jx}lEc>tnb--XM& zaPdOmU7YYjMBd+p%l|iUvG+!Ak1$6banvb+ydQn9$AykV7S1pYhiyI1$CdJ_Ns%o2 z0iEqtC%bb^rLsH6PqpkWv7>%jin&eWd0SNs1G(0GLP_e;kxIOYgI2pPf~afIVCqP1 z)|v9^>im;sC`mb8S$eFetIMVO)BU7Zgd&zzj7?RugBI7!1^g>sl{#jYOXXTq@3eUV z>QycPP3DfZv{P4N%d1bbD%d^BShg@rp)-1>SITGSS5V2kh4!krG59>xy(?!Zz%sIG z=jp+3{M^g-p7Hw1)AK8(rjA0LGz-_go3wzI=xg5wdRGrh8>zAS+4Ejl;<#plY=dZ^ zP+l&rS_l(eTA+fslGv}ms7?>1RDNO}S0r0!SE|bhEKO6^-ZNEys%#bOO#=}}YBWOy z{9&!Cp2rQ#6^>I~ttpkcn#!}#d6!YMM;$MB>=8c9u2k2`Rvr3wrTM1ggUe4+djkEl zmGi6Bh4~tSU{mGQTDia7%AH+<5t@pWf8y*p6vy?=HJV0XMM>kSLZ_qUHERmrHjNLC z98+*VqF&_7Yb(_eu|ACSAU}cI_`T>|6R-P=c?Nkd;4}+osHCH6z5KDEsQ*gdivZ{!U zC=fnVUOq>-v$R})dRa{$dqoh6qcvscShZWV9a?6xW3jQ6VN}VN&k!=zm+?Qsme*nB z5DN+{DG1kP)vBwwc-yBbUQX23l%g?c`i$M6w&LjalmU_yw=#R&>bxvppN2Hy!lFB~ z`anCyg)G%M3ZQ_5qo2NgtzI?ir zt*=!Vw6V*X7Y(Ltu9zOvvjWpddrtv(Nm^vIsy%kt|_>NL^N{3SXg>h06IJtKBoiWFlScPo;4@B0rWQk{m0Q z9#FH$5&MOjfux){4cJzyX9@jvOV*Ps^>b%|=B9O#Tb{R$sx0>~n%bMH<7#@EM*#&P zu2jlfAZ9iTg66J^Ow?2HL=0v?+}Oe{gea_$2WBt61mkEvH!}^|21{xAi7FQKJk!Rt z`q@6%O3O8;nRX4#BJwhv#|<_krd$#P?~dtyu3m7H(ek|Ybfvmbu~yHW=KdpGYo&g! z2F$Fj!XkV2Ym|J&tF%pgZ?*@Br!84{Xtm_dmWjgwp%>PMSILUn zB4mf4y@>aNDzH!YLUVnt4Zt>(`P$7rxwc^&>6nOO4yH)OY1;O4smIlZD&iTvO1(jy zc9sH^j~(5Oeoba{n^m;lwjJHJl6zLHZANzt?Znm4R;>($Z_AEu&(1O5LqV{jI~;S9 z37yn@qi|O~ND3{|#j&CZhC9-J<>*(XQ$GFk%%_@>AI7ZiGM73Y76`;RJ(o`(O%*|u uj+a;JKVgm4SI*YOc@fc&598z^{tVL}7?BU-Iwbr-rw@-F24d35zW)cx$~d3^ diff --git a/library/lafite/LAFITEBROWSE.LCOM.~2~ b/library/lafite/LAFITEBROWSE.LCOM.~2~ deleted file mode 100644 index a0587f9cb40f383d4ff005271f2126e6a6a58e75..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 52417 zcmeHweQ;dYbsu&CQ8F#S3lgGbh?ZYg5(TOPj9mZ(Ncm%Tu?y}3i(PPcArKTL8pN)& z3oHQy0IjgihnqTaosTwB94r2c$8J(5vEuAp%lsPG>Mb6P5vnu zwwX>dlKMO6-22{rZy!j@%4GV7I1=`~d+)m+=bn4+`MT%!BvWIVT&j00lTGzza$|Yx z-l_QLMErQl3TJYqR3V!wPKB*|3#oXr6i;M5$%%L|WkvcAxA#y5qbOBMC9QDeXzy6% zY;Ux`KVtPCJr+H3Y$zJGdcyO|=T>UC0^=fVDDXWH-vSY_l+UZhXUticN&#j{)?O`(`8adWKbZl@W`~wWA z|1A%|8aWaf9Xv75*Yv71=Vme<+SlF4ie6D{;A08YJ>b;cuF8V`o*?LzjUJs@_su=5lswNt-dnt>ikARErMUSX) z+dW{YMsFy>G;%CDwm8}!!{H#_mfklv3x{M*6XA zb!R{n34AoM4!UOJ#gZCj9|PB^$eTseH~@q_raNvUYrAW?s_NpPixC+eS6s{-JND3Y zZYGmU_M%gz)M)7;D}y!68Kc=$JU2bni@GO^4_RYsZR0_~WehlwjnC$%OGq0q(P0c& zr|<-n;NF(oS^`tgO`TwvHHsf22=Q~N@NRkrw6Jb9+D#QwQ}IGd&1=Dm_M?@)Y(96K zHWBVPt^U43s+cMj)A1z1FEXUid@`QN_N7jikal=iAVl8|5cC2dI4E?oTApnQwggV> zq0wBqv&v+Rho+MDURs~x#GS8CwQkO&*?pEct-lNNLT_K_;nOk))4|* z0>F(Y)w+s|SouULp2_u1=5v`+zL3q2P7r_x1}%cEE*2fMj!DHDGol#ShZj9P+tCGawM1$b!{x$6POf-gFm&J;^nPv|sl zjTzKJBpDA;y*ltrq?^|eEj)oP5(<9y*dFnI{d5FQ=q+kx*eF&CJ10ek~!Pb_*$7m@V3%STZtrnQP zcXkFq_vd7}ADZ1BPRrvR+udoi+}20ZC0?!@QBLMcnJzSH8-LEz_t^~p{37QU4*pAd zZPd0})3kh}LsshK6qYKMFSd?SzLcM$l}!6^DmODliwk6sC?m7y!!&z|KH(aOu;*v2 zBbXsIFO%`vM5>QI)%$2vb5eb3+3N*9vo+n^Wz$Wb-liRrPiRH2wTm9ntB)thxB zVr6nu*d2zjVc09v8tgaU!0JdLjLx;12klPF_NnNQvuAryLoe)I7NqaOrj=-~zKF3X z&6Nm@=naCGJ(VB3`6LO>Lf9C@5DDn1LLm=%FKY9M#9`a}!ePvY0s)=`!FGeVY*Yj` znn44!v<+z%hIStTGeG*6pj5ZTgpdWd_o}D1&L6#flpzI(j%tXG5=3Xen%KIXvtFn+ znD_1Md{;gcVDLUsmXDrmIYeb3g(8~ZNAm>~0FCXN$>&N;KcO)o z+K~YFFvS6IT?BG5eTYp0nW|-AtwQA?U_v%&fm9u%UkI1{3trkF z*X9d4WkrS|H;&e8^NUtCHCBS2!kS-Rda|~9&YEAX%&n7FmQ>50=DtB1hWmg}ff%FD);)r*i&wklVd3gMk`p6ZOgt9&UT{;O_G*Iz z=L@da87RgEAEU6Wd=ThFypw-j#xeyy5joO?daJypHp>}uB$DOc^f zSJF>yzdu&yyvrR6J6oAXtj1U_Vp5DN$^-+i-`M=_xD*RyAV&x4L8<6+=#@Wu*?yFU z8ynv&XS7rr0iqbg$U?bS#7IZ1nc4i<7}kMx6kryW(tUlUeBbO;zG#gQW0&X?!Iia6 z7T9%4nv74R`Z5p{GVyF*F$EjQZDM71|cHsOT`O7;9)CSoEpt$rlzp-6jH}g zmJl6F(F8nLO7j)Wj;zGV;&BW503#1#g7F4yH{Q%FLfqjID?GMbFIQHr+L~24x3Yer z5895KjKY~+r&^lfvrt#48NS@1W_oXDv@N}`^9*RrqEMU1p34Ze38lZi_*nMFrLcNG z#WVL}i?y(``CggE7h6ILJHI+E6FeT8SiH9JQcDk(y?|6rhy~_7l?96);hzB^Kv2*o z73fpRKEMcr#Tqq0X2Q>f)qWzAn|TBq0mjS$#0-s}uraXo=9|)8EHK~{5DCKh@lx8> ztq@>ce5kG^YLzl2sETdLNAFLlyY+)1QXBquZ2MtG{IhM1&Yh0V(0e|HHd{VW=AW*% zM!D8?XCwASruRS33v1&QemN6rl=Gpk0}WLaubkdx>4$@jh4Ru*y;%km*WG<)ABykm z+S@o)=2~X?@0C4Il(DK#b8E8B_HxGK@$J^1z8JW{8QTx@&t{Z=&fMEddBKs|=8tef zRsN!pv%z1io;lb!)6FFU--`!Y&vbC%d$W`EcfC?AmwB)WUf;r_oaw;2#*TGJ^Szk3t|gCK7<^|1z^E>gSA0Jw5!mt@zHkE{VOH`s#4z{X*d8noi2QhYS6GNU6$ zEJd-bC`=6aIFUao+Y}O_7I+v4KUM^f=~U);x|A7HpGHW5naLHW3n@EA)THVaGB6QD zrhI*1GO_;=ogQ-Se8bo`ovp?i#?E(Iv|vKbg~=#dM}}#CCG(folJndUb+aIYknm~H#nD1On?=Kekn^1v zH)}oE@2YCxsC+vGbKclAe?2gQC1Jc`UsqF^n01CT06nTR!vnx6oV8reaKD*#mDopVrFs*!mX+=bz+)yG5uDKg;2nMI!B%f+C=1#*a+yGPmbj# z0T2%S3SnW12~IBxTKQyN0`Y-jwgeRsi93*AxEOS!25B%CHz7m>J6>3P8zN+U4MUGR zWQ7j{A)?6WnOy#O#VResWKT+XvCWb+td zkj_Xel-9#Mi)s=#4?AzC%A5DR*s`)f8k2n@jeaXL9*ZaHw@q|lYQYF#zy)kagy!0S z1aT6(q!1bCL14A(A7sec#r%%dajHTm=(fVx}f*f@6K9GY}9!5;+Rv*z2 zXq^0jc56664P?LxP&VFngHyanjEW<#7Y%abd`_?l1Anxrt5hqO@43G99#bz-!x+_8 zEHsrh1elbY%9>!PtZ;7GI#*d+nu3ol(jethw~j5@E<_wXkhe*n2;LL)8gwW8T7eOtNQA&G z7&sk@j+m4OIzBfjqSzR{JSOzV5T9hMQ7mpE?D66#%uUDP^cMxm{~+{%;2a;t&K|fTbX5Y>* zy;z#cM8JS6a;W%nTjGmAzH8=jBM{0RCYM+b50^{4hl^*mP|q$+K)Br{C$j4|c82h; zeFRS8f(A(sTbw($Qm<(Kmlz&s6_hvHDs#y{87Ci2>;^yizyrv}OonHd&s)_w@JMrY z7#hkK;Ji6sKVOEM=6ZE*9d4fF%eML;b`oZ~Yx6KhEH7~d?N}~@R=9+6$VbK2oRyt> zvbJ8)pIJ}WmdeXdf3OB)#v|7H>IG}=skxeb4XpwAu|j1X3B-`q=PoRtUnk$u^KhO! zdja+i>1K3jxZP)P5o+7tWU^LSXN!q|S52*!Dp2tr?sEixA+5-~pl zeI(Bi7PfoE#@7%}P-a^i2?n41lUer6<9HrXjc0nP|kh3DJ&Z^H8Q z&jvo15qtZUJ)eq8;{Dv<_KO=|g*;AzG&FNC9fP%T>nEWo#2h&aPO`#jJ00*3d0G#H zt=rjcv2UtU&`s$lW;0Ngvq58KGI0N!5Mv=I(W zcZU(qrPYP65_>~o&LfbvjQu#`-u1~HQtf1Fsr9kf63OF!=}=YB3bcoXz2DU^>lqD= z5b2N52@&jlbU)?V+6s0Lwb_KBIdxP-E6Zy&+OT;0Bcj^}>ZUnCA9mD1VDi2f37&ZN=9X z$|oaxtt%`EVgqFqpS`+Y(k^$5zw(%5NWy~rTnSISoS6{waR_$he2AA({iw4{9{s|Plka%>uNc5$^}ha9i1+m2-TFgn=jE&KmDkCu@8dHmSU6*ulaPZ*eoe!T zgDLm`IC9a&s(0dN>|8Ly<{Rz&P9DS^;|(&md!dqb&E5rApBRB?iX}*{D9Z9fuF=}z zfRv@kWup>g&f^&<>PL9Vf*6xi6RkI)8Fc1Fwi;kG3EIX^F$n42cpU(TBWsOh{4vsd zvSW+qs>tiJDxNip!Q><+F<&s4%@D8Ya{czds0VkRYe?A; zUKe+^+Rbus&!Jwz|1IA)4RcAc2$O7a7KUGJ1kyaT`Q%jOQwTgExW-Hpwi-+roj+nt z4H!xSvwAxT(*`X#w__Kai^N?WYt8mYVnw(@EXSY$B(W+dzcG}z zs~J|d05}*&EfA1t=$_P(rX1veNC3wHPB6jc{ecdBu|42Yx3U1-Su6AOZ0$XfF4S9# za+dFij{`j!K5W{i?Ijo$D1(7&z6j)*J;oqR3ifSmw#6U(G>S1qa{q-bgbtnv9smNc zh8l-X?rjaUv=(7%!G~rl6 z&q9J%9K^y)K?@#TFk8vCweV7leitLhDh6^Sud%9AK%WzlS_z4mekrgkxXog%?Sv@=r=VDO=diifmi!1aqhHS41)(9N!08*4zS@+vXUpU8|id1SHY`t zl%0ubUAWvo+>QpIExY3c`CsCY^72xpk6A9}IbA0>-tMB%PI>Au5_Tu;HI9RCKqBp( z57tqDpk@blmA!4v=VzE&iOz*ABfn7H$DVY5K65vlNdC)A7b8|DxIxCX2cMVUDzB`D zu!t{IAN$VuOc&4K*T(sS?IEuD1Lc{nu3)1)4)cm+oaun&qyzSq(=&I^bk7{9iIMt= z@}*d4M%g$v|1GJ1#NqZzo2vNPi*G*J$f(4ilX#*5Jz1^Gb^0m z$1k!7xjk;@QqRl*e%tw-nFFnx`}uk1z`^J8`}nh;&5Lh+Hk9K&Z&q`vn~!bYC)ytA z{RCHc$_3V5f#PFZ_wQB`-M&K#J^sb49?MrRzWK;ZcWz=E(BzpT7IKKZ;$@$NUy`3Q z{SbUfbP0$-W7!PYt=#cGxTWh=Gzbw%7h#vz)JYsyqe5z#4Pu*vn!?{v0Ok=t`~D!7 z5jZw@&ExQ&v3~sippnC1<{7w+WbM*udfoOJW6g149Ig9o?B-1`+|Utcx@q zeE?;FQi&ax^s!Dl_l0fKi2~p|NQnEp^$994zai2|IUo>Z52B^M-Xn1I^V!2ewg&;y zL_RqSl0RUP5sO5FL2TlZ2+D0IV#Bu&X3*i0UeZ*-aV6@PJOGJb!^V5o8zw58iG|7x z`~%Bk_A?ZDF0U98JC2o7ILkSJtw+|Kvy*_c0xRolqZ)upz&``rxl;o)2QJAe>Nb!? zVT5BiMA43hLljaDI*HR%F!#Bb9Xd~9)J>-x$t-1`7ZisoQXuNO44Bg?9g@r*P028Y z6yQVyaWux!UD4|=2?l%t2W%-@>1rj^TMc)=3?M2mYPv)3I=fj z`*>?&>*K-;UODu2b@b-S-pvW|mEbK~j<)e&W#cv!D@}RKVLD}NA=&I>P7-g;d^Deg zrb22mk2CHO!?l2IB$~QIz9ny(hy`*b50J0r0n1(m76JdUqe*G1Ua<9-Sl#PoA%@*U0?)@yhBN6y9srIjF>! zV3a*u!Q)bG<$Rr^@4%?L3=<`y@jyNg)2SV8{X1JBJFM6};V?u;F~f1ITzitOn(Mk| zYxzm7k+i*K-zHzI*1ne@b`+HhYCfAe=T1vRaLN z*_9i&%-t?BG}t$9Rp2`f(&7s~_z$zA_S;4aTY`qJ@+7Mgz#ou24RQrGbsEP+$Fj!( zydy0Tk0g8t)046&6W*^R4vjvaZ%myi6d8ZSr;s^mlU6eRU^&VVTn^#bjG7RLHbr0E zgKKZUDUkHe_|~-!9xwp8K>TJI#{jKcXdv4DE;JCXi3Ta!MfU)i-gc3Hn>az?NjLxl zhr`JxGn4S-hoPAc!()rGiN}w(Lct`b))^tHMgHmB7fgF_;!?69i$^P-sx>7ZXZVv- zA|{V7zNVIA=(|!^db}$3wrWVwZSy}hilu4(7-WgugVd-^G>Wi?zlS(sN3zd~f+Hm* zh**1IQA41tV(HOLF@s2O`phCu*Zbfi&^DgU=4aIDkUl<2!b(4%!r0TAwTru8Gq` z5GF0PPGJ~e8vRm$!a4E2C2LV{a91>Wh63o9Bxci>)M9*CxJB9eeluO*54YdLm6X51 zKcWNLxN)MqxxZZ7`NlwK``w&z0@g%0=erZrNGz1Mx?Cj-NMzHa(>ba7W3;PE7d%X; zPwvT{azTo(X;2*E<9|_&n-Q;4yU)}wTiNRn+W>D zQxOO*+2g!1dU3Q_Lm&LR*dNVq-PO`YKKJ3rwXD z2Ys*>;!QJ_gXp;pqA;}b#>kP^=;WB;YvD0`-a3d`f@}}*9GzTaT1r+Q;&hwXcus5% zUS^9dwEcL2+yhrZlfd8H)&o(K8u5fA!pheiJB&dzaNS`+k6pHEfYPTjb49AngciKN z;ZW}_u5Dghv&f0BpCUFgY1|eidX>pC3*k&GNp#ujkP}jk_@au#>FBFPMajfY8GD$G z;L}8qsFmJDt1OX>K0{$6>D*~1rM7Y3P9kRkCpxE{?ChT$Oha=~dZ6~$AgK*n55bg# z6LBER5~S`SQX2Lu28@yr_=$NkGc960q-y2RPyKkcm2DK&3Hli6J#;8I@5vit+t<2q zR>t51Ib5bRE!SIjKHH$AjnR7B&X?2qj>T8=`|@2ZDQ*m+z->EU zrUJRe*L3Q=^*uY!AqgcrelAL}Gd)Z|*$VZ>hxGX0h{zm>)76!S~8kwxRk2ZmF(O5i9ElcfA%NGNGAiZ3qTBfO! zL4;p<>z&;6b~1P|@bQIrE5 z=$|Ygr~}O%!{K5eiiz9o$HeAC{1G5dGsvL080bR8Ec)uF7ru>&l}}pUL{ocqHj`)p zxtH#d8J2=vy(;%dIjZ!V=#kT2%kSkoIJ>cMv1J=LvH4-?@TK?WbVJkwRmEq}>EEGd z?3AC**%fT8HFPwo&Rt5NO{>}}|dd+vtFGT1b%Av*s|pWtw_G5tdjHpnlLLS?C4^*$UF zq`O=pa21$tK%e6rIwZVRS6X7%#c# z*{>%pm}a4NWVbPKQ)1+8))T>#&qsYkM`M~i%XVWZBdTg{Ogoan@&U(yQXz{7V5GPd zSM6cj<&UC@4HNJRbX&nN>?C&QbrnY-qv{Wj!2BphDaKB7QNTrI+wn1|g&_#Bx{4w8 zwNv<^+Zdwb7u3rko^DU>AdnKw9s~)ON_zm#=MMJz=)Nmx2W6d zN=G-1dMNmf@fv}9f|48D4yEJ<+5`cLCfAfmDg~R%q)=?en|ll%W3tN!(?>RNA+^IL zJJpjE@UO79*be7n?z`O8`Rrch2L5<3aAw~m0&P*8tyj;z`RbXFFpo+cS z=Q20IqsX?_k>B_Fjo-+3U<>;~c5APSELjz|Okz*Fz-RR2yTEqdlkX7T_|(MCrLSc- z?^T62-Yfjm_p@6s>ZE^NJKczlKPEf##W(*Ub~B+znH&g62?6&IE&(TPptxZYz#e5V zYjOrhCbE|;$1g!}KF@bJ0MJCSB22NG%5uv#9fM)Up4XEU2i3i-;XKf^QX$Qd;nDs~ zBRljs{s`qlXP@cD&IAuSd%SwWA^#PR-v{wlS$84ENI+UsMg}7M85^!drLZ^7K-SjZ z&al|2)ceDvXDfGim%8WgU}h#w_f@!)B=`v{gHLt-tLO0!C9qFp>d zBC~W5DhidF2$M{7urZ_&2og~@u>(<@py^yOmCC7CEq78;@)GjL5a{_d9R*p^DoY$8 z7d;IUrpSif)F)6G+A)b);r76YIYfdYxG06@EtG&D-Qm)O72KHt3p8xlxUOY&4q+=+ zVYyyie3%Z-A|?@?c%3`Dyt)pZVAEnVkk%oIvM7mI4Z*h}sLt|*W3S26<<3{tL+E?u zh3j8g45`-+gg{Q0GuMA96Kdg0ExNDvDJIDA)2A*UY%#j5 z`>E(`;JdG>p1HOoxQ!a!Z0ZW8%FQ|Ju7FcS)UnK15)2YuCPa*WvBXQCxQF`=v(43` z2q9|VRfKRzYDW=50jNzy2u2leZEINLO^djs)9)f8_#(U5H`yUuhJ9V>0ZL8n+`?Q@oAYjX!VcVU?#> z7{Fd5!^CQ1u1Kl3ngoo$hjESm0OK-rHow7R{G@lJe}D;PcGxqa_DDfzg#UxAY0oU7 zfMUHg1Wa~bj~<`8kXzX5`+(%k8WWZ~Q%4K$A7d+PQ#+Q5*nQa!)6+R{TO$6QZ%<}# zYz}9}Z+tzjR%G|6o#IQy7_Zj+Tiy3j&(uY&wJE426zg8gJN+j5peJ96EVxy5W|mG-z)L%Fja) z-WpF_fA(U_FAEH=?1eHs5r5(N@yw0QkJ`}N*&LVrSYq*24LDx%+v)@!f={ccrkA1M zff_HK7B_H52ROcX?bOC^+i>66`hcoaFz|ABTxsXFTNi06zy>lqM;7Ww;X>>Q`AZSL zN$6v}N1{2OrpCSDkx*xX6+(ycYDXKPY4jXYaP2Q}oi#p#Ro{4nvA}qPjOe_nMc~s@ z+ZcVz35(K%CDgQFu3CvSU;4nfP-X@-YZZT;JrS8q;dUuFBQmJa1JGc5RU(prPw)I; z{R5*E_b{#|nR}Sd(B`pQ7tg(U?fH%WiXO6d0zCv#xoHnQ;yZVY?rCZ!`cV3N_Xcbi zj`;wz895G9EG&2tYZl=_d@8l+LTpAhAG1qT={eg7u#%H5yxo+7LTv}cuzO^W9twkBHp; z6JYotU23h$5Y*dly~hw%bz-78Tg1IbaEyUxjKn~rGfm*&u~H@MC7m#WB2oo|gD9pR z2RN#OS&m|giTePARSMr?D2<~yiXkf6C{E7rS_(A?VNo7>B=&l0ilD1avMH%@ZM7~U zgxQ*#SqsND?6;E^l=A8_Du^vjdLNu-*V()1YKK4x?CP{yXbAB$pc0ryIM_@oIhH}V zUT74cb2oQt3Hz)m-H?4;ok-#!+cb3EAX^OVH?&AI0jD2>9mk}g|8$qzAV{rG-{dDBYbxbd1M%W2Q{^V!#d&Lj9#^|XYeaEQ2m3uKm_v6; z1gbS$4mzG1r8wnk#1SY}d5mtwD^%ddzJS8U8=5lSZmtv=!nPDvfotJC5Vm@I@n-;1 zL3nI+`5Xnb9l#E!iVTnng_6L5@-JpEe4nECELC|BRa1O25C9|K)WEx+()EGeu{VO2 z%V1&J5~A2sdWd~5gNq*pwF6`SNkwQj4>VNnUC$?YE5CBbMn#dFtjap@e8NS0q~MDt z?NhWzRiS9l`_=2-js2>oyLBUXo)V)a6oR8Q+!gYRDy$fgoh~Me*3biFj-zj;UZixdF27<1h)0a)KmQ1D=VMR$-czSdi zf$b5nL@t#g7eb^Dleafi&v=A4Jf2ep;NDNQ?r8~>)KUjEDs6|SH%}A;HTdBOT#Lc^ zJ#yXa;tS8GiyM8MJm1lnkpR1w-#>q6W8*)R1Fr{{f-U2Vub#U8o7MUt&roCguf`E) zy0~$7IRG;EoH{H2Gvc_@2)1tjCF>8cL{SUPl2nlEJHL&X?@Tn&b~X;Pa*-7aMT zaI9BzY4V{yh3|Aa%{fGN>&a0!@RG19iwF?YXZ7%iUCkH1d|?^-2%z@k7){I6R__U> z--WC1FEY&JV2wl#kgUa*z(j*-uI`ZV?~M}%y@z+q=)GH40#i9gC$7;31a3Y`?W>8i zT!IpG7|U-|DS#0cG+fH7KbUsMScFrRK`rr0$UK^S<*=Sm4t$+6SMwo|yB zN=#Yxy|MBaWP20m^v?U*c#~sD@t^U{e<1Sr#MSpVvYgaV2mVEiEx8Osg!>>wf;HV8 zunGE5F9_*Co^}aUz6Up1r(k>R_?T9(zykHV;BmdA51(XwVExOs5Gr*-mKDJ$`DtNicxadRa_JXj;0xp3fE+2o>u6&A@8%pfDyb0=jFy zq8jrRmVFlzMBM6eC}$_*C-rT+h&aZNaNY3+wIZ&N*eYd6rEK^nnN5MR84a7AVszp) zt8GJwI2bR?8v0p9v~04Cnqj!&Bcvt~L!|xtFr%&Yy^0-vU+3x_GG~l&&&7maZ!D;X z1Y=HOfw4iQsZYByplO0`fyZzBa=mq9f4w|;*6fRX!k_d9gW;4s%o>wZE~vRyYiuWkb49svEHBWxc)Un>^pk> zD+`~1g@&s2)mrbxM}{G3w#d+%d6 zJ~uw`vZ_NR-Yu`{d#wYJM59TS-`13&s@bpG!o8CZO4|6<{c4m~tkc2Z_}z^J6TGb2 zHT00-{QS*ETvT)BhQbu&8}XQY#p*6vutQirkYrd2WD73^))0p%uW6CI>fDQQ5H2au zL^$#82C?-B%QMJZI59tiw5XX4;_Jr9*TIe8>gE`P+u&1&PHh7eFs(S1K)94?y5odn z5*pd6vE8a;A30i$ePb!yvP?pR5@-1U6!k4C-kw-RT4NL?<%Bt;D8w%5eiU{LR~8-b z%9YX-dT=zKgtsdkQ;(DI6zM&J7evYcDI~T6(Hy~OxY$8gMJTH0fITIk-?Aewl4(wy zMxd$o%9y0}5sK3%0kAL<5{M|`73j$jG)3AXI>hJRwahmJ;OHE>o68Xx2O;(1Yy<^l z8+3>0A4E3|+BHc1am<8+F164A2)B>cX27L0r-+Y64Wy_sU!kq=tHR~rLcW(y-${XE zyy4z375Q@K!{pJEMyK(6(x2K;=ZZ~%!%opEX7G@8Z zwa3F)If&h0JqA+%b}ub@`?+jtPD95>0CVa9l4SAYbSOs=op8MT4fS}4$t!VDaB0!5 zcq(A)<$c%edu_i*QhfUQSJI(H;^?8;@;ZnTvYEV*_nelQU z5167=5=+~5oWg|Aqll#2-eL+q6-fzXX z3yEJDPuzGW@j`O*!x|LdwnOczlzlH}$6t9F!GN>lnU@z|eT9#}F7TEkF{&Hm8Mg3! zt{Q^1{+sdVH-39UOnouA@su2xKqmIXdyoRZ zDI;-P6E}|!ggFnEJNlnn4Q3WpILe3YaO6M{VVf_5gkZX7H7&jg@cer59g2(M5pGRt zqE3M&zkX@|IJk1X0yD2)-|9{;=%jk^d#^5JUVD{yb0rTJIf#ZCIzTojPe4!-$(q%Y zzGD;b7`o3`J}_^na`0^ute{#`S2SPPz4)5KnS0;>LuUW+>(5Mt(qe`+_!1n-`m^t3 zx8F5c?LPgjjaMfReS6~%;l`xB1ArwCt#$Lsw^&S|-0Z!N00%z3cNQg)!X!yxy1(jI zIq+zg2D(x@BLPO?87#wK#20>w9UHz!Mk@5TnMq=l#%6;&mtzc(NDP&I-rs_K_;9<7 z%?In8%@_3EL_r$oeGbXL902`}r`3@*lQ$%6Viv+X4BlkTGZE-L%rbga85^s;IF9Fy zBN@ixpsU{;1bT{nEq}iS|DKI+s5qcklxHx@8O}WqD*Ctxvz8Ey;Jfo%3Hc?5 zW!mX76sR?`j}&t*A@9l|7R0nzs6xA64v64!WrUm&KLb~vtve+pt&Vh)c~YRuodY+g z0uwOY>8g6e6&gdMNOQ)x!6F)Oe7;5l2#mjx1=W+|#EhjwGo^i)4d68alBU_!2Lmew zBON%7dzMRDNn!`#x~E2c^(d113WYC(z$nML;9ITCfi>e%wbGhEr40*Orx<*OJ0c1jL*K;v_CY!5!@2XXI z9T)mS$ikJ7;PbF(3UQ8gFYWE#q1U+8&C~ZBKYu9RGoM^ah zm?j}(igQxK?)?5W9`E;GuJW(%a4DRqcM=H%T1r$d?PN+)x8~UXf6ZC$J=_0$mJ0~7 zZxaizp@2X|_FUhJYaGPjTX|>;Wrf3s7Mfsi?r*PE#l)UyXMP{66-t@J1n&O9q!Y&a z008Ko$w8Gv5oFA1c1=1TcCyFNCzlEF0GayA+OUV#yfab6aK-i#$qBUBs%#1ma91PE zgWLH{^}BUMM(I#dMYX);I%2W_-ra(K7%rS12od#;$zCoVx{qFC1GhH~_Wjd`VsLWB z*iQgEdo!lXj-7o6c5$PeONux4Acl|Nj_#12{ALJ!7z0oc!l*;Cm$-IjB=@T=CZ>rw z6ED`^5r;#lEZc*vy~CV0?R@ALR2iD$dfdHTNZ=g|j_UHkk6RBXXHGcOkeBQ()8sR6 z$94n>9j{zQV#3|=cw%wcdL%YTh(#UJzi_-WZ#a1DNq#b=!IawoQHQNutN;PT=EluQ z$IKc_!V8UEI-}><+u9quWrtwkVo=T3Uq? z1rXMezB5nQ6qXvjcCXb zVN_oT8_l@X6zq@h`I0-oNwoI^kR@`PLCK!xA!wrsc4N(@S&5Ri6P=pNRUkbU=INU4#sxI!Zsn1lx8UYua3#4 zjl4$CAqp_nJnQffYf8jaV~-JdDaMILD0OQBFib#QT|;6KB??pV6DOK7a1$!!TRjh1kKpcDW&*>w0Cg-^v>lKn z)qaIzq)M?b){}Sg=Nh$(sWfyN;8X1?{MK=q^&Ft{Fm zem7`3i70CkVFb8#I$q2cmpJ-TK>6b0!%6>_}i zcs8GiXSv)>inY6NLT&`MmRBmPd>8PV#t#CIL@lK!_tICOGwv6%JU7zlv8X_BYC?6d ze50xBOj-**ms?Pqgh{YQg5aWlbWa5)=DD+jdh#2G>O(m$rbEopiy6a@b9Edx4So(Y zCg=?#p+XiAH$SM!*$>3$b_0z<+-UBL+jL@z(1BI=`TQpTa`okXq@1Hng@gDIkTF8_ zAi*2GM`~{>CNhBpPvNiJ34TY+sN4QWyQmF!G#Dg!1Gm_H2Edz+r^uW%dE4U~j3*0H z@xU>wJ%uaKV}Sn@T?K*=l_jdj>Y2hkWRDRk%EmL3`T}Q4gNNQID1!Usu5)U)>A+XJ z=d_o3(u=3trx{sbKpS`H5nLXPeR z!q`9McxUOQ)9g%&Ug66ra@Hg&QDl_=0XuNGU3LmTuHDbLLtyb31!)K_H!(_ZD{^@( zf{>;y!%w*@rOcJ(R$-e`C0FYbATV@8Er%Cx*bgMRR6n}BEtcp6=?Ccvpz4QSQ%Tlt zvCAul(a4)G$-?|#Z+^sT5Boq_?^`RYwWakniw+7{bGR$Kc>e4{Wq!TSvI>=Q1=oh- ze)p%Vl_hI3Gnt}00P4$geCPYJRj$m{ah2|R)rkD>#ACqi=F4RSX;|wEw-csVJz%Pm zAJxl>x-@`v2^G702ff%ICVs|RTR;EglZ^LR!f?Pu+Kfgi0tPcZLZRu=y~UtabDK1{ zR%f9(n<6Hgc205$v9F=*@1w3uhU?17$dH{bWQ(H6(zWnXR%S72sF)(iQ!QvFhC6St z@YE@zziRs+j!_sxsoLhPoD5a3`hehI=b=hxggzD6J@$NTr}Ium)zRJdCUf9Z85RdY z&{LI4btdySui0u41iL>XnbrEv;L%r6)Pq2%n?G`gl^;hwiGz+QXTpwH2%? zr!i>@zJu6VfFE{&^=ifB=F4;Ib3pdh^YiQHS1Z=s+S>AbjW6fmb+=wcgK`bWDugLn zD*{4|CZ<-_8X;T~-5pVDhr`thJ!Bh9eg5p)a=o&S$jT;%WP^N|9prGFRe$67vZr!N1Rni6{unZT!t;!i+mBrnCf%h{m&9)gMkUS)@4*;qOri;cyz$yh8o4yD;xEEXG2renD=q@Ay&T#Z_EU*3%kUjt6IuCQ_ z{Wq!;viiaKB^=^^_Jd9U62+201N^fqF!RPF)i*DdilvVy{J%>fu2^E1yksVUe_+^M z|ESy4m(kqrd5OgFQSb2NJEza)(=GE{JuqIVFUG6uk@CEqP>m9p-pNzIFn->FivbMd z@g2Arz%U-)fr|kQverTeLt@Aa?}y`Kb<9={QJyvTBaxJwmZdn`}@wL`EpwKJiU|W0f>5i2QKfx#S4LV zaKZ}_d4C5k|KGsH-W$C=!W?wDRG&KFopr9V zwl?=v1=>|kSC%eV8kyXDy z4}Rn4UbctFmRFyiTP-(r6ndx`xGvtJ1++w8`!>+Cc39d-k1nrV@WK*jS(9WNMFYjk zQhCinwC(ad6~xWXe*HytdMGd+&EckLiw#Tw4&c-to?QNT#VRc~4MZHt(F_&vhqbDD z4i{BdIox-xu5|5cDp#N^ub^g+9$&61Bz%}zt*uwAWhm;E%AC$tEwP&r4~w7i7>5&nG{_7SnY zzy?Fs%zAAN7nu7r#p{XMnp8vvO`o$H)b=0Up0dD_%9jSKTAh>i>(h{?Tv&DI)*gOf zF9p~vFLO9g!5LmSgk0AA^3wWTZHewuudT~6R8;NeT@#Ys_qKZWz+STUdU`}_%&$|q z<@MUUHkCPZqd}F+molSzW?)!p4;OJSr$r{O+LJXbl5%Yo)~{tyJ!+INVs42jAX(nX zVs;*>3PEWquLB#x?e|U|kr8QLcg>uPjT$ zxIy4NmOV|%+9ROIj9BZ{<+X}@zeHhGvGP|z0)SPrP70N!IT!+M`=Prp@Vsmn^&;4rm1U%e2v+C4)|B{QYIbOvWc3ZrSF%kgsg zVKt3>`+<-&kdOV>ID4-zR zl}dRZ#LVVE)ZBHEfqOEMjKheC+i%#95`{JLz-Y!7iX1QGr>8*QU}t5w19Y0`M0p=j*`C z`Wo!HD=U?`RST$t_APFoiLaOZdTiP@0lw8XAnwLw=AqS+Ux9xG+j51!;Z?G#wh7rK zXhY&Xp$6>Jz0j-~=l!qZxv75H_UFvbQp^A7$uTpPPr=6t$ zg7uD6V0rpg>6B0ZJoBk$lafite>sources>lafitebrowse;15" 80228 - - changes to%: (VARS LAFITESUBBROWSEMENUITEMS) - - previous date%: "21-Jun-89 12:11:09" "{pooh/n}lafite>sources>lafitebrowse;14") - - -(* " -Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITEBROWSECOMS) - -(RPAQQ LAFITEBROWSECOMS ((COMS (* ; "BROWSE") (FNS \LAFITE.BROWSE \LAFITE.SUBBROWSE \LAFITE.BROWSE.PROC \LAFITE.BROWSE.FORGET LAFITE.BROWSE.FOLDER \LAFITE.PREPARE.BROWSER \LAFITE.MAYBE.OPEN.FOLDER LAB.LOADFOLDER LAB.DISPLAYFOLDER LAB.MAKE.INITIAL.SELECTION LAB.CREATEWINDOW LAB.TITLE.STRING LAB.COMMANDFN LAB.DO.COMMAND LAB.ASSURE.SELECTIONS) (FNS BUILD.LAFITE.LAYOUTS \LAFITE.LAYOUT.FROM.WINDOW \LAFITE.MAKE.DUMMY.WINDOWS) (VARS LAFITE.DUMMY.SHADE LAFITE.DUMMY.HALF.SHADE) (INITVARS (\LAFITE.LAST.FOLDER.NAME)) (GLOBALVARS \LAFITE.LAST.FOLDER.NAME)) (COMS (* ; "Browser operations") (FNS LAB.SETUP LAB.BUTTONEVENTFN LAB.DO.UNLESS.BUSY LOADMAILFOLDER LAFITE.OBTAIN.FOLDER \LAFITE.FIND.EXISTING.FOLDER \LAFITE.CONFLICTING.OLD.FOLDER LAB.REPAINTFN LAB.SCROLLFN LAB.RESHAPEFN LAB.CLOSEFN LAB.SHRINKFN LAB.CLOSE/SHRINK LAB.EXPANDFN LAFITEEXTRABROWSERCOMMANDFN)) (COMS (* ; "Browser selection") (FNS LAB.SELECTMESSAGE LAB.CHANGEMARK LA.READ.NEW.MARK YPOS.TO.MESSAGE# MESSAGE#.TO.YPOS) (FNS LA.CONSIDERRANGE LA.DECONSIDERRANGE LA.RECONSIDERRANGE LA.SELECTRANGE LA.DESELECTRANGE LAB.FIND.SELECTED.MSG LAB.REV.FIND.SELECTED.MSG LA.UNDOSELECTION LA.VERIFY.SELECTION) (FNS LAB.COPYBUTTONEVENTFN LAB.SHOW.COPY.SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*))) (CL:PROCLAIM (QUOTE (GLOBAL LASTMOUSEBUTTONS)))))) (COMS (* ; "Browser display") (FNS LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM LAB.PRINT.TO.PROMPTWINDOW LAB.PAGEFULLFN \LAFITE.MAYBE.CLEAR.PROMPT) (PROP ARGNAMES LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM) (FNS PRINTMESSAGESUMMARY FIRSTVISIBLEMESSAGE LASTVISIBLEMESSAGE LAB.DISPLAYLINES LAB.EXPOSEMESSAGE LAB.SELECTED.MESSAGES UNSELECTALLMESSAGES SELECTMESSAGE LAB.GO.TO.MESSAGE MARKMESSAGE LAB.MARKS.CHANGED LA.SHOW.MARK LA.INVERT.MARK.BOX LA.BLT.MARK.BOX LA.SHOW.DELETION LA.SHOW.SELECTION SEENMESSAGE DELETEMESSAGE UNDELETEMESSAGE LAB.SET.EXPUNGEABILITY)) (COMS (* ; "ICON stuff") (FILES ICONW) (FNS LAB.ICONFN LAB.ICON.BUTTONEVENTFN) (VARS LAFITE.FOLDER.ICON)) (COMS (INITVARS (LAFITEFROMFRACTION 0.3) (LAFITEMINFROMCHARS 15) (LAFITEVERIFYFLG T) (LAFITEDELETEDLINEHEIGHT 1) (LAFITE.BROWSER.ICON.PREFERENCE)) (VARS LAFITEBROWSERMENUITEMS LAFITESUBBROWSEMENUITEMS LAFITEBROWSERICONMENUITEMS) (INITVARS (LAFITESUBBROWSEMENU) (LAFITEBROWSERICONMENU) (LAFITEEXTRAMENU)) (GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) (ADDVARS (LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) (LAFITEEXTRAMENUITEMS ("Describe Folder" (QUOTE \LAFITE.DESCRIBE.FOLDER) "Display some relevant info about this folder" (SUBITEMS ("Inspect Folder" (QUOTE INSPECT) "Inspect the MAILFOLDER data structure associated with this browser"))))) (VARS (BROWSERMARKXPOSITION 8)) (BITMAPS LA.SELECTION.BITMAP)) (COMS (* ; "Obsolete") (INITVARS (LAFITEBROWSERREGION (CREATEREGION 30 30 575 210)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * TOCSTATES) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL \CURRENTDISPLAYLINE)))) (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT))))) - - - -(* ; "BROWSE") - -(DEFINEQ - -(\LAFITE.BROWSE -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 17-Sep-87 19:13 by bvm:") (* ;;; "Function called by the Browse button on main Lafite window.") (LET ((SUBP (EQ BUTTON (QUOTE MIDDLE)))) (* ; "Pass the :confirm option to LAFITE.BROWSE.FOLDER to require confirmation on folder creation.") (\LAFITE.PROCESS (BQUOTE ((\, (COND (SUBP (FUNCTION \LAFITE.SUBBROWSE)) (T (FUNCTION \LAFITE.BROWSE.PROC)))) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) (\,@ (AND (NOT SUBP) (QUOTE (NIL (QUOTE (:CONFIRM)))))))) (QUOTE LAFITEBROWSE)))) -) - -(\LAFITE.SUBBROWSE -(LAMBDA (ITEM MENU) (* ; "Edited 3-Sep-87 18:00 by bvm:") (PROG ((COMMAND (MENU (.LAFITEMENU. LAFITESUBBROWSEMENU LAFITESUBBROWSEMENUITEMS "Browse subcommands")))) (COND (COMMAND (CL:FUNCALL COMMAND ITEM MENU))))) -) - -(\LAFITE.BROWSE.PROC -(LAMBDA (ITEM MENU FOLDERNAME OPTIONS) (* ; "Edited 10-Sep-87 15:19 by bvm:") (LET (MAILFOLDER) (COND ((NULL (OR FOLDERNAME (SETQ FOLDERNAME (\LAFITE.PROMPTFORFOLDER)))) (* ; "From BROWSE command, user aborted by not giving a file name") NIL) ((LISTP FOLDERNAME) (* ; "From LAFITE. Each element is (foldername browserregion displayregion iconposition . options)") (for ITEM in FOLDERNAME do (LAFITE.BROWSE.FOLDER (CAR FOLDERNAME) (CDR FOLDERNAME) (APPEND (CDDDDR FOLDERNAME) OPTIONS) ITEM MENU))) (T (LAFITE.BROWSE.FOLDER FOLDERNAME NIL OPTIONS ITEM MENU))))) -) - -(\LAFITE.BROWSE.FORGET -(LAMBDA (ITEM MENU) (* ; "Edited 18-Jul-88 11:41 by bvm") (LET ((FOLDERNAME (PROMPTFORFILENAME NIL \LAFITE.LAST.FOLDER.NAME))) (COND (FOLDERNAME (SETQ \LAFITE.LAST.FOLDER.NAME FOLDERNAME) (* ; "Save name as typed now in case it fails. Guy who gets the actual folder will set canonical name here.") (\LAFITE.BROWSE.PROC ITEM MENU FOLDERNAME (QUOTE (:FORGET :CONFIRM))))))) -) - -(LAFITE.BROWSE.FOLDER -(LAMBDA (FOLDERNAME LAYOUT OPTIONS ITEM MENU) (* ; "Edited 3-May-89 19:04 by bvm") (* ;; "Browse folder named FOLDERNAME. LAYOUT is a triple (browserregion iconposition displayregion). OPTIONS may include :SHRINK, meaning to shrink folder when finished, and :CONFIRM, meaning require confirmation before creating an empty folder. ITEM, if specified, is a menu item in MENU to shade while the browser is being prepared.") (LET ((FOLDER (RESETLST (AND ITEM (LA.RESETSHADE ITEM MENU)) (\LAFITE.PREPARE.BROWSER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) OPTIONS LAYOUT)))) (COND (FOLDER (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (if (NULL (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) then (* ; "Got a browser, but haven't loaded anything into it yet") (COND ((EQMEMB :ACTIVE OPTIONS) (replace (MAILFOLDER FOLDERGETSMAIL) of FOLDER with T))) (LAB.LOADFOLDER FOLDER) (COND ((EQMEMB :GETMAIL OPTIONS) (LAB.DO.COMMAND (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (FUNCTION \LAFITE.GETMAIL))) ((EQMEMB :SHRINK OPTIONS) (SHRINKW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)))))) FOLDER)))) -) - -(\LAFITE.PREPARE.BROWSER -(LAMBDA (FOLDERNAME OPTIONS LAYOUT) (* ; "Edited 7-Sep-88 12:18 by bvm") (* ;; "Get a browser on FOLDERNAME. If there already is one, we just top it, otherwise we create a new one. Returns the folder object or NIL on failure. OPTIONS are the options to browse. LAYOUT is where to put the browser if we have to create it.") (SETQ OPTIONS (CONS :BROWSE (MKLIST OPTIONS))) (WITH.MONITOR \LAFITE.BROWSELOCK (LET ((MAILFOLDER (LAFITE.OBTAIN.FOLDER FOLDERNAME (QUOTE INPUT) NIL OPTIONS)) BROWSERWINDOW STREAM) (AND MAILFOLDER (COND ((SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (* ; "Already have browser") (COND ((OPENWP BROWSERWINDOW) (TOTOPW BROWSERWINDOW)) ((NOT (FMEMB :SHRINK OPTIONS)) (* ; "Make sure the EXPANDFN runs") (EXPANDW BROWSERWINDOW))) T) ((COND ((SETQ STREAM (fetch (MAILFOLDER FOLDERSTREAM) of MAILFOLDER)) (* ; "Already have folder open, e.g., from MOVETO, but no browser yet") (SETFILEINFO STREAM (QUOTE BUFFERS) LAFITEBUFFERSIZE) T) (T (\LAFITE.MAYBE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) NIL OPTIONS))) (* ; "Success in opening") (LAB.CREATEWINDOW MAILFOLDER LAYOUT))) MAILFOLDER)))) -) - -(\LAFITE.MAYBE.OPEN.FOLDER -(LAMBDA (FOLDER ACCESS PROMPTFOLDER OPTIONS RETURNERRORS) (* ; "Edited 8-Sep-88 17:41 by bvm") (* ;; "Open FOLDER for indicated access, with the possibility that the file does not yet exist. If it doesn't, then create it, asking for confirmation if PROMPTFOLDER is supplied (a folder in whose browser to prompt for confirmation, or T for global prompt). Returns the stream on success. On failure, returns the condition if RETURNERRORS true, else NIL.") (PROG* ((FOLDERNAME (OR (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER))) (OLDP (EQMEMB :OLD OPTIONS)) (RECOG (AND (OR OLDP PROMPTFOLDER) (QUOTE OLD))) STREAM CONDITION) RETRY (* ;; "Just try opening. If confirmation desired, open only OLD file on first try.") (CL:MULTIPLE-VALUE-SETQ (STREAM CONDITION) (IGNORE-ERRORS (\LAFITE.OPENSTREAM FOLDERNAME ACCESS RECOG (FUNCTION \LAFITE.EOF) (EQMEMB :BROWSE OPTIONS) (QUOTE LAFITE)))) (RETURN (if CONDITION then (* ; "Failed to open") (if (AND (NEQ RECOG (QUOTE NEW)) (NOT OLDP) (TYPEP CONDITION (QUOTE XCL:FILE-NOT-FOUND))) then (* ; "Just couldn't find it, so maybe create it. If RECOG was NEW, we normally shouldn't be getting this error") (if (OR (NOT (EQMEMB :CONFIRM OPTIONS)) (LAB.MOUSECONFIRM PROMPTFOLDER "Click LEFT to confirm creating ~A" FOLDERNAME)) then (SETQ RECOG (QUOTE NEW)) (SETQ ACCESS (QUOTE BOTH)) (GO RETRY) else (* ; "Disconfirmed the create request.") NIL) elseif RETURNERRORS then (* ; "Caller wants to know why") CONDITION else (* ; "File wouldn't open for some other reason than just not existing, so report it. Should probably be a little more discriminating here.") (\LAFITE.REPORT.FILE.WONT.OPEN (AND (NEQ PROMPTFOLDER T) PROMPTFOLDER) CONDITION FOLDERNAME) NIL) else (\LAFITE.SET.FOLDER.STREAM FOLDER STREAM) (* ; "Notice name fields and such") STREAM)))) -) - -(LAB.LOADFOLDER -(LAMBDA (MAILFOLDER) (* ; "Edited 13-Sep-88 17:42 by bvm") (COND ((LOADMAILFOLDER MAILFOLDER) (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER with 1) (* ; "Nothing selected") (replace (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER with 0) (LAB.DISPLAYFOLDER MAILFOLDER) MAILFOLDER))) -) - -(LAB.DISPLAYFOLDER -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 15:50 by bvm") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (CLIPREGION (DSPCLIPPINGREGION NIL WINDOW)) MSG) (CLEARW WINDOW) (LAB.SETUP FOLDER) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (COND ((AND (SETQ MSG (LAB.MAKE.INITIAL.SELECTION FOLDER)) (< (MESSAGE#.TO.YPOS MSG FOLDER) (fetch (REGION BOTTOM) of CLIPREGION))) (* ; "Quietly scroll so that selected message is in window") (WYOFFSET (TIMES (- (fetch (LAFITEMSG %#) of MSG) (QUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) (TIMES 2 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) WINDOW))) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (LAB.PROMPTPRINT FOLDER T "Folder is empty.")) (T (LAB.DISPLAYLINES FOLDER NIL NIL CLIPREGION))))) -) - -(LAB.MAKE.INITIAL.SELECTION -(LAMBDA (MAILFOLDER) (* bvm%: "24-Feb-86 16:31") (LET ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSGDESCRIPTOR I) (COND ((EQ LASTMSG# 0) NIL) ((SETQ I (LAB.FIND.SELECTED.MSG MAILFOLDER 1 LASTMSG#)) (* ; "There are already selected messages") (NTHMESSAGE MESSAGES I)) (T (find old I from 1 to LASTMSG# suchthat (AND (NOT (fetch (LAFITEMSG SEEN?) of (SETQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES I)))) (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR)))) (* ;; "Found an unseen, undeleted message. If we don't find one, the last MSGDESCRIPTOR is the one to select") (SELECTMESSAGE MSGDESCRIPTOR MAILFOLDER) MSGDESCRIPTOR)))) -) - -(LAB.CREATEWINDOW -(LAMBDA (FOLDER LAYOUT TITLE) (* ; "Edited 20-Apr-89 16:05 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (if (NULL TITLE) then (SETQ TITLE (if FOLDER then (LAB.TITLE.STRING FOLDER) else "Dummy Browser"))) (PROG (BROWSERPROMPTWINDOW BROWSERMENUWINDOW BROWSERMENU BROWSERWINDOW WIDTH HEIGHT MENUREGION WHOLEREGION) (SETQ BROWSERMENU (create MENU ITEMS _ LAFITEBROWSERMENUITEMS CENTERFLG _ T WHENSELECTEDFN _ (if FOLDER then (FUNCTION LAB.COMMANDFN) else (FUNCTION NILL)) MENUFONT _ LAFITEMENUFONT)) (SETQ MENUREGION (WINDOWPROP (SETQ BROWSERMENUWINDOW (MENUWINDOW BROWSERMENU)) (QUOTE REGION))) (SETQ WIDTH (fetch (REGION WIDTH) of MENUREGION)) (SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (* ;; "Now figure out where to put it all") (if LAYOUT then (* ; "user tells us all. If this happens to match one of the default regions, make sure to use it instead (future test is with EQ).") (if (EQ LAYOUT T) then (* ; "Requires prompting") (SETQ LAYOUT NIL) else (for SPEC in LAFITE.BROWSER.LAYOUTS when (EQUAL SPEC LAYOUT) do (RETURN (SETQ LAYOUT SPEC)))) elseif LAFITE.BROWSER.LAYOUTS then (* ; "Take the first layout not currently in use") (for SPEC in LAFITE.BROWSER.LAYOUTS unless (for OPEN in \ACTIVELAFITEFOLDERS thereis (EQ (fetch (MAILFOLDER BROWSERLAYOUT) of OPEN) SPEC)) do (RETURN (SETQ LAYOUT SPEC))) elseif (AND LAFITEBROWSERREGION (for OPEN in \ACTIVELAFITEFOLDERS never (fetch (MAILFOLDER BROWSERWINDOW) of OPEN))) then (* ; "For backward compatibility: if there are no open browsers, use LAFITEBROWSERREGION") (SETQ LAYOUT (LIST LAFITEBROWSERREGION NIL LAFITEDISPLAYREGION))) (COND ((SETQ WHOLEREGION (LISTP (CAR LAYOUT))) (COND ((> (fetch (REGION WIDTH) of WHOLEREGION) WIDTH) (* ; "Only use specified region width if it is wide enough") (SETQ WIDTH (fetch (REGION WIDTH) of WHOLEREGION)))) (SETQ WHOLEREGION (create REGION using WHOLEREGION WIDTH _ WIDTH)) (* ; "Copy the region so we don't smash user variable")) (T (* ; "Prompt for region") (SETQ WHOLEREGION (GETBOXREGION WIDTH (TIMES HEIGHT 9) NIL NIL NIL (CONCAT "Specify region for " TITLE))))) (replace (REGION HEIGHT) of WHOLEREGION with (- (fetch (REGION HEIGHT) of WHOLEREGION) (+ HEIGHT (fetch (REGION HEIGHT) of MENUREGION)))) (* ; "Shrink user-supplied region by the combined heights of the menu and prompt window") (SETQ BROWSERWINDOW (CREATEW WHOLEREGION TITLE)) (ATTACHWINDOW BROWSERMENUWINDOW BROWSERWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (DSPFONT LAFITEBROWSERFONT BROWSERWINDOW) (SETQ BROWSERPROMPTWINDOW (GETPROMPTWINDOW BROWSERWINDOW 1 LAFITEBROWSERFONT)) (CLEARW BROWSERPROMPTWINDOW) (* ; "Get the xy set correctly for the actual font being used") (LINELENGTH MAX.SMALLP BROWSERPROMPTWINDOW) (* ; "Make LINELENGTH ignored -- we try not to overflow window anyway, and the LINELENGTH is no good for variable width font") (if FOLDER then (* ; "MAILFOLDER = NIL is used by dummy routine to set up regions") (WINDOWADDPROP BROWSERPROMPTWINDOW (QUOTE RESHAPEFN) (FUNCTION (LAMBDA (W) (LINELENGTH MAX.SMALLP W)))) (WINDOWADDPROP BROWSERPROMPTWINDOW (QUOTE RESHAPEFN) (FUNCTION RESHAPEBYREPAINTFN)) (* ; "Adding our own reshapefn overrode the default, so add the default back in.") (WINDOWPROP BROWSERPROMPTWINDOW (QUOTE PAGEFULLFN) (FUNCTION LAB.PAGEFULLFN)) (replace (MAILFOLDER ORIGINALBROWSERTITLE) of FOLDER with TITLE) (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER) FOLDER) (WINDOWPROP BROWSERWINDOW (QUOTE SCROLLFN) (FUNCTION LAB.SCROLLFN)) (replace (MAILFOLDER BROWSERWINDOW) of FOLDER with BROWSERWINDOW) (replace (MAILFOLDER BROWSERMENUWINDOW) of FOLDER with BROWSERMENUWINDOW) (replace (MAILFOLDER BROWSERMENU) of FOLDER with BROWSERMENU) (replace (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER with BROWSERPROMPTWINDOW) (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (CADDR LAYOUT)) (replace (MAILFOLDER BROWSERLAYOUT) of FOLDER with LAYOUT) (WINDOWPROP BROWSERWINDOW (QUOTE REPAINTFN) (FUNCTION LAB.REPAINTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION LAB.ICONFN)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONPOSITION) (CADR LAYOUT)) (WINDOWPROP BROWSERWINDOW (QUOTE BUTTONEVENTFN) (FUNCTION LAB.BUTTONEVENTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION LAB.BUTTONEVENTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION LAB.COPYBUTTONEVENTFN)) (* ; "make sure Lafite has the first CLOSEFN and SHRINKFN") (WINDOWADDPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE RESHAPEFN) (FUNCTION LAB.RESHAPEFN))) (RETURN BROWSERWINDOW))) -) - -(LAB.TITLE.STRING -(LAMBDA (FOLDER) (* ; "Edited 24-Oct-88 18:07 by bvm") (* ;; "Returns string to be used for FOLDER's browser's title. It is arranged to convey as much info as possible before it falls off the right edge of the window.") (LET* ((DEST (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER)) (FIELDS (UNPACKFILENAME.STRING (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER))) (BODY (FMEMB (QUOTE NAME) FIELDS))) (RPLACD (NLEFT FIELDS 1 BODY)) (* ; "detach name.ext;version from host/directory") (CONCAT "Browsing " (if (STRING-EQUAL (LISTGET BODY (QUOTE EXTENSION)) LAFITEMAIL.EXT) then (* ; "Just the name field will do") (LISTGET BODY (QUOTE NAME)) else (CL:APPLY (FUNCTION PACKFILENAME.STRING) BODY)) (if DEST then (CONCAT " (Move To: " (fetch (MAILFOLDER SHORTFOLDERNAME) of DEST) ")") else "") " on " (if (U-CASEP (SETQ FIELDS (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS))) then (CL:STRING-CAPITALIZE FIELDS) else (* ; "Leave the capitalization alone") FIELDS)))) -) - -(LAB.COMMANDFN -(LAMBDA (ITEM MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) (LET ((MENUW (WFROMMENU MENU)) WINDOW FOLDER) (AND MENUW (SETQ WINDOW (WINDOWPROP MENUW (QUOTE MAINWINDOW))) (SETQ FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) WINDOW FOLDER ITEM MENU KEY)))) -) - -(LAB.DO.COMMAND -(LAMBDA (WINDOW ITEM/FN MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") (* ;; "Runs some browser command--variant on LAB.COMMANDFN to be called programmatically. If ITEM/FN is a function name, we get the real item and MENU from the window.") (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) (LET ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (AND FOLDER (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (CL:FUNCALL (if (LITATOM ITEM/FN) then (PROG1 ITEM/FN (OR MENU (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (SETQ ITEM/FN (LA.MENU.ITEM ITEM/FN MENU))) else (EXTRACTMENUCOMMAND ITEM/FN)) WINDOW FOLDER ITEM/FN MENU KEY)))) -) - -(LAB.ASSURE.SELECTIONS -(LAMBDA (MAILFOLDER) (* bvm%: " 3-Feb-86 14:44") (COND ((IGREATERP (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (LAB.PROMPTPRINT MAILFOLDER T "No messages selected.") T))) -) -) -(DEFINEQ - -(BUILD.LAFITE.LAYOUTS -(LAMBDA NIL (* ; "Edited 23-Nov-87 16:48 by bvm:") (LET (DUMMYWINDOWS) (CL:UNWIND-PROTECT (PROG ((ICONBM (fetch (TITLEDICON ICON) of LAFITE.FOLDER.ICON)) (N 0) W MAILFOLDER LAYOUTS LAYOUT CURRENT OLDLAYOUTS POS) (if (AND (LISTP LAFITE.BROWSER.LAYOUTS) (CL:Y-OR-N-P "Do you wish to retain the ~D browser specifications you already have? " (LENGTH LAFITE.BROWSER.LAYOUTS))) then (SETQ OLDLAYOUTS LAFITE.BROWSER.LAYOUTS) (for LAYOUT in OLDLAYOUTS do (for FOLDER in \ACTIVELAFITEFOLDERS when (EQ (fetch (MAILFOLDER BROWSERLAYOUT) of FOLDER) LAYOUT) do (add N 1) (RETURN (CL:FORMAT T "Retaining layout in use by ~A.~%%" (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER))) finally (* ; "Display dummy browser and icon to aid in positioning.") (SETQ W (LAB.CREATEWINDOW NIL LAYOUT (CONCAT "Sample Browser " (add N 1)))) (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W LAYOUT N)))) (SETQ LAYOUTS (REVERSE OLDLAYOUTS))) (CL:FORMAT T "Click in preference order in each browser or browser icon whose current layout you wish to include; click in background to finish~%%") (while (SETQ W (WHICHW (GETPOSITION))) do (if (AND (NOT (SETQ MAILFOLDER (WINDOWPROP W (QUOTE MAILFOLDER)))) (OR (NOT (SETQ W (WINDOWPROP W (QUOTE ICONFOR)))) (NOT (SETQ MAILFOLDER (WINDOWPROP W (QUOTE MAILFOLDER)))))) then (CL:FORMAT T "That's not a Lafite browser window/icon; try again.~%%") elseif (OR (MEMB (fetch (MAILFOLDER BROWSERLAYOUT) of MAILFOLDER) OLDLAYOUTS) (MEMBER (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW W MAILFOLDER ICONBM)) LAYOUTS)) then (CL:FORMAT T "You have already included that browser's specification.~%%") else (* ; "It's a Lafite browser window or icon.") (push LAYOUTS LAYOUT) (CL:FORMAT T "Browser for ~A noted.~%%" (fetch (MAILFOLDER SHORTFOLDERNAME) of MAILFOLDER)) (add N 1))) (while (OR (NULL LAYOUTS) (MENU (create MENU ITEMS _ (QUOTE (("Specify another browser" T) ("Finish" (QUOTE NIL)))) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))) do (SETQ W (LAB.CREATEWINDOW NIL T (CONCAT "Sample Browser " (add N 1)))) (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW W NIL ICONBM)) N)) (push LAYOUTS LAYOUT)) (RETURN (if (AND LAYOUTS (MOUSECONFIRM "Click LEFT to confirm setting LAFITEBROWSERLAYOUTS to these values" T T T)) then (/SETTOPVAL (QUOTE LAFITE.BROWSER.LAYOUTS) (REVERSE LAYOUTS)) (MARKASCHANGED (QUOTE LAFITE.BROWSER.LAYOUTS) (QUOTE VARS)) LAFITE.BROWSER.LAYOUTS))) (* ;; "Cleanup dummy windows put up earlier") (for X in DUMMYWINDOWS bind TMP do (CLOSEW X) (if (SETQ TMP (WINDOWPROP X (QUOTE DUMMY.ICON))) then (CLOSEW TMP)) (if (SETQ TMP (WINDOWPROP X (QUOTE DUMMY.DISPLAY))) then (CLOSEW TMP)))))) -) - -(\LAFITE.LAYOUT.FROM.WINDOW -(LAMBDA (W FOLDER ICONBM) (* ; "Edited 10-Dec-87 17:15 by bvm:") (* ;; "Return a browser layout spec corresponding to window W optionally containing FOLDER.") (LET ((PW (if (OPENWP W) then (GETPROMPTWINDOW W 1 LAFITEBROWSERFONT) else PROMPTWINDOW))) (LIST (WINDOWREGION W) (if (WINDOWPROP W (QUOTE ICONPOSITION)) else (CLEARW PW) (CL:FORMAT PW "Specify position for icon.") (PROG1 (GETBOXPOSITION (BITMAPWIDTH ICONBM) (BITMAPHEIGHT ICONBM)) (CLEARW PW))) (PROG (CURRENT) (if FOLDER then (* ; "Use current values, if known") (RETURN (OR (if (CAR (SETQ CURRENT (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER))) then (* ; "take current primary window region") (COPY (WINDOWPROP (CAR CURRENT) (QUOTE REGION))) elseif (COPY (fetch (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER))) (GO PROMPT)))) PROMPT (CLEARW PW) (CL:FORMAT PW "Specify region for display window") (RETURN (PROG1 (if LAFITE.DISPLAY.SIZE then (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) (CDR LAFITE.DISPLAY.SIZE) NIL NIL) else (GETREGION)) (CLEARW PW))))))) -) - -(\LAFITE.MAKE.DUMMY.WINDOWS -(LAMBDA (MAINW LAYOUT N) (* ; "Edited 23-Nov-87 16:44 by bvm:") (LET (TMP SUBW) (DSPFILL NIL LAFITE.DUMMY.SHADE (QUOTE REPLACE) MAINW) (WINDOWPROP MAINW (QUOTE SHRINKFN) (QUOTE DON'T)) (if (SETQ TMP (CADR LAYOUT)) then (* ; "An icon position is given") (SETQ SUBW (TITLEDICONW LAFITE.FOLDER.ICON (CONCAT "Icon " N) LAFITETITLEFONT TMP)) (ICONW.SHADE SUBW LAFITE.DUMMY.HALF.SHADE) (WINDOWPROP SUBW (QUOTE BUTTONEVENTFN) (FUNCTION ICONBUTTONEVENTFN)) (WINDOWPROP MAINW (QUOTE DUMMY.ICON) SUBW)) (if (SETQ TMP (CADDR LAYOUT)) then (* ; "A display region is given") (SETQ SUBW (CREATEW TMP (CONCAT "Lafite Display window " N) LAFITETITLEFONT TMP)) (DSPFILL NIL LAFITE.DUMMY.SHADE (QUOTE REPLACE) SUBW) (WINDOWPROP MAINW (QUOTE DUMMY.DISPLAY) SUBW)) MAINW)) -) -) - -(RPAQQ LAFITE.DUMMY.SHADE #*(16 16)@L@HA@@FALD@@DJ@AHF@@@JDH@NFD@@EDD@EDJ@EDJD@@LD@@HD@@HDD@@DJ@@DL) - -(RPAQQ LAFITE.DUMMY.HALF.SHADE #*(16 16)@H@@A@@D@@D@@DB@A@D@@@HDH@DB@@@DDD@A@B@DDHD@@D@@@@D@@H@D@@DJ@@@@) - -(RPAQ? \LAFITE.LAST.FOLDER.NAME) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \LAFITE.LAST.FOLDER.NAME) -) - - - -(* ; "Browser operations") - -(DEFINEQ - -(LAB.SETUP -(LAMBDA (MAILFOLDER) (* bvm%: "31-Jul-84 14:39") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) WIDTH HEIGHT TOTALHEIGHT ASCENT DIGITWIDTH SPACEWIDTH XPOS) (CLEARW WINDOW) (SETQ LAFITEBROWSERFONT (FONTCREATE LAFITEBROWSERFONT)) (DSPFONT LAFITEBROWSERFONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH 10000 WINDOW) (replace (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER with (SETQ HEIGHT (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (replace (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER with (SETQ ASCENT (FONTPROP LAFITEBROWSERFONT (QUOTE ASCENT)))) (replace (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER with (FONTPROP LAFITEBROWSERFONT (QUOTE DESCENT))) (replace (MAILFOLDER BROWSERORIGIN) of MAILFOLDER with (+ (DSPYPOSITION NIL WINDOW) ASCENT)) (replace (MAILFOLDER BROWSERMAXXPOS) of MAILFOLDER with (SETQ WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH)))) (SETQ TOTALHEIGHT (TIMES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (MAILFOLDER BROWSEREXTENT) of MAILFOLDER with (create REGION LEFT _ 0 BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) TOTALHEIGHT) WIDTH _ WIDTH HEIGHT _ TOTALHEIGHT))) (* ;; "Now figure out columns for printing toc entries") (SETQ DIGITWIDTH (CHARWIDTH (CHARCODE 9) LAFITEBROWSERFONT)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE r) LAFITEBROWSERFONT)) (replace (MAILFOLDER ORDINALXPOS) of MAILFOLDER with (SETQ XPOS (+ BROWSERMARKXPOSITION (CHARWIDTH (CHARCODE m) LAFITEBROWSERFONT) (LRSH DIGITWIDTH 1)))) (* ; "Message # starts here") (replace (MAILFOLDER DATEXPOS) of MAILFOLDER with (add XPOS (+ (TIMES 2 SPACEWIDTH) (TIMES 4 DIGITWIDTH)))) (* ; "Date starts here. Allow 4 columns of digits plus some space") (replace (MAILFOLDER FROMXPOS) of MAILFOLDER with (add XPOS (+ (TIMES 2 DIGITWIDTH) (TIMES 2 SPACEWIDTH) (CHARWIDTH (CHARCODE -) LAFITEBROWSERFONT) (STRINGWIDTH (QUOTE MAY) LAFITEBROWSERFONT)))) (* ; "From field starts here. Allow 3 columns of digits, a month, and some space") (replace (MAILFOLDER SUBJECTXPOS) of MAILFOLDER with (add XPOS (IMAX (TIMES LAFITEMINFROMCHARS (CHARWIDTH (CHARCODE A) LAFITEBROWSERFONT)) (FIXR (FTIMES LAFITEFROMFRACTION (- WIDTH XPOS)))))) (* ;; "Subject field starts here. Space is divided up between From and Subject so that From field gets LAFITEFROMFRACTION of the available space, but at least LAFITEMINFROMCHARS wide") (replace (MAILFOLDER FROMMAXXPOS) of MAILFOLDER with (- XPOS (TIMES 2 SPACEWIDTH))) (* ; "From field gets truncated beyond this position") (replace (MAILFOLDER BROWSERDIGITWIDTH) of MAILFOLDER with DIGITWIDTH))) -) - -(LAB.BUTTONEVENTFN -(LAMBDA (WINDOW) (* ; "Edited 28-Jul-88 17:37 by bvm") (TOTOPW WINDOW) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAB.SELECTMESSAGE))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((LASTMOUSESTATE (ONLY MIDDLE)) (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAFITEEXTRABROWSERCOMMANDFN))))) -) - -(LAB.DO.UNLESS.BUSY -(LAMBDA (WINDOW FN ARGUMENT) (* ; "Edited 3-Sep-87 18:01 by bvm:") (RESETLST (PROG ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T)) (CL:FUNCALL FN WINDOW MAILFOLDER ARGUMENT)))))) -) - -(LOADMAILFOLDER -(LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") (* ;; "LAFITEVERSION# is used to keep track of changed in internal datastructures that get written out to Lafite TOC files. If the datastructures change, then just change the version number to LAFITEVERSION#+1 and the rest of Lafite should adjust appropriately.") (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL) (* ; "Assume ok until we hear otherwise") (COND ((OR (\LAFITE.READ.TOC.FILE FOLDER) (\LAFITE.PARSE.FOLDER FOLDER)) (LAB.PROMPTPRINT FOLDER " done.") (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (OR (LAB.SET.EXPUNGEABILITY FOLDER) (MAX 1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) (* ; "Only %"changed%" messages are deleted ones now, except for possibly the last message in the case where it was truncated.") FOLDER))) -) - -(LAFITE.OBTAIN.FOLDER -(LAMBDA (FOLDERNAME ACCESS PROMPTFOLDER OPTIONS) (* ; "Edited 12-Sep-88 17:42 by bvm") (* ;;; "Locates a MAILFOLDER on FOLDERNAME, or creates one if there is none. If the folder is not already on the active list, we will try to open it for ACCESS, or just return NIL if ACCESS is NIL. If PROMPTFOLDER is supplied, it is a folder (or T for PROMPTWINDOW) indicating focus of attention for prompting for confirmation to create new folder. OPTIONS may include :FORGET, in which case we don't add this folder name to the set of known folders, or :BROWSE, meaning we plan to browse the folder.") (WITH.MONITOR \LAFITE.BROWSELOCK (OR (for FOLDER in \ACTIVELAFITEFOLDERS when (OR (STRING-EQUAL (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER) FOLDERNAME) (STRING-EQUAL (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) FOLDERNAME)) do (* ; "Found existing folder without sweating too hard") (RETURN FOLDER)) (AND ACCESS (LET* ((UNPACKEDNAME (UNPACKFILENAME.STRING FOLDERNAME)) (OLDVERSION (LISTGET UNPACKEDNAME (QUOTE VERSION))) (VERSIONLESSNAME (PROGN (LISTPUT UNPACKEDNAME (QUOTE VERSION) NIL) (PACKFILENAME.STRING UNPACKEDNAME))) SHORTNAME NEWNAME NEWFOLDER OLDFOLDER STREAM) (COND ((AND (NOT (STRING-EQUAL VERSIONLESSNAME FOLDERNAME)) (SETQ NEWFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION)) (* ; "Found a folder describing a different version--can't have more than one version up at once") NIL) ((NULL (SETQ STREAM (\LAFITE.MAYBE.OPEN.FOLDER (SETQ NEWFOLDER (create MAILFOLDER FULLFOLDERNAME _ FOLDERNAME VERSIONLESSFOLDERNAME _ VERSIONLESSNAME FOLDERLOCK _ (CREATE.MONITORLOCK VERSIONLESSNAME))) ACCESS PROMPTFOLDER OPTIONS T))) (* ; "File not found and user didn't confirm creating it") NIL) ((type? STREAM STREAM) (* ; "succeeded in opening the new folder.") (PROG ((VERSIONLESSNEW (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (fetch (MAILFOLDER FULLFOLDERNAME) of NEWFOLDER))) (SHORTNAME (fetch SHORTFOLDERNAME of NEWFOLDER))) (if (NOT (STRING-EQUAL VERSIONLESSNEW VERSIONLESSNAME)) then (* ; "We guessed wrong about the versionless name--having actually opened the file, here's the canonical name") (if (SETQ OLDFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNEW)) then (* ; "it turns out we already had this file open under a different full name. Close the new one and return the old") (\LAFITE.CLOSE.FOLDER NEWFOLDER T) (RETURN (AND (NOT (\LAFITE.CONFLICTING.OLD.FOLDER OLDFOLDER FOLDERNAME OLDVERSION)) OLDFOLDER)) else (replace (MAILFOLDER VERSIONLESSFOLDERNAME) of NEWFOLDER with VERSIONLESSNEW))) (push \ACTIVELAFITEFOLDERS NEWFOLDER) (if (NOT (CL:MEMBER SHORTNAME (CDR LAFITEMAILFOLDERS) :TEST (QUOTE STRING-EQUAL))) then (* ; "This is a new folder") (COND ((EQMEMB :FORGET OPTIONS) (* ; "Don't remember it, but do set default for next Browse&Forget") (SETQ \LAFITE.LAST.FOLDER.NAME SHORTNAME)) (T (* ; "Add to list for menu") (\LAFITE.NOTICE.FILE SHORTNAME)))) (RETURN NEWFOLDER))) (T (* ; "STREAM is a condition signaled by the attempt to open the file") (if (AND (TYPEP STREAM (QUOTE XCL:FILE-WONT-OPEN)) (SETQ OLDFOLDER (OR (AND (SETQ NEWNAME (XCL:FILE-WONT-OPEN-PATHNAME STREAM)) (NOT (STRING-EQUAL VERSIONLESSNAME (SETQ VERSIONLESSNAME (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWNAME)))) (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) (AND (SETQ NEWNAME (INFILEP VERSIONLESSNAME)) (NOT (STRING-EQUAL VERSIONLESSNAME (SETQ VERSIONLESSNAME (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWNAME)))) (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)))) (NOT (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION))) then (* ; "Looks like file wouldn't open because we already have it open by a different name. Return that folder") OLDFOLDER else (* ; "Report the problem") (\LAFITE.REPORT.FILE.WONT.OPEN PROMPTFOLDER STREAM (OR NEWNAME FOLDERNAME)) NIL)))))))) -) - -(\LAFITE.FIND.EXISTING.FOLDER -(LAMBDA (VERSIONLESSNAME) (* ; "Edited 22-Aug-88 17:32 by bvm") (* ;; "Returns an existing mail folder object whose versionless name is (case-insensitively) equal to VERSIONLESSNAME, or NIL on failure.") (find FOLDER in \ACTIVELAFITEFOLDERS suchthat (STRING-EQUAL (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER) VERSIONLESSNAME))) -) - -(\LAFITE.CONFLICTING.OLD.FOLDER -(LAMBDA (NEWFOLDER FOLDERNAME OLDVERSION) (* ; "Edited 22-Aug-88 18:30 by bvm") (* ;; "NEWFOLDER is a folder we found somewhere during the search for FOLDERNAME. Check that it works, i.e., that it doesn't have a version number that differs from that of FOLDERNAME") (COND ((NULL OLDVERSION) (* ; "User didn't ask for a specific version, so this folder is fine") NIL) ((OR (fetch (MAILFOLDER BROWSERWINDOW) of NEWFOLDER) (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of NEWFOLDER)) (printout PROMPTWINDOW T "A different version of " FOLDERNAME " is already being browsed." "Multiple versions may not be manipulated at once.") T) (T (* ; "Not being browsed, so kill it and pretend it never existed") (\LAFITE.CLOSE.FOLDER NEWFOLDER T) (SETQ \ACTIVELAFITEFOLDERS (DREMOVE NEWFOLDER \ACTIVELAFITEFOLDERS)) NIL))) -) - -(LAB.REPAINTFN -(LAMBDA (WINDOW REGION) (* ; "Edited 28-Apr-89 16:00 by bvm") (LET ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (AND (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) (LAB.DISPLAYLINES FOLDER NIL NIL REGION)) (T (MAILFOLDERBUSY FOLDER))))))) -) - -(LAB.SCROLLFN -(LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* bvm%: " 3-Jan-84 14:53") (* ;;; "only scroll if can get the monitor lock") (RESETLST (PROG ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T)) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG)) (T (MAILFOLDERBUSY MAILFOLDER)))))) -) - -(LAB.RESHAPEFN -(LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 28-Apr-89 15:57 by bvm") (RESETLST (PROG ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) MSG#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T)) (* ; "Folder is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) NIL T)) ((NOT (fetch (MAILFOLDER BROWSERREADY) of FOLDER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ MSG# (FIRSTVISIBLEMESSAGE FOLDER REGION)) (LAB.SETUP FOLDER) (WYOFFSET (ITIMES (SUB1 MSG#) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) WINDOW) (LAB.DISPLAYLINES FOLDER MSG# NIL REGION)))) -) - -(LAB.CLOSEFN -(LAMBDA (BROWSERWINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") (LAB.CLOSE/SHRINK BROWSERWINDOW :CLOSE)) -) - -(LAB.SHRINKFN -(LAMBDA (WINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") (LAB.CLOSE/SHRINK WINDOW :SHRINK))) - -(LAB.CLOSE/SHRINK -(LAMBDA (BROWSERWINDOW FLG) (* ; "Edited 7-Jun-88 14:42 by bvm") (* ;; "Called from CLOSEFN or SHRINKFN of BROWSERWINDOW with FLG = :CLOSE or :SHRINK. Before doing anything, let user update file.") (RESETLST (LET ((MAILFOLDER (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T) (AND (OPENWP BROWSERWINDOW) (CLEARW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER))) (SELECTQ (SETQ HOW? (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (SETQ HOW? (LAB.CHOOSE.UPDATE.MENU MAILFOLDER FLG))) (MENU HOW?)) (T (FUNCTION \LAFITE.FINISH.UPDATE)))) (NIL (QUOTE DON'T)) (PROGN (\LAFITE.PROCESS (LIST HOW? (KWOTE BROWSERWINDOW) (KWOTE MAILFOLDER) (KWOTE FLG)) (QUOTE LAFITEUPDATE)) (* ; "Return DON'T now, for UPDATE.PROC will do it later") (QUOTE DON'T)))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) -) - -(LAB.EXPANDFN -(LAMBDA (BROWSERWINDOW) (* ; "Edited 28-Apr-89 18:50 by bvm") (LET ((FOLDER (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (LET ((FIRSTCHANGEDMSG# (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (COND (FIRSTCHANGEDMSG# (* ; "Browser has changed since shrinking") (COND ((EQ FIRSTCHANGEDMSG# 0) (* ; "After expunge") (LAB.DISPLAYFOLDER FOLDER)) (T (LAB.DISPLAYLINES FOLDER FIRSTCHANGEDMSG# NIL NIL T))) (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with NIL))))))) -) - -(LAFITEEXTRABROWSERCOMMANDFN -(LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 28-Jul-88 17:37 by bvm") (PROG ((FN (MENU (.LAFITEMENU. LAFITEEXTRAMENU LAFITEEXTRAMENUITEMS)))) (COND (FN (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (CL:FUNCALL FN MAILFOLDER))))) -) -) - - - -(* ; "Browser selection") - -(DEFINEQ - -(LAB.SELECTMESSAGE -(LAMBDA (WINDOW) (* ; "Edited 7-Jun-88 17:37 by bvm") (PROG ((*MAILFOLDER* (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE* SELECTIONREGION FIRST# LAST# SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS MSG LASTX LASTY MARKRIGHT) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of *MAILFOLDER*) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of *MAILFOLDER*)) (SETQ FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of *MAILFOLDER*)) (SETQ *FIRST-VISIBLE* (FIRSTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) (SETQ *LAST-VISIBLE* (LASTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) (SETQ *MESSAGES* (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of *MAILFOLDER*)) (SETQ MARKRIGHT (fetch (MAILFOLDER ORDINALXPOS) of *MAILFOLDER*)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION) (SETQ OLDSEL#))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (SELECTC *TOC-STATE* (TS.REPLACING (for MSG selectedin *MAILFOLDER* do (replace SELECTED? of MSG with NIL)) (replace SELECTED? of (NTHMESSAGE *MESSAGES* OLDSEL#) with T) (replace FIRSTSELECTEDMESSAGE of *MAILFOLDER* with (replace LASTSELECTEDMESSAGE of *MAILFOLDER* with OLDSEL#))) (TS.ADDING (LA.SELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL# T)) (TS.REMOVING (LA.DESELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (LA.SELECTRANGE *MAILFOLDER* (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (LA.SELECTRANGE *MAILFOLDER* OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (LA.DESELECTRANGE *MAILFOLDER* (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (LA.DESELECTRANGE *MAILFOLDER* FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND (>= LASTX BROWSERMARKXPOSITION) (< LASTX MARKRIGHT)) (* ; "Inside mark region") (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION) (SETQ OLDSEL#))) (LAB.CHANGEMARK *MAILFOLDER*)) ((OR (NEQ (SETQ SEL# (YPOS.TO.MESSAGE# (LASTMOUSEY WINDOW) *MAILFOLDER*)) OLDSEL#) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (COND ((AND (SHIFTDOWNP (QUOTE CTRL)) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Deselect this message") (SELECTC *TOC-STATE* (TS.REMOVING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE REPLACE))) (TS.IDLE) (LA.UNDOSELECTION)) (SETQ *TOC-STATE* (COND ((fetch SELECTED? of (SETQ MSG (NTHMESSAGE *MESSAGES* SEL#))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single message") (COND ((EQ *TOC-STATE* TS.REPLACING) (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE ERASE))) (T (LA.DECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) (SETQ *TOC-STATE* TS.REPLACING))) (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* SEL#) (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this message to the selection") (SELECTC *TOC-STATE* (TS.ADDING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE ERASE))) (TS.IDLE) (LA.UNDOSELECTION)) (SETQ *TOC-STATE* (COND ((NOT (fetch SELECTED? of (SETQ MSG (NTHMESSAGE *MESSAGES* SEL#)))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SELECTC *TOC-STATE* (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (LA.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (LA.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (LA.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (LA.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (LA.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (LA.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (LA.RECONSIDERRANGE FIRST# LAST#) (SETQ *TOC-STATE* TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (LA.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (LA.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (LA.RECONSIDERRANGE FIRST# LAST#) (SETQ *TOC-STATE* TS.IDLE)))) (COND ((NOT (> FIRST# LAST#)) (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ *TOC-STATE* (COND ((> SEL# LAST#) (LA.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (LA.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (LA.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI) (T (LA.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO)))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSEL# (AND (NEQ *TOC-STATE* TS.IDLE) SEL#))))) (COND ((EQ LAFITEVERIFYFLG (QUOTE TOC)) (LA.VERIFY.SELECTION *MAILFOLDER*))))) -) - -(LAB.CHANGEMARK -(LAMBDA (MAILFOLDER) (* bvm%: "17-Feb-84 15:46") (* ;; "Called when mouse is inside the 'mark' region of a browser. Tracks mouse while in that region and does whatever is appropriate") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (RIGHT (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER)) SEL# OLDSEL# COCKED REGION X Y TOP BOTTOM) (SETQ BOTTOM (fetch (REGION BOTTOM) of (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOP (fetch (REGION TOP) of REGION)) (do (GETMOUSESTATE) (COND ((OR (< (SETQ X (LASTMOUSEX WINDOW)) BROWSERMARKXPOSITION) (> X RIGHT) (< (SETQ Y (LASTMOUSEY WINDOW)) BOTTOM) (> Y TOP)) (COND (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#))) (RETURN)) ((LASTMOUSESTATE UP) (COND (COCKED (LA.READ.NEW.MARK MAILFOLDER OLDSEL#))) (RETURN)) ((NEQ (SETQ SEL# (YPOS.TO.MESSAGE# Y MAILFOLDER)) OLDSEL#) (COND (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#)) (T (SETQ COCKED T))) (LA.INVERT.MARK.BOX MAILFOLDER (SETQ OLDSEL# SEL#))))))) -) - -(LA.READ.NEW.MARK -(LAMBDA (FOLDER MSG#) (* ; "Edited 25-Apr-89 17:55 by bvm") (PROG ((MSG (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) MSG#)) (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) YPOS MARK) (RESETSAVE NIL (LIST (FUNCTION CLEARW) (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER))) (RESETSAVE NIL (LIST (FUNCTION LA.SHOW.MARK) MSG FOLDER)) (* ; "Display correct mark on exit no matter what happens") (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (* ; "So caret flashes in the right place") (RESETSAVE NIL (LIST (QUOTE WINDOWPROP) WINDOW (QUOTE PROCESS) NIL)) (* ;; "PROCESS prop put there by TTYDISPLAYSTREAM -- don't want it to linger, else MOUSE proc will get tty in future when we bug browser") (LA.BLT.MARK.BOX FOLDER WINDOW (SETQ YPOS (MESSAGE#.TO.YPOS MSG FOLDER)) (QUOTE REPLACE) WHITESHADE) (* ; "Erase whatever's there") (LAB.PROMPTPRINT FOLDER T "Type single character mark, or ESC to abort") (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) (COND ((AND (>= (SETQ MARK (\GETKEY)) (CHARCODE SPACE)) (<= MARK (CHARCODE DEL))) (LAB.MARKS.CHANGED MSG FOLDER) (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) (replace (LAFITEMSG MARKCHAR) of MSG with MARK))))) -) - -(YPOS.TO.MESSAGE# -(LAMBDA (YPOS MAILFOLDER) (* bvm%: "24-Dec-83 17:45") (PROG ((N (IQUOTIENT (IPLUS (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) YPOS) (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER)) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) (RETURN (COND ((ILEQ N 0) 1) (T (IMIN N (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))))))) -) - -(MESSAGE#.TO.YPOS -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "24-Dec-83 16:37") (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (ITIMES (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) (fetch (LAFITEMSG %#) of MSGDESCRIPTOR)))) -) -) -(DEFINEQ - -(LA.CONSIDERRANGE -(LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 7-Jun-88 17:34 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected. Deleted messages are not selected unless EVENIFDELETED is true") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind MSG do (SETQ MSG (NTHMESSAGE *MESSAGES* I)) (COND ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE REPLACE)))))) -) - -(LA.DECONSIDERRANGE -(LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as unselected.") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) do (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* I) (QUOTE ERASE)))) -) - -(LA.RECONSIDERRANGE -(LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind MSG do (LA.SHOW.SELECTION *MAILFOLDER* (SETQ MSG (NTHMESSAGE *MESSAGES* I)) (COND ((fetch SELECTED? of MSG) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) -) - -(LA.SELECTRANGE -(LAMBDA (MAILFOLDER FIRST# LAST# EVENIFDELETED) (* bvm%: "15-Feb-84 15:39") (* ;;; "Mark internally messages FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) (FIRSTSEL (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (LASTSEL (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) MSG) (for I from FIRST# to LAST# do (SETQ MSG (NTHMESSAGE MESSAGES I)) (COND ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) (replace SELECTED? of MSG with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER))) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) (replace LASTSELECTEDMESSAGE of MAILFOLDER with LAST#))))) -) - -(LA.DESELECTRANGE -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "28-Mar-84 14:52") (* ;;; "Mark internally messages FIRST# thru LAST# as unselected. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") (COND ((ILEQ FIRST# LAST#) (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER))) (for I from FIRST# to LAST# do (replace SELECTED? of (NTHMESSAGE MESSAGES I) with NIL)) (COND ((EQ FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with (COND ((LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 LAST#) (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) (T (replace LASTSELECTEDMESSAGE of MAILFOLDER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)))))) ((EQ LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (replace LASTSELECTEDMESSAGE of MAILFOLDER with (OR (LAB.REV.FIND.SELECTED.MSG MAILFOLDER (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) (SUB1 FIRST#)) 1)))))))) -) - -(LAB.FIND.SELECTED.MSG -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "15-Feb-84 12:22") (find I from FIRST# to LAST# bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) -) - -(LAB.REV.FIND.SELECTED.MSG -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: " 2-Mar-84 18:02") (find I from LAST# to FIRST# by -1 bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) -) - -(LA.UNDOSELECTION -(LAMBDA NIL (* ; "Edited 7-Jun-88 17:37 by bvm") (* ;;; "Restore browser to state before any selections were attempted") (LA.RECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) (SETQ *TOC-STATE* TS.IDLE)) -) - -(LA.VERIFY.SELECTION -(LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 11:53") (PROG ((FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (%#OFMESSAGES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) SEL) (COND ((IGREATERP FIRST# LAST#) (COND ((SETQ SEL (for I from 1 to %#OFMESSAGES collect I when (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) (HELP "First > Last, but these msgs selected" SEL)))) (T (for I from 1 to %#OFMESSAGES do (COND ((fetch SELECTED? of (NTHMESSAGE MESSAGES I)) (COND ((< I FIRST#) (HELP "First is too high" FIRST#)) ((> I LAST#) (HELP "Last is too low" LAST#)))))) (COND ((AND (EQ FIRST# 1) (EQ LAST# 1)) (* ; "The only time it is okay for them not to be selected")) ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES FIRST#))) (HELP "First not selected" FIRST#)) ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES LAST#))) (HELP "Last not selected" LAST#))))))) -) -) -(DEFINEQ - -(LAB.COPYBUTTONEVENTFN -(LAMBDA (WINDOW) (* ; "Edited 11-Dec-87 17:17 by bvm:") (* ;;; "copy select an item from the window.") (PROG ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) SELECTIONREGION CURRENTITEM CURRENTMSG CURRENTFIELD NEWITEM NEWFIELD LASTX LASTY DATEX FROMX SUBJECTX MSGS) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (* ; "Nothing to select") (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ DATEX (fetch (MAILFOLDER DATEXPOS) of FOLDER)) (SETQ FROMX (fetch (MAILFOLDER FROMXPOS) of FOLDER)) (SETQ SUBJECTX (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) (SETQ MSGS (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) LP (TOTOPW WINDOW) (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (YPOS.TO.MESSAGE# LASTY FOLDER))) (SETQ NEWFIELD (if (< LASTX DATEX) then T elseif (< LASTX FROMX) then (QUOTE DATE) elseif (< LASTX SUBJECTX) then (QUOTE FROM) else (QUOTE SUBJECT))) (* ; "Figure out which field of the message is being pointed at by the xpos.") (COND ((OR (NEQ CURRENTITEM NEWITEM) (NEQ CURRENTFIELD NEWFIELD)) (* ; "Something changed") (COND (CURRENTITEM (* ; "turn off old selection.") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD))) (COND ((SETQ CURRENTITEM NEWITEM) (* ; "turn on new selection") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER (SETQ CURRENTMSG (NTHMESSAGE MSGS CURRENTITEM)) (SETQ CURRENTFIELD NEWFIELD)))))) LP2 (* ;; "wait for a button up or move out of region") (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (* ; "If something is selected, bksysbuf the selected field") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD) (BKSYSBUF (OR (SELECTQ CURRENTFIELD (T (* ; "Do whole line") (CONCAT "#" (fetch (LAFITEMSG %#) of CURRENTMSG) " " (fetch (LAFITEMSG DATE) of CURRENTMSG) " " (COND ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of CURRENTMSG))) (T (CONCAT "From: " (OR (fetch (LAFITEMSG FROM) of CURRENTMSG) UNSUPPLIEDFIELDSTR)))) " -- " (OR (fetch (LAFITEMSG SUBJECT) of CURRENTMSG) UNSUPPLIEDFIELDSTR))) (DATE (fetch (LAFITEMSG DATE) of CURRENTMSG)) (FROM (COND ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of CURRENTMSG))) (T (fetch (LAFITEMSG FROM) of CURRENTMSG)))) (fetch (LAFITEMSG SUBJECT) of CURRENTMSG)) UNSUPPLIEDFIELDSTR)))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, but shift still down, no action") (GO LP2)) (T (GO LP))))) -) - -(LAB.SHOW.COPY.SELECTION -(LAMBDA (WINDOW FOLDER MSG FIELD) (* ; "Edited 11-Dec-87 17:16 by bvm:") (* ;;; "underline FIELD of MSG in FOLDER's window") (LET ((BOTTOM (- (MESSAGE#.TO.YPOS MSG FOLDER) (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER))) LEFT STR) (SELECTQ FIELD (T (* ; "Whole line")) (DATE (SETQ LEFT (fetch (MAILFOLDER DATEXPOS) of FOLDER)) (SETQ STR (fetch (LAFITEMSG DATE) of MSG))) (FROM (SETQ LEFT (fetch (MAILFOLDER FROMXPOS) of FOLDER)) (SETQ STR (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of MSG))) (T (fetch (LAFITEMSG FROM) of MSG))))) (PROGN (SETQ LEFT (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) (SETQ STR (fetch (LAFITEMSG SUBJECT) of MSG)))) (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM (if (EQ FIELD T) then (* ; "whole line") NIL else (* ; "width of just this field") (STRINGWIDTH (OR STR UNSUPPLIEDFIELDSTR) WINDOW)) 2 (QUOTE INVERT)))) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY - -(CL:PROCLAIM (QUOTE (CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*))) - -(CL:PROCLAIM (QUOTE (GLOBAL LASTMOUSEBUTTONS))) -) - - - -(* ; "Browser display") - -(DEFINEQ - -(LAB.PROMPTPRINT -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:36 by bvm:") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS)) -) - -(LAB.FORMAT -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:53 by bvm:") (* ;; "Outputs to FOLDER's prompt window using FORMAT. If first format arg is T, then we clear the window first, and consider then next format arg to be the format string. All this is done in a way that lets the window expand if it needs to.") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T)) -) - -(LAB.MOUSECONFIRM -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 11-Dec-87 17:33 by bvm:") (* ;; "Version of MOUSECONFIRM using FOLDER's prompt window. ARGS are args to FORMAT.") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T) (PROG1 (MOUSECONFIRM T T) (if FOLDER then (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) else (CLEARW PROMPTWINDOW)))) -) - -(LAB.PRINT.TO.PROMPTWINDOW -(LAMBDA (FOLDER ARGS FORMAT-P) (* ; "Edited 14-Oct-87 19:01 by bvm:") (* ;; "Outputs to FOLDER's prompt window the text in ARGS. If FORMAT-P is NIL, ARGS is a list of items to print, with T meaning clear the window. If FORMAT-P is true, ARGS is considered a format string and format args, except that ARGS may be prefixed with T to indicate clearing the window. All this is done in a way that lets the window expand if it needs to. If FOLDER is NIL, or its browser is not open, prints to global PROMPTWINDOW. Returns NIL.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (AND FOLDER (OPENWP (ffetch (MAILFOLDER BROWSERPROMPTWINDOW) of (\DTEST FOLDER (QUOTE MAILFOLDER)))))) \CURRENTDISPLAYLINE OLDTTY) (* ;; "*PRINT-CASE* is bound so symbols get printed in %"expected%" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case. \currentdisplayline changes with TTYDISPLAYSTREAM") (CL:UNWIND-PROTECT (LET ((ACTUALWINDOW (OR WINDOW PROMPTWINDOW))) (if WINDOW then (SETQ OLDTTY (TTYDISPLAYSTREAM WINDOW)) (SETQ \CURRENTDISPLAYLINE (fetch (MAILFOLDER CURRENTPROMPTLINE) of FOLDER)) (* ; "Do this second because TTYDISPLAYSTREAM smashes it.")) (if FORMAT-P then (if (EQ (CAR ARGS) T) then (* ; "First arg of T means clear window first.") (CLEARW ACTUALWINDOW) (SETQ ARGS (CDR ARGS))) (CL:APPLY (FUNCTION CL:FORMAT) ACTUALWINDOW ARGS) else (for ARG in ARGS do (COND ((EQ ARG T) (CLEARW ACTUALWINDOW)) (T (PRIN3 ARG ACTUALWINDOW)))))) (if WINDOW then (* ;; "Now clean up the mess. Note position for next time.") (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with \CURRENTDISPLAYLINE) (TTYDISPLAYSTREAM OLDTTY) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* ; "Get rid of process handle") (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with T))) NIL)) -) - -(LAB.PAGEFULLFN -(LAMBDA (PW) (* ; "Edited 14-Oct-87 16:54 by bvm:") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (* ; "\Currentdisplayline is the line we're on when window fills, origin zero") (LET ((MAIN (MAINWINDOW PW)) FOLDER) (GETPROMPTWINDOW MAIN (+ 1 \#DISPLAYLINES)) (if (SETQ FOLDER (WINDOWPROP MAIN (QUOTE MAILFOLDER))) then (* ; "Note that we expanded window so that we can shrink it back later") (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with T)))))) -) - -(\LAFITE.MAYBE.CLEAR.PROMPT -(LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 15:35 by bvm:") (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") (LET (PW) (COND ((AND (fetch (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER) (OPENWP (SETQ PW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)))) (CLEARW PW) (if (fetch (MAILFOLDER BROWSERPROMPTGREW) of FOLDER) then (* ; "Window grew") (LET (PROP HEIGHT) (SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (WINDOWPROP PW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (* ; "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") (WINDOWPROP PW (QUOTE MAXSIZE) (CONS 64000 HEIGHT)) (SHAPEW PW (create REGION using (WINDOWPROP PW (QUOTE REGION)) HEIGHT _ HEIGHT)) (CLEARW PW) (* ; "Clear it again to get coordinates right.") (if (SETQ PROP (WINDOWPROP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE PROMPTWINDOW))) then (* ; "Main window thinks it knows how tall the prompt window is.") (RPLACD PROP 1)) (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with NIL) (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with 0))) (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with NIL))))) -) -) - -(PUTPROPS LAB.PROMPTPRINT ARGNAMES (NIL (FOLDER &REST ARGS))) - -(PUTPROPS LAB.FORMAT ARGNAMES (NIL (FOLDER &REST ARGS))) - -(PUTPROPS LAB.MOUSECONFIRM ARGNAMES (NIL (FOLDER FORMAT-STRING &REST ARGS))) -(DEFINEQ - -(PRINTMESSAGESUMMARY -(LAMBDA (MSG FOLDER WINDOW) (* ; "Edited 5-May-89 12:15 by bvm") (PROG ((*PRINT-BASE* 10) (DIGITWIDTH (fetch (MAILFOLDER BROWSERDIGITWIDTH) of FOLDER)) FROMSTR HERE THERE EXTENT MSG#) (OR (fetch (LAFITEMSG PARSED?) of MSG) (LAFITE.PARSE.MSG.FOR.TOC MSG FOLDER)) (MOVETO 0 (MESSAGE#.TO.YPOS MSG FOLDER) WINDOW) (POSITION WINDOW 0) (LA.SHOW.MARK MSG FOLDER) (DSPXPOSITION (+ (fetch (MAILFOLDER ORDINALXPOS) of FOLDER) (TIMES DIGITWIDTH (COND ((< (SETQ MSG# (fetch (LAFITEMSG %#) of MSG)) 10) 3) ((< MSG# 100) 2) ((< MSG# 1000) 1) (T 0)))) WINDOW) (* ; "Ugh. Manually right-justify message # given that font may be variable width") (PRIN3 MSG# WINDOW) (LET ((DATE (OR (fetch (LAFITEMSG DATE) of MSG) (if (fetch (LAFITEMSG DATEKNOWN?) of MSG) then (* ; "Convert idate to date") (replace (LAFITEMSG DATE) of MSG with (GDATE1-6 (fetch (LAFITEMSG IDATE) of MSG)))) UNSUPPLIEDFIELDSTR))) (DSPXPOSITION (+ (fetch (MAILFOLDER DATEXPOS) of FOLDER) (if (DIGITCHARP (NTHCHARCODE DATE 2)) then 0 else (* ; "for 1-digit day, try to get the digits to line up") DIGITWIDTH)) WINDOW) (PRIN3 DATE WINDOW)) (DSPXPOSITION (fetch (MAILFOLDER FROMXPOS) of FOLDER) WINDOW) (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (PRIN3 "To: " WINDOW) (SETQ FROMSTR (OR (fetch (LAFITEMSG TO) of MSG) (LAFITE.FETCH.TO.FIELD MSG FOLDER)))) (T (SETQ FROMSTR (OR (fetch (LAFITEMSG FROM) of MSG) UNSUPPLIEDFIELDSTR)))) (PRIN3 FROMSTR WINDOW) (COND ((> (SETQ HERE (DSPXPOSITION NIL WINDOW)) (SETQ THERE (fetch (MAILFOLDER FROMMAXXPOS) of FOLDER))) (* ; "Erase the overflow") (DSPBACKUP (- HERE THERE) WINDOW))) (DSPXPOSITION (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER) WINDOW) (PRIN3 (OR (fetch (LAFITEMSG SUBJECT) of MSG) UNSUPPLIEDFIELDSTR) WINDOW) (PRIN3 " [" WINDOW) (PRIN3 (fetch (LAFITEMSG MESSAGELENGTH) of MSG) WINDOW) (PRIN3 " chars]" WINDOW) (* ;; "keep track of maximum width printed to. If header is allowed to print on two lines, $$MAXWIDTH$$ was set to right margin by BUILDBROWSERMAP so this should not reset it.") (COND ((< (fetch (MAILFOLDER BROWSERMAXXPOS) of FOLDER) (SETQ HERE (DSPXPOSITION NIL WINDOW))) (replace (MAILFOLDER BROWSERMAXXPOS) of FOLDER with HERE) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) with HERE) (WINDOWPROP WINDOW (QUOTE EXTENT) EXTENT))) (COND ((fetch (LAFITEMSG SELECTED?) of MSG) (LA.SHOW.SELECTION FOLDER MSG (QUOTE REPLACE)))) (COND ((fetch (LAFITEMSG DELETED?) of MSG) (LA.SHOW.DELETION FOLDER MSG WINDOW (QUOTE REPLACE)))))) -) - -(FIRSTVISIBLEMESSAGE -(LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 12:22") (* ;; "Computes number of the first message in MAILFOLDER that is visible in REGION") (IMAX 1 (IQUOTIENT (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (+ (fetch (REGION TOP) of (OR REGION (DSPCLIPPINGREGION NIL (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)))) (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) -) - -(LASTVISIBLEMESSAGE -(LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 11:33") (* ;; "Computes number of the last message in MAILFOLDER that is visible in REGION") (IMIN (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) (IQUOTIENT (+ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (- (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)))) (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER))) (SUB1 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) -) - -(LAB.DISPLAYLINES -(LAMBDA (FOLDER FIRST# LAST# REGION CLEAR) (* ; "Edited 28-Apr-89 18:48 by bvm") (* ;; "Display toc line for messages FIRST# thru LAST# (default to extreme). If REGION is given, only display messages visible in the region (default is the browser window's clipping region). If CLEAR is true, clear the region first (otherwise, caller has cleared it).") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (REG (OR REGION (DSPCLIPPINGREGION NIL WINDOW))) (MIN# (FIRSTVISIBLEMESSAGE FOLDER REGION)) (MAX# (LASTVISIBLEMESSAGE FOLDER REGION)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (if (AND FIRST# (> FIRST# MIN#)) then (SETQ MIN# FIRST#)) (if (AND LAST# (< LAST# MAX#)) then (SETQ MAX# LAST#)) (if CLEAR then (DSPFILL (LET ((LINEHEIGHT (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) (create REGION LEFT _ 0 BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) of FOLDER) (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER) (TIMES LINEHEIGHT MAX#)) WIDTH _ MAX.SMALLP HEIGHT _ (TIMES LINEHEIGHT (ADD1 (- MAX# MIN#))))) WHITESHADE (QUOTE REPLACE) WINDOW)) (for MSG# from MIN# to MAX# do (PRINTMESSAGESUMMARY (NTHMESSAGE MESSAGES MSG#) FOLDER WINDOW)))) -) - -(LAB.EXPOSEMESSAGE -(LAMBDA (MAILFOLDER MSGDESCRIPTOR) (* bvm%: "24-Dec-83 19:00") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) CLIPREGION) (COND ((OR (IGREATERP (fetch (REGION BOTTOM) of (SETQ CLIPREGION (DSPCLIPPINGREGION NIL WINDOW))) YPOS) (ILESSP (fetch (REGION TOP) of CLIPREGION) YPOS)) (SCROLLBYREPAINTFN WINDOW 0 (IPLUS (fetch (REGION BOTTOM) of CLIPREGION) (IQUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) 2) (IMINUS YPOS))))))) -) - -(LAB.SELECTED.MESSAGES -(LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 16:15 by bvm:") (* ;; "Return a list of message descriptors currently selected") (for MSG selectedin FOLDER collect MSG)) -) - -(UNSELECTALLMESSAGES -(LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 16:21") (for N from (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) to (fetch LASTSELECTEDMESSAGE of MAILFOLDER) bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) do (LA.DESELECTRANGE MAILFOLDER N N) (LA.SHOW.SELECTION MAILFOLDER (NTHMESSAGE MESSAGES N) (QUOTE ERASE)))) -) - -(SELECTMESSAGE -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "15-Feb-84 12:34") (PROG ((N (fetch (LAFITEMSG %#) of MSGDESCRIPTOR))) (LA.SELECTRANGE MAILFOLDER N N T) (LA.SHOW.SELECTION MAILFOLDER MSGDESCRIPTOR (QUOTE REPLACE)))) -) - -(LAB.GO.TO.MESSAGE -(LAMBDA (FOLDER N) (* ; "Edited 23-Aug-88 18:14 by bvm") (* ;; "Jump to nth message in folder. N must be in range, or be a msg object in the folder. Returns the message object") (LET ((MSG (if (type? LAFITEMSG N) then N else (\DTEST (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) N) (QUOTE LAFITEMSG))))) (UNSELECTALLMESSAGES FOLDER) (LAB.EXPOSEMESSAGE FOLDER MSG) (LA.SHOW.SELECTION FOLDER MSG (QUOTE REPLACE)) (replace (LAFITEMSG SELECTED?) of MSG with T) (replace FIRSTSELECTEDMESSAGE of FOLDER with (replace LASTSELECTEDMESSAGE of FOLDER with (fetch (LAFITEMSG %#) of MSG))) MSG)) -) - -(MARKMESSAGE -(LAMBDA (MSG FOLDER MARK) (* ; "Edited 25-Apr-89 17:54 by bvm") (* ;;; "Changes the mark byte of MSGDESCRIPTOR to be MARK. This may also imply something about SEEN?") (replace (LAFITEMSG MARKCHAR) of MSG with MARK) (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) (LAB.MARKS.CHANGED MSG FOLDER) (COND ((OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (LA.SHOW.MARK MSG FOLDER)) (T (* ; "Wait until browser expanded before showing mark update") (PROG ((N (fetch (LAFITEMSG %#) of MSG)) (OLDU (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) (COND ((OR (NULL OLDU) (> OLDU N)) (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with N))))))) -) - -(LAB.MARKS.CHANGED -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:50 by bvm") (* ;; "Call this whenever you change one of the 3 mark bytes (seen, deleted, mark) of a message.") (LET ((N (fetch (LAFITEMSG %#) of MSG))) (if (< N (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with N))) (replace (LAFITEMSG MARKSCHANGED?) of MSG with T) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T)) -) - -(LA.SHOW.MARK -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "17-Feb-84 15:34") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) (MARK (fetch (LAFITEMSG MARKCHAR) of MSGDESCRIPTOR))) (LA.BLT.MARK.BOX MAILFOLDER WINDOW YPOS (QUOTE REPLACE) WHITESHADE) (* ; "Erase whatever's there") (COND ((NEQ MARK (CHARCODE SPACE)) (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) (BOUT WINDOW MARK))))) -) - -(LA.INVERT.MARK.BOX -(LAMBDA (MAILFOLDER MSG#) (* bvm%: "17-Feb-84 14:44") (LA.BLT.MARK.BOX MAILFOLDER (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) (MESSAGE#.TO.YPOS (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER) MSG#) MAILFOLDER) (QUOTE INVERT) BLACKSHADE)) -) - -(LA.BLT.MARK.BOX -(LAMBDA (MAILFOLDER WINDOW YPOS OPERATION TEXTURE) (* ; "Edited 3-Sep-87 18:02 by bvm:") (BLTSHADE TEXTURE WINDOW BROWSERMARKXPOSITION (- YPOS (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER)) (- (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER) BROWSERMARKXPOSITION) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) OPERATION)) -) - -(LA.SHOW.DELETION -(LAMBDA (MAILFOLDER MSGDESCRIPTOR WINDOW OPERATION) (* ; "Edited 3-Sep-87 16:23 by bvm:") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that MSGDESCRIPTOR is deleted") (BLTSHADE BLACKSHADE WINDOW BROWSERMARKXPOSITION (- (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) 1)) (LRSH LAFITEDELETEDLINEHEIGHT 1)) NIL LAFITEDELETEDLINEHEIGHT OPERATION)) -) - -(LA.SHOW.SELECTION -(LAMBDA (MAILFOLDER MSGDESCRIPTOR OPERATION) (* bvm%: " 2-Feb-84 12:37") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that MSGDESCRIPTOR is selected") (BITBLT LA.SELECTION.BITMAP 0 0 (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) 0 (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) 1) -5) NIL NIL (QUOTE INPUT) OPERATION)) -) - -(SEENMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") (* ;;; "causes the 'seen character' -- as opposed to the 'seen mark' -- to be changed to 'S' on the file") (LET ((OLDMARK (fetch (LAFITEMSG MARKCHAR) of MSG))) (COND ((OR (NULL (fetch (LAFITEMSG SEEN?) of MSG)) (UNSEENMARKP OLDMARK)) (replace (LAFITEMSG SEEN?) of MSG with T) (LAB.MARKS.CHANGED MSG FOLDER) (COND ((UNSEENMARKP OLDMARK) (* ;; "only change the mark if it was ? -- it might already be something more meaningful like an answer mark") (MARKMESSAGE MSG FOLDER SEENMARK))))))) -) - -(DELETEMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:53 by bvm") (replace (LAFITEMSG DELETED?) of MSG with T) (LAB.MARKS.CHANGED MSG FOLDER) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with T) (LA.SHOW.DELETION FOLDER MSG (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE REPLACE))) -) - -(UNDELETEMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") (if (fetch (LAFITEMSG DELETED?) of MSG) then (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (replace (LAFITEMSG DELETED?) of MSG with NIL) (LAB.MARKS.CHANGED MSG FOLDER) (LA.SHOW.DELETION FOLDER MSG WINDOW (QUOTE ERASE)) (* ; "undeleted; reprint the header.") (PRINTMESSAGESUMMARY MSG FOLDER WINDOW) (* ; "Finally, maybe clear the expungeable flag if this was the last deleted message") (LAB.SET.EXPUNGEABILITY FOLDER)))) -) - -(LAB.SET.EXPUNGEABILITY -(LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 17:46 by bvm") (* ;; "Sets the FOLDERNEEDSEXPUNGE flag according to whether any messages are marked deleted, and returns the number of the first deleted message (or NIL if none).") (LET ((FIRSTDELETED (for I from 1 to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) thereis (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE MESSAGES I))))) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with FIRSTDELETED) FIRSTDELETED)) -) -) - - - -(* ; "ICON stuff") - - -(FILESLOAD ICONW) -(DEFINEQ - -(LAB.ICONFN -(LAMBDA (WINDOW OLDICON) (* ; "Edited 20-Apr-89 19:38 by bvm") (* ;;; "the holding place for all the fancy stuff for making an icon for a mail broswer window") (OR (WINDOWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))) (LET ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) ICON) (SETQ ICON (TITLEDICONW LAFITE.FOLDER.ICON (COND (MAILFOLDER (LA.SHORTFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) LAFITEMAIL.EXT)) (T "??")) NIL (OR (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) (SELECTQ LAFITE.BROWSER.ICON.PREFERENCE ((:ASK ASK) (* ; "force prompt") NIL) (NIL (LA.POSITION.FROM.REGION (WINDOWPROP WINDOW (QUOTE REGION)))) (CL:FUNCALL LAFITE.BROWSER.ICON.PREFERENCE WINDOW))) T NIL (QUOTE FILE))) (WINDOWPROP ICON (QUOTE BUTTONEVENTFN) (FUNCTION LAB.ICON.BUTTONEVENTFN)) ICON))) -) - -(LAB.ICON.BUTTONEVENTFN -(LAMBDA (ICONW) (* ; "Edited 23-Aug-88 18:30 by bvm") (* ;; "BUTTONEVENTFN for browser windows. This one is like the default, except that middle button offers choices") (COND ((LASTMOUSESTATE MIDDLE) (LET (HOW) (if (AND (fetch (MAILFOLDER FOLDERGETSMAIL) of (WINDOWPROP (WINDOWPROP ICONW (QUOTE ICONFOR)) (QUOTE MAILFOLDER))) (SETQ HOW (MENU (OR LAFITEBROWSERICONMENU (SETQ LAFITEBROWSERICONMENU (\LAFITE.CREATE.MENU LAFITEBROWSERICONMENUITEMS NIL T)))))) then (* ; "Folder accepts new mail, and offer was accepted") (CL:FUNCALL HOW ICONW) else (* ; "No menu selection, just expand as you otherwise would") (EXPANDW ICONW)))) (T (MOVEW ICONW)))) -) -) - -(RPAQQ LAFITE.FOLDER.ICON (#*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@C@@@@@@@@L@@@@@@@@@@@@@@@@@@F@@@@@@@@F@@@@@@@@@@@@@@@@@@L@DA@@@@@C@@@@@@@@@@@@@@@@@@L@FC@@@@@C@@@@@@@@@@@@@@@@@@L@EE@HGB@C@@@@@@@@@@@@@@@@@@L@EEADBB@C@@@@@@@@@@@@@@@@@@L@DIBBBB@COOOOOOOOOOOOOOL@@@L@DACNBB@COOOOOOOOOOOOOOL@@@L@DABBGCL@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@FL@@@@@@@@@@@@@@@@@@@@@@C@@@CL@@@@@@@@@@@@@@@@@@@@@@C@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ -#*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@COOOOOOOOL@@@@@@@@@@@@@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ (8 4 88 51))) - -(RPAQ? LAFITEFROMFRACTION 0.3) - -(RPAQ? LAFITEMINFROMCHARS 15) - -(RPAQ? LAFITEVERIFYFLG T) - -(RPAQ? LAFITEDELETEDLINEHEIGHT 1) - -(RPAQ? LAFITE.BROWSER.ICON.PREFERENCE) - -(RPAQQ LAFITEBROWSERMENUITEMS (("Display" (QUOTE \LAFITE.DISPLAY) "Displays the selected message in the display window.") ("Delete" (QUOTE \LAFITE.DELETE) "Deletes the selected messages.") ("Undel" (QUOTE \LAFITE.UNDELETE) "Undeletes the selected messages.") ("Answer" (QUOTE \LAFITE.ANSWER) "Prepares a delivery form to reply to the selected message.") ("Forward" (QUOTE \LAFITE.FORWARD) "Prepares a delivery form to forward the selected message(s).") (HCopy (QUOTE \LAFITE.HARDCOPY) "Sends hardcopy of the selected message(s) to the default printer") ("Move To" (QUOTE \LAFITE.MOVETO) "Moves the selected message(s) to another mail folder.") ("Update" (QUOTE \LAFITE.UPDATE) "Write out browser changes to the physical mail file. - Option to expunge all deleted messages.") ("Get Mail" (QUOTE \LAFITE.GETMAIL) "Retrieves new messages and puts them into this mail folder."))) - -(RPAQQ LAFITESUBBROWSEMENUITEMS (("Browse" (QUOTE \LAFITE.BROWSE.PROC) "Browse a mail file") ("Browse & Forget" (QUOTE \LAFITE.BROWSE.FORGET) "Browse a mail file, but don't add it to the menu of known folders") ("Forget Folders" (QUOTE \LAFITE.UNCACHE.FOLDER) "Remove one or more folders from list of known folders") ("Forget Message Form" (QUOTE \LAFITE.UNCACHE.MESSAGEFORM) "Remove a form from list of known message forms, -but do not delete the file containing it.") ("Delete Message Form" (QUOTE \LAFITE.DELETE.MESSAGEFORM) "Remove a form from list of known message forms -and delete the file(s) containing it.") ("Notice Folders" (QUOTE \LAFITE.NOTICE.FOLDERS) "Scan specified directory and add any folders found to the list of known folders") ("Clean up Folders" (QUOTE \LAFITE.GC.FOLDERS) "Check that all known folders correspond to actual files; remove those that no longer exist") ("Rename Folder" (QUOTE \LAFITE.RENAME.FOLDER) "Change the name of a folder") ("Edit Folder Hierarchy" (QUOTE \LAFITE.EDIT.HIERARCHY) "Add, delete, or change membership of a folder group" (SUBITEMS ("Edit a Group" (QUOTE \LAFITE.EDIT.HIERARCHY) "Modify an existing group") ("Add New Group" (QUOTE (LAMBDA (ITEM MENU) (\LAFITE.ADD.NEW.GROUP))) "Define a new top-level group") ("Change Top-Level Groups" (QUOTE \LAFITE.CHANGE.TOP.GROUPS) "Specify which subgroups should also appear at top level."))))) - -(RPAQQ LAFITEBROWSERICONMENUITEMS (("Get Mail" (QUOTE \LAFITE.GETMAIL.FROM.ICON) "Open this window and retrieve new mail into it"))) - -(RPAQ? LAFITESUBBROWSEMENU) - -(RPAQ? LAFITEBROWSERICONMENU) - -(RPAQ? LAFITEEXTRAMENU) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) -) - -(ADDTOVAR LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) - -(ADDTOVAR LAFITEEXTRAMENUITEMS ("Describe Folder" (QUOTE \LAFITE.DESCRIBE.FOLDER) "Display some relevant info about this folder" (SUBITEMS ("Inspect Folder" (QUOTE INSPECT) "Inspect the MAILFOLDER data structure associated with this browser")))) - -(RPAQQ BROWSERMARKXPOSITION 8) - -(RPAQQ LA.SELECTION.BITMAP #*(8 10)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@@@@@) - - - -(* ; "Obsolete") - - -(RPAQ? LAFITEBROWSERREGION (CREATEREGION 30 30 575 210)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) -(DECLARE%: EVAL@COMPILE - -(RPAQQ TS.IDLE 0) - -(RPAQQ TS.REPLACING 1) - -(RPAQQ TS.ADDING 2) - -(RPAQQ TS.REMOVING 3) - -(RPAQQ TS.EXTENDING.HI 4) - -(RPAQQ TS.EXTENDING.LO 5) - -(RPAQQ TS.SHRINKING.HI 6) - -(RPAQQ TS.SHRINKING.LO 7) - - -(CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) -) - - -(CL:PROCLAIM (QUOTE (CL:SPECIAL \CURRENTDISPLAYLINE))) - - -(FILESLOAD (SOURCE) LAFITEDECLS) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA) - -(ADDTOVAR NLAML) - -(ADDTOVAR LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT) -) -(PUTPROPS LAFITEBROWSE COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3692 18728 (\LAFITE.BROWSE 3702 . 4228) (\LAFITE.SUBBROWSE 4230 . 4469) ( -\LAFITE.BROWSE.PROC 4471 . 5058) (\LAFITE.BROWSE.FORGET 5060 . 5461) (LAFITE.BROWSE.FOLDER 5463 . 6595 -) (\LAFITE.PREPARE.BROWSER 6597 . 7758) (\LAFITE.MAYBE.OPEN.FOLDER 7760 . 9635) (LAB.LOADFOLDER 9637 - . 9951) (LAB.DISPLAYFOLDER 9953 . 10877) (LAB.MAKE.INITIAL.SELECTION 10879 . 11614) (LAB.CREATEWINDOW - 11616 . 16400) (LAB.TITLE.STRING 16402 . 17385) (LAB.COMMANDFN 17387 . 17796) (LAB.DO.COMMAND 17798 - . 18457) (LAB.ASSURE.SELECTIONS 18459 . 18726)) (18729 23245 (BUILD.LAFITE.LAYOUTS 18739 . 21404) ( -\LAFITE.LAYOUT.FROM.WINDOW 21406 . 22455) (\LAFITE.MAKE.DUMMY.WINDOWS 22457 . 23243)) (23600 36734 ( -LAB.SETUP 23610 . 26223) (LAB.BUTTONEVENTFN 26225 . 26621) (LAB.DO.UNLESS.BUSY 26623 . 26966) ( -LOADMAILFOLDER 26968 . 27863) (LAFITE.OBTAIN.FOLDER 27865 . 31781) (\LAFITE.FIND.EXISTING.FOLDER 31783 - . 32154) (\LAFITE.CONFLICTING.OLD.FOLDER 32156 . 32996) (LAB.REPAINTFN 32998 . 33395) (LAB.SCROLLFN -33397 . 33817) (LAB.RESHAPEFN 33819 . 34621) (LAB.CLOSEFN 34623 . 34745) (LAB.SHRINKFN 34747 . 34856) -(LAB.CLOSE/SHRINK 34858 . 35804) (LAB.EXPANDFN 35806 . 36477) (LAFITEEXTRABROWSERCOMMANDFN 36479 . -36732)) (36769 45147 (LAB.SELECTMESSAGE 36779 . 42313) (LAB.CHANGEMARK 42315 . 43304) ( -LA.READ.NEW.MARK 43306 . 44512) (YPOS.TO.MESSAGE# 44514 . 44891) (MESSAGE#.TO.YPOS 44893 . 45145)) ( -45148 50175 (LA.CONSIDERRANGE 45158 . 45642) (LA.DECONSIDERRANGE 45644 . 45970) (LA.RECONSIDERRANGE -45972 . 46421) (LA.SELECTRANGE 46423 . 47410) (LA.DESELECTRANGE 47412 . 48468) (LAB.FIND.SELECTED.MSG -48470 . 48704) (LAB.REV.FIND.SELECTED.MSG 48706 . 48950) (LA.UNDOSELECTION 48952 . 49177) ( -LA.VERIFY.SELECTION 49179 . 50173)) (50176 53640 (LAB.COPYBUTTONEVENTFN 50186 . 52731) ( -LAB.SHOW.COPY.SELECTION 52733 . 53638)) (53861 58341 (LAB.PROMPTPRINT 53871 . 54004) (LAB.FORMAT 54006 - . 54382) (LAB.MOUSECONFIRM 54384 . 54716) (LAB.PRINT.TO.PROMPTWINDOW 54718 . 56537) (LAB.PAGEFULLFN -56539 . 57116) (\LAFITE.MAYBE.CLEAR.PROMPT 57118 . 58339)) (58541 70320 (PRINTMESSAGESUMMARY 58551 . -61054) (FIRSTVISIBLEMESSAGE 61056 . 61519) (LASTVISIBLEMESSAGE 61521 . 62094) (LAB.DISPLAYLINES 62096 - . 63295) (LAB.EXPOSEMESSAGE 63297 . 63811) (LAB.SELECTED.MESSAGES 63813 . 64003) (UNSELECTALLMESSAGES - 64005 . 64347) (SELECTMESSAGE 64349 . 64581) (LAB.GO.TO.MESSAGE 64583 . 65209) (MARKMESSAGE 65211 . -65900) (LAB.MARKS.CHANGED 65902 . 66362) (LA.SHOW.MARK 66364 . 66815) (LA.INVERT.MARK.BOX 66817 . -67103) (LA.BLT.MARK.BOX 67105 . 67463) (LA.SHOW.DELETION 67465 . 67926) (LA.SHOW.SELECTION 67928 . -68370) (SEENMESSAGE 68372 . 68937) (DELETEMESSAGE 68939 . 69245) (UNDELETEMESSAGE 69247 . 69765) ( -LAB.SET.EXPUNGEABILITY 69767 . 70318)) (70367 71857 (LAB.ICONFN 70377 . 71177) (LAB.ICON.BUTTONEVENTFN - 71179 . 71855))))) -STOP diff --git a/library/lafite/LAFITEBROWSE.~2~ b/library/lafite/LAFITEBROWSE.~2~ deleted file mode 100644 index be815b40..00000000 --- a/library/lafite/LAFITEBROWSE.~2~ +++ /dev/null @@ -1,153 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Feb-2001 09:26:50" {DSK}medley3.5>library>LAFITEBROWSE.;4 86175 changes to%: (VARS LAFITEBROWSECOMS) (FNS PRINTMESSAGESUMMARY) previous date%: "21-Jun-99 22:42:30" {DSK}medley3.5>library>LAFITEBROWSE.;2) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1999, 2001 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITEBROWSECOMS) (RPAQQ LAFITEBROWSECOMS [(COMS (* ; "BROWSE") (FNS \LAFITE.BROWSE \LAFITE.SUBBROWSE \LAFITE.BROWSE.PROC \LAFITE.BROWSE.FORGET LAFITE.BROWSE.FOLDER \LAFITE.PREPARE.BROWSER \LAFITE.MAYBE.OPEN.FOLDER LAB.LOADFOLDER LAB.DISPLAYFOLDER LAB.MAKE.INITIAL.SELECTION LAB.CREATEWINDOW LAB.TITLE.STRING LAB.COMMANDFN LAB.DO.COMMAND LAB.ASSURE.SELECTIONS) (FNS BUILD.LAFITE.LAYOUTS \LAFITE.LAYOUT.FROM.WINDOW \LAFITE.MAKE.DUMMY.WINDOWS) (VARS LAFITE.DUMMY.SHADE LAFITE.DUMMY.HALF.SHADE) (INITVARS (\LAFITE.LAST.FOLDER.NAME)) (GLOBALVARS \LAFITE.LAST.FOLDER.NAME)) (COMS (* ; "Browser operations") (FNS LAB.SETUP LAB.BUTTONEVENTFN LAB.DO.UNLESS.BUSY LOADMAILFOLDER LAFITE.OBTAIN.FOLDER \LAFITE.FIND.EXISTING.FOLDER \LAFITE.CONFLICTING.OLD.FOLDER LAB.REPAINTFN LAB.SCROLLFN LAB.RESHAPEFN LAB.CLOSEFN LAB.SHRINKFN LAB.CLOSE/SHRINK LAB.EXPANDFN LAFITEEXTRABROWSERCOMMANDFN)) [COMS (* ; "Browser selection") (FNS LAB.SELECTMESSAGE LAB.CHANGEMARK LA.READ.NEW.MARK YPOS.TO.MESSAGE# MESSAGE#.TO.YPOS) (FNS LA.CONSIDERRANGE LA.DECONSIDERRANGE LA.RECONSIDERRANGE LA.SELECTRANGE LA.DESELECTRANGE LAB.FIND.SELECTED.MSG LAB.REV.FIND.SELECTED.MSG LA.UNDOSELECTION LA.VERIFY.SELECTION) (FNS LAB.COPYBUTTONEVENTFN LAB.SHOW.COPY.SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (P (CL:PROCLAIM '(CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*)) (CL:PROCLAIM '(GLOBAL LASTMOUSEBUTTONS] [COMS (* ; "Browser display") (FNS LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM LAB.PRINT.TO.PROMPTWINDOW LAB.PAGEFULLFN \LAFITE.MAYBE.CLEAR.PROMPT) (PROP ARGNAMES LAB.PROMPTPRINT LAB.FORMAT LAB.MOUSECONFIRM) (FNS PRINTMESSAGESUMMARY FIRSTVISIBLEMESSAGE LASTVISIBLEMESSAGE LAB.DISPLAYLINES LAB.EXPOSEMESSAGE LAB.SELECTED.MESSAGES UNSELECTALLMESSAGES SELECTMESSAGE LAB.GO.TO.MESSAGE MARKMESSAGE LAB.MARKS.CHANGED LA.SHOW.MARK LA.INVERT.MARK.BOX LA.BLT.MARK.BOX LA.SHOW.DELETION LA.SHOW.SELECTION SEENMESSAGE DELETEMESSAGE UNDELETEMESSAGE LAB.SET.EXPUNGEABILITY) (* ;; "PRINTMESSAGESUMMARY.STRING prints From and Subject. Redefined when MIME is loaded to deal with different character encodings.") (P (MOVD? 'PRIN3 'PRINTMESSAGESUMMARY.STRING] (COMS (* ; "ICON stuff") (FILES ICONW) (FNS LAB.ICONFN LAB.ICON.BUTTONEVENTFN) (VARS LAFITE.FOLDER.ICON)) (COMS (INITVARS (LAFITEFROMFRACTION 0.3) (LAFITEMINFROMCHARS 15) (LAFITEVERIFYFLG T) (LAFITEDELETEDLINEHEIGHT 1) (LAFITE.BROWSER.ICON.PREFERENCE)) (VARS LAFITEBROWSERMENUITEMS LAFITESUBBROWSEMENUITEMS LAFITEBROWSERICONMENUITEMS) (INITVARS (LAFITESUBBROWSEMENU) (LAFITEBROWSERICONMENU) (LAFITEEXTRAMENU)) (GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) [ADDVARS (LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) (LAFITEEXTRAMENUITEMS ("Describe Folder" '\LAFITE.DESCRIBE.FOLDER "Display some relevant info about this folder" (SUBITEMS ("Inspect Folder" 'INSPECT "Inspect the MAILFOLDER data structure associated with this browser" ] (VARS (BROWSERMARKXPOSITION 8)) (BITMAPS LA.SELECTION.BITMAP)) [COMS (* ; "Obsolete") (INITVARS (LAFITEBROWSERREGION (CREATEREGION 30 30 575 210] (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * TOCSTATES) [P (CL:PROCLAIM '(CL:SPECIAL \CURRENTDISPLAYLINE] (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT]) (* ; "BROWSE") (DEFINEQ (\LAFITE.BROWSE -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 17-Sep-87 19:13 by bvm:") (* ;;; "Function called by the Browse button on main Lafite window.") (LET ((SUBP (EQ BUTTON (QUOTE MIDDLE)))) (* ; "Pass the :confirm option to LAFITE.BROWSE.FOLDER to require confirmation on folder creation.") (\LAFITE.PROCESS (BQUOTE ((\, (COND (SUBP (FUNCTION \LAFITE.SUBBROWSE)) (T (FUNCTION \LAFITE.BROWSE.PROC)))) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) (\,@ (AND (NOT SUBP) (QUOTE (NIL (QUOTE (:CONFIRM)))))))) (QUOTE LAFITEBROWSE)))) -) (\LAFITE.SUBBROWSE -(LAMBDA (ITEM MENU) (* ; "Edited 3-Sep-87 18:00 by bvm:") (PROG ((COMMAND (MENU (.LAFITEMENU. LAFITESUBBROWSEMENU LAFITESUBBROWSEMENUITEMS "Browse subcommands")))) (COND (COMMAND (CL:FUNCALL COMMAND ITEM MENU))))) -) (\LAFITE.BROWSE.PROC -(LAMBDA (ITEM MENU FOLDERNAME OPTIONS) (* ; "Edited 10-Sep-87 15:19 by bvm:") (LET (MAILFOLDER) (COND ((NULL (OR FOLDERNAME (SETQ FOLDERNAME (\LAFITE.PROMPTFORFOLDER)))) (* ; "From BROWSE command, user aborted by not giving a file name") NIL) ((LISTP FOLDERNAME) (* ; "From LAFITE. Each element is (foldername browserregion displayregion iconposition . options)") (for ITEM in FOLDERNAME do (LAFITE.BROWSE.FOLDER (CAR FOLDERNAME) (CDR FOLDERNAME) (APPEND (CDDDDR FOLDERNAME) OPTIONS) ITEM MENU))) (T (LAFITE.BROWSE.FOLDER FOLDERNAME NIL OPTIONS ITEM MENU))))) -) (\LAFITE.BROWSE.FORGET -(LAMBDA (ITEM MENU) (* ; "Edited 18-Jul-88 11:41 by bvm") (LET ((FOLDERNAME (PROMPTFORFILENAME NIL \LAFITE.LAST.FOLDER.NAME))) (COND (FOLDERNAME (SETQ \LAFITE.LAST.FOLDER.NAME FOLDERNAME) (* ; "Save name as typed now in case it fails. Guy who gets the actual folder will set canonical name here.") (\LAFITE.BROWSE.PROC ITEM MENU FOLDERNAME (QUOTE (:FORGET :CONFIRM))))))) -) (LAFITE.BROWSE.FOLDER -(LAMBDA (FOLDERNAME LAYOUT OPTIONS ITEM MENU) (* ; "Edited 3-May-89 19:04 by bvm") (* ;; "Browse folder named FOLDERNAME. LAYOUT is a triple (browserregion iconposition displayregion). OPTIONS may include :SHRINK, meaning to shrink folder when finished, and :CONFIRM, meaning require confirmation before creating an empty folder. ITEM, if specified, is a menu item in MENU to shade while the browser is being prepared.") (LET ((FOLDER (RESETLST (AND ITEM (LA.RESETSHADE ITEM MENU)) (\LAFITE.PREPARE.BROWSER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) OPTIONS LAYOUT)))) (COND (FOLDER (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (if (NULL (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) then (* ; "Got a browser, but haven't loaded anything into it yet") (COND ((EQMEMB :ACTIVE OPTIONS) (replace (MAILFOLDER FOLDERGETSMAIL) of FOLDER with T))) (LAB.LOADFOLDER FOLDER) (COND ((EQMEMB :GETMAIL OPTIONS) (LAB.DO.COMMAND (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (FUNCTION \LAFITE.GETMAIL))) ((EQMEMB :SHRINK OPTIONS) (SHRINKW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)))))) FOLDER)))) -) (\LAFITE.PREPARE.BROWSER -(LAMBDA (FOLDERNAME OPTIONS LAYOUT) (* ; "Edited 7-Sep-88 12:18 by bvm") (* ;; "Get a browser on FOLDERNAME. If there already is one, we just top it, otherwise we create a new one. Returns the folder object or NIL on failure. OPTIONS are the options to browse. LAYOUT is where to put the browser if we have to create it.") (SETQ OPTIONS (CONS :BROWSE (MKLIST OPTIONS))) (WITH.MONITOR \LAFITE.BROWSELOCK (LET ((MAILFOLDER (LAFITE.OBTAIN.FOLDER FOLDERNAME (QUOTE INPUT) NIL OPTIONS)) BROWSERWINDOW STREAM) (AND MAILFOLDER (COND ((SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (* ; "Already have browser") (COND ((OPENWP BROWSERWINDOW) (TOTOPW BROWSERWINDOW)) ((NOT (FMEMB :SHRINK OPTIONS)) (* ; "Make sure the EXPANDFN runs") (EXPANDW BROWSERWINDOW))) T) ((COND ((SETQ STREAM (fetch (MAILFOLDER FOLDERSTREAM) of MAILFOLDER)) (* ; "Already have folder open, e.g., from MOVETO, but no browser yet") (SETFILEINFO STREAM (QUOTE BUFFERS) LAFITEBUFFERSIZE) T) (T (\LAFITE.MAYBE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) NIL OPTIONS))) (* ; "Success in opening") (LAB.CREATEWINDOW MAILFOLDER LAYOUT))) MAILFOLDER)))) -) (\LAFITE.MAYBE.OPEN.FOLDER -(LAMBDA (FOLDER ACCESS PROMPTFOLDER OPTIONS RETURNERRORS) (* ; "Edited 8-Sep-88 17:41 by bvm") (* ;; "Open FOLDER for indicated access, with the possibility that the file does not yet exist. If it doesn't, then create it, asking for confirmation if PROMPTFOLDER is supplied (a folder in whose browser to prompt for confirmation, or T for global prompt). Returns the stream on success. On failure, returns the condition if RETURNERRORS true, else NIL.") (PROG* ((FOLDERNAME (OR (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER))) (OLDP (EQMEMB :OLD OPTIONS)) (RECOG (AND (OR OLDP PROMPTFOLDER) (QUOTE OLD))) STREAM CONDITION) RETRY (* ;; "Just try opening. If confirmation desired, open only OLD file on first try.") (CL:MULTIPLE-VALUE-SETQ (STREAM CONDITION) (IGNORE-ERRORS (\LAFITE.OPENSTREAM FOLDERNAME ACCESS RECOG (FUNCTION \LAFITE.EOF) (EQMEMB :BROWSE OPTIONS) (QUOTE LAFITE)))) (RETURN (if CONDITION then (* ; "Failed to open") (if (AND (NEQ RECOG (QUOTE NEW)) (NOT OLDP) (TYPEP CONDITION (QUOTE XCL:FILE-NOT-FOUND))) then (* ; "Just couldn't find it, so maybe create it. If RECOG was NEW, we normally shouldn't be getting this error") (if (OR (NOT (EQMEMB :CONFIRM OPTIONS)) (LAB.MOUSECONFIRM PROMPTFOLDER "Click LEFT to confirm creating ~A" FOLDERNAME)) then (SETQ RECOG (QUOTE NEW)) (SETQ ACCESS (QUOTE BOTH)) (GO RETRY) else (* ; "Disconfirmed the create request.") NIL) elseif RETURNERRORS then (* ; "Caller wants to know why") CONDITION else (* ; "File wouldn't open for some other reason than just not existing, so report it. Should probably be a little more discriminating here.") (\LAFITE.REPORT.FILE.WONT.OPEN (AND (NEQ PROMPTFOLDER T) PROMPTFOLDER) CONDITION FOLDERNAME) NIL) else (\LAFITE.SET.FOLDER.STREAM FOLDER STREAM) (* ; "Notice name fields and such") STREAM)))) -) (LAB.LOADFOLDER -(LAMBDA (MAILFOLDER) (* ; "Edited 13-Sep-88 17:42 by bvm") (COND ((LOADMAILFOLDER MAILFOLDER) (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER with 1) (* ; "Nothing selected") (replace (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER with 0) (LAB.DISPLAYFOLDER MAILFOLDER) MAILFOLDER))) -) (LAB.DISPLAYFOLDER -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 15:50 by bvm") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (CLIPREGION (DSPCLIPPINGREGION NIL WINDOW)) MSG) (CLEARW WINDOW) (LAB.SETUP FOLDER) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (COND ((AND (SETQ MSG (LAB.MAKE.INITIAL.SELECTION FOLDER)) (< (MESSAGE#.TO.YPOS MSG FOLDER) (fetch (REGION BOTTOM) of CLIPREGION))) (* ; "Quietly scroll so that selected message is in window") (WYOFFSET (TIMES (- (fetch (LAFITEMSG %#) of MSG) (QUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) (TIMES 2 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) WINDOW))) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (LAB.PROMPTPRINT FOLDER T "Folder is empty.")) (T (LAB.DISPLAYLINES FOLDER NIL NIL CLIPREGION))))) -) (LAB.MAKE.INITIAL.SELECTION -(LAMBDA (MAILFOLDER) (* bvm%: "24-Feb-86 16:31") (LET ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSGDESCRIPTOR I) (COND ((EQ LASTMSG# 0) NIL) ((SETQ I (LAB.FIND.SELECTED.MSG MAILFOLDER 1 LASTMSG#)) (* ; "There are already selected messages") (NTHMESSAGE MESSAGES I)) (T (find old I from 1 to LASTMSG# suchthat (AND (NOT (fetch (LAFITEMSG SEEN?) of (SETQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES I)))) (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR)))) (* ;; "Found an unseen, undeleted message. If we don't find one, the last MSGDESCRIPTOR is the one to select") (SELECTMESSAGE MSGDESCRIPTOR MAILFOLDER) MSGDESCRIPTOR)))) -) (LAB.CREATEWINDOW -(LAMBDA (FOLDER LAYOUT TITLE) (* ; "Edited 20-Apr-89 16:05 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (if (NULL TITLE) then (SETQ TITLE (if FOLDER then (LAB.TITLE.STRING FOLDER) else "Dummy Browser"))) (PROG (BROWSERPROMPTWINDOW BROWSERMENUWINDOW BROWSERMENU BROWSERWINDOW WIDTH HEIGHT MENUREGION WHOLEREGION) (SETQ BROWSERMENU (create MENU ITEMS _ LAFITEBROWSERMENUITEMS CENTERFLG _ T WHENSELECTEDFN _ (if FOLDER then (FUNCTION LAB.COMMANDFN) else (FUNCTION NILL)) MENUFONT _ LAFITEMENUFONT)) (SETQ MENUREGION (WINDOWPROP (SETQ BROWSERMENUWINDOW (MENUWINDOW BROWSERMENU)) (QUOTE REGION))) (SETQ WIDTH (fetch (REGION WIDTH) of MENUREGION)) (SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (* ;; "Now figure out where to put it all") (if LAYOUT then (* ; "user tells us all. If this happens to match one of the default regions, make sure to use it instead (future test is with EQ).") (if (EQ LAYOUT T) then (* ; "Requires prompting") (SETQ LAYOUT NIL) else (for SPEC in LAFITE.BROWSER.LAYOUTS when (EQUAL SPEC LAYOUT) do (RETURN (SETQ LAYOUT SPEC)))) elseif LAFITE.BROWSER.LAYOUTS then (* ; "Take the first layout not currently in use") (for SPEC in LAFITE.BROWSER.LAYOUTS unless (for OPEN in \ACTIVELAFITEFOLDERS thereis (EQ (fetch (MAILFOLDER BROWSERLAYOUT) of OPEN) SPEC)) do (RETURN (SETQ LAYOUT SPEC))) elseif (AND LAFITEBROWSERREGION (for OPEN in \ACTIVELAFITEFOLDERS never (fetch (MAILFOLDER BROWSERWINDOW) of OPEN))) then (* ; "For backward compatibility: if there are no open browsers, use LAFITEBROWSERREGION") (SETQ LAYOUT (LIST LAFITEBROWSERREGION NIL LAFITEDISPLAYREGION))) (COND ((SETQ WHOLEREGION (LISTP (CAR LAYOUT))) (COND ((> (fetch (REGION WIDTH) of WHOLEREGION) WIDTH) (* ; "Only use specified region width if it is wide enough") (SETQ WIDTH (fetch (REGION WIDTH) of WHOLEREGION)))) (SETQ WHOLEREGION (create REGION using WHOLEREGION WIDTH _ WIDTH)) (* ; "Copy the region so we don't smash user variable")) (T (* ; "Prompt for region") (SETQ WHOLEREGION (GETBOXREGION WIDTH (TIMES HEIGHT 9) NIL NIL NIL (CONCAT "Specify region for " TITLE))))) (replace (REGION HEIGHT) of WHOLEREGION with (- (fetch (REGION HEIGHT) of WHOLEREGION) (+ HEIGHT (fetch (REGION HEIGHT) of MENUREGION)))) (* ; "Shrink user-supplied region by the combined heights of the menu and prompt window") (SETQ BROWSERWINDOW (CREATEW WHOLEREGION TITLE)) (ATTACHWINDOW BROWSERMENUWINDOW BROWSERWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (DSPFONT LAFITEBROWSERFONT BROWSERWINDOW) (SETQ BROWSERPROMPTWINDOW (GETPROMPTWINDOW BROWSERWINDOW 1 LAFITEBROWSERFONT)) (CLEARW BROWSERPROMPTWINDOW) (* ; "Get the xy set correctly for the actual font being used") (LINELENGTH MAX.SMALLP BROWSERPROMPTWINDOW) (* ; "Make LINELENGTH ignored -- we try not to overflow window anyway, and the LINELENGTH is no good for variable width font") (if FOLDER then (* ; "MAILFOLDER = NIL is used by dummy routine to set up regions") (WINDOWADDPROP BROWSERPROMPTWINDOW (QUOTE RESHAPEFN) (FUNCTION (LAMBDA (W) (LINELENGTH MAX.SMALLP W)))) (WINDOWADDPROP BROWSERPROMPTWINDOW (QUOTE RESHAPEFN) (FUNCTION RESHAPEBYREPAINTFN)) (* ; "Adding our own reshapefn overrode the default, so add the default back in.") (WINDOWPROP BROWSERPROMPTWINDOW (QUOTE PAGEFULLFN) (FUNCTION LAB.PAGEFULLFN)) (replace (MAILFOLDER ORIGINALBROWSERTITLE) of FOLDER with TITLE) (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER) FOLDER) (WINDOWPROP BROWSERWINDOW (QUOTE SCROLLFN) (FUNCTION LAB.SCROLLFN)) (replace (MAILFOLDER BROWSERWINDOW) of FOLDER with BROWSERWINDOW) (replace (MAILFOLDER BROWSERMENUWINDOW) of FOLDER with BROWSERMENUWINDOW) (replace (MAILFOLDER BROWSERMENU) of FOLDER with BROWSERMENU) (replace (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER with BROWSERPROMPTWINDOW) (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (CADDR LAYOUT)) (replace (MAILFOLDER BROWSERLAYOUT) of FOLDER with LAYOUT) (WINDOWPROP BROWSERWINDOW (QUOTE REPAINTFN) (FUNCTION LAB.REPAINTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION LAB.ICONFN)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONPOSITION) (CADR LAYOUT)) (WINDOWPROP BROWSERWINDOW (QUOTE BUTTONEVENTFN) (FUNCTION LAB.BUTTONEVENTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION LAB.BUTTONEVENTFN)) (WINDOWPROP BROWSERWINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION LAB.COPYBUTTONEVENTFN)) (* ; "make sure Lafite has the first CLOSEFN and SHRINKFN") (WINDOWADDPROP BROWSERWINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (WINDOWADDPROP BROWSERWINDOW (QUOTE RESHAPEFN) (FUNCTION LAB.RESHAPEFN))) (RETURN BROWSERWINDOW))) -) (LAB.TITLE.STRING -(LAMBDA (FOLDER) (* ; "Edited 24-Oct-88 18:07 by bvm") (* ;; "Returns string to be used for FOLDER's browser's title. It is arranged to convey as much info as possible before it falls off the right edge of the window.") (LET* ((DEST (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER)) (FIELDS (UNPACKFILENAME.STRING (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER))) (BODY (FMEMB (QUOTE NAME) FIELDS))) (RPLACD (NLEFT FIELDS 1 BODY)) (* ; "detach name.ext;version from host/directory") (CONCAT "Browsing " (if (STRING-EQUAL (LISTGET BODY (QUOTE EXTENSION)) LAFITEMAIL.EXT) then (* ; "Just the name field will do") (LISTGET BODY (QUOTE NAME)) else (CL:APPLY (FUNCTION PACKFILENAME.STRING) BODY)) (if DEST then (CONCAT " (Move To: " (fetch (MAILFOLDER SHORTFOLDERNAME) of DEST) ")") else "") " on " (if (U-CASEP (SETQ FIELDS (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS))) then (CL:STRING-CAPITALIZE FIELDS) else (* ; "Leave the capitalization alone") FIELDS)))) -) (LAB.COMMANDFN -(LAMBDA (ITEM MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) (LET ((MENUW (WFROMMENU MENU)) WINDOW FOLDER) (AND MENUW (SETQ WINDOW (WINDOWPROP MENUW (QUOTE MAINWINDOW))) (SETQ FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) WINDOW FOLDER ITEM MENU KEY)))) -) (LAB.DO.COMMAND -(LAMBDA (WINDOW ITEM/FN MENU KEY) (* ; "Edited 18-Jul-88 11:41 by bvm") (* ;; "Runs some browser command--variant on LAB.COMMANDFN to be called programmatically. If ITEM/FN is a function name, we get the real item and MENU from the window.") (OR \LAFITE.READY (\LAFITE.MARK.FOLDERS.OBSOLETE)) (LET ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (AND FOLDER (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (CL:FUNCALL (if (LITATOM ITEM/FN) then (PROG1 ITEM/FN (OR MENU (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (SETQ ITEM/FN (LA.MENU.ITEM ITEM/FN MENU))) else (EXTRACTMENUCOMMAND ITEM/FN)) WINDOW FOLDER ITEM/FN MENU KEY)))) -) (LAB.ASSURE.SELECTIONS -(LAMBDA (MAILFOLDER) (* bvm%: " 3-Feb-86 14:44") (COND ((IGREATERP (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (LAB.PROMPTPRINT MAILFOLDER T "No messages selected.") T))) -) ) (DEFINEQ (BUILD.LAFITE.LAYOUTS -(LAMBDA NIL (* ; "Edited 23-Nov-87 16:48 by bvm:") (LET (DUMMYWINDOWS) (CL:UNWIND-PROTECT (PROG ((ICONBM (fetch (TITLEDICON ICON) of LAFITE.FOLDER.ICON)) (N 0) W MAILFOLDER LAYOUTS LAYOUT CURRENT OLDLAYOUTS POS) (if (AND (LISTP LAFITE.BROWSER.LAYOUTS) (CL:Y-OR-N-P "Do you wish to retain the ~D browser specifications you already have? " (LENGTH LAFITE.BROWSER.LAYOUTS))) then (SETQ OLDLAYOUTS LAFITE.BROWSER.LAYOUTS) (for LAYOUT in OLDLAYOUTS do (for FOLDER in \ACTIVELAFITEFOLDERS when (EQ (fetch (MAILFOLDER BROWSERLAYOUT) of FOLDER) LAYOUT) do (add N 1) (RETURN (CL:FORMAT T "Retaining layout in use by ~A.~%%" (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER))) finally (* ; "Display dummy browser and icon to aid in positioning.") (SETQ W (LAB.CREATEWINDOW NIL LAYOUT (CONCAT "Sample Browser " (add N 1)))) (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W LAYOUT N)))) (SETQ LAYOUTS (REVERSE OLDLAYOUTS))) (CL:FORMAT T "Click in preference order in each browser or browser icon whose current layout you wish to include; click in background to finish~%%") (while (SETQ W (WHICHW (GETPOSITION))) do (if (AND (NOT (SETQ MAILFOLDER (WINDOWPROP W (QUOTE MAILFOLDER)))) (OR (NOT (SETQ W (WINDOWPROP W (QUOTE ICONFOR)))) (NOT (SETQ MAILFOLDER (WINDOWPROP W (QUOTE MAILFOLDER)))))) then (CL:FORMAT T "That's not a Lafite browser window/icon; try again.~%%") elseif (OR (MEMB (fetch (MAILFOLDER BROWSERLAYOUT) of MAILFOLDER) OLDLAYOUTS) (MEMBER (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW W MAILFOLDER ICONBM)) LAYOUTS)) then (CL:FORMAT T "You have already included that browser's specification.~%%") else (* ; "It's a Lafite browser window or icon.") (push LAYOUTS LAYOUT) (CL:FORMAT T "Browser for ~A noted.~%%" (fetch (MAILFOLDER SHORTFOLDERNAME) of MAILFOLDER)) (add N 1))) (while (OR (NULL LAYOUTS) (MENU (create MENU ITEMS _ (QUOTE (("Specify another browser" T) ("Finish" (QUOTE NIL)))) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))) do (SETQ W (LAB.CREATEWINDOW NIL T (CONCAT "Sample Browser " (add N 1)))) (push DUMMYWINDOWS (\LAFITE.MAKE.DUMMY.WINDOWS W (SETQ LAYOUT (\LAFITE.LAYOUT.FROM.WINDOW W NIL ICONBM)) N)) (push LAYOUTS LAYOUT)) (RETURN (if (AND LAYOUTS (MOUSECONFIRM "Click LEFT to confirm setting LAFITEBROWSERLAYOUTS to these values" T T T)) then (/SETTOPVAL (QUOTE LAFITE.BROWSER.LAYOUTS) (REVERSE LAYOUTS)) (MARKASCHANGED (QUOTE LAFITE.BROWSER.LAYOUTS) (QUOTE VARS)) LAFITE.BROWSER.LAYOUTS))) (* ;; "Cleanup dummy windows put up earlier") (for X in DUMMYWINDOWS bind TMP do (CLOSEW X) (if (SETQ TMP (WINDOWPROP X (QUOTE DUMMY.ICON))) then (CLOSEW TMP)) (if (SETQ TMP (WINDOWPROP X (QUOTE DUMMY.DISPLAY))) then (CLOSEW TMP)))))) -) (\LAFITE.LAYOUT.FROM.WINDOW -(LAMBDA (W FOLDER ICONBM) (* ; "Edited 10-Dec-87 17:15 by bvm:") (* ;; "Return a browser layout spec corresponding to window W optionally containing FOLDER.") (LET ((PW (if (OPENWP W) then (GETPROMPTWINDOW W 1 LAFITEBROWSERFONT) else PROMPTWINDOW))) (LIST (WINDOWREGION W) (if (WINDOWPROP W (QUOTE ICONPOSITION)) else (CLEARW PW) (CL:FORMAT PW "Specify position for icon.") (PROG1 (GETBOXPOSITION (BITMAPWIDTH ICONBM) (BITMAPHEIGHT ICONBM)) (CLEARW PW))) (PROG (CURRENT) (if FOLDER then (* ; "Use current values, if known") (RETURN (OR (if (CAR (SETQ CURRENT (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER))) then (* ; "take current primary window region") (COPY (WINDOWPROP (CAR CURRENT) (QUOTE REGION))) elseif (COPY (fetch (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER))) (GO PROMPT)))) PROMPT (CLEARW PW) (CL:FORMAT PW "Specify region for display window") (RETURN (PROG1 (if LAFITE.DISPLAY.SIZE then (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) (CDR LAFITE.DISPLAY.SIZE) NIL NIL) else (GETREGION)) (CLEARW PW))))))) -) (\LAFITE.MAKE.DUMMY.WINDOWS -(LAMBDA (MAINW LAYOUT N) (* ; "Edited 23-Nov-87 16:44 by bvm:") (LET (TMP SUBW) (DSPFILL NIL LAFITE.DUMMY.SHADE (QUOTE REPLACE) MAINW) (WINDOWPROP MAINW (QUOTE SHRINKFN) (QUOTE DON'T)) (if (SETQ TMP (CADR LAYOUT)) then (* ; "An icon position is given") (SETQ SUBW (TITLEDICONW LAFITE.FOLDER.ICON (CONCAT "Icon " N) LAFITETITLEFONT TMP)) (ICONW.SHADE SUBW LAFITE.DUMMY.HALF.SHADE) (WINDOWPROP SUBW (QUOTE BUTTONEVENTFN) (FUNCTION ICONBUTTONEVENTFN)) (WINDOWPROP MAINW (QUOTE DUMMY.ICON) SUBW)) (if (SETQ TMP (CADDR LAYOUT)) then (* ; "A display region is given") (SETQ SUBW (CREATEW TMP (CONCAT "Lafite Display window " N) LAFITETITLEFONT TMP)) (DSPFILL NIL LAFITE.DUMMY.SHADE (QUOTE REPLACE) SUBW) (WINDOWPROP MAINW (QUOTE DUMMY.DISPLAY) SUBW)) MAINW)) -) ) (RPAQQ LAFITE.DUMMY.SHADE #*(16 16)@L@HA@@FALD@@DJ@AHF@@@JDH@NFD@@EDD@EDJ@EDJD@@LD@@HD@@HDD@@DJ@@DL) (RPAQQ LAFITE.DUMMY.HALF.SHADE #*(16 16)@H@@A@@D@@D@@DB@A@D@@@HDH@DB@@@DDD@A@B@DDHD@@D@@@@D@@H@D@@DJ@@@@) (RPAQ? \LAFITE.LAST.FOLDER.NAME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LAFITE.LAST.FOLDER.NAME) ) (* ; "Browser operations") (DEFINEQ (LAB.SETUP -(LAMBDA (MAILFOLDER) (* bvm%: "31-Jul-84 14:39") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) WIDTH HEIGHT TOTALHEIGHT ASCENT DIGITWIDTH SPACEWIDTH XPOS) (CLEARW WINDOW) (SETQ LAFITEBROWSERFONT (FONTCREATE LAFITEBROWSERFONT)) (DSPFONT LAFITEBROWSERFONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH 10000 WINDOW) (replace (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER with (SETQ HEIGHT (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (replace (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER with (SETQ ASCENT (FONTPROP LAFITEBROWSERFONT (QUOTE ASCENT)))) (replace (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER with (FONTPROP LAFITEBROWSERFONT (QUOTE DESCENT))) (replace (MAILFOLDER BROWSERORIGIN) of MAILFOLDER with (+ (DSPYPOSITION NIL WINDOW) ASCENT)) (replace (MAILFOLDER BROWSERMAXXPOS) of MAILFOLDER with (SETQ WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH)))) (SETQ TOTALHEIGHT (TIMES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (MAILFOLDER BROWSEREXTENT) of MAILFOLDER with (create REGION LEFT _ 0 BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) TOTALHEIGHT) WIDTH _ WIDTH HEIGHT _ TOTALHEIGHT))) (* ;; "Now figure out columns for printing toc entries") (SETQ DIGITWIDTH (CHARWIDTH (CHARCODE 9) LAFITEBROWSERFONT)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE r) LAFITEBROWSERFONT)) (replace (MAILFOLDER ORDINALXPOS) of MAILFOLDER with (SETQ XPOS (+ BROWSERMARKXPOSITION (CHARWIDTH (CHARCODE m) LAFITEBROWSERFONT) (LRSH DIGITWIDTH 1)))) (* ; "Message # starts here") (replace (MAILFOLDER DATEXPOS) of MAILFOLDER with (add XPOS (+ (TIMES 2 SPACEWIDTH) (TIMES 4 DIGITWIDTH)))) (* ; "Date starts here. Allow 4 columns of digits plus some space") (replace (MAILFOLDER FROMXPOS) of MAILFOLDER with (add XPOS (+ (TIMES 2 DIGITWIDTH) (TIMES 2 SPACEWIDTH) (CHARWIDTH (CHARCODE -) LAFITEBROWSERFONT) (STRINGWIDTH (QUOTE MAY) LAFITEBROWSERFONT)))) (* ; "From field starts here. Allow 3 columns of digits, a month, and some space") (replace (MAILFOLDER SUBJECTXPOS) of MAILFOLDER with (add XPOS (IMAX (TIMES LAFITEMINFROMCHARS (CHARWIDTH (CHARCODE A) LAFITEBROWSERFONT)) (FIXR (FTIMES LAFITEFROMFRACTION (- WIDTH XPOS)))))) (* ;; "Subject field starts here. Space is divided up between From and Subject so that From field gets LAFITEFROMFRACTION of the available space, but at least LAFITEMINFROMCHARS wide") (replace (MAILFOLDER FROMMAXXPOS) of MAILFOLDER with (- XPOS (TIMES 2 SPACEWIDTH))) (* ; "From field gets truncated beyond this position") (replace (MAILFOLDER BROWSERDIGITWIDTH) of MAILFOLDER with DIGITWIDTH))) -) (LAB.BUTTONEVENTFN -(LAMBDA (WINDOW) (* ; "Edited 28-Jul-88 17:37 by bvm") (TOTOPW WINDOW) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAB.SELECTMESSAGE))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((LASTMOUSESTATE (ONLY MIDDLE)) (LAB.DO.UNLESS.BUSY WINDOW (FUNCTION LAFITEEXTRABROWSERCOMMANDFN))))) -) (LAB.DO.UNLESS.BUSY -(LAMBDA (WINDOW FN ARGUMENT) (* ; "Edited 3-Sep-87 18:01 by bvm:") (RESETLST (PROG ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T)) (CL:FUNCALL FN WINDOW MAILFOLDER ARGUMENT)))))) -) (LOADMAILFOLDER -(LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") (* ;; "LAFITEVERSION# is used to keep track of changed in internal datastructures that get written out to Lafite TOC files. If the datastructures change, then just change the version number to LAFITEVERSION#+1 and the rest of Lafite should adjust appropriately.") (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL) (* ; "Assume ok until we hear otherwise") (COND ((OR (\LAFITE.READ.TOC.FILE FOLDER) (\LAFITE.PARSE.FOLDER FOLDER)) (LAB.PROMPTPRINT FOLDER " done.") (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (OR (LAB.SET.EXPUNGEABILITY FOLDER) (MAX 1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) (* ; "Only %"changed%" messages are deleted ones now, except for possibly the last message in the case where it was truncated.") FOLDER))) -) (LAFITE.OBTAIN.FOLDER -(LAMBDA (FOLDERNAME ACCESS PROMPTFOLDER OPTIONS) (* ; "Edited 12-Sep-88 17:42 by bvm") (* ;;; "Locates a MAILFOLDER on FOLDERNAME, or creates one if there is none. If the folder is not already on the active list, we will try to open it for ACCESS, or just return NIL if ACCESS is NIL. If PROMPTFOLDER is supplied, it is a folder (or T for PROMPTWINDOW) indicating focus of attention for prompting for confirmation to create new folder. OPTIONS may include :FORGET, in which case we don't add this folder name to the set of known folders, or :BROWSE, meaning we plan to browse the folder.") (WITH.MONITOR \LAFITE.BROWSELOCK (OR (for FOLDER in \ACTIVELAFITEFOLDERS when (OR (STRING-EQUAL (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER) FOLDERNAME) (STRING-EQUAL (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER) FOLDERNAME)) do (* ; "Found existing folder without sweating too hard") (RETURN FOLDER)) (AND ACCESS (LET* ((UNPACKEDNAME (UNPACKFILENAME.STRING FOLDERNAME)) (OLDVERSION (LISTGET UNPACKEDNAME (QUOTE VERSION))) (VERSIONLESSNAME (PROGN (LISTPUT UNPACKEDNAME (QUOTE VERSION) NIL) (PACKFILENAME.STRING UNPACKEDNAME))) SHORTNAME NEWNAME NEWFOLDER OLDFOLDER STREAM) (COND ((AND (NOT (STRING-EQUAL VERSIONLESSNAME FOLDERNAME)) (SETQ NEWFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION)) (* ; "Found a folder describing a different version--can't have more than one version up at once") NIL) ((NULL (SETQ STREAM (\LAFITE.MAYBE.OPEN.FOLDER (SETQ NEWFOLDER (create MAILFOLDER FULLFOLDERNAME _ FOLDERNAME VERSIONLESSFOLDERNAME _ VERSIONLESSNAME FOLDERLOCK _ (CREATE.MONITORLOCK VERSIONLESSNAME))) ACCESS PROMPTFOLDER OPTIONS T))) (* ; "File not found and user didn't confirm creating it") NIL) ((type? STREAM STREAM) (* ; "succeeded in opening the new folder.") (PROG ((VERSIONLESSNEW (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (fetch (MAILFOLDER FULLFOLDERNAME) of NEWFOLDER))) (SHORTNAME (fetch SHORTFOLDERNAME of NEWFOLDER))) (if (NOT (STRING-EQUAL VERSIONLESSNEW VERSIONLESSNAME)) then (* ; "We guessed wrong about the versionless name--having actually opened the file, here's the canonical name") (if (SETQ OLDFOLDER (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNEW)) then (* ; "it turns out we already had this file open under a different full name. Close the new one and return the old") (\LAFITE.CLOSE.FOLDER NEWFOLDER T) (RETURN (AND (NOT (\LAFITE.CONFLICTING.OLD.FOLDER OLDFOLDER FOLDERNAME OLDVERSION)) OLDFOLDER)) else (replace (MAILFOLDER VERSIONLESSFOLDERNAME) of NEWFOLDER with VERSIONLESSNEW))) (push \ACTIVELAFITEFOLDERS NEWFOLDER) (if (NOT (CL:MEMBER SHORTNAME (CDR LAFITEMAILFOLDERS) :TEST (QUOTE STRING-EQUAL))) then (* ; "This is a new folder") (COND ((EQMEMB :FORGET OPTIONS) (* ; "Don't remember it, but do set default for next Browse&Forget") (SETQ \LAFITE.LAST.FOLDER.NAME SHORTNAME)) (T (* ; "Add to list for menu") (\LAFITE.NOTICE.FILE SHORTNAME)))) (RETURN NEWFOLDER))) (T (* ; "STREAM is a condition signaled by the attempt to open the file") (if (AND (TYPEP STREAM (QUOTE XCL:FILE-WONT-OPEN)) (SETQ OLDFOLDER (OR (AND (SETQ NEWNAME (XCL:FILE-WONT-OPEN-PATHNAME STREAM)) (NOT (STRING-EQUAL VERSIONLESSNAME (SETQ VERSIONLESSNAME (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWNAME)))) (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)) (AND (SETQ NEWNAME (INFILEP VERSIONLESSNAME)) (NOT (STRING-EQUAL VERSIONLESSNAME (SETQ VERSIONLESSNAME (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) NEWNAME)))) (\LAFITE.FIND.EXISTING.FOLDER VERSIONLESSNAME)))) (NOT (\LAFITE.CONFLICTING.OLD.FOLDER NEWFOLDER FOLDERNAME OLDVERSION))) then (* ; "Looks like file wouldn't open because we already have it open by a different name. Return that folder") OLDFOLDER else (* ; "Report the problem") (\LAFITE.REPORT.FILE.WONT.OPEN PROMPTFOLDER STREAM (OR NEWNAME FOLDERNAME)) NIL)))))))) -) (\LAFITE.FIND.EXISTING.FOLDER -(LAMBDA (VERSIONLESSNAME) (* ; "Edited 22-Aug-88 17:32 by bvm") (* ;; "Returns an existing mail folder object whose versionless name is (case-insensitively) equal to VERSIONLESSNAME, or NIL on failure.") (find FOLDER in \ACTIVELAFITEFOLDERS suchthat (STRING-EQUAL (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of FOLDER) VERSIONLESSNAME))) -) (\LAFITE.CONFLICTING.OLD.FOLDER -(LAMBDA (NEWFOLDER FOLDERNAME OLDVERSION) (* ; "Edited 22-Aug-88 18:30 by bvm") (* ;; "NEWFOLDER is a folder we found somewhere during the search for FOLDERNAME. Check that it works, i.e., that it doesn't have a version number that differs from that of FOLDERNAME") (COND ((NULL OLDVERSION) (* ; "User didn't ask for a specific version, so this folder is fine") NIL) ((OR (fetch (MAILFOLDER BROWSERWINDOW) of NEWFOLDER) (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of NEWFOLDER)) (printout PROMPTWINDOW T "A different version of " FOLDERNAME " is already being browsed." "Multiple versions may not be manipulated at once.") T) (T (* ; "Not being browsed, so kill it and pretend it never existed") (\LAFITE.CLOSE.FOLDER NEWFOLDER T) (SETQ \ACTIVELAFITEFOLDERS (DREMOVE NEWFOLDER \ACTIVELAFITEFOLDERS)) NIL))) -) (LAB.REPAINTFN -(LAMBDA (WINDOW REGION) (* ; "Edited 28-Apr-89 16:00 by bvm") (LET ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (AND (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) (LAB.DISPLAYLINES FOLDER NIL NIL REGION)) (T (MAILFOLDERBUSY FOLDER))))))) -) (LAB.SCROLLFN -(LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* bvm%: " 3-Jan-84 14:53") (* ;;; "only scroll if can get the monitor lock") (RESETLST (PROG ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER)))) (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T)) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG)) (T (MAILFOLDERBUSY MAILFOLDER)))))) -) (LAB.RESHAPEFN -(LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 28-Apr-89 15:57 by bvm") (RESETLST (PROG ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) MSG#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T)) (* ; "Folder is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) NIL T)) ((NOT (fetch (MAILFOLDER BROWSERREADY) of FOLDER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ MSG# (FIRSTVISIBLEMESSAGE FOLDER REGION)) (LAB.SETUP FOLDER) (WYOFFSET (ITIMES (SUB1 MSG#) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER)) WINDOW) (LAB.DISPLAYLINES FOLDER MSG# NIL REGION)))) -) (LAB.CLOSEFN -(LAMBDA (BROWSERWINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") (LAB.CLOSE/SHRINK BROWSERWINDOW :CLOSE)) -) (LAB.SHRINKFN -(LAMBDA (WINDOW) (* ; "Edited 15-Sep-87 17:56 by bvm:") (LAB.CLOSE/SHRINK WINDOW :SHRINK))) (LAB.CLOSE/SHRINK -(LAMBDA (BROWSERWINDOW FLG) (* ; "Edited 7-Jun-88 14:42 by bvm") (* ;; "Called from CLOSEFN or SHRINKFN of BROWSERWINDOW with FLG = :CLOSE or :SHRINK. Before doing anything, let user update file.") (RESETLST (LET ((MAILFOLDER (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) T T) (AND (OPENWP BROWSERWINDOW) (CLEARW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER))) (SELECTQ (SETQ HOW? (COND ((AND (fetch (MAILFOLDER BROWSERREADY) of MAILFOLDER) (SETQ HOW? (LAB.CHOOSE.UPDATE.MENU MAILFOLDER FLG))) (MENU HOW?)) (T (FUNCTION \LAFITE.FINISH.UPDATE)))) (NIL (QUOTE DON'T)) (PROGN (\LAFITE.PROCESS (LIST HOW? (KWOTE BROWSERWINDOW) (KWOTE MAILFOLDER) (KWOTE FLG)) (QUOTE LAFITEUPDATE)) (* ; "Return DON'T now, for UPDATE.PROC will do it later") (QUOTE DON'T)))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) -) (LAB.EXPANDFN -(LAMBDA (BROWSERWINDOW) (* ; "Edited 28-Apr-89 18:50 by bvm") (LET ((FOLDER (WINDOWPROP BROWSERWINDOW (QUOTE MAILFOLDER)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (LET ((FIRSTCHANGEDMSG# (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP BROWSERWINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN) T) (COND (FIRSTCHANGEDMSG# (* ; "Browser has changed since shrinking") (COND ((EQ FIRSTCHANGEDMSG# 0) (* ; "After expunge") (LAB.DISPLAYFOLDER FOLDER)) (T (LAB.DISPLAYLINES FOLDER FIRSTCHANGEDMSG# NIL NIL T))) (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with NIL))))))) -) (LAFITEEXTRABROWSERCOMMANDFN -(LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 28-Jul-88 17:37 by bvm") (PROG ((FN (MENU (.LAFITEMENU. LAFITEEXTRAMENU LAFITEEXTRAMENUITEMS)))) (COND (FN (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (CL:FUNCALL FN MAILFOLDER))))) -) ) (* ; "Browser selection") (DEFINEQ (LAB.SELECTMESSAGE -(LAMBDA (WINDOW) (* ; "Edited 7-Jun-88 17:37 by bvm") (PROG ((*MAILFOLDER* (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE* SELECTIONREGION FIRST# LAST# SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS MSG LASTX LASTY MARKRIGHT) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of *MAILFOLDER*) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of *MAILFOLDER*)) (SETQ FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of *MAILFOLDER*)) (SETQ *FIRST-VISIBLE* (FIRSTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) (SETQ *LAST-VISIBLE* (LASTVISIBLEMESSAGE *MAILFOLDER* SELECTIONREGION)) (SETQ *MESSAGES* (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of *MAILFOLDER*)) (SETQ MARKRIGHT (fetch (MAILFOLDER ORDINALXPOS) of *MAILFOLDER*)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION) (SETQ OLDSEL#))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (SELECTC *TOC-STATE* (TS.REPLACING (for MSG selectedin *MAILFOLDER* do (replace SELECTED? of MSG with NIL)) (replace SELECTED? of (NTHMESSAGE *MESSAGES* OLDSEL#) with T) (replace FIRSTSELECTEDMESSAGE of *MAILFOLDER* with (replace LASTSELECTEDMESSAGE of *MAILFOLDER* with OLDSEL#))) (TS.ADDING (LA.SELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL# T)) (TS.REMOVING (LA.DESELECTRANGE *MAILFOLDER* OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (LA.SELECTRANGE *MAILFOLDER* (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (LA.SELECTRANGE *MAILFOLDER* OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (LA.DESELECTRANGE *MAILFOLDER* (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (LA.DESELECTRANGE *MAILFOLDER* FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND (>= LASTX BROWSERMARKXPOSITION) (< LASTX MARKRIGHT)) (* ; "Inside mark region") (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION) (SETQ OLDSEL#))) (LAB.CHANGEMARK *MAILFOLDER*)) ((OR (NEQ (SETQ SEL# (YPOS.TO.MESSAGE# (LASTMOUSEY WINDOW) *MAILFOLDER*)) OLDSEL#) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (COND ((AND (SHIFTDOWNP (QUOTE CTRL)) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Deselect this message") (SELECTC *TOC-STATE* (TS.REMOVING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE REPLACE))) (TS.IDLE) (LA.UNDOSELECTION)) (SETQ *TOC-STATE* (COND ((fetch SELECTED? of (SETQ MSG (NTHMESSAGE *MESSAGES* SEL#))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single message") (COND ((EQ *TOC-STATE* TS.REPLACING) (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE ERASE))) (T (LA.DECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) (SETQ *TOC-STATE* TS.REPLACING))) (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* SEL#) (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this message to the selection") (SELECTC *TOC-STATE* (TS.ADDING (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* OLDSEL#) (QUOTE ERASE))) (TS.IDLE) (LA.UNDOSELECTION)) (SETQ *TOC-STATE* (COND ((NOT (fetch SELECTED? of (SETQ MSG (NTHMESSAGE *MESSAGES* SEL#)))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SELECTC *TOC-STATE* (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (LA.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (LA.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (LA.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (LA.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (LA.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (LA.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (LA.RECONSIDERRANGE FIRST# LAST#) (SETQ *TOC-STATE* TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (LA.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ *TOC-STATE* TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (LA.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (LA.RECONSIDERRANGE FIRST# LAST#) (SETQ *TOC-STATE* TS.IDLE)))) (COND ((NOT (> FIRST# LAST#)) (COND ((NEQ *TOC-STATE* TS.IDLE) (LA.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ *TOC-STATE* (COND ((> SEL# LAST#) (LA.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (LA.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (LA.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI) (T (LA.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO)))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSEL# (AND (NEQ *TOC-STATE* TS.IDLE) SEL#))))) (COND ((EQ LAFITEVERIFYFLG (QUOTE TOC)) (LA.VERIFY.SELECTION *MAILFOLDER*))))) -) (LAB.CHANGEMARK -(LAMBDA (MAILFOLDER) (* bvm%: "17-Feb-84 15:46") (* ;; "Called when mouse is inside the 'mark' region of a browser. Tracks mouse while in that region and does whatever is appropriate") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (RIGHT (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER)) SEL# OLDSEL# COCKED REGION X Y TOP BOTTOM) (SETQ BOTTOM (fetch (REGION BOTTOM) of (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOP (fetch (REGION TOP) of REGION)) (do (GETMOUSESTATE) (COND ((OR (< (SETQ X (LASTMOUSEX WINDOW)) BROWSERMARKXPOSITION) (> X RIGHT) (< (SETQ Y (LASTMOUSEY WINDOW)) BOTTOM) (> Y TOP)) (COND (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#))) (RETURN)) ((LASTMOUSESTATE UP) (COND (COCKED (LA.READ.NEW.MARK MAILFOLDER OLDSEL#))) (RETURN)) ((NEQ (SETQ SEL# (YPOS.TO.MESSAGE# Y MAILFOLDER)) OLDSEL#) (COND (COCKED (LA.INVERT.MARK.BOX MAILFOLDER OLDSEL#)) (T (SETQ COCKED T))) (LA.INVERT.MARK.BOX MAILFOLDER (SETQ OLDSEL# SEL#))))))) -) (LA.READ.NEW.MARK -(LAMBDA (FOLDER MSG#) (* ; "Edited 25-Apr-89 17:55 by bvm") (PROG ((MSG (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) MSG#)) (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) YPOS MARK) (RESETSAVE NIL (LIST (FUNCTION CLEARW) (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER))) (RESETSAVE NIL (LIST (FUNCTION LA.SHOW.MARK) MSG FOLDER)) (* ; "Display correct mark on exit no matter what happens") (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (* ; "So caret flashes in the right place") (RESETSAVE NIL (LIST (QUOTE WINDOWPROP) WINDOW (QUOTE PROCESS) NIL)) (* ;; "PROCESS prop put there by TTYDISPLAYSTREAM -- don't want it to linger, else MOUSE proc will get tty in future when we bug browser") (LA.BLT.MARK.BOX FOLDER WINDOW (SETQ YPOS (MESSAGE#.TO.YPOS MSG FOLDER)) (QUOTE REPLACE) WHITESHADE) (* ; "Erase whatever's there") (LAB.PROMPTPRINT FOLDER T "Type single character mark, or ESC to abort") (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) (COND ((AND (>= (SETQ MARK (\GETKEY)) (CHARCODE SPACE)) (<= MARK (CHARCODE DEL))) (LAB.MARKS.CHANGED MSG FOLDER) (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) (replace (LAFITEMSG MARKCHAR) of MSG with MARK))))) -) (YPOS.TO.MESSAGE# -(LAMBDA (YPOS MAILFOLDER) (* bvm%: "24-Dec-83 17:45") (PROG ((N (IQUOTIENT (IPLUS (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) YPOS) (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER)) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) (RETURN (COND ((ILEQ N 0) 1) (T (IMIN N (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))))))) -) (MESSAGE#.TO.YPOS -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "24-Dec-83 16:37") (IDIFFERENCE (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (ITIMES (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) (fetch (LAFITEMSG %#) of MSGDESCRIPTOR)))) -) ) (DEFINEQ (LA.CONSIDERRANGE -(LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 7-Jun-88 17:34 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected. Deleted messages are not selected unless EVENIFDELETED is true") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind MSG do (SETQ MSG (NTHMESSAGE *MESSAGES* I)) (COND ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) (LA.SHOW.SELECTION *MAILFOLDER* MSG (QUOTE REPLACE)))))) -) (LA.DECONSIDERRANGE -(LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as unselected.") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) do (LA.SHOW.SELECTION *MAILFOLDER* (NTHMESSAGE *MESSAGES* I) (QUOTE ERASE)))) -) (LA.RECONSIDERRANGE -(LAMBDA (FIRST# LAST#) (* ; "Edited 7-Jun-88 17:35 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (for I from (IMAX FIRST# *FIRST-VISIBLE*) to (IMIN LAST# *LAST-VISIBLE*) bind MSG do (LA.SHOW.SELECTION *MAILFOLDER* (SETQ MSG (NTHMESSAGE *MESSAGES* I)) (COND ((fetch SELECTED? of MSG) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) -) (LA.SELECTRANGE -(LAMBDA (MAILFOLDER FIRST# LAST# EVENIFDELETED) (* bvm%: "15-Feb-84 15:39") (* ;;; "Mark internally messages FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) (FIRSTSEL (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (LASTSEL (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) MSG) (for I from FIRST# to LAST# do (SETQ MSG (NTHMESSAGE MESSAGES I)) (COND ((OR EVENIFDELETED (NOT (fetch DELETED? of MSG))) (replace SELECTED? of MSG with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER))) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) (replace LASTSELECTEDMESSAGE of MAILFOLDER with LAST#))))) -) (LA.DESELECTRANGE -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "28-Mar-84 14:52") (* ;;; "Mark internally messages FIRST# thru LAST# as unselected. Keeps MAILFOLDER:LASTSELECTEDMESSAGE and MAILFOLDER:FIRSTSELECTEDMESSAGE up to date. Assumes display has already been appropriately modified") (COND ((ILEQ FIRST# LAST#) (PROG ((MESSAGES (fetch MESSAGEDESCRIPTORS of MAILFOLDER))) (for I from FIRST# to LAST# do (replace SELECTED? of (NTHMESSAGE MESSAGES I) with NIL)) (COND ((EQ FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (replace FIRSTSELECTEDMESSAGE of MAILFOLDER with (COND ((LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 LAST#) (fetch LASTSELECTEDMESSAGE of MAILFOLDER))) (T (replace LASTSELECTEDMESSAGE of MAILFOLDER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)))))) ((EQ LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (replace LASTSELECTEDMESSAGE of MAILFOLDER with (OR (LAB.REV.FIND.SELECTED.MSG MAILFOLDER (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) (SUB1 FIRST#)) 1)))))))) -) (LAB.FIND.SELECTED.MSG -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: "15-Feb-84 12:22") (find I from FIRST# to LAST# bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) -) (LAB.REV.FIND.SELECTED.MSG -(LAMBDA (MAILFOLDER FIRST# LAST#) (* bvm%: " 2-Mar-84 18:02") (find I from LAST# to FIRST# by -1 bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) suchthat (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) -) (LA.UNDOSELECTION -(LAMBDA NIL (* ; "Edited 7-Jun-88 17:37 by bvm") (* ;;; "Restore browser to state before any selections were attempted") (LA.RECONSIDERRANGE *FIRST-VISIBLE* *LAST-VISIBLE*) (SETQ *TOC-STATE* TS.IDLE)) -) (LA.VERIFY.SELECTION -(LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 11:53") (PROG ((FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) (LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (%#OFMESSAGES (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) SEL) (COND ((IGREATERP FIRST# LAST#) (COND ((SETQ SEL (for I from 1 to %#OFMESSAGES collect I when (fetch SELECTED? of (NTHMESSAGE MESSAGES I)))) (HELP "First > Last, but these msgs selected" SEL)))) (T (for I from 1 to %#OFMESSAGES do (COND ((fetch SELECTED? of (NTHMESSAGE MESSAGES I)) (COND ((< I FIRST#) (HELP "First is too high" FIRST#)) ((> I LAST#) (HELP "Last is too low" LAST#)))))) (COND ((AND (EQ FIRST# 1) (EQ LAST# 1)) (* ; "The only time it is okay for them not to be selected")) ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES FIRST#))) (HELP "First not selected" FIRST#)) ((NOT (fetch SELECTED? of (NTHMESSAGE MESSAGES LAST#))) (HELP "Last not selected" LAST#))))))) -) ) (DEFINEQ (LAB.COPYBUTTONEVENTFN -(LAMBDA (WINDOW) (* ; "Edited 11-Dec-87 17:17 by bvm:") (* ;;; "copy select an item from the window.") (PROG ((FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) SELECTIONREGION CURRENTITEM CURRENTMSG CURRENTFIELD NEWITEM NEWFIELD LASTX LASTY DATEX FROMX SUBJECTX MSGS) (COND ((EQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) 0) (* ; "Nothing to select") (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ DATEX (fetch (MAILFOLDER DATEXPOS) of FOLDER)) (SETQ FROMX (fetch (MAILFOLDER FROMXPOS) of FOLDER)) (SETQ SUBJECTX (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) (SETQ MSGS (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) LP (TOTOPW WINDOW) (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (YPOS.TO.MESSAGE# LASTY FOLDER))) (SETQ NEWFIELD (if (< LASTX DATEX) then T elseif (< LASTX FROMX) then (QUOTE DATE) elseif (< LASTX SUBJECTX) then (QUOTE FROM) else (QUOTE SUBJECT))) (* ; "Figure out which field of the message is being pointed at by the xpos.") (COND ((OR (NEQ CURRENTITEM NEWITEM) (NEQ CURRENTFIELD NEWFIELD)) (* ; "Something changed") (COND (CURRENTITEM (* ; "turn off old selection.") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD))) (COND ((SETQ CURRENTITEM NEWITEM) (* ; "turn on new selection") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER (SETQ CURRENTMSG (NTHMESSAGE MSGS CURRENTITEM)) (SETQ CURRENTFIELD NEWFIELD)))))) LP2 (* ;; "wait for a button up or move out of region") (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (* ; "If something is selected, bksysbuf the selected field") (LAB.SHOW.COPY.SELECTION WINDOW FOLDER CURRENTMSG CURRENTFIELD) (BKSYSBUF (OR (SELECTQ CURRENTFIELD (T (* ; "Do whole line") (CONCAT "#" (fetch (LAFITEMSG %#) of CURRENTMSG) " " (fetch (LAFITEMSG DATE) of CURRENTMSG) " " (COND ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of CURRENTMSG))) (T (CONCAT "From: " (OR (fetch (LAFITEMSG FROM) of CURRENTMSG) UNSUPPLIEDFIELDSTR)))) " -- " (OR (fetch (LAFITEMSG SUBJECT) of CURRENTMSG) UNSUPPLIEDFIELDSTR))) (DATE (fetch (LAFITEMSG DATE) of CURRENTMSG)) (FROM (COND ((fetch (LAFITEMSG MSGFROMMEP) of CURRENTMSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of CURRENTMSG))) (T (fetch (LAFITEMSG FROM) of CURRENTMSG)))) (fetch (LAFITEMSG SUBJECT) of CURRENTMSG)) UNSUPPLIEDFIELDSTR)))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, but shift still down, no action") (GO LP2)) (T (GO LP))))) -) (LAB.SHOW.COPY.SELECTION -(LAMBDA (WINDOW FOLDER MSG FIELD) (* ; "Edited 11-Dec-87 17:16 by bvm:") (* ;;; "underline FIELD of MSG in FOLDER's window") (LET ((BOTTOM (- (MESSAGE#.TO.YPOS MSG FOLDER) (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER))) LEFT STR) (SELECTQ FIELD (T (* ; "Whole line")) (DATE (SETQ LEFT (fetch (MAILFOLDER DATEXPOS) of FOLDER)) (SETQ STR (fetch (LAFITEMSG DATE) of MSG))) (FROM (SETQ LEFT (fetch (MAILFOLDER FROMXPOS) of FOLDER)) (SETQ STR (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (CONCAT "To: " (fetch (LAFITEMSG TO) of MSG))) (T (fetch (LAFITEMSG FROM) of MSG))))) (PROGN (SETQ LEFT (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER)) (SETQ STR (fetch (LAFITEMSG SUBJECT) of MSG)))) (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM (if (EQ FIELD T) then (* ; "whole line") NIL else (* ; "width of just this field") (STRINGWIDTH (OR STR UNSUPPLIEDFIELDSTR) WINDOW)) 2 (QUOTE INVERT)))) -) ) (DECLARE%: EVAL@COMPILE DONTCOPY (CL:PROCLAIM '(CL:SPECIAL *MAILFOLDER* *MESSAGES* *FIRST-VISIBLE* *LAST-VISIBLE* *TOC-STATE*)) (CL:PROCLAIM '(GLOBAL LASTMOUSEBUTTONS)) ) (* ; "Browser display") (DEFINEQ (LAB.PROMPTPRINT -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:36 by bvm:") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS)) -) (LAB.FORMAT -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 14-Oct-87 15:53 by bvm:") (* ;; "Outputs to FOLDER's prompt window using FORMAT. If first format arg is T, then we clear the window first, and consider then next format arg to be the format string. All this is done in a way that lets the window expand if it needs to.") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T)) -) (LAB.MOUSECONFIRM -(CL:LAMBDA (FOLDER &REST ARGS) (* ; "Edited 11-Dec-87 17:33 by bvm:") (* ;; "Version of MOUSECONFIRM using FOLDER's prompt window. ARGS are args to FORMAT.") (LAB.PRINT.TO.PROMPTWINDOW FOLDER ARGS T) (PROG1 (MOUSECONFIRM T T) (if FOLDER then (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) else (CLEARW PROMPTWINDOW)))) -) (LAB.PRINT.TO.PROMPTWINDOW -(LAMBDA (FOLDER ARGS FORMAT-P) (* ; "Edited 14-Oct-87 19:01 by bvm:") (* ;; "Outputs to FOLDER's prompt window the text in ARGS. If FORMAT-P is NIL, ARGS is a list of items to print, with T meaning clear the window. If FORMAT-P is true, ARGS is considered a format string and format args, except that ARGS may be prefixed with T to indicate clearing the window. All this is done in a way that lets the window expand if it needs to. If FOLDER is NIL, or its browser is not open, prints to global PROMPTWINDOW. Returns NIL.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (AND FOLDER (OPENWP (ffetch (MAILFOLDER BROWSERPROMPTWINDOW) of (\DTEST FOLDER (QUOTE MAILFOLDER)))))) \CURRENTDISPLAYLINE OLDTTY) (* ;; "*PRINT-CASE* is bound so symbols get printed in %"expected%" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case. \currentdisplayline changes with TTYDISPLAYSTREAM") (CL:UNWIND-PROTECT (LET ((ACTUALWINDOW (OR WINDOW PROMPTWINDOW))) (if WINDOW then (SETQ OLDTTY (TTYDISPLAYSTREAM WINDOW)) (SETQ \CURRENTDISPLAYLINE (fetch (MAILFOLDER CURRENTPROMPTLINE) of FOLDER)) (* ; "Do this second because TTYDISPLAYSTREAM smashes it.")) (if FORMAT-P then (if (EQ (CAR ARGS) T) then (* ; "First arg of T means clear window first.") (CLEARW ACTUALWINDOW) (SETQ ARGS (CDR ARGS))) (CL:APPLY (FUNCTION CL:FORMAT) ACTUALWINDOW ARGS) else (for ARG in ARGS do (COND ((EQ ARG T) (CLEARW ACTUALWINDOW)) (T (PRIN3 ARG ACTUALWINDOW)))))) (if WINDOW then (* ;; "Now clean up the mess. Note position for next time.") (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with \CURRENTDISPLAYLINE) (TTYDISPLAYSTREAM OLDTTY) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* ; "Get rid of process handle") (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with T))) NIL)) -) (LAB.PAGEFULLFN -(LAMBDA (PW) (* ; "Edited 14-Oct-87 16:54 by bvm:") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (* ; "\Currentdisplayline is the line we're on when window fills, origin zero") (LET ((MAIN (MAINWINDOW PW)) FOLDER) (GETPROMPTWINDOW MAIN (+ 1 \#DISPLAYLINES)) (if (SETQ FOLDER (WINDOWPROP MAIN (QUOTE MAILFOLDER))) then (* ; "Note that we expanded window so that we can shrink it back later") (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with T)))))) -) (\LAFITE.MAYBE.CLEAR.PROMPT -(LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 15:35 by bvm:") (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") (LET (PW) (COND ((AND (fetch (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER) (OPENWP (SETQ PW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER)))) (CLEARW PW) (if (fetch (MAILFOLDER BROWSERPROMPTGREW) of FOLDER) then (* ; "Window grew") (LET (PROP HEIGHT) (SETQ HEIGHT (HEIGHTIFWINDOW (FONTPROP LAFITEBROWSERFONT (QUOTE HEIGHT)))) (WINDOWPROP PW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (* ; "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") (WINDOWPROP PW (QUOTE MAXSIZE) (CONS 64000 HEIGHT)) (SHAPEW PW (create REGION using (WINDOWPROP PW (QUOTE REGION)) HEIGHT _ HEIGHT)) (CLEARW PW) (* ; "Clear it again to get coordinates right.") (if (SETQ PROP (WINDOWPROP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE PROMPTWINDOW))) then (* ; "Main window thinks it knows how tall the prompt window is.") (RPLACD PROP 1)) (replace (MAILFOLDER BROWSERPROMPTGREW) of FOLDER with NIL) (replace (MAILFOLDER CURRENTPROMPTLINE) of FOLDER with 0))) (replace (MAILFOLDER BROWSERPROMPTDIRTY) of FOLDER with NIL))))) -) ) (PUTPROPS LAB.PROMPTPRINT ARGNAMES (NIL (FOLDER &REST ARGS))) (PUTPROPS LAB.FORMAT ARGNAMES (NIL (FOLDER &REST ARGS))) (PUTPROPS LAB.MOUSECONFIRM ARGNAMES (NIL (FOLDER FORMAT-STRING &REST ARGS))) (DEFINEQ (PRINTMESSAGESUMMARY [LAMBDA (MSG FOLDER WINDOW) (* ; "Edited 5-May-89 12:15 by bvm") (PROG ((*PRINT-BASE* 10) (DIGITWIDTH (fetch (MAILFOLDER BROWSERDIGITWIDTH) of FOLDER)) FROMSTR HERE THERE EXTENT MSG#) (OR (fetch (LAFITEMSG PARSED?) of MSG) (LAFITE.PARSE.MSG.FOR.TOC MSG FOLDER)) (MOVETO 0 (MESSAGE#.TO.YPOS MSG FOLDER) WINDOW) (POSITION WINDOW 0) (LA.SHOW.MARK MSG FOLDER) (DSPXPOSITION [+ (fetch (MAILFOLDER ORDINALXPOS) of FOLDER) (TIMES DIGITWIDTH (COND ((< (SETQ MSG# (fetch (LAFITEMSG %#) of MSG)) 10) 3) ((< MSG# 100) 2) ((< MSG# 1000) 1) (T 0] WINDOW) (* ;  "Ugh. Manually right-justify message # given that font may be variable width") (PRIN3 MSG# WINDOW) (LET ((DATE (OR (fetch (LAFITEMSG DATE) of MSG) [if (fetch (LAFITEMSG DATEKNOWN?) of MSG) then (* ; "Convert idate to date") (replace (LAFITEMSG DATE) of MSG with (GDATE1-6 (fetch (LAFITEMSG IDATE) of MSG] UNSUPPLIEDFIELDSTR))) (DSPXPOSITION (+ (fetch (MAILFOLDER DATEXPOS) of FOLDER) (if (DIGITCHARP (NTHCHARCODE DATE 2)) then 0 else (* ;  "for 1-digit day, try to get the digits to line up") DIGITWIDTH)) WINDOW) (PRIN3 DATE WINDOW)) (DSPXPOSITION (fetch (MAILFOLDER FROMXPOS) of FOLDER) WINDOW) [COND [(fetch (LAFITEMSG MSGFROMMEP) of MSG) (PRIN3 "To: " WINDOW) (SETQ FROMSTR (OR (fetch (LAFITEMSG TO) of MSG) (LAFITE.FETCH.TO.FIELD MSG FOLDER] (T (SETQ FROMSTR (OR (fetch (LAFITEMSG FROM) of MSG) UNSUPPLIEDFIELDSTR] (* ;; "PRINTMESSAGESUMMARY.STRING defaults to PRIN3, redefined to deal with multiple character sets if MIME is loaded.") (PRINTMESSAGESUMMARY.STRING FROMSTR WINDOW) (COND ((> (SETQ HERE (DSPXPOSITION NIL WINDOW)) (SETQ THERE (fetch (MAILFOLDER FROMMAXXPOS) of FOLDER))) (* ; "Erase the overflow") (DSPBACKUP (- HERE THERE) WINDOW))) (DSPXPOSITION (fetch (MAILFOLDER SUBJECTXPOS) of FOLDER) WINDOW) (PRINTMESSAGESUMMARY.STRING (OR (fetch (LAFITEMSG SUBJECT) of MSG) UNSUPPLIEDFIELDSTR) WINDOW) (PRIN3 " [" WINDOW) (PRIN3 (fetch (LAFITEMSG MESSAGELENGTH) of MSG) WINDOW) (PRIN3 " chars]" WINDOW) (* ;; "keep track of maximum width printed to. If header is allowed to print on two lines, $$MAXWIDTH$$ was set to right margin by BUILDBROWSERMAP so this should not reset it.") (COND ((< (fetch (MAILFOLDER BROWSERMAXXPOS) of FOLDER) (SETQ HERE (DSPXPOSITION NIL WINDOW))) (replace (MAILFOLDER BROWSERMAXXPOS) of FOLDER with HERE) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) with HERE) (WINDOWPROP WINDOW 'EXTENT EXTENT))) [COND ((fetch (LAFITEMSG SELECTED?) of MSG) (LA.SHOW.SELECTION FOLDER MSG 'REPLACE] (COND ((fetch (LAFITEMSG DELETED?) of MSG) (LA.SHOW.DELETION FOLDER MSG WINDOW 'REPLACE]) (FIRSTVISIBLEMESSAGE -(LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 12:22") (* ;; "Computes number of the first message in MAILFOLDER that is visible in REGION") (IMAX 1 (IQUOTIENT (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (+ (fetch (REGION TOP) of (OR REGION (DSPCLIPPINGREGION NIL (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)))) (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) -) (LASTVISIBLEMESSAGE -(LAMBDA (MAILFOLDER REGION) (* bvm%: "25-Feb-86 11:33") (* ;; "Computes number of the last message in MAILFOLDER that is visible in REGION") (IMIN (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) (IQUOTIENT (+ (- (fetch (MAILFOLDER BROWSERORIGIN) of MAILFOLDER) (- (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)))) (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER))) (SUB1 (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER))) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER)))) -) (LAB.DISPLAYLINES -(LAMBDA (FOLDER FIRST# LAST# REGION CLEAR) (* ; "Edited 28-Apr-89 18:48 by bvm") (* ;; "Display toc line for messages FIRST# thru LAST# (default to extreme). If REGION is given, only display messages visible in the region (default is the browser window's clipping region). If CLEAR is true, clear the region first (otherwise, caller has cleared it).") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (REG (OR REGION (DSPCLIPPINGREGION NIL WINDOW))) (MIN# (FIRSTVISIBLEMESSAGE FOLDER REGION)) (MAX# (LASTVISIBLEMESSAGE FOLDER REGION)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (if (AND FIRST# (> FIRST# MIN#)) then (SETQ MIN# FIRST#)) (if (AND LAST# (< LAST# MAX#)) then (SETQ MAX# LAST#)) (if CLEAR then (DSPFILL (LET ((LINEHEIGHT (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) (create REGION LEFT _ 0 BOTTOM _ (- (fetch (MAILFOLDER BROWSERORIGIN) of FOLDER) (fetch (MAILFOLDER BROWSERFONTDESCENT) of FOLDER) (TIMES LINEHEIGHT MAX#)) WIDTH _ MAX.SMALLP HEIGHT _ (TIMES LINEHEIGHT (ADD1 (- MAX# MIN#))))) WHITESHADE (QUOTE REPLACE) WINDOW)) (for MSG# from MIN# to MAX# do (PRINTMESSAGESUMMARY (NTHMESSAGE MESSAGES MSG#) FOLDER WINDOW)))) -) (LAB.EXPOSEMESSAGE -(LAMBDA (MAILFOLDER MSGDESCRIPTOR) (* bvm%: "24-Dec-83 19:00") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) CLIPREGION) (COND ((OR (IGREATERP (fetch (REGION BOTTOM) of (SETQ CLIPREGION (DSPCLIPPINGREGION NIL WINDOW))) YPOS) (ILESSP (fetch (REGION TOP) of CLIPREGION) YPOS)) (SCROLLBYREPAINTFN WINDOW 0 (IPLUS (fetch (REGION BOTTOM) of CLIPREGION) (IQUOTIENT (fetch (REGION HEIGHT) of CLIPREGION) 2) (IMINUS YPOS))))))) -) (LAB.SELECTED.MESSAGES -(LAMBDA (FOLDER) (* ; "Edited 14-Oct-87 16:15 by bvm:") (* ;; "Return a list of message descriptors currently selected") (for MSG selectedin FOLDER collect MSG)) -) (UNSELECTALLMESSAGES -(LAMBDA (MAILFOLDER) (* bvm%: "15-Feb-84 16:21") (for N from (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER) to (fetch LASTSELECTEDMESSAGE of MAILFOLDER) bind (MESSAGES _ (fetch MESSAGEDESCRIPTORS of MAILFOLDER)) do (LA.DESELECTRANGE MAILFOLDER N N) (LA.SHOW.SELECTION MAILFOLDER (NTHMESSAGE MESSAGES N) (QUOTE ERASE)))) -) (SELECTMESSAGE -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "15-Feb-84 12:34") (PROG ((N (fetch (LAFITEMSG %#) of MSGDESCRIPTOR))) (LA.SELECTRANGE MAILFOLDER N N T) (LA.SHOW.SELECTION MAILFOLDER MSGDESCRIPTOR (QUOTE REPLACE)))) -) (LAB.GO.TO.MESSAGE -(LAMBDA (FOLDER N) (* ; "Edited 23-Aug-88 18:14 by bvm") (* ;; "Jump to nth message in folder. N must be in range, or be a msg object in the folder. Returns the message object") (LET ((MSG (if (type? LAFITEMSG N) then N else (\DTEST (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) N) (QUOTE LAFITEMSG))))) (UNSELECTALLMESSAGES FOLDER) (LAB.EXPOSEMESSAGE FOLDER MSG) (LA.SHOW.SELECTION FOLDER MSG (QUOTE REPLACE)) (replace (LAFITEMSG SELECTED?) of MSG with T) (replace FIRSTSELECTEDMESSAGE of FOLDER with (replace LASTSELECTEDMESSAGE of FOLDER with (fetch (LAFITEMSG %#) of MSG))) MSG)) -) (MARKMESSAGE -(LAMBDA (MSG FOLDER MARK) (* ; "Edited 25-Apr-89 17:54 by bvm") (* ;;; "Changes the mark byte of MSGDESCRIPTOR to be MARK. This may also imply something about SEEN?") (replace (LAFITEMSG MARKCHAR) of MSG with MARK) (replace (LAFITEMSG SEEN?) of MSG with (NOT (UNSEENMARKP MARK))) (LAB.MARKS.CHANGED MSG FOLDER) (COND ((OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (LA.SHOW.MARK MSG FOLDER)) (T (* ; "Wait until browser expanded before showing mark update") (PROG ((N (fetch (LAFITEMSG %#) of MSG)) (OLDU (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER))) (COND ((OR (NULL OLDU) (> OLDU N)) (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with N))))))) -) (LAB.MARKS.CHANGED [LAMBDA (MSG FOLDER) (* ; "Edited 21-Jun-99 22:42 by rmk:") (* ;;  "Call this whenever you change one of the 3 mark bytes (seen, deleted, mark) of a message.") (LET ((N (fetch (LAFITEMSG %#) of MSG))) (if (< N (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with N))) (replace (LAFITEMSG MARKSCHANGED?) of MSG with T) (* ;;  "rmk: MARKSCHANGEDINTOC? wasn't being set, and changes only to marks weren't being written out.") (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with T) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with T]) (LA.SHOW.MARK -(LAMBDA (MSGDESCRIPTOR MAILFOLDER) (* bvm%: "17-Feb-84 15:34") (PROG ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER)) (YPOS (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER)) (MARK (fetch (LAFITEMSG MARKCHAR) of MSGDESCRIPTOR))) (LA.BLT.MARK.BOX MAILFOLDER WINDOW YPOS (QUOTE REPLACE) WHITESHADE) (* ; "Erase whatever's there") (COND ((NEQ MARK (CHARCODE SPACE)) (MOVETO BROWSERMARKXPOSITION YPOS WINDOW) (BOUT WINDOW MARK))))) -) (LA.INVERT.MARK.BOX -(LAMBDA (MAILFOLDER MSG#) (* bvm%: "17-Feb-84 14:44") (LA.BLT.MARK.BOX MAILFOLDER (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) (MESSAGE#.TO.YPOS (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER) MSG#) MAILFOLDER) (QUOTE INVERT) BLACKSHADE)) -) (LA.BLT.MARK.BOX -(LAMBDA (MAILFOLDER WINDOW YPOS OPERATION TEXTURE) (* ; "Edited 3-Sep-87 18:02 by bvm:") (BLTSHADE TEXTURE WINDOW BROWSERMARKXPOSITION (- YPOS (fetch (MAILFOLDER BROWSERFONTDESCENT) of MAILFOLDER)) (- (fetch (MAILFOLDER ORDINALXPOS) of MAILFOLDER) BROWSERMARKXPOSITION) (fetch (MAILFOLDER BROWSERFONTHEIGHT) of MAILFOLDER) OPERATION)) -) (LA.SHOW.DELETION -(LAMBDA (MAILFOLDER MSGDESCRIPTOR WINDOW OPERATION) (* ; "Edited 3-Sep-87 16:23 by bvm:") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that MSGDESCRIPTOR is deleted") (BLTSHADE BLACKSHADE WINDOW BROWSERMARKXPOSITION (- (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) 1)) (LRSH LAFITEDELETEDLINEHEIGHT 1)) NIL LAFITEDELETEDLINEHEIGHT OPERATION)) -) (LA.SHOW.SELECTION -(LAMBDA (MAILFOLDER MSGDESCRIPTOR OPERATION) (* bvm%: " 2-Feb-84 12:37") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that MSGDESCRIPTOR is selected") (BITBLT LA.SELECTION.BITMAP 0 0 (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER) 0 (+ (MESSAGE#.TO.YPOS MSGDESCRIPTOR MAILFOLDER) (LRSH (fetch (MAILFOLDER BROWSERFONTASCENT) of MAILFOLDER) 1) -5) NIL NIL (QUOTE INPUT) OPERATION)) -) (SEENMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") (* ;;; "causes the 'seen character' -- as opposed to the 'seen mark' -- to be changed to 'S' on the file") (LET ((OLDMARK (fetch (LAFITEMSG MARKCHAR) of MSG))) (COND ((OR (NULL (fetch (LAFITEMSG SEEN?) of MSG)) (UNSEENMARKP OLDMARK)) (replace (LAFITEMSG SEEN?) of MSG with T) (LAB.MARKS.CHANGED MSG FOLDER) (COND ((UNSEENMARKP OLDMARK) (* ;; "only change the mark if it was ? -- it might already be something more meaningful like an answer mark") (MARKMESSAGE MSG FOLDER SEENMARK))))))) -) (DELETEMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:53 by bvm") (replace (LAFITEMSG DELETED?) of MSG with T) (LAB.MARKS.CHANGED MSG FOLDER) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with T) (LA.SHOW.DELETION FOLDER MSG (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER) (QUOTE REPLACE))) -) (UNDELETEMESSAGE -(LAMBDA (MSG FOLDER) (* ; "Edited 25-Apr-89 17:52 by bvm") (if (fetch (LAFITEMSG DELETED?) of MSG) then (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (replace (LAFITEMSG DELETED?) of MSG with NIL) (LAB.MARKS.CHANGED MSG FOLDER) (LA.SHOW.DELETION FOLDER MSG WINDOW (QUOTE ERASE)) (* ; "undeleted; reprint the header.") (PRINTMESSAGESUMMARY MSG FOLDER WINDOW) (* ; "Finally, maybe clear the expungeable flag if this was the last deleted message") (LAB.SET.EXPUNGEABILITY FOLDER)))) -) (LAB.SET.EXPUNGEABILITY -(LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 17:46 by bvm") (* ;; "Sets the FOLDERNEEDSEXPUNGE flag according to whether any messages are marked deleted, and returns the number of the first deleted message (or NIL if none).") (LET ((FIRSTDELETED (for I from 1 to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) thereis (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE MESSAGES I))))) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with FIRSTDELETED) FIRSTDELETED)) -) ) (* ;; "PRINTMESSAGESUMMARY.STRING prints From and Subject. Redefined when MIME is loaded to deal with different character encodings." ) (MOVD? 'PRIN3 'PRINTMESSAGESUMMARY.STRING) (* ; "ICON stuff") (FILESLOAD ICONW) (DEFINEQ (LAB.ICONFN -(LAMBDA (WINDOW OLDICON) (* ; "Edited 20-Apr-89 19:38 by bvm") (* ;;; "the holding place for all the fancy stuff for making an icon for a mail broswer window") (OR (WINDOWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))) (LET ((MAILFOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) ICON) (SETQ ICON (TITLEDICONW LAFITE.FOLDER.ICON (COND (MAILFOLDER (LA.SHORTFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) LAFITEMAIL.EXT)) (T "??")) NIL (OR (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) (SELECTQ LAFITE.BROWSER.ICON.PREFERENCE ((:ASK ASK) (* ; "force prompt") NIL) (NIL (LA.POSITION.FROM.REGION (WINDOWPROP WINDOW (QUOTE REGION)))) (CL:FUNCALL LAFITE.BROWSER.ICON.PREFERENCE WINDOW))) T NIL (QUOTE FILE))) (WINDOWPROP ICON (QUOTE BUTTONEVENTFN) (FUNCTION LAB.ICON.BUTTONEVENTFN)) ICON))) -) (LAB.ICON.BUTTONEVENTFN -(LAMBDA (ICONW) (* ; "Edited 23-Aug-88 18:30 by bvm") (* ;; "BUTTONEVENTFN for browser windows. This one is like the default, except that middle button offers choices") (COND ((LASTMOUSESTATE MIDDLE) (LET (HOW) (if (AND (fetch (MAILFOLDER FOLDERGETSMAIL) of (WINDOWPROP (WINDOWPROP ICONW (QUOTE ICONFOR)) (QUOTE MAILFOLDER))) (SETQ HOW (MENU (OR LAFITEBROWSERICONMENU (SETQ LAFITEBROWSERICONMENU (\LAFITE.CREATE.MENU LAFITEBROWSERICONMENUITEMS NIL T)))))) then (* ; "Folder accepts new mail, and offer was accepted") (CL:FUNCALL HOW ICONW) else (* ; "No menu selection, just expand as you otherwise would") (EXPANDW ICONW)))) (T (MOVEW ICONW)))) -) ) (RPAQQ LAFITE.FOLDER.ICON (#*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@C@@@@@@@@L@@@@@@@@@@@@@@@@@@F@@@@@@@@F@@@@@@@@@@@@@@@@@@L@DA@@@@@C@@@@@@@@@@@@@@@@@@L@FC@@@@@C@@@@@@@@@@@@@@@@@@L@EE@HGB@C@@@@@@@@@@@@@@@@@@L@EEADBB@C@@@@@@@@@@@@@@@@@@L@DIBBBB@COOOOOOOOOOOOOOL@@@L@DACNBB@COOOOOOOOOOOOOOL@@@L@DABBGCL@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@@@@@L@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LOOOOOOOOOOOOOOOOOOOOOOOO@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@LL@@@@@@@@@@@@@@@@@@@@@@C@@@FL@@@@@@@@@@@@@@@@@@@@@@C@@@CL@@@@@@@@@@@@@@@@@@@@@@C@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ #*(100 72)@OOOOOOOO@@@@@@@@@@@@@@@@@@@AOOOOOOOOH@@@@@@@@@@@@@@@@@@COOOOOOOOL@@@@@@@@@@@@@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOOOOOOOOO@@@@OOOOOOOOOOOOOOOOOOOOOOOO@@@ (8 4 88 51))) (RPAQ? LAFITEFROMFRACTION 0.3) (RPAQ? LAFITEMINFROMCHARS 15) (RPAQ? LAFITEVERIFYFLG T) (RPAQ? LAFITEDELETEDLINEHEIGHT 1) (RPAQ? LAFITE.BROWSER.ICON.PREFERENCE ) (RPAQQ LAFITEBROWSERMENUITEMS (("Display" '\LAFITE.DISPLAY "Displays the selected message in the display window.") ("Delete" '\LAFITE.DELETE "Deletes the selected messages.") ("Undel" '\LAFITE.UNDELETE "Undeletes the selected messages.") ("Answer" '\LAFITE.ANSWER "Prepares a delivery form to reply to the selected message.") ("Forward" '\LAFITE.FORWARD "Prepares a delivery form to forward the selected message(s).") (HCopy '\LAFITE.HARDCOPY "Sends hardcopy of the selected message(s) to the default printer") ("Move To" '\LAFITE.MOVETO "Moves the selected message(s) to another mail folder.") ("Update" '\LAFITE.UPDATE "Write out browser changes to the physical mail file.% - Option to expunge all deleted messages." ) ("Get Mail" '\LAFITE.GETMAIL "Retrieves new messages and puts them into this mail folder."))) (RPAQQ LAFITESUBBROWSEMENUITEMS [("Browse" '\LAFITE.BROWSE.PROC "Browse a mail file") ("Browse & Forget" '\LAFITE.BROWSE.FORGET "Browse a mail file, but don't add it to the menu of known folders") ("Forget Folders" '\LAFITE.UNCACHE.FOLDER "Remove one or more folders from list of known folders") ("Forget Message Form" '\LAFITE.UNCACHE.MESSAGEFORM "Remove a form from list of known message forms,% -but do not delete the file containing it." ) ("Delete Message Form" '\LAFITE.DELETE.MESSAGEFORM "Remove a form from list of known message forms% -and delete the file(s) containing it." ) ("Notice Folders" '\LAFITE.NOTICE.FOLDERS "Scan specified directory and add any folders found to the list of known folders") ("Clean up Folders" '\LAFITE.GC.FOLDERS "Check that all known folders correspond to actual files; remove those that no longer exist" ) ("Rename Folder" '\LAFITE.RENAME.FOLDER "Change the name of a folder") ("Edit Folder Hierarchy" '\LAFITE.EDIT.HIERARCHY "Add, delete, or change membership of a folder group" (SUBITEMS ("Edit a Group" '\LAFITE.EDIT.HIERARCHY "Modify an existing group") ("Add New Group" '[LAMBDA (ITEM MENU) (\LAFITE.ADD.NEW.GROUP] "Define a new top-level group") ("Change Top-Level Groups" '\LAFITE.CHANGE.TOP.GROUPS "Specify which subgroups should also appear at top level."]) (RPAQQ LAFITEBROWSERICONMENUITEMS (("Get Mail" '\LAFITE.GETMAIL.FROM.ICON "Open this window and retrieve new mail into it"))) (RPAQ? LAFITESUBBROWSEMENU ) (RPAQ? LAFITEBROWSERICONMENU ) (RPAQ? LAFITEEXTRAMENU ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) ) (ADDTOVAR LAFITEMENUVARS LAFITESUBBROWSEMENU LAFITEBROWSERICONMENU LAFITEEXTRAMENU) (ADDTOVAR LAFITEEXTRAMENUITEMS ("Describe Folder" '\LAFITE.DESCRIBE.FOLDER "Display some relevant info about this folder" (SUBITEMS ("Inspect Folder" 'INSPECT "Inspect the MAILFOLDER data structure associated with this browser" )))) (RPAQQ BROWSERMARKXPOSITION 8) (RPAQQ LA.SELECTION.BITMAP #*(8 10)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@@@@@) (* ; "Obsolete") (RPAQ? LAFITEBROWSERREGION (CREATEREGION 30 30 575 210)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (CL:PROCLAIM '(CL:SPECIAL \CURRENTDISPLAYLINE)) (FILESLOAD (SOURCE) LAFITEDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA LAB.MOUSECONFIRM LAB.FORMAT LAB.PROMPTPRINT) ) (PUTPROPS LAFITEBROWSE COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1999 2001)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5838 20874 (\LAFITE.BROWSE 5848 . 6374) (\LAFITE.SUBBROWSE 6376 . 6615) ( \LAFITE.BROWSE.PROC 6617 . 7204) (\LAFITE.BROWSE.FORGET 7206 . 7607) (LAFITE.BROWSE.FOLDER 7609 . 8741 ) (\LAFITE.PREPARE.BROWSER 8743 . 9904) (\LAFITE.MAYBE.OPEN.FOLDER 9906 . 11781) (LAB.LOADFOLDER 11783 . 12097) (LAB.DISPLAYFOLDER 12099 . 13023) (LAB.MAKE.INITIAL.SELECTION 13025 . 13760) ( LAB.CREATEWINDOW 13762 . 18546) (LAB.TITLE.STRING 18548 . 19531) (LAB.COMMANDFN 19533 . 19942) ( LAB.DO.COMMAND 19944 . 20603) (LAB.ASSURE.SELECTIONS 20605 . 20872)) (20875 25391 ( BUILD.LAFITE.LAYOUTS 20885 . 23550) (\LAFITE.LAYOUT.FROM.WINDOW 23552 . 24601) ( \LAFITE.MAKE.DUMMY.WINDOWS 24603 . 25389)) (25817 38951 (LAB.SETUP 25827 . 28440) (LAB.BUTTONEVENTFN 28442 . 28838) (LAB.DO.UNLESS.BUSY 28840 . 29183) (LOADMAILFOLDER 29185 . 30080) (LAFITE.OBTAIN.FOLDER 30082 . 33998) (\LAFITE.FIND.EXISTING.FOLDER 34000 . 34371) (\LAFITE.CONFLICTING.OLD.FOLDER 34373 . 35213) (LAB.REPAINTFN 35215 . 35612) (LAB.SCROLLFN 35614 . 36034) (LAB.RESHAPEFN 36036 . 36838) ( LAB.CLOSEFN 36840 . 36962) (LAB.SHRINKFN 36964 . 37073) (LAB.CLOSE/SHRINK 37075 . 38021) (LAB.EXPANDFN 38023 . 38694) (LAFITEEXTRABROWSERCOMMANDFN 38696 . 38949)) (38986 47364 (LAB.SELECTMESSAGE 38996 . 44530) (LAB.CHANGEMARK 44532 . 45521) (LA.READ.NEW.MARK 45523 . 46729) (YPOS.TO.MESSAGE# 46731 . 47108 ) (MESSAGE#.TO.YPOS 47110 . 47362)) (47365 52392 (LA.CONSIDERRANGE 47375 . 47859) (LA.DECONSIDERRANGE 47861 . 48187) (LA.RECONSIDERRANGE 48189 . 48638) (LA.SELECTRANGE 48640 . 49627) (LA.DESELECTRANGE 49629 . 50685) (LAB.FIND.SELECTED.MSG 50687 . 50921) (LAB.REV.FIND.SELECTED.MSG 50923 . 51167) ( LA.UNDOSELECTION 51169 . 51394) (LA.VERIFY.SELECTION 51396 . 52390)) (52393 55857 ( LAB.COPYBUTTONEVENTFN 52403 . 54948) (LAB.SHOW.COPY.SELECTION 54950 . 55855)) (56064 60544 ( LAB.PROMPTPRINT 56074 . 56207) (LAB.FORMAT 56209 . 56585) (LAB.MOUSECONFIRM 56587 . 56919) ( LAB.PRINT.TO.PROMPTWINDOW 56921 . 58740) (LAB.PAGEFULLFN 58742 . 59319) (\LAFITE.MAYBE.CLEAR.PROMPT 59321 . 60542)) (60768 75148 (PRINTMESSAGESUMMARY 60778 . 65535) (FIRSTVISIBLEMESSAGE 65537 . 66000) ( LASTVISIBLEMESSAGE 66002 . 66575) (LAB.DISPLAYLINES 66577 . 67776) (LAB.EXPOSEMESSAGE 67778 . 68292) ( LAB.SELECTED.MESSAGES 68294 . 68484) (UNSELECTALLMESSAGES 68486 . 68828) (SELECTMESSAGE 68830 . 69062) (LAB.GO.TO.MESSAGE 69064 . 69690) (MARKMESSAGE 69692 . 70381) (LAB.MARKS.CHANGED 70383 . 71190) ( LA.SHOW.MARK 71192 . 71643) (LA.INVERT.MARK.BOX 71645 . 71931) (LA.BLT.MARK.BOX 71933 . 72291) ( LA.SHOW.DELETION 72293 . 72754) (LA.SHOW.SELECTION 72756 . 73198) (SEENMESSAGE 73200 . 73765) ( DELETEMESSAGE 73767 . 74073) (UNDELETEMESSAGE 74075 . 74593) (LAB.SET.EXPUNGEABILITY 74595 . 75146)) ( 75385 76875 (LAB.ICONFN 75395 . 76195) (LAB.ICON.BUTTONEVENTFN 76197 . 76873))))) STOP \ No newline at end of file diff --git a/library/lafite/LAFITECOMMANDS.LCOM.~1~ b/library/lafite/LAFITECOMMANDS.LCOM.~1~ deleted file mode 100644 index 02aac7e89ba7d4840a8d10968819a628e36535db..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 59005 zcmeIb3vgW5c_!H1fGC;~AOM6Y8kDGOh^7FB=%BmtBAv)+bT`-yboT|j8*D!A&n;iNyil1hS<6dSx7G5?@%-ek{Nm!m(z8#_f9~?~%9ST83#*ss zmRIJVtju0mxHA9b<=K@vH1cFRI-V*dVs<7I&BpV=PlbBX#Yo@8)e3hpd^|jId|;^C zI!`@Ro+w!hOIAyFX1-LJf8KH*3By!eS`N&|#K9vZnyZIo`dp4SOZbzr464|(ZAUI~nXL_xk zQ_)=BYVl4JrYqlTU0#|0?85TZRsL@D-W`g_yoIgM(DDAk3rDP!)h{<<=|nU;J=HgE=Q8;t z*0>e2GSO6e+)l?a8{<~kq8IHV4kOlN0$=IN`KQcjJNbv-J1p=;!3e+~2Km z?&KaiZTI_<-#VGh^JClmT-(WoWx6FVNjv@iHeb(h$Vx}Yf*53GsxXzqq+5d{&XmXP zp!!TJa?Hvn0Otj@Kn2^m)6Y#r^ZDsqA}9}~Y%Fwmz-cHGof%66>BDoXFF=-Mj}@Y+ zEY>}nD%iQS9h(Fo4iB5NF&MTosdyZS7>Zz83Q7I6HE2AB*Q}u-t2?`FT>=tWm*!Vj zX90FWKz5_`dcUQb!jkYB<`VftL9Nr2UOyUWBHpKleYb@TTR`3nuVW^WoyI~Q3Iu%q zTwd16^79h$8uHI>TBGWrU9>V`OgO+u_0lKM#B-WC1#(odLdTrxt%t=StVxhZpHD{P z2~1FEph0`MUN=KBIa7c=dA|U{W=#Pq8_Wox2WWgcN#jXb0|c%38v%}Ir*WXZKjnpR zLIelG2iz7gJ)vg5@4ognU!naIO*_p^$7!Cc&5tGdZy9qnFlZI*f<0BVBEza_40wn~ z%paj=FJzt7vp3Xm_GqGH?Tz=mv*h9gBYfKG30v7jQNCzAeS$tVe5VadZzeiwbe!xwSe5spokJ;1W+(zWl}Kb2qFbRbaIltUheAVE z%+AK51wuRYw+08TRCa2*U;&xN>_U>z=a;jfT)CK?OZ_9d(@OX&7MhpUzmHT|YfGqEgA@z5UTJA3O_dt7R^Tgy&UMjaGzn)}B zc&EAT;`Ucl6THH06O-HDipq`aez}y=r)MX(Uz+%}XnOIzNrp4Ijr9itB+{TS{X|5@ zf{=~kimWHVelg=C{mwVa#|5*ru$T(Ght(SyG1g$%T&n@|4i?2l3@hxJ2vB?DUd=M~ zw$#ESb74)m6zv9V#*%%xL}5CY?HdP!I|3@ESa5tglbIm~+{aH56AoJhog~XKy*3CG znB!C)7YCW1WYb^?C;LuC)6)s8(t$v8z_&2k9spG@mkKRdG@q~BHMfVcmC$LB!JQfx z2*Csa43B5Q{iA6nEwx`G9|FP>@e&pcF;&3$On~pjM}@-H5g=ncRRG`ZOF~jiCvtsb zShrO61SAYRq2@#eKc0@B;H&-C5qw-M0d5wH<`ev=upRR&@&1S=*u)uSK8UCrGlm7L zZ3}|Uz+DH{YX#yh0bjEsTm3v`pOFdd5*o%NzCC_FUtNEE^5XW!!6=_xWT1WKoBZ4u z1Mm6fYHVX~(*N|*EUOyiM%B9j+3*(Bs^)z?OKip(BNgF}}ani8ng?e?9g}GLsB+ef(FGnf+CK z$2UiL-t2l|GR^Pa`9a#4!MD>{9z!*qDVHYX>8d<rn31&4sZ7#^IjMjCgGQ9 z!&D&$78kNkBnlw!d^R}XG&RsaY#jI3Aifm=VbtPiG8In*lTb4g&|e~;s7eWfBoUl~ zPNQ#H5%5>Hw+MP8ZtId0D*|P!R)&v&cGprBp^;$>{%n?5ci0MJT58`6hx;u|p^!hq zbSsRHV#&P-krP~>xH}H<=ityW3p5)lI+X9hfrvBxgP^g}1~X?h8RIr7IFMcHZ-F>l1IGYE zELbG$v^6kDaB#XnKr%3}<2#UNoDmFwr#Y{H`sw4yFzZ6HuyG7R>s2lY3=GIDV@j+D zD7s=0P~t^!R}|T#*Wj7xf>}anBy3@*xv0!{9xCpL$w5Pd5eM{?wgAygtO_90gbjoN zB)1#aA$Dna5 z=iKFikQVt==e)?6L0N2L7630+Bs^kuPpvGUugqV9X#i%I%Ixzn#Au!IsC8w9&#x|B zSYEj_dj&QV*iOR7B34fDl7M2jy}%|zFkD!*<}Y2o@_cuTH8f~-A3+O) zRu7q#>}-0*Di9Ne#;v3bTzsMcQL&-CtOZ3#;U2XjWZBb1?UdkcPHHct6_UPb?oTCh zsqq=;B@k9pe!s8DP&1f%!d!6jt7D=PRFly$q4@#%dwthUb)i|`xXDTcsa?Q567R=m z3JGZY!w#%Smn11d_|X7FR4XVp4y*%YMHwDF1=w^?fCugg0MI>wY<@gCW)p=Lv7Ut| z-M$AvH5TZ(>jyB9b%o^W7odLmwaC%lt`156;x8|E9!!?jpI+-M`I*J=4^I?v`2RiW zpJB$d9+JmXe0F13nK@nOp=zr3EqOxeSmn-snz<0bQxnquK}96vi8K?*5n!DdyTaBm zI0o1fEGr6Bh6Wr37w{$*)r*)8qN#@59O`!^bP%nh5-piSqunefshKUz-@62ykm3hgualz4i*}#1Si= zOOS;U)DEOnuMcL?yFO4kGl|R?S!eVDLt-`=DlHS3tTA6Bo<)PgWZWC_oI$%b?t$5y zjm8S8Qwc#5f$==h!(;`X6`0O?1P^xsT!DfX;omgVBDfORjd5O(C)z_z$@TrCBHqc& zt2vN+4Hw7D;`IC!zNUEUUPSBx2c|IFfhNq@kfy2Zp~RLOSI;~CZPR%Viqxa$QG zIE^u}RJeGNn&$qVDy<*jM<@97Mo&dnk#SeV#RWcIdjr-rP$n%chOwZY6~f|;So!HO zP*x~V5Opxm9wZEbor6{j&<07j47&3NqUVYsgpgVY2th~kNTDI1zFbJ#_GI2dKj|ne zX^>v^JCM+XQ;2PrMOBeV=v6+#`i3E~o=W9Yn1V3>;>~2hpY#i8?FG^Pk%li&UXU=) z8bBN{mY}yKn@U4Uz)G3llLc?qG%=TGILO+O{RxvX7ZDr`0`2;J163N~()ZsNmy%4M z6x?fcnVN9XrCehD>@MgsQ(8aB=)!|hY^;adH84g<@Y)}N1d=qT^sCUwa4p6_{#3$y z2#Qz@x_~I&1zjLOI}iqjrH|o4({t{bad0dB2vj2zJ9upcJ3z0^I}VT&@r5X-AvFYc zs*nW^4&7`BwkYQbur}v9v?_fJJEJ}Xy6dOGJM~parH)$QMV1icCXxst19eX?Ei7G` zUzuOMLNaI>h%vtc6oC&zqe*$8RGMFc{0O-f{*9{*Ua&4K%vVaQ)^ljcy0Cn8iBL*d zLJ)4r;B*$&=v0pUnXu+1(s76JhOE>H7^29eq>u`dW7uM08wT)cm;uQN#ph$t(z3w0 z2wWHe0j%8mBl#T2_?`96oS#G~hWFQ!fz*C~TVBpUw{u-{&4PMRZpgw$dNbrjfJq>k4FG=rxS5uCvZ!|NDWA2vAhJ9F5RqvZZ^wYkhie3evVge^Rze_gt}~Rri7$M z$8IgYC%ywsN#$LpH!dHJZSEh9Rd!cSvy{e-{DsgGkPq-W1(KMvAe`$#870U{EE&xe zQ*qemp(|>~51QajG2_MP1;tdSHPqa4$_#mHT0PpJRA~wNrZamE*Tb_|3nZm-SSVXH%d?P=x+lPO= zqSd{ycFRiwKo)m;qvv#K{UH$#D@V3pttOQa*1?UC=EHML>#8RWrV4zVD{Vn=h$X>G zLg2!6f)}X9jtdKml2#YV&S$_Fxil2;>0bG+09~lx3tABFG!U|MARGl=uq**8OeN&uz@wepkviWj;sG4r ztZS=kIB>RP;)@}q!$Zyk6$dY_IUK`zlSqv$G*L;&cb4zx362$+;!*Ms12$7F2L8XQ z?EVWLII%7m5K^bXv|#^4!_pk21fm*5m(ej`k3&|bFdo22$ciUUrD6$7gCrAXht$w| zL70yW2E)U{!y_&!A;4v55Ve9G>6*Hm(@t6%jm|&1z(d9$bx#cZ+=jzNwID^UBibnn z#;(ZkPHnev+n>R&Pqz;#Mj??iNPLDS>xS`-m%;3kzx`+3Vcmo}OYaQNa0`AI5-cK~ zLxM-h8z-1LZXF|;BdX6ZHFePuFu{c^Vol>&;0TC@ok9ExTl{-1|F7S_%jajXE4K0< zQgDSJ7dyM=I*Y9gdrZGwC0bo=pWRjL*a#Oz(O&PZEEL;#mCjU(>S%j?FE=|0C@y!Q z?YWLO#q)dPfu|O4ub0x_zUKSqW-nSpIlHj^@-^Q#)UBr#2iZE1;UjKTHMDD@E8VrW zSa*pLY3+1z|5sHbFJ6329Wg*{&0f5fy7hXoHMRKO1ivjTCcXYi_1H7I*CScCS7iby zwv`sP*FRZRkMcCFS=@}$@Bc@+_RX&qTh(k-iyd^*!IM-i?t7)!x>(%TiZ(>P1NKCY zkzQd491$2|ks-oCdPr720?WDL3K3`@T0bHq^I6YxVVAUr;q1{2BMeo*(`gv3 zILyTggG6XN63BsU3;`WR1>IH1FcyRi#U9MSrBvwAJt2=a+pfjm) z0f8fEtDZrDQ`TJ!!ztu^4{VptG1z)8bs~xAiyfUOVR#NCgn%4CVFc0DHBZ(T_Ytyg z)IS0%sqU5h9?mh$W%Un(mOBrCXuEC0=mTCs-ZTq42oQ!eO{zulof6hcKG;m{_`iVnn5Ecm{U%7SY@@SeCXkzQA}*USZ&6&+K; zmZ_nbA3+Q)38RU`eT^~AQW{D}AWA5I2-?`9ToQV*_E5?H`e<^(KM{}%u=V^Oqbbd= zYHMrt8|UI!@9ABw>+v{ZMM=mQ@FJN1uB z4A+7q5^Jb;fl1q;hO8bQ8DNktk^Sr>VgXZ_TrrUgQs{=k=@2(kJFkyI-O~y&>|{(H zN5vGYCkv8|OpbDbL%2zEPzVKa$Q`&DAofDFl2af~Fq#hn1Ti#6((piy9^H=f(Ju2* zT43@m@c^VGXerm65r}&Y8`p5@vVYPgQiW;w9ZyY>F~OLe4nU?8(>DHMMQb;Bd-5|InxyMs6yB& zpa?;CPHL)@T5VQ&9G{iXMO@9Ou=Cw@;o@!Q(r zaLxDSs_wn@Dfqbg-Ir8fd(I>m-($#kv7t;4El=P^d&m9R%cZMld8rwvf2d+Q-)ZhANBS3Su{vyiEW3E~nYA~|9h;9vB^E>V+;f(@O>5aT0tL=l zL&@l}BCN(qEE!`LX}Pf40{Y1qnn}Rq2y36v`-uESk#D|Tn4a& zVcIuPC~QPrD!4!(mX?$mg{X~(c6@{f`*!km+SK0+>^xfuB1 ztK^D&KMwiCJ#a`$@$k$I<#}xU*yM*VSJ!T7e)y;0hcG$nFVoWmrblS^GiGBghTg3L?BL4z;O?IHkr60D zpw{}-{86n>n!M{z;pGP5xvM7R$soQb0NFVy7ocEI=VA#*8zPSm>kp?9IiJktN@p&}T3J6`Jln>sf5rY|BP1@6*g8ksV);!iwq{l(@hMFM5(}NY5n6(Tl;iQ9)+H@NAF8*SrcvK3~$=n zz0k4#qtP}$>%reHuid6F(*LdLJE^zIUr71iN(Elah>D!~Vlu+Lo_}0{S_d4q}H(U6JYPo`Ap`?A1)=B_Jx;4*Db1SKv~m=qiL(RLzrkXJjDy ze;+obUFs{3!sjFw!ze3vFJJS2F)rfp`md;G2F|XpEWDK#m~Vb#>>FdT&-n09ELJHv zoW99#@XshLWPA|S2b1~$#$UM=!+~VGC+LVAWb}_;6C7%jG4YU|@xPvh$!wy8j{b@} z=4Z~R(KYkgx3Ar~7?o_P33l^}(XrgdFKpenu=cQ$#b2&wevNzDekD_eOYF{glwU}E zh5vkkf2Hl~PCn*e-`-5C{+wLR#UHAt4qR++-eb2d-aOZ4cl>0-vRiF&+bMyZIQqY{ zJ8{3Wy7oi6vm?Fr_@w(GGSZi?{q(J|(pO`mE|=S6ws)=lh+-SzR@a&nGWJRG90NkY z35j@$@l-B@izGb-^GSr!Q?L@-LnH76kysFhZdR8M1X~~S9**Zz8A!H$ViD|1oSa5w zh7eq4Xe@1KPdIH+aGQga5KT25muNght|+7m!Ln!Ei;>eD2|(`f5pU60C5KQa=}5re z0dF8RC0Hr+fVC(H2MN-rOo1?hFLY4`9{8G54=RL7Hg~N~VTkAEDRdB3njlPmro=cV z(9Kt11XQ!mN#WkcD1x$Pq#;;H)g=xyheC038nq*!O*ls|jH_!1r;;Oh-{b%-ssqlb zVJCsm0V=r=qdaYC-lH-jY0CU6XhX&~MnGVs`a+HDjA%q;wOm^M>^uS!5deb%Czqe6 z!?4vIt1Qed%6wc|w&s?XE-b8EvR;T%DsO|#GE}^+-k(6Jqr71^w4XQFBig3U& zRbMxRqinoVGSKI^rg{*bIQ{?q7^WbK762Sp_@RVmP$@O%{IB5n!ca z8I2Z)1gV-e_Db7B2)DZbZqjzg=ELJ(7uLlbuuYYJ0F;B`)GPQFObB&c;9ldkYC(Gk ziJg4x-7(M%&=CBIZ&OH=ULzpxoTqFifuf~V#4?3E-&+|qtOX@U`)E@ ztL?cx>87nGvK=!~u?pTe{OxQ06V+(x9pB}PkaGN=5-YGQolgcw%&FFV-1e}I%*7kKHAc>9D#Ky<*$vmIZwKD;B zC-U;`)~yGTVBdAF_3d=v?6se6+HHr=wN}^ugEbU2FBpTV zjnan5QIl_lz*!&J{pNyrF!pyBXBRm22Fc#0cnQUbvSkz_0w`lvJ$ilca!@fAq%^J1O@Qc40-8QS@VLI8&* zdXX7(90CA))Iykpk0T=-j#rQVZCs1L<7nbHKS4;C$5E06RH9I#qUzuOw5{Q@Pm#zj4U80U|>BUCOZaS_NR*JrJ zEJAWX7NI$~G_-KAi_(o0Je+ZX;i(x^r73s4Hn#q_N}}Jjwl7(#UEPfXsjkSR2T~fy={ky2J!N&C>WWnsMlQ$?A@V( zdsKvK;ghr>01wqsS6a94D8~`K3nj}_! z73)4nl`mCQz@F7!(J-M?3cMJg&|pL`ExIEry2IgNlzy9+S<)o2NMO<4g7r9?tO*N{}KP5+gFvpomHb( zzQnDw47DkX#>ZXmWf|1j0G9C$yOZD9UOzZlss#Sc&2+$@rW@~Fy7S)au;-<2f32GO zBDXMki~oppxaStb!#PPV;tx63=7%t5w*~xf^Mj9-vYpM zd9n91ndef4&|kd}LPdjwsOl;?WX6gX3ei|nu0tw-4H{6QPQzqZQ*{i(h7cFc<)YaW zq-B%r1=b+XtMWP_7-yWi1tCaWc`BtrIaYPV!2$tL)eB%6j3>;YNd2KA`S9ys1Q-vv z!J97q<`E4T0$nYL1M`7r5nW#hDH9QruIyMe%>zNzK&n?kX?`f1f>8A#^>Hj$aPnTn z5vvpv6Jw3s172$4DFs_x{DU{tm4h3M3(G?x`;e08E3|+F>6}`I%C5^ihB1>e;qI8i zkWTObswpND912erl#uEP$ynR}>IZ8GQm|kmu$ZL~78g-lz@fSI_b?`yWv5`SU}sRsS3Ls(jIEq3X|s8;W`P~4)16#_ z#ahN4hS(tly0Cn_8hm-gw|^r z4VmD)suggFi3OR47^=acPSPV!o0_*;Xds7M9kLKr*TTN>;Ue0YK@}bvUk8QygTh=y z6@oA!aX%Y}i08b*Vg^$lD#AfNjxX~W^7vnHKNUqVF0&?&V4!EgF$*q5N`Zp$86`LK zfhf5=Mb0ICKwcT9uC*=~nZq|y6Qj|w%6*fq#Pm>gm7$TU181jIT`2&dtH6;3noRs$ z;==1Oz*^MJDV0xwRIm6Z>}N%Z9AZWpa)Wf(P!11;GKD)9a1HsS8L%4wil{sT;8h3x z>Hri@ueT_7Vg>XFrC2&33o1BKl_vePK!?Mep{`E@VNm$E*1hIPjY1xf^ew#qooZGtuJ2ElD!YG-7%*YtukmWH<&%{*T>Jq)q^^A$ zPg=P62c9Q;D}mYv_a!UMxb}VHu1`<=p~%JCuW-|Ac6z->Oq!FWuZqq@7MbeA)&aY8<>v4JI5xaGB5BG{Ey4L=!2p}4T%JAv#MUu%6B5hkg$1jk7GFp3)uwrto_A2=+ zW2Mbb&-?7VtV13+>7X8I2+~*)A=eV&djzqnq|e2YHmdA7`WxR;aZg@%9`es%J4r99WEUJSh;-4nY&h9=U{0j01z!3zQ z27pBB2gMU^QG|G!#3#7{zhUDWu)8$A0YBDp)dq+KhU}bBK$)5| z%%T1)81Ig2;YM?6akuH|af~{_n(Gh;*)K>vzjS4lTycCnuVg3hm@bH@I0MjDgA{kIWJ0PL=v;@~3paylXU>r-a2 zU%nRYs7i~-uCb)q>sufmU6BO*ybdHQ8;s%kD5$kuEK~jtew17xdX(_LuG|=c@p8gG9 z^zE-CD=+@#=@*l%^RVQ;wOa)AHZC+P5~=txwP4D889`W39+T005*0ZbO0BMkL*W6v z2LQqw@E>Sd45n<6#TZifi;-Un--+>(118YQkuh+Z)bj7)XEOCj(!Y4=|6vl2dhq+JsnJqplr*GYlCpnm<9@iAM@wnC z)>Ziz`14zK+v(5SZBTHsTkUphx$BvytCN8@(*M(&YpBY8_?flal^5~YKV|hs0uy-> zpBkOu&bhM*($wKlg!PfXK7^TZ2)=x*Oes=sooY;o2ZJX7n{!}ZLQW{1IV)-^2d!y1 zjB}ie4m0Eonlq(Tt$e0gPIY0+{n!b%2lc6oK) zy+jhOy;OM~w7q`4jU{r;LIh&kO*i_|;)@rRiRhgGA_&%h5mW7Q(%-FC0&5S8dAU_w zIoBUVm_ak%Qcv|$*um}>FaG6knis6kSK9uv&Bx^S@JfiymrbN_7UEX8(!XHo}`u1#l>YOO%AOdM0=c1BBL8)1oui9~LN_l|9KM3ob< z=lm|l;~4*{i#iNX$~d$!b=~+Ap_bLP{|03VkqdQt3cG+5_1-+N)*I?-*QSc4#F$mF?#q1)vX9^U|A<8P1S%*ZKEnku zDluxDf#4fw2+DwkB1I;D=w8OoYOWqIma~h9%#@AUT>Y?q{RHSanv~S6y1nmyc6nIF z2as6pEHv$&0Hl}Pn|~0%LaX8fW~~CThHw9VK?x!2k5%uMcOtUM=Ae||$cb7n+v>US zQ+Lh?NxT-=AOq76K1F(Q5h4}!y%iy)wkIKF)zk^r*a=lY>y+*+YW;e) z5yHx&8?IkD!8{DFAzV@ZEmJr)#K9{^TRq4};e_-4#$aD3VngS&2ZcI@$5P8ypb-rQ z2wEcG=ZIc#7#~k3TG6O!TWaZoJj~@D>g_}k5RC_ z^F9FV2vHF@^ym|Uve|18|_@jc}zn6!T?<)OQy}KuxO0sFLbC0@W z=>jEff6?A?-y|Zo(%9Kf$D(zoZ|zr`-rP7Wd+f>``H}YLMNOg{o z2u<4v(0r&hPh*E}iZOO7e3Lc83qA;~(YzNjm5yAeh;#~!njsZP$yZXC4Dr^`4s&=Q zMw$%(*Qx1DnT_VEA(qNK1^Gj~1MJ=G%QEjE=EgkrSgavDdG12sGoFPAZ=89J25^|k z$SFh|(GSLh-UP^uF-?(`8t@1PH zT4A7?KoQwTlTw>QZxk4KOVyLP(fnp=apE?NEfdIPMGT_dX?NV-=uO(4OjFbgT*hgA zudOQ7+z4cDrSELaRwq-47Z}ZMb%>nq5;}n(GLJFvf@<}P8AG23C|nO_4LO(J>#d9L zz5B@Mq}|2}Uz?b1c2lb!A#~TqjfqUEhN#+i>@x6uM#jFxw+Ff>L)893a`^wc-7qV1Kw; z)DBv-S()sJOCbYJEt#-40zV8Vya8)eiq$;z>YB9ejcT1Xlv4?JP9zQ>H-tbtw=ZZ2 z?umn&4B_5hJ@9Vc@=Ceh8DswY{sP~ib%gDf95m5Kl6oHpZpmJ;*wGaEWqo5PuzA;Q zzBL-b_5dCxumH0u?T3sjG{O183EPh2;~u9gkSk-T6dFsiYJdw6r~Aw}j<;YIZ_ zr4hpC!Bs_Z7vv8Cd!SRjR@0X{cl-R6J;fdd=o|XrdaJr}y-Ob)Xy1CU*u&OgM!$6N z=qPPB;(Hg{_wKd3 zZR_?%FlBek!-oa4sA|u*>_fJk-e|sg?oie4Mpk?G+JA2!>UgF^d1iqm_4R7;2(zTM zqiU#Zlihe!T}Hgpe=7DAkAgrj>#g@di|J*>;?m)_48QpVR^lXnb9$u^H7KeD<+`;O(N2>Ng`;prlohkdEgzV!20Q2D5U)i1CP;J?roxix&<<6l3FuPR-ub*n| z468*eh9RzuxO>F1d2a;7+{m>XfpUw}s5J}^OcFLAYZ$~>*#l`ioMA`~#_15Up7{Ae zw97&Nve~0G2+6=r5~Pi7HOs*MThVli6Mjgd8AN=CF@QnD66q(s%q5I1IEfSoiLW5x zVv32<0OS!zBEq&bu3e+1p8+yVC>zFr5j&gX+7i;15nwHXyi$fED7ihZ)6gmEUCn?p zkW!%svgz?2xH}D=O0bh~sO+B+$l~t&L_k^TvlKn05)NRilQb$K^Y8}n4sT(Ehl0$~ zZuXQTIh}3zkWr*Z&mc#=g2H2}!TSr?ZJe5==3yCtZqeW>R3u{9Na3VED!3w-IMraE zb#`5PA}_%4Mj+-Mha21)L14DQjYp_XjM#ujyl$mouaYy2Ko8@+VJ{aS#=F_XNoxp8 zW3XpHopAxMG~FBI0&isI4usgiW{KhD&BaR#fCu$%8ElG z%MxB%QHpp+UU_8z4Iig>A`s0}>=;JfZ32FT^FvyeiHIQTj~=2D^$LH&cz(=|&tRdk z0wl!esbDw7#+hf>Ee{(r^Bpv2Oqc5fB}pX&J<$C=uY5zBZ@TxqekQLB4=bS2gX#9e zdRxN-6fD26IyYOHyIPqgcPS;crDrctB%X@9L+BrDxII02RAvDdr%;`x(2H2XO*(>`INRFlWZuYMw*$B8q@`4LnK$hS57Hf6f&m}8Ip-! zFvfT?&1;E<5+%q&=EyX#28av;QAjH`PR2d1!7*ZpJSfJmny~Vbz!ILWFZ|i_+W3&AfbBFEC-BJ}p{B-Mk#g{PG{AF&Wy7tF% zp}KaRHl^eWwmgFru&SsZZCIxd;Y5;o1bqQ#P-)w)lgZ=MXD_H)Ap?o-}c`)Uo z{q+oh$LBFByG|?+K8^BljwvF+RF4pXbe?X@O3qgh}l@3nGi^vRIy|TQ5oWWTX zs)^#EndPh2rK<=?U725+MI!MPsz}3~a1|T0i3H+#>+;I--28kA$OIf}p#YO^Yn*dZ zY3IwO<>v@<|gwWnO96_e)#kTxp$0@WzDtg2h6X4m)1 z>yyc-;OyGNqW#18B={<3r)qj@NM~Cow;ok*e@kKOE8;TWpd<_8$}Vd4GH1NR|Nd}Q2*PH+#nuL36!@iWLd>MVUa z0u+NMteawf$n(~lUJS3nZ;jnt5l4%54u3}O(o8EV;%L*_m|Mg**8aOKRK+)~tN5B$ zK2(`GP<-T7*xLl{9mCqWE@+O-T(9p!!m_^Jd~Tn;{}vSMxHcI=X>KjYg;U3MX&3Cx z(`E0!iJyJCdoyDpzgmszqBT*wvusOhP~`#jY_t-W(L{9-nP}xjeMPp_ zkeIxv8g!RBi0c01(KyoyRP^h-Ww(i19am-js*`pn>df4H!`^RqY`<)`{v+tf9b^h6 z`$N~;nXT4rx$9||N^j0w`|0)U;kVZQBcuQ*DF(|8BSXbiXu{y7hME`#PIDy~%BUn` zRRp#q%82J9kV-WUp1sB?!xz87f&N>)Q7 zs7Mx&24F-}XvoH5yma>EB-z?iUBzQ8gh1>H)^{y608<-8+#{u{mr;}s zT=qx<1}Zw7wuqD5YEO|O=s_7GorVq1!4a^#&)iRYsR{&}HLb@kwtsS$2Opl+frc=U ztv?|GW%Jt^IS5St_3dw@vo|a4H_w)0w>SQ@I+?wBrpi^X-{i~&nIq2Ta&#zD{lLQC zS#lqd)xD0a$Jq{96QFVf!yzBxF{m@SU7@qFUQ zeQj&IsSc+V_b4L|^#axhS(zPN(iz+4)SytmLScF}c zK)d!funyykVVcR>78D|Wi?kw;EcL12B5bTY=9nQ>1Ob~Eq0wds=APs%~R;P z<|*QF%~Q&5kB)Hx9+-)hZ5pO&SAeSt-S!5ccnrp7%NQ462WDPa#L8sTmAvW_%u%rU zK^C@3%S-cgMpk9Y%ch5nbZ#z;2WM5cGFz2l0XsiGzXY4q@(OCJ&6kc^t4P=8YR#() zDBgq#A~4lTo1aIx0*$uYx&VtY+gf2|QwRcVLA4i$!v~E?RuY&YJ=Ux-`$+i5 zwajQ63uat6C0SQ!4@fOcAsja zBT**P28Z(&|4)kDh9`(2u4rvNR_ta8 z*Jb?tki<(^#cr~~Q1)5zaM#@7YVnZn;z87T`^ihy%-o@B(c%`sq&{_#Pn8WiSv<7( z9s)TKZUK`{+ih5#elw+NA{Q-Yakzolf{wKx6%Qfg1-T|gs}hhqMa%l1@&7%>neFxO zqcMa`yp70|+Z*3XspyTf{Jrn&2Cv?DtZ1o@)4FxpX9HmvR&_#-uit<3b-NXPwywQa zwA3W<@P#E8t&6(*%DQuOL?7{Be&ji;-1)IS*RvkxKnnZdkA8&mf9E>wed-OEwe~rW z+mF}>Azu9$#=Ud?9WLJS&q z_(5opwX}mO?r5!&YS;iQwO$GDGGt)ZS_k0bR!0=OC)Xfvs3Rgkat%GmQ3R@uI--II zd^ZC3xjLd$5V-~k#jv79C|bZw1OufpO?ohOvDkuPdgBR=Ho~x6Q1}4tm~LDSA)G+J z3okIqkq|@ZLE8A&d=NUb>&Qd&gCXF;x$l{wIXp zo%<`*fyJhp{o|YNwxbz##L3k;Hz~S z@>X(0Bm|cH3Cyei)NZK#73GGw(cFIi{!y{br$BdZuTP|Y^rN$tpWa^oWVE8H)<@Hd z-bB-y+@JM-+nr)9?WFd9*QcG8BOW8Q_kBeP4~Ja={g$CDCqTJ zy$8S^QNl+--lL-xtI~{Gq^;<;`Q{&qw(|~aK%;VUWA{@``OZ{!ZNEIRc5q^`vWsc= z*4~NAuE`%(gtPE)l`A4y*>&^9q|O+AfN$L_>GM4`=Mooq^R#rAeD{7iU@pRe(-e9i zK@_ld3h+)rn0(rPK5RG(Jl8=88$J(GqFfQM9RL70zzW!CZYCav6~e7I5C(p0=L1L< z(@)w>Qz&VOOfqr}NY4id9*`>_8hpVa#pqJ*Kpm2IP@j`>@=U@CIIJz5u9a~jJ`wmy zT$QXgw%T+2eFpGpm?oKF!%YZZ{!ty;0iItJj6U8AT zfK;nzMf^LGko&&|5E2lDL++pCzN+xFI;KEgi9}-z`2Q4Wjm%0l>SiBMX-e)O9d1ko z*2;zCt;Jifjj1}us;%ZRmU>bw=5?uX(=ltW+@?(_{;|`DZcO#XJ4#pLdOHa}gIQ;n+*#0!zo@G?PbaT>4Iw zB!`VMrn+wfzzkUemO73#W%~tp3SA=uot9i-{RmHjK7sV+GzIwM(s}SQAb!o+yImKoLFob6kKRFmeyeYG z<=NFfvKJ2D=L`7eVe4C*Z4Wh90<*7Invy?xsr-e7H!4lDZ%%A>rOKrV2D8bR(qCY4 zSL}l5Y^{l-H}@coD;Nq!Rt~7{~Lc1%)*4(>I;*!i+=39G#u_6azN%{Gvbr z!|ds7kJn&VJpKeIF{H=fAHzPQJwC|rw6fBhrxGrd(k4@=MwUXMV8@-RN2@=DzFjIf zBCb~s0Gx85%c#0Ga{V?%f5n)P)XoCmVSSx`lybbY-gy_@(v;MQ;sDZUKTMKi3a}w7 z`a}i|=Ud2R}0qo=n%UD)^pFUxwDME3E?U*G=T$!RIuw)Q9!r*cW$ae4^_5a)KC%;zM{uCUpE zGRJpW0FWN?ouhJ~I(#z6%iZ~8d2Sb1N(#Y+el|<2HVoO{^=T3z*HyDpNE#0rMFE_J zLtJc%lI)sSRcsHqn3Nw?M$`t|dJ!2xmSa9Yje5><9~uG* z$GMQypg;-Wu3<)a$eTn*@koXcAA%xcp2D%AKbGNwW(A+C<8<{sE*VZz2Ol^=%lbBo zab`Jb5Pb{fs=MQjsRns8M{)Nm2cUm2(;6mIr*Xn7!(h5I;%I-HX+?n*M=XU$D9IWI zM70;{UGth`Ycj$rrdlRG0eg;em5qF1^L`gh@19c)dO|vbcN853PYo)*wYGnoyxwWUA%4 zB`Yn})WMS;5N5JvsAj)#AIf23mZ$Gl1R%Bfz-THabc6(YNWdC?m?>f{C6;myBZ~p(@m9uEG z!0!XcA4Cmp=6UW9)5`X1Kj--N#unQX@+yIy!{1cbL(PY)%%91wp&qf zTMhWjy1zX;^tVs-x6d8g12vCwPm~--k$_#WWOh}r{WN~@nM(L3uUS{N^7}U>nVf_k zDAlp`hj=2Ss(BaH_QusXKV8NdA7m<>9C6n*nN}+nCy@`Oi3CXu&^PB zPC5WdrP1?1wkzNsA&)9hJQXtY6MTK+DCj5yr1zGU2;AX7#|B9F+Yz$k+(U0Xu5I zi4{hPg6=O!V2 zeD*%n_?oVl-PNT%^7ndcd$>8dx%<=^DWxMmmFxbeQa{-kOeZH;eBNF^A`X;yd|xV6 zKE3@tY2Bd*N7$z}{$&KoV5(?S-CpM9RlPw-$gOmD;Y-eJ38hnGbAHG5*FMI z)<7)f&gkqPund*)^FdIcZe}zRz_z3(o{{o>kwQNmR2sZ1WM=`N^WFYrn*E_U+jEeu-JQ(eq}s@<1h! zZmpKj?^-)3Q(KL1?B@rS=R#jye@M1+(YYOqHz8q1Cnot>k*}kC%*47%70$juv0$|7 zB)!F=2tF6_%?t*UoMCM;q^W^B6q)F*`~?{U{ElQjX!0VU!C;^+5!q5JPcn=O5(6y? z!Kc@VeTxA@WVblx+R?CrTK9n@<$W=qAZCo6tt<#?N>%_^$wTm9PDM}fav}0aMT;rX z0K>qyAk0f6;0tjuV=q5$^!*wzuv2y_jSq#{g~+{IP)d=1?QC;FgP`Ge01eG*2g`u` zy}s+Fy5QWnDd8%Bk=WO;g*a{bz^dUM4q2WC2!rl^S#lS}&D$__383I23{H@W z%`8?j|Hy4%GfF^ldZ}7?Sxl9>0*Tn;GMAT>;z|;erxS>+su8TClIT@KSYf9jEF>j# zknHQ2p-3!*LqaHa>8<9qwRN42D`GomsFN zcI!|}I7FOnb|^KtCc!?MjV02~3^=X=bJ3C<^DWZClN8PTeRGcGSWFv?44aQ6|8dDb z%FE_p%(g5JRs@rzC$Qn{1AmC`C{F>!dy~o5yYZAWyHLGq0&Xz76jqN-51D(_&J5tZ zc8j7}?DgZq{!aVn@Rd zYlIJBcWT9zSMGcgB@s1h^kBA`Y^hLjp*EOAD2;4PWTPEi)lk08!q`Tli-svOaT^fB zIz%e1JU}(GggKl7S1Zg=;w|ORDJaBg2E}&s_)Gqr+*I`B$p*I&hjPUF)TapSmP!>4 z@x8#CDj_-EDIFm><|~x^ehH63XhXy!+O_Ci1iMJB0L-b?GY$j21{rnTJ-2m@KCF2f z5rYbD3Q$(_Q)v|5Qy0`JJWiM^$|H1mGqD-V*;h}ZxYg5A+0pIYb2E{{kj=48XOpRT z!eO|2$mYcsXW+Snd0ow75W7AEr?I_5K9%Dwz{R|yh!x#Daq7e=rwzTfL9+EY^MIWR z*hb{sg_R>%OvRBa<{d9M5;jAG;Yr?SORyd^-HRv2qtj{ij5|Yg3r^KUTwc~gcUm(q zP}d?HsX@_GBzD00!qNv7Ine`_7K$jFPr|m-3~dLIDon%bb!sY@u(3O554LeDoPwRo znF+OCSXhBjJcBBX{78>(9?Oh=YoEm4pXuf0MeG5gGPKMYsF|H!tED?uo~50}cvtVs zm*;0!h97_qP_YOOjn|J7+&lDH55ff#XA#XM z#{Q&w<20!S;k3VGEnHc(=B}=wQp6Q&))^r8GQCt@D9!6W+y(W*EgFw6tfHF5^ZZHW z`B?AGvuGCd4=t4tm(SYRXBXz5gRQ3rfiy&qfWqBL>8M5AwR%duFi&5B z$E>SM3)tmtWqy@|+f+wR!`AGxpc>eY6*8c+l(H`9Pp>z+JT+yd7nbI&v6cB*V>vb4 z)k9HBcTN@Uprt#7kGQ;yky!IfFfv`RK)6tv1H_%`cVHo@oX7IjmDM26WqSF!`IWiZ zRd+gdM~qY&hzVkxM|nP1=AWe+I<=r7t>!Od@Fi;soj$uVd%5gFrO|o~`cN17`OA0( zbv)>gylI_(9>S!>pR{WATwR^Na21tF&~IU3`Po?wlB>PabA0~7?A6MZdf*_W^bi6p zo5BGBVfvaL=W__~d#&@cbBnaic}ZGDw@X)e+Qt_?2d-IMC|xO|s~Yg2t_;F*FCC$e z3)E!abJV2jhalxd+8&FhnE*JXy%zQ9Ig{nE1Wv;wqOK-f#B$9m41y!#dW&i^Iu3nC ziSQcQg&ze;33lid(RPyaYr3YbUu!z%ZI>1A%7Y%nZ0v87Ad^32Z!#I_Ze-h7=ag7m z!FEo~O=ZnDoG%K3y(evtrPHcqmhQyTENvK>!JrGvR%U+b zssqQm+1kMq)QD`=h-<(h4X||CEYMV`K9I3!iDFp`Om=^ z&63U1JocG1NFPxZF5jcyYB-#_@2BxhNQs~2%OI@GUwC|O|2#~vkOj~v>Yq#U5G0|D z*5&7|!gAeL3otMdT3FN*bksVJ4K$%1Jb_<|DHd*~ct{UZ1T?A;K)5C^p(gHqeSL~U z;K=FISzCn?HGE_Vgh3M>CI!?A_ii?#mrG#@CPkj%`Oqv=H-n)PUogZ0J!tRN;QWk% z=mM4+yq$5&We0f8y%?Q~3ZgkSOOI8vXm=l2-W#gHre&n6G}uOrE~|#sez#74P)MC! zGf7UW*+R&9&a-KQb5+Du&)y4|Eun5>o-JRv>6+r-`ui|*$T@X3|7?8OwN!c^54$+8 zZ!knTWArBCJC}{j-}=O4Nbuq?lyZ^yrWTJJ&YO(t#7aG0HN!d*-07+2I;y~{FkQ)E zkbqP(YF8ep2~n*f=o%(8kSS!+mmTWs&W^t2j7wkOfQS04+UB4?uhu~9fOWkIL%-tm zpbWSAdL!GN(_AA{6|vQzJxJ9Zep&q!(sE)Mr-~Ym|9NMF!b$^bIY6>Zx-A z{E(ZDFOp@}H=R%|^JcxkKqhf2m#AhzI5xm^JeAAPJ*AgK)5Yjap5RP+F)Xz7wp>JM zPJ3KS4e(TV?@fp_t3G)zE7bMRvg@~peuX~iPJ0R|vU8BD>o}u5A3&JxZ6} zm(>d2lLQH;+;jn!hbe8Ggeb@EI0V;B&7i1xvH)y6J-@R2IV-lja(NlXD;Q_tzdVLw ULHId_AB6JaCxYxYNZ&30FK>ycOaK4? diff --git a/library/lafite/LAFITECOMMANDS.LCOM.~2~ b/library/lafite/LAFITECOMMANDS.LCOM.~2~ deleted file mode 100644 index 161d2fc586e440651ef3f193f5f17c1080f0adcf..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 59009 zcmeIb4RD+1eJ2Qjl&q*GO;WV1P`3PrmSs{EQ34<(N@*Q}04RV2@KOLMh?Z=HA}E6- zL~2PXj;C9%)5|64cH55KjpH;QcTKv}q)B@eKW6Js+}_@7CAXg5O{JbQyK{55Zfzn-3WVlTx21>Pi{XtzB5rkuhx*2@F7_Qi zZiV_!gd-;+$Gfeb?wO@am**<8C2MKX>b8D4o*(~}U%b4$G(S6Y<;hF4rONE{k>KEy zmAMPc)6364nU0R83W=DV$wag9eDKo)y;e(i_;}ygv@{$#5gt4d?(eoPEYCVE&wl>$ z^2*~UtaI{qFm4Cq72WzC_}^yo>;9a}IM?6ykNS1=;9>#?bO%r!vyp;!KdtPPD(jKSV!a>qLC0r6(KBB&>Yu#EHX`*P5Up&`p2DMVA*V8+g-3U)4S$HoCT$Bvn^F&MTosdyZi6pCP43Q7I6 zHE2AB*Q}#Qt?ulSb!lmN*19yivN8=I2?7!ut=9)F)dZG=*D#mJCkkqvCiMEzKojvk zHSD`BY}f)KW_TSliR>g6@?ap~^XKxiPL`jSh}V#RcF`JD5ALLu31h+mMyi)SfhL~Q z%xTb*f)zUMOs`rB0~U{BO@ci7d@>qOV1hye4cf!?x*3wmnE>p``vp)YYXVT&U`7Bv zK!Y<$8c)g^AZW$kh(%wE1NHqWFN6~!I1oPIwt(pgHT!)#+S`1E_D?l!H#Z$;c&;`+ zk>tN+%+>8MA3>IQ%z&QM|s5j5qkDQ);T?UM;p!_O_Z#?@t${s&?j3@H3TxtSvjjwglyO;4>Xzb}kE;TxZH}K)V8Swj>+AaTZltE*d zQMBB7beLy>e;9XjUyBa&6V>792wyofoMhCF@+;T7tipIJgqcyt3gAGlLj8kQ%+AK5ARJ)=x|lsN6;zJ} z3yCuYYarrGwR|$B$BMYb!JbHDgNphcXIhdtGhycwsu5a}h>7i1DC{{sPW=+gqjrxS zH)flNf_n=Xbs{=q=L&>HsqDlgaL8;39a&(!-Na&+SDx;+hCos*%R1X_9gE=T;_}iZ z{5jfhb!UXYSfDT4P(=+J9@?(qz85RLyu;@U$fDgis{Za)i`b?9?r-mG9vlD3OXarY zH4Dw5lO1k;bR@ z)7*>%A-lvC)lS5NG=)R`&U(qm1+%n_NBKQW($J7GshAmeh6l_$m~I#Dt*~bzK+KJM zHH*;OQVV5F*fd>Iq!|zwOZMdwg~?pDZxsCNFo=}mu<^-EW{UW0A3sGrHf#|rlB~t# z*q}e)eG_?H9At8lO@rc}>N_1xPbRQR`vc7Z-`sF}07Sc7DzsqHe7@47?YbtFiSxN&nNE)3NWXMh|Z8=f_KHd;EM5D3?kjEsQJj*3;ZA|8SGlj5`jw zkX(;TYq7P#a;Dt18saC)eD^CQKM%4RXxjV_899^|g#4~{;*HM!Uyr?#%p?O{pZwKi zW?vQG@vUJVIS>4rKiuB7EBgb5wy$N*w^iHQKEdNHc6EtpR(!atz3G0tle_5P5o~QV z+Z`SL&Bulf>8%>I+sY-rKbPw25{NvvC%aY{PxHHXewa39@a=S#$52gY%B3-Rx+)Kz zZ{=yaF}m6GtJi!l*>cJ)XUkn(ougH5XYGnS&JWN3`H8k_y2KrwUHFk|x@1*aw$?vc zm5#?3Zk}CuuRNza<5tEO-s8W{Rc?aYT;MhrWW}qyeE64XlVR`@T)XqUuV?VsAV~@Z zqS}K;!`8W26u1vHrI@t_2af_)fghk_1&}OjFfzozYmbcKm;jk>rn312i2q>!aqooz z@C*|3KpQ3sIcoqiG348XJ<4Z;15Q%|{l|>s{u;!$A|Q-f+DxY6iC_|HU?P{t4HA)w zLxGYOgA>tQUf;ALU{P*w5%lIICsrgv6xJ)EM?kw9)5tIee=bW5Ic$Y7Ewyik!~GVf zP{7X9`Io!_L*Gb zBnX#<=it%f7S;tSG?e2(2ogk+cvV4TWl9rJl}6QMjM}8Xgf!DP zZ-F>l1IGbFybcLFZ4C?(97uBm1KYj>LB$!t0C<}73aFnxjvQlYMiw@XL1^9C1%ZJ9 znPp6g6#+$83<65E$mNP6oAeqy6J0P%2n~fT3^f;(h09x^qeCVK4Gp?7mXggNh=~CJ zWSX#nFo48z<9fuEfqB{Ws7b5?*6_8_EF=YIy>#38)KdwPl@wHaFPr>}ghJrN-DZZ> zn7cd>I;Of&z3?Jq24%60Spd9Pk?@e!J+ZuWp)z|3y8qnD<;wK)bBoVvmGFplWtq>f zE?!((zBGLWHVoJ@!p9?4Pb_^Rk;_3~4;qqyVz<4(rjRT5&8=9omo8sg=T%@CMyFeCdes%wamPWFGIvR4ow{*j)*rFOfUi%7AP_a`y*3@ z1ZZ5uds(9Es23`b)2a}8f!lMI@W(-L7yomWC zYHdj5p?+5f@XQZL1Bj>q07yElGp^+dG_>KI;vH}b{f<|61Fbe%s8a;CYtLOC`4C#3 z-)f@e5%{ea-B|c&|5PB^wAoy4^S?Hn65*%+DW3neQ*w^gtm-4E!(;xfwV#*sVO~9B zy~YCnbgaB@b+3NB|JTNb#{%5iC!w$f&aA$I^#WeRbBT<78Wya65NW+Wm__gU4C3Px znGrJU=mmx>ZnA1xCa`Z~zJ@%D235?schqw>;IXQKjh&0e3aQfxK|6u*JX9c)$)G*YBGLv#J>5=dpx=E0W*Fx>@K_&%mg_@^Xu3T}7y2q#xFbV> zTC27{8FG7- zPF*-X;wS6N>Vc9U)^Y`5{)L;#fIsOM(Aoo{{l11TP+pKQ&l-Rk8B5UHl1-)YJPGb&4ys*a-INdbFM>Q z)5q{{=tH2pej2<}U)>&ALePdt)`TUldvbAZ@yhJ-?8+6AZp%Q7*=3*zoF5uZ%5$aC z>>?ynNW^fATy5}zb#ZRCQd+T|LqpcZrK^jCQc9+WLozs-g&8}QBTpvmgo$+AF@!5bp*eFOxsa%&Igb0Fh));e>35~Ud4 zUrPp3`}}QrIRo9!bOpPN`g!;m>6QA70VF@3ng|x`Ak;dAh@Q_ldHUpOXXNI9 z2h0Iugcsm`P-6kZQW#b_xwSS>RU;g>&X!>7So?+Q+}Z&~fMFP%=EUIi)YnsE75a>WV;lR1 zW0hT%Gc2WXBY!Eh1mpv}PJtxmEC{!HP(}%|5=%yN#Z(+B0kklUKdjap%o6;>Ak-Gz zm6$`}z>_ctvE&S#BR!=!ff?SG;9#0TT9m{@v&CJr8hXs7K8i1@DWjF?_pk)8I9IB| z__tXef!B}XO%@qK`Uetx!gxFLD6*Ov3Vf_%b9a;|s-uj&)+O#wd0 zCmF!Iy1Ix>Fq|7tv&fcbq)4W)@F^D2s$<{GkL~i|AFpV25A5jjk^qp!o!;mN2wMo9ezw6_ zfRh1&f(l?-x+TY2QfK^9uhm>9+Hu?qp{CH%a5Ms&3;to?(O&ULol_Tq1ddbJwSqMqI1@g6F@$uu)_I`f8OAk- zV>oXTsgZ>yDhc_{^8Gx)u_9AEO8#NMW~#-&|JRjWf5`(U)&&DX>P(KD(Jrxqlt5I2 z=rTG6>~WCL1jYjx30d*P=~OIXX^>>X?2sB-F9`FI!C?5ts~AU3dXL;?{;msaND27uTQrRk>8-;s)HU) z)(x{BFN4`7fBVn6!@3D|mfo2|!{PW*NU(@_4hbG2Kc8UgsCArVj;KDv)YOGlz_Avx zh&93XisP_lXAt!_AHZipyPSd#2+}@hRW9|EY!BYo+veuKE7C*^Aat z&dqJTe9iYwb?a%xK{oei_=p=-4ecE3N_VX;)LmjkT0K+T_chhXi}SCkBL=9=>G@l! zTdx;eQw#5n@!P^;(rb^a$DYx>9?rVGDic7ltu(i__IOo2%G0!JaWhK4{~zVrx4vF% zRkKkocF;)&Pg1qG_myJnLUC^^+7S5;*b_ngfk!ipzz`!B+?9?XYQQ6fz$UM_LIm1} z){n@1ea`b7Y@M34hv7zYj-d*8It`;0hq=H)3OA5uTnssojUk}JsGz$F8O8#Nuh1=n z8Mu@RJ-R34ivih!j6_cpCq{?lZgbfW5IBOi>KPO`W!=Rv+)cXIFl?93G1z)8buvkD z8k#iKa4mSPK*Kp6ja*A%MBmjlPu3Ur5wdR7KLRVM?v*?$&N0ko^$&xVI}d(y|W+@G&BM>E&KL~AX zK`sfsSbebMe| zMrt8|S_CN2AByfUv{ZMM=mQ@BJM|BXUuMn`i8a)_z@+U^N39+nEMSl=k^Ss`VgXZ_ zTrrUgQc#G&=@5}pJFkyG-O~y&>|{(Hhs6}DCkv8|OpbD|L%2zExCw=a$Q}46AofDF zl2af~Fq#hn1Ti#6((piy9^JO{(Ju2*nq%@Ukp`f}=+e^;jH8%w$9>u0(>)79xoOp46F zdi9v*hu9TP5Y8GH&l+Tv0V|qDe5|Z3>s6j}wuA9Y!a2ZfT$}+hR*MJFbt5Dk{ate# z0a8Q(VC`Iwz7Yn1-Vq~W5NLzFLE!oz!dwdlADuv(==8Uv?r3PQ9rHcWT)|5nteOAV z(C$RAQvh(DqQvun@RJR$q_eJ`bcBPWmV z7LuG}IIXV!1yq%zP>+b3s17I^lcO28i6*D`al=EYWdL$5!&HB_fO1DEsF@`V4clnD zjNPo@J6f;925N??f#4YH z7~Te$?r9NG-usyAKVZ%@g;T27cM4TPH2A2cL$d)BUv6&p`3vmYM533`DFRE2;FGO4zhjv@p}p0QxS=a_o_yq|IMLx{YK9HGPz>PXET7vXW0 zgESj}4aw6u`#{L{uKP!WXu|P(3i8Kt_X5hBM`E7^P>U7t?hp^Z4xy13U=gF^Ks?xt z_Y(wkDGZjf9cX0$-%xfMG@~^NdT3-aKc({{dRrQ-wU$G5z=Vss(8P}cO9T8(8wjBE z_eosG^{)14b5b4e-&&XWRL1Wuer|_y4YbKKH;ztyBPlTi*Zo`T2f0Cs@7(&K`b+Qm z-qr7!PyD`m;&-&e;hOI&Ro#2*Q}A)~yDzD}cArfyyvLC5Vndl8S{lQR_Ky3qncM5} zaS0hc->PxOn&0~E>fGuPd8rwvf25*C-)ZhANBWm+u{vygBD-+&nbkMT9UG5CB^E>V z+;fh*O>5aT0tL=lLzQS2VKq*o)EK+Mki=oN1@x0KG?ReI5!ODT_YwJPBo~N6Cc)|< z;DB!4ybe*m!DRqT7^Zy#g~CQGr-BQFcxma9(2*2w7gfU$gWWTVo;1$9VKN~!WAsE3 zA{m&~QWNBZhxZ_wE=H%w5J=xn5_>&dQkDtaAI@vXL;9^DO+OmHL_xF;d4Za3i~|$t zvx2|ENFkXbJW1Q(JYS_Pr>6pvn;#rg^?PI_*w@uQ2o&%_9l zw~-(*=ArpS<-ayO&LG!DoMQFgAcR-~X;0eZD%A1=Xbs>A1A~C;PL21Qwhc=n|0oF~ zOn&I+Ve2^FjzS`lglo*#N0lGdC$qWInG3R3)=wAbP8+id0%@^Kx$(%|MM?0} z1~MR`C>`ZVb42eqX{b^D8LucRY^-ilT_&a$8BC0)n;000Qi0*p+9#Vf_o~3_-4uG( z9^H}Jw8q-V8Q!$HYp!GM{oyu0>%reCuimCG(*LdLyQ#OzUrhPmN(Elah>D!~QZmE9 z@aFjDC(`Avv#+ndo<8)(>ZY%UQU#c!LF{lj8d7B46A*ZVy_#X3w6F!+L4S$xCUHY@ zdlf>fyk1XApOM?>{{z^RcB-#D0-uvu45O^vy?o98rMQU0YrmqN892ALJoi>wV7~c{ zk#CN~KI_9ju~?n49#>7K< z#{YU2CbO{;I{Itwn4dYTM%T<|-??^YJ}P-wW9;S?qhq;^U)bC+xB8Hh#b2&wevNzD zdL>haOYF{QlwU}EmH&K^f2Hl~PNwJI+}=p5{+uk(g&(P>_RqIB@3z|(Zk}(mJASfm z*{!y??UX=H9R1(gow(mwUHy^W*^%CSY~1}28R^T{e)`r(>1#1jm&6Bo7H6+!PbY2iWB)% z29j-`SOohLrzSy@LY%S-zi#%V(-sA{IYF5OiGi&j_eyoe+=0Cylo$g0g0$Ay`P=mtoh6Sf?gYbOPFha|FY< zx`uEnIfD014$z`H;9MPc5(pijS`9HbiQ1zwBOS{e7qlT`lo1dZDcevZJ0ltq`7)Q5 zJ~xZNLSXau3Weg%OCkzW2;)oG9oXS(4wuTwvItGQ~ z3L6k@*qDK+Mpy+*CEs_L1KtEzdWc}l;So`8#R;55t|MP&Z?FTMik7m>>?*YYKEr&W zp1DVT!&sGjl46-{QZ14OB}Zz6l$uf%kV%lRCNc?*2R%G_GM#4hA4QA`M=3=oS)<|# z7sGzUC#VV+r)0A3FN=SDlBwb;{$)D=F};mFr;<{}II{Zc4RYGuHk9} zBk+7tQ4-2r*V2@uyarW$5k)xQn5r*0!cjI}DH-Tb|K@3w6MGF89EBr`8 zGpLlB_Y~&cJHL>XfOTSbiwLk%l?_v1(u+faRLvTDrR}2#x4Q3c(sswjL!;ji*2NsK zO_hrPl!M~bEBI9Cp^gjOYrIx1Xm2C2laIYS2ATo-aOrYomecoKN-WN-52|c#b$zEH zOjPx=3Sp`$MyqP3HEryTG6wO_Fyqmg-z{rv;=ohUt#xGpym9CaAy?7Pf$F$C&jOFg zRby*bZ2b`y6Mi6fd6{1wj*iI#BhoEjZO`paH*G$V?U;&+Rq)24?_BertVT=k_%6>w z%JF|%tPI!upYfmXK&Z^Cc84lelDu?>+mL*6TY_oMcQSDhF|0FCwdH*N&zpVj@vb)G z*m943#`Wg5YSQiyN`riPKDfT~mfa~Ik*rKg=lY>{e6U}Br;`6d{f#fHCzWTkn$hpv z2sjPjtnKSYKoTgciS)YwTxobb&u-guuZ>_HW zdvhMbbA(;Uzj587l+WySPYfbuI}^=~YvarS#q5A)NG9e0QjJIKNvgXts1Bg+@f8x{ zJ1Aqb7Rl4b z&C6_K_U6}v`!rw`tU`Goq`2`$MXUzBe#b!=28F=UvRMNdi4xdg_Zsk)P(j|FaSvZ? zoN*8{$!BCD8*qZ2=!{a(-6tc6hd0icSL*j79!n=hoEc97){L`$vrRIIyZ6HA?;kcd zITs336N$(EAxm9`92kNpO;y@)zA`A%0`iAJ~usAnMPJQm%f9s zzq>d+$Ei0+BR9oMC`ObmqZkoDS@Ryp=?i1PQWJ&M2+2A`NvTYmnfSb>E)TqJ7X298 z?2$yPskMjX;gpaVhe6Eo+ghnJa*3Hitp2w!>vExo6VdpXoyv-})eFp&ekJP}oScZG z>X-2qNb&Pxo&!=!0#gN?@(qOm4o&nTGv+u10QRVbFbAJNE;$^p9+d~!sD@PwIdzVR zZJw)DLP&_nU!I+ryZAiP4CiLbNPent0u@$#ZgHk^wKPj*51~w0(=#)(mDy!3c6e!a z@oLb}CFUvE$xCV={@)iRG<%|Ozwp~|fW8QTIrH9r|naD`nhSFO{g|TqZ z+qRi#5HHV)f|1FJdfnB)-fbGVM@6U>K1mw_@K6Cpj$$JcNpt+5j}WbCvxS8$mVMd+ z0srd%MP7e1(ND+C0WdPGNn+(!u{;m*4HG)0z>5J24MqfCzB{6#I~*QH z>34XUB~22G1QzXG2!>fMA!!#0Sv1S2p^>=diodmkaQdf&16Y7f&DQ^YMCvP-+Kof) z|Kfgw2%XnuZU$fEIamwQ{v9-13{rd zs#ig2ekjO-Q1zqg<5;fXl4O?^AM_EM(0VPSArqWewE`|Nu^`hh4ry?xlk~{brsk~{8pz>Rhb%0m!=I!zqGyb$yKh(GI{&%Zcxwy73S*q;% zF=D`kiND6Hy_!!}+HmoQ{E)i#89Zs>;vagR?5zZ9AKaU)G~?P2jF(?5zn)ycwe?3+ z=H-9Py-EGk*RS0_vW=bJI2=cj;~FQ{gKGUTd#1_t9E*= zM@*XIrLT$3L>8Iq*yet_wTtnB!FuCRYV$F9kDTC%RVujR+tbh05^h?m?2t z4QLErMrC)j=+fUGOmA`mBZcc@dF$|qIhTtaV~J8*EF z$S09oG7k0|GHm(aa{3jW<4e`r6xKp2(RUT~X6IM9UiRSYRFO|Vk8;J6BtFRv_zfH1 zfZe6>4fwH6s5U?>Fl6V10?O2!VGi|Y!FYE<3pbimi@Qxvk7Lvc)?9};$bLDZOJp+Y zwx$GV+t+4|RjyAYlyOYz)C34ms!PDVE)Iio3$Pouu+vH{15Wu=ZMiL9|I{5Fd z%r0J8Ay*tEq3+`H9BwaNy`n4lgMC9>?M{6D@>LY{w|buA2UeDrp>p*SZzm&*aSfNC zMe66fsc0P4HPQP4tUzx^_t4ua(<@gj8IGZ#nTzx>oo8lnB3b`+q&pCYs%MhdmO`5t zG0BgnsJG=i>f3?Po>O_I!4phEB-UMyCxjs7en+Bz<~xVx+vE;-B|CXXbcsgA8GyDL zq_}HcMjK+9a~*Oo+#LE2_@l1&>Ef2Wt2{a~S~%66CXnEtLopb(2@yJ*-;Z;bv6*u$ z?CqmOjWzOcITK56EyHX_9!?oBPq`UQ_5}P}cg zX(bBso1SO$+ZnzvGmT@;^cx15`C9`>f<2plRdn{2FzC7Zda#-T%4ehU zjSI5smV)tZ;Sf~GfCQ*{#u)@l;|$B>o)PIoz(_sqV7hUY$(TVmj8$?ZHUrT$`1O7y zUvE9Ad!V~EK=MB^NE@GiZxCI_R{yr)`ay)|lo0|4O-_z$!!22-}kVhkz##r2)(FNRi*jDa(xmVX}~ z=Wp+q{Go;RkzM0WnJ*B^~23PTuRfmuF8LnKfi6ao%w>@1_dX(*>1O%yPkQvIv#i<{Xf0AihA#d zo>{$Jc@dBOGgfaTFp($mso^p1oI4xCM20Yvus-tFhcGh^!IzJfDMiYyQ;iAnVDJQB z8xPD&$O)x0mq1PBpfw4HagKA*VTPQ7+#yC3nRRNJEm&v=0-!5s+Ly1)EiJB)R0v|8 zFE7t6E?CY*SjiyHF0IVEmq^037c0+$w%4z>gUKc&5{PLx-SA5bFU~6y(K`V|5Ul+o zrrPDCzgMjURv!}ca;vy3#5>{B_462iH2FhognQYNR%}lAzpwsL>ao;Cc?QrK|{?C2GuxlgbOAYy+ zns;WmHqOrI2l88eEgW?IOFq9YbRCsaa*mcwMaU+)W>iex0u9Y5>pCp^KLB{)h0^fa zh!sGx*0)7|L5*otM-cIYt9B8*)N%?0SGc2xS=MQzeqI|gmAW>aNm81F6J#CB#4$B) zXS5`?5tev}NaSXC&&Xy+R5=lQF6?AHj`6R$sKfB2j6)k!*Y!UYYFS472p} zF_Ny#X=P2$(Is3F53^k&F@p(WnSqbVq7r~lNm9m4K#JE%6^E_$0g<9_gukH==I?A+ z>R2kA@!HI9ZR}Pui}KZ~SRWVH;iCnsqTn0eT@a!zgK3f6vjjz>>B+oy_#pV%3(HD~ zh6%EMoiMkwGeshM5)~8?pW%WSl^8Y7K=6$-1ZBWNks^~nbT4B|HdhZA$=O9jX3CCk zu6|g*eggCyO-gE3-KKdzyF4u814yiP7Mk{D5TzXp{f`1zXjOc`tW_Y^@U1^6C?RC+ z(dymuPDD1@7?ctmIZ^9nKRy?J>dqM;}0pWYtzKLRfip!}TjCn1|stge%IwWeUfJIJJp{d=ySN?{5V5 zbs{!&PP<#EV|XmJYy}$8V1S?{0)CF@1&4tb5buqE2<&}W2y+Pof^j`q;@TnrNr#c1 zL>s#Cdh^Qi&n~c1F6_>JDl&PDn9RRW5; zHX_v|Dtf_M8Hb=%Kf4}sD^TO%hCdskD?|yi)C1=3Y*{m8qZy%U+5@ii&B%H{#bJcTm~ z$>0q?w-3^XuN6Bhs>dkU-gzHWcWQ?&;cDCMlX=+PjRP0V8H$ySY+yVHo`q= z(S0;@M+qNi4KV9euf=~Cv<8%Z7=&#wOvW&v;kMXW%ks5y>7hlASqfu*86+nloNxBlZ%&?d9VRk7=Dh1o45(B8%!Zu*H%?+?H zgQCE$X`FdgHK-THJ+Isgs&Cx$s&R0t8230t0+tMxRj?E(R9B#Q)P?t^L}^f}!!BO4&Tw?KtK@%*)z{?0%`@-%t79t09~Jce zojja;SLwg%-QCetl1+1+yVVs-7bt1_%l3{PJC=VGa+(NV5UpIyIdsv(a2N#8R23Ab*H=fW4c2S>_$Y+?b~x zi#23E&s_+7#sB`p)`vbv%W5f#K|ChsfzJp%Vxq^B4m! zs8+w2G4y$W!u4R*kaPLH-n#JKyAKbK+ik4ywTang7iHT%YPX`BJ+<9D!w+K6Z|Lta zzf3Z8uifbflK?!joG09!(gGxVBMi+;10&Hs?YE->Gy1x+M>?((s)MfY!IW*d`%ntq zFn*Zrks3j%y9f@DZ1LLgeowGJTrGO*T#z%h373vYW!UmY;D_OaH(-rQv6`n|U6Z!G zQLWQfbt>V`iNpcqh7f4y!Z9=i_r$?X9)-7854@YVyi%@r#+d(pu)sHH9cH^F2Tk;m zq~6DYTe1r+_DV&5S>Ff>Y~FQ$aE(T=J%EP^EWm7vZDi>RO>n+&(zfIHxX0)UUF>0izM&7U zx2h}GyY#{S_RR;1J!~Cj^h+0y++KTd9KSD@&;DAm2S*I?Zx)Xr2W)=zkyP=B;OSmz zyV+I;ft%-B$BIW5-kWdVv&ZhXt=sFtl-(^49}>)>sy*Mf5885iqxt6fgH^j5S?%4c z|Gj;%?D%#v1*sG+h=cKs1`8SzU0vDi~Q0s_IT$8Np-Vi_0z9a97m zn2U$`gh$|hAzv#VmPAxOaewUA>`f=SjoY0GR*Q#=!FjutPpfmqAh%aV=ZC5LVo;?9 zgY*=GJmi_6+b?LG8u83wyd#DJ36`4a#|y>7+#J7mejnx4+4} zrnQ59UPZeL0oVwgw!55j|GPWs^n4dTF#qS2)hEXYuSVuyt2(0nUB&82C^_bf z2U9%qu7>*Y&8CHSHRPu^o95r$&j5S=K=u5?Rr`Sb@a^@^lzl)#_HhA#d0_Rg?apti zw(QQ%UtH~S=THHd-716EPqlW2)uI){5LbrW-DlanHw0pCKgOCi|BthCTSF;T4zZFfVIN^sR znnA>O7y}qYERlZF%Ur_P+>=OgkoXD`E+&{L4L}}oBqD4}#I@6h=-qj2!11S}HAe$cVuDjjfBj7b894h-~1hTk0KM_z? z`Yc6Hse}XA>Nt&x$UM9Oyu(`<;h`Y22&3a1$;oWPhm7D7J%b$e3JQ;@2JbImA9HG! z*AyYF(EaMKLPa8mjTBD$qk=1PiPH^saA()0C-MRuZwO-U3An+nAp~X{+;|A#{b~+| zyl$mqUM1%k0zHiPj(NHGF}#~ioB{xvlEYCzox!Xjj2LGK$TQ9;1ktTc2ZObHHpmr8 zbOPfbq}mg-IM^y~fRd|tOJ^1v1|cXb4v8#Fcxgo`;=O+5l>sz-g5HThG*7W(7lijq?as`t%uH8iu2!bWT}nx9>FJ9U ziKpW35c&rjZck4hm05trDO6`E^dejt>6~g1a5sgq)ZKkZguFaW2~pk1S*0v|KBeu) zBpV8;k!B{O26aK%5Xn{Wl~alqh0G~LhGe1_j4_@}^ID>zL)TcH>gu$*y!KdCqVy(j zuRT;y+2rC8m=w~k+Fg54-Y>T13M#W__2E;@XOLk9Cmr+BSCq$XPqA%t@RSPq+uX0( z*l0h^++k~DmsG_NKi%3M@g>YOe}x;VuKtN!sIFe8O)0s8EzckYtSah98`kMVIFV!? zVR-~+P-)w)lgZ=MC*r9U56bhw?%PtL6AlTWDdAob?Ql*S{7-f+0|E%GRIv@F!T=eA ziy)}jU<%?JFayIN{gTdZTml5smQN@j&S@S@xoCeq1K{y_jLNPP3xrRjJe*^SNHEnS zgdm-#+p?0gmCK*9VoO&mC2Mi%inTn8O`;JydI>4M*bxumtIy3{DRY4d26w)O8Z?v( zJbe`*1usNjcsgiVv`M9d6Y?T516QsrEhA@e8ii`2cxY<&f%26O(AbXUUKUzKg;M8r-h z^!!%UxVrk3i?m|$90SruC10Q#<(5@-3)Sq}9(jE{85NveeMq!_7@q`R#q3l~Zywdz z*2&FB)Z5=y*!qe%)wyIhzx7`TmY>n+`mYq$Gr9tdVW|{!1rjM7C8b%TEA1o8svIU9 ze5@W_fl!WM<3U&G=O(&>$7*!tpl}CWX*XgMUqx_>1L3NgQJIEL!A`2og# zSa|<#;64P3kB$4#3GM;+Rp107eg-*5oiqxBtD9I2>!z3=@}ykUV0aCFYwYHVI9jxG z_%m{srdm-EN1N70+#`87}m~rL33p0dVMDn zmi6`K^Ly=mx1dfi{Or}`TR>o59xvHlw_zyw)oN51 zt%=&5Wm{5%D)*~rqm{UfCaR0bL@O`qE3&PI#Nt(z3pFl_MAX6yWAG+SoY_?|0T~EVQdUNX9Pp@YWy|wxu zAO%24F<5RG87i(q69z9e)I>5fawQnbs3c=m1hyo~i032Z-^opwpyUAdXgPok#|Ko| zqo#rkRdi8%T9FOj7z$OWbB98{7ij}ZRzoAGNEVO=U_?{pX$*R&h#{nC$i`y4boS*W z+1gWG#bYdlKQh7Hfb z5wN?@-bZ_>3Iv-qtw-kDAK&T0ho^O*Aq-?|Pl!O-{B}kT0^@&k`tbEVkr z^*^hQXK$XZa@FfMIkQ3L2zCYc;}PZIo?zkKle>3QfafnA@hvW>E;5}~P^P@TFj$9aoSS6{ecxt-|6{(D4 zF-2se`~o#@97$lzc5^{QoIiB}64y3nYJB`0;Lnc&Wg@!p7q4yi9OVGYr9e=$%cF-UAawgzsD%XLG;!jqjENwMaxy2WyY)y*%a!^c6 zgA|n|VKPAROMHO%!v;&7$mQ%D()gWeZUlOuPtZD;fwA64hcpG4V(?Q`G?7*iYoHc| zWCD<%Pxf$+9L3zX-F&L_a@|U=k;?1ZZT{1sfB=Jneh zy)C669ncJ))wZw-tCS`Q?zd^l7xY2{68U`G3BekCRA{WX7HY19$f%Jq6v(8Q;W%Q3 zQRRTK_qVIVtNR3xmA13{OG>*btvxD?16GP2^HB)YPPltm8n$pwbK$ux}Laup3MKRA4sBx`RrhxW#Z$Yf;wU0xl(*02QK- z*)XD6(HIv8z#dTAAV(kiECok1sc!T$EEGMuc^}^$QGd&^jTXKj`PZTg(hQW=_Pfon z6uEfkjw<|$xggV|Yej|@RZJ$btj1ZWrR1^%+O@ZVbr@d^(@fU3pb+s}q!oc=sZRwL zVPoZS#|)_=2-w63okkcpS>Np(aTv0QV&0L|q7WLqAZh1mhYOe2C0^3LUm-M)GP0eS7Fzp^DP=}*neUcxmSYzbwJe_zajqk7wa5Nn~DH1m#5>QAb5$AXX zmcn7atN9S{Ol(={SOLj^*LY5dnHoUJvUg4UG*NexJ}_x%%vn==n~x&~3tf_23}K_G zNrc7@oT47~V2m)+DwHJrO2aQQq5||-9)}$hbD#dP| z4}`bK!HwOO-R*zzKyn_29{-;fyA4keLtN3?e6-lj60Xbm`5}pyu!`Meg`w=T;-RjY zL)GFz-Ngf_^Y)XMs+pOC)uP2MfJuFNo==qxI$1op@E!s=5N-jJPTOr*oqj8&Y9bdc zW^uTI*n*DL_lpM+@`7BGqE!jVouXy^&-niyv zc7a!~KU%a@$7$WV?6ZL|468aO$Jg(>`MTYTK3i8`D_Uw2c=*DSi`KmEzOv>V9o9!Y znD;$rl{-Jy=X%z|97tgwc>jHr|2yAl?^SQWthLv9+D zmmveQ);a(ew>qNOJ-G&XLmd$Tl56Nejv`QP)Daa#;JXpH&(#s7g2**UD25d+LeTj)WLO57NfJ=7Z3gT}K|G z9}EE(&VA1e)p-p-Q3mlz2Iq))0|O&Yv;b^;B;h^=6Q9lpb}wP;K&=UISuh!fqVwFD$Q2QbvQs)`qUwNArX=oAqNfhB(u^Xfmn3u=Ewxgl;e zw_mt#SZwnt(4E_BW2yJwKUewb?X}0F6;-u9npX5Cn%3k7H3$MX&wMGG79tm=cYpl$ z(^>UkCcFAzRFTYRO23_Q-d1V4*Ck2U(P)N2uMg=x0CtNKJ`D069j;iFX4E2WMZe8A z|5&u0cUS`&mXjO1o?^;(wz6~U<+0TRV+)m?OuIMtj8%4y|EMCIg@>zL5y{HVn=dAH z#_;`o>t;!x@2)wQxWJodq`Tz1_sIcs5e}TD(EA9YfVESAcM5{YLfg-W4QGMpItXFI z=Rr!8D+0Cy000MA0UOQD#KW*cxb+6Yz;Eq*0LfzdNxNwZB@K~DMy>(r`2fKKas@<# zFF2$aUCJG(L-G#lb5c&8Nmv1gwWZUwGET%N0zZkXlGVmmn{J3OQ8Op*N!%)$poKt_ z*kVG3E|sB#Y9JWTV-nmm;|@!2b)$C7%1(0{FMRublqEF$j_*DJ5)EXsCj#NE^8CP< z4Yd>PI~0{Li-bk)PAG%RfHWq;@;wQOmBW)gQ5-S?NVR%a#J?k(;r*`xgakz4ko%{( zuPHpOjwp~tw`o&~-*g($jj6tPN9jsjZzrKfSG&uEb6Msyy3wJVMl`G{sK9YN3gQ%$ zQte&2!WIlz)uQp3J;@0q9D8Y8VCh(#X7WglOW%o-y@VDPhKj2aqf*u)AXBT8(pb#X^g>a{H634S=<%-APbQW!*Y5fWfA4|>Nj4*FdeBx zKRv?n{AocU&HMCCXS^`uP%%fRD1>6bW}aUZ2w<2!o$c`&?25;q040X>82n?{XSBx$ z8J<>Fdh=Amg;LsN3f0I`C=~3tQ}t-|r_i@c1xLj7$^n2=4s;n+*G8`2rs%I26O!6l z;5)U-@%DP>U35!RQX`53NTdBQNscMNhOFol88n=4AxlP@{0>_72gLlDABFr*35Pc8 z1W3qU?)&l=s@?CyzLEQ$oX#{?)hhwfQg#=+nddPPU%Yo|f$s8|t=ac1`om?p? z1Q+_bEV0@!WPjJENrYTi%}OC@JY*CFa25`6u_;QjgXTi|fH9L4$5XeO;?mDsX(eepDGz8*J-EWTerye&9>GhXw^o0Cx>D!b9F9I*La!g!m8?5%Uy|4gIkU7c?vQ zTpg#Y?{Ud+k~;Xn30l^-QH(RoNrUKHC|BJbZ%j4FqdAJZS2+OvgPGPanL3RVUNQCv zHQ63uS-yx#;MwxL+OTi#d&|p?TM4jEIHm?%N*Ok z*f3@orEn2|tW_qQg-pUjbM2uuFv%LECEJ&nIn*umTKzYNe>7!+0y-B(tlwG z%3)%bC+}7SAhmJ-a4IHrgamp>z#6wuPd=N^qzalCP#}DrA_tc2C~|IsiJnN8jAJ69 zD%7Zfjb~RA3oS>&8t)Qn^7_Zplkvo3JROS1LoP7swP#+y?*k_uKn-o?dF~I>%JyqN z=lJ$U7TP;n?R}hE3Ggm1cx@=Tejadejt|JW}0loSA(if?{)tTB+iJjH(f#e-roX+azrF6z z?yq^2d!pnxiUjO}C9|t~?WghiXDZ>Fyk=e5${*a6WO5REpj5}!9^{FTs^(o(+Z$Ko z{B#*-e2}Sha>QNNcv`JkoJ2lU$HJDAzy;)kN7J@Fj%|p6W z&n3wKr#8uX(%6EhMLOe6FJ!P;BE9?0B-|b)YllBVD&p*_k|SsU;EXhSJ!ZS zHwchD+Iq<7mXmBCU799CC-@oOal?%c4Z?j2bYYMLf9x^=zIzgzR}DhYC`3o{NI-*Z zM!Qc?;twATK(ChrL}*NA^Kd_;A-C{cL%OqQcRWXHfCLL0g6O0JkW?BykEkX0`3MS% z8)qI>JmOKs$rPem4kMVmLCayU?GmcKejc$-`p~O9K_!yjHANMH1CC%mfRL^>Ta&aX z($rDeYry*DECjS%3>#tm3MLc2tK(J=jLAXSpM#8zkQ}h12Ao)7lql$aAs&Pui!RK9%eKr&2#zA5165SbW}EJ1h>AcYI$iRX(%zeQbBI^?RjCa_i;l z+!w0lucs%AD*JOhu=>y83Fb6;cjrcJWZyLnOL9ZD!LkqsD zk$~v=*gE;;W5OAmtweY9h;VGj@`xX#T)NAH89D8PSCU0vqjb}$a%m#)4Jif4jOjP{ zcS5qLuS!Rbev}9Sm-ahME!> zn>%_iHv=R=GCh#yYGS%~RhS9c$K)<2dVqvO+GI^=g!LG0J%DR!i?tPlEYvO7M}tp% zvu8C}a2BnfVAc>O>mc_iAh-E0ipd_yFp}Tl5m%WZ83B^8;BK%6Vkvh9%NGc zDuOF_jKpf|O|?JPtV)x;k^1i3)aozsoP8&@wohUfZuGnvt=wM;q+6@y3p-a2$kbNj z>-+dY<+;#T*B+FuTy$>7!c9on(XnxUR^;m_A2YG8QiZcGQY;v)I!SM_D1y&Ld^3Z= zBxhKg3~6fM4n-!qD}O=80KX$y51PCPXfPP4OGLKR%99MEg2X_JLh$J|V&7uG5ZNt` zxpp+Hpw@jLNqJw)Cx{tiXDbVWnvxX&R`L)$m=n>Hyj+MpQqf{cG{7+MEeP|{2>3!A z%-GA18-2e94D6JhO5;OOub;@hTTn`of03nNgLQN?f`;D(G&HLnECcfQ`p%o`f^*}h zgsT8XVqeD=b}3%LH-^VhGlYe4J|B*%8{=z3^88pTdF$q#?+?c$uW$9h`0D!JXcvC?CEhdsxl#2LYhDA?9t9)%(<@o?-saB5Z>xQXI00kFekb+cfX0ej_M{Wa~ zQ38t7OVz^5Vye^?NW>nOxxAzlSCW`Koj`0=jbI&>M6Vjc3Ofy9At|AQWM9V&MS=n7 zh`dfGkObTlgK&EoW22JDdb!Pz&;?LK9TKX&j!z4Qd-7xZE~(uqp;at&z?wSPi>%s3jaC&Ne%g z8eEfLAI-)RX=et6J(?*az`P{Ke2cX3BtgN(ZFp4+-cAJ#mLh(QH61t_ce zi8KoDsSD~99w*Ed*w}NUG&+{jhXQvT(k7^UM zmC_2XOru%QKeSXrTs~`KpPQR~4z`{i1kw;a0t$C0rK1*c*Xk+t!aRKi9<#14&S96g z<=GVuZc`mO4O`RCf@)wpR>*+PQp&oZKfT`Q^7Mq2o?D!?MwVx%jpfvER}V!k-8ogX zgO=_zKH~BcMqVboh(nAQaYzhYigz0N~ zoX;V^@3k&W&n(b3=Ot+s-7a3?X&asUJh*0Yu5_i0u4=%8x-tmMy>x^=E>e?y&ry@A zAA*#VX?rA^W&+@l_FB}Z=S-Hv5;zT$h`O3^5z95NFbIx_>n*Cy=qU6VCBkcH7k(5Z zCD@@;MB7Quuj!h$ey!=4w_R4eD-U`Qv$4NTf=vDp%E@G;yOC{Uol|0M1=~3_Hnh-3*3Ge8CV0^q{?4gYz>6q6=7R@OH*6 zmmT0W_hNJ|Dv0LTEIn4uqTPL9d2gr&o0gHP(qJ1gx~v*j``tSIK_PW^%_KRgW(y(b zInSmI&Q%dtJ$o-;wuHKkc(#1urfZ6S>+i$NA?MWD{Il_8*HY!<>+!gM8vK>||Es9kxW zCPcM{plg`WK&FsMUv{XkJ3IQ8GcJ9B10L$HYMX=pyjlaX1J?B>4E>7JgEHLe>y2!8 zPIHYcJ^IC1jWNNwo=!w_j*WqK!2$;~=(>{7YYBUIOjPp;NMuB7wan{~9H)J6zeMjw zmzJNMg{XRgvP-pwPK^*@bu@Y8l3tt!QJ-F3s8Qx26&Ym1(KoaNs;ABg@I!7ozDSl? z-*iH?%$xNB18wz7SX4NO}VTHQ>S$6&Q(67)Z-DyuDh1Q^5MzLK0b{;IC$ZJeyMjCPSseJ0Gg!9&5 ze}4-+!;$`eo<#MiZ0M8=LMx{*Zp!C(241trwEE^AXBTU|oe$M+p^4#k)r{%+c4Mr_ zj5_GFt?#=A@9xKU@1cKImbg+z`H}e2_UQklv>VQ;v{LZ zJu-XhEP{9i#1hCa-MHCuo!8v9h(iLd+0{V>j0*X)&IQ;_cK@F>Lwj~<&g#S9&|Y^SScEPS5*!M`tEzuPB*K1gQtKJAely|?Z~eq_JT zXB0CxU--~Mq_^*FMM+1Jta-kXJX!NdCKZpvW+ghFBc9$(s`NJCSw!}@iD=pQse2YM zy|1e^z9$(Ho;hsAfIU35g%ZLX`{WQ|GckqA=E(x^@yzV<(&w$%((>gcSg>HBg%k5Q YDhA=_IDQb%i=PPn97moTlafite>sources>lafitecommands.;33 87568 - - changes to%: (FNS MESSAGEDISPLAYER \LAFITE.MOVE.MESSAGES.INTERNAL \LAFITE.APPEND.MESSAGE.BODY) (VARS LAFITECOMMANDSCOMS) - - previous date%: "13-Jul-92 16:05:32" {DSK}lafite>sources>lafitecommands.;30) - - -(* ; " -Copyright (c) 1988, 1989, 1992, 1993 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITECOMMANDSCOMS) - -(RPAQQ LAFITECOMMANDSCOMS ((* ;; "Handling of the main Lafite browser commands") (COMS (* ; "DISPLAY") (FNS \LAFITE.DISPLAY \LAFITE.DO.DISPLAY SELECTMESSAGETODISPLAY MESSAGEDISPLAYER LA.COPY.MESSAGE.TEXT \LAFITE.CLOSE.DISPLAYWINDOWS \LAFITE.CLOSE.DISPLAYER) (FNS \LAFITE.UNHIDE.HEADERS \LAFITE.HIDE.HEADERS \LAFITE.REHIDE.HEADERS LAFITE.EAT.UNDESIRABLE.FIELD LAFITE.EAT.GVGV \LAFITE.HARDCOPY.FROM.DISPLAY LAFITE.HARDCOPY.TAB.WIDTH) (FNS \LAFITE.SET.LOOKS.FROM.MENU \LAFITE.SET.DEFAULT.LOOKS \LAFITE.SET.FIXED.LOOKS LAFITE.SET.LOOKS LAFITE.SET.TAB.LOOKS LAFITE.SET.PARA.SEPARATION LAFITE.SET.LOWER.CASE LAFITE.SUBSTITUTE.VP.EOL) (INITVARS \LAFITE.DISPLAY.COMMANDS) (ADDVARS (LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" (QUOTE \LAFITE.SET.LOOKS.FROM.MENU) "Change the appearance of the selected text, or whole message if nothing selected") ("Hardcopy" (QUOTE \LAFITE.HARDCOPY.FROM.DISPLAY) "Hardcopy this message in its current appearance") ("Unhide" (QUOTE \LAFITE.UNHIDE.HEADERS) "Display the header fields that are hidden from view." (SUBITEMS ("Hide" (QUOTE \LAFITE.REHIDE.HEADERS) "Hide uninteresting fields from view again")))) (LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" (QUOTE LAFITE.SUBSTITUTE.VP.EOL) "Replace the Viewpoint end of line character with ours.") ("Lowercase" (QUOTE LAFITE.SET.LOWER.CASE) "Lowercase the region or whole message.") ("Spread Paragraphs" (QUOTE LAFITE.SET.PARA.SEPARATION) "Separate paragraphs by 10 points (useful for Tioga messages).") ("Default" (QUOTE \LAFITE.SET.DEFAULT.LOOKS) "Change selection (or whole text) back to default font") ("Fixed Width" (QUOTE \LAFITE.SET.FIXED.LOOKS) "Change selection (or whole text) to fixed-width font"))) (GLOBALVARS \LAFITE.DISPLAY.COMMANDS)) (COMS (* ; "DELETE") (FNS LAFITE.DELETE.MESSAGES \LAFITE.DELETE DISPLAYAFTERDELETE \LAFITE.SELECT.NEXT \LAFITE.UNDELETE)) (COMS (* ; "MOVE") (FNS LAFITE.MOVE.MESSAGES \COERCE.TO.MSGLST \LAFITE.MOVETO \LAFITE.COPYTO \LAFITE.MOVETO.PROC \LAFITE.MOVE.MESSAGES.INTERNAL) (* ; "Aux move") (FNS \LAFITE.ENABLE.MOVE.MENU \LAFITE.ADD.TO.MOVE.MENU \LAFITE.UPDATE.MOVE.MENU \LAFITE.RESTORE.MOVE.MENU \LAFITE.HANDLE.AUTO.MOVE) (ADDVARS (LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" (QUOTE \LAFITE.ENABLE.MOVE.MENU) "Attach a menu of folders for accelerated MoveTo (or modify existing one)" (SUBITEMS ("Restore MoveTo Menu" (QUOTE \LAFITE.RESTORE.MOVE.MENU) "Just reopen the attached MoveTo menu if it existed."))) ("Copy To" (QUOTE \LAFITE.COPYTO) "Like MoveTo, but don't delete the message(s).")) (LAFITE.EXTRA.MOVE.ITEMS ("---Display---" (QUOTE \LAFITE.DISPLAY) "Display the next message") ("---Delete---" (QUOTE \LAFITE.DELETE) "Delete the selected message(s)"))) (INITVARS (LAFITE.AUTO.MOVE.MENU))) (COMS (* ; "UPDATE") (FNS \LAFITE.UPDATE \LAFITE.EXPUNGE.PROC \LAFITE.UPDATE.PROC \LAFITE.HARDCOPYONLY.PROC LAB.CHOOSE.UPDATE.MENU LAB.CREATE.UPDATE.MENU LAB.UPDATE.NEEDED? \LAFITE.START.UPDATE LAB.START.COMMAND \LAFITE.FINISH.UPDATE \LAFITE.CLOSE.OTHER.FOLDERS) (FNS LAB.FLUSHWINDOW LAB.APPENDMESSAGES \LAFITE.COMPACT.FOLDER \LAFITE.COMPACT.FOLDER1 \LAFITE.COMPACT.FOLDER2 \LAFITE.COMPACT.EXTRA \LAFITE.INVALIDATE.TOC \LAFITE.RENAMEFILE SMART-RENAMEFILEP LA.OPENTEMPFILE) (FNS \LAFITE.UPDATE.FOLDER \LAFITE.UPDATE.CONTENTS \LAFITE.UPDATE.CONTENTS1 WRITETOCENTRY WRITETOCMARKBYTES WRITEFOLDERMARKBYTES)) (COMS (* ; "HARDCOPY") (FNS LAFITE.HARDCOPY.MESSAGES \LAFITE.HARDCOPY \LAFITE.HARDCOPY.PROC \LAFITE.HARDCOPY.HEADERS \LAFITE.MARK.HARDCOPIED \LAFITE.TRANSMIT.HARDCOPY \LAFITE.HARDCOPY.BODIES \LAFITE.APPEND.MESSAGE.BODY \LAFITE.DO.PENDING.HARDCOPY \LAFITE.CANCEL.HARDCOPY \LAFITE.CLEAR.HARDCOPY.STATE) (ADDVARS (LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" (QUOTE \LAFITE.CANCEL.HARDCOPY) "Forget about hardcopying the messages so far marked for hardcopy.")))) (COMS (INITVARS (LAFITEHARDCOPYBATCHFLG NIL) (LAFITEHARDCOPY.MIN.TOC NIL) (LAFITEDISPLAYAFTERDELETEFLG T) (LAFITEMOVETOCONFIRMFLG (QUOTE ALWAYS)) (LAFITENEWPAGEFLG T) (LAFITEENDOFMESSAGESTR "End of message") (LAFITEENDOFMESSAGEFONT (FONTCREATE (QUOTE (TIMESROMAN 10 ITALIC)))) (LAFITE.DISPLAY.SIZE (QUOTE (500 . 300))) (LAFITE.BROWSER.LAYOUTS NIL) (LAFITE.MIDDLE.UPDATE (QUOTE (:EXPUNGE :SHRINK :CONFIRM))) (LAFITEHARDCOPYBATCHSHADE 1025) (LAFITEHARDCOPYSEPARATOR " - Next Message  -")) (COMS (* ; "Obsolete") (INITVARS (LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335))))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAFITE.HARDCOPY.MESSAGES))))) - - - -(* ;; "Handling of the main Lafite browser commands") - - - - -(* ; "DISPLAY") - -(DEFINEQ - -(\LAFITE.DISPLAY -(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* ; "Edited 22-Sep-87 14:56 by bvm:") (PROG (DISPLAYWINDOW) (COND ((WINDOWP (SETQ DISPLAYWINDOW (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (LET ((MSGDESCRIPTOR (SELECTMESSAGETODISPLAY WINDOW MAILFOLDER)) W) (COND (MSGDESCRIPTOR (\LAFITE.DO.DISPLAY MAILFOLDER MSGDESCRIPTOR (EQ KEY (QUOTE MIDDLE)))) (T (LAB.PROMPTPRINT MAILFOLDER T "No more messages.") (* ; "But return current display window for topping, just in case it was buried") (CAR (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)))))))))) (* ; "make sure the display window is on top in case SHADEITEM put the browser back on top") (TOTOPW DISPLAYWINDOW))))) -) - -(\LAFITE.DO.DISPLAY -(LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 13-Oct-87 15:56 by bvm:") (* ;;; "Display MSGDESCRIPTOR from MAILFOLDER, using a new window if NEWWINDOWFLG is true, else reusing if possible the primary window. Returns the window") (PROG (TEMPMSG DISPLAYWINDOW) (LAB.EXPOSEMESSAGE MAILFOLDER MSGDESCRIPTOR) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with NIL) (* ; "Clear it here in case of abort") (LA.COPY.MESSAGE.TEXT MAILFOLDER (SETQ TEMPMSG (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) MSGDESCRIPTOR) (SETQ TEMPMSG (CLOSEF TEMPMSG)) (SETQ DISPLAYWINDOW (MESSAGEDISPLAYER MAILFOLDER (OPENSTREAM TEMPMSG (QUOTE INPUT) NIL (QUOTE ((ENDOFSTREAMOP \LAFITE.EOF)))) (CONCAT "Message " (fetch (LAFITEMSG %#) of MSGDESCRIPTOR) " from " (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) " [" (fetch (LAFITEMSG MESSAGELENGTH) of MSGDESCRIPTOR) " chars]") NEWWINDOWFLG)) (SEENMESSAGE MSGDESCRIPTOR MAILFOLDER) (PROGN (* ; "Cache the stream that we copied the message text to, since we might be able to use it to accelerate a Move or Hardcopy. Unfortunately, we can't take advantage of it now, since NODIRCORE doesn't support multiple streams per file.") (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of MAILFOLDER with TEMPMSG) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with MSGDESCRIPTOR)) (RETURN DISPLAYWINDOW))) -) - -(SELECTMESSAGETODISPLAY -(LAMBDA (WINDOW MAILFOLDER) (* bvm%: " 1-Mar-86 18:19") (* ;;; "Laurel acts differently if there is currently only one message selected or many about whether it unselects the one that was displayed before. Lafite will follow the same model") (LET ((CURRENTDISPLAYEDMSG (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) DISPLAYED# MSGDESCRIPTOR) (COND ((IGREATERP FIRST# LAST#) (* ; "Nothing selected, so nothing to display") NIL) ((OR (NULL CURRENTDISPLAYEDMSG) (NOT (fetch (LAFITEMSG SELECTED?) of CURRENTDISPLAYEDMSG))) (* ; "haven't displayed any yet, or displayed one is not part of the selection") (NTHMESSAGE MESSAGES FIRST#)) ((EQ FIRST# LAST#) (* ; "Only one msg selected and it is displayed, so move on to next undeleted msg") (\LAFITE.SELECT.NEXT MAILFOLDER (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG))) (T (* ; "Multiple selections -- Cycle to the next one") (NTHMESSAGE MESSAGES (COND ((EQ (SETQ DISPLAYED# (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG)) LAST#) (* ; "Cycle back to first") FIRST#) (T (LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 DISPLAYED#) LAST#)))))))) -) - -(MESSAGEDISPLAYER -(LAMBDA (MAILFOLDER TEXTFILE TITLE NEWWINDOWFLG) (* ; "Edited 6-Aug-93 18:48 by bvm") (* ;;; "Displayer for individual messages") (LET ((CURRENTWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)) (PROPS (BQUOTE (FONT (\, LAFITEDISPLAYFONT)))) (WINDOWPROPS (QUOTE (READONLY T PROMPTWINDOW DON'T))) (EOF (GETEOFPTR TEXTFILE)) TEXTSTREAM DISPLAYWINDOW EOF FILTERED) (* ;; "WINDOWPROPS for when we finally give TEdit a window: READONLY in order to avoid TEdit's odd temptation to display an ugly caret at the start and prevent mouse actions from yielding %"NewEditProcess%" menu; PROMPTWINDOW to inhibit attaching a prompt window. Due to a TEdit bug, you can't give the PROMPTWINDOW prop when opening without a window or it will try to make the symbol DON'T be the promptwindow later on.") (if (AND \LAPARSE.DONT.DISPLAY.HEADERS (NEQ EOF 0) (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTFILE \LAPARSE.DONT.DISPLAY.HEADERS 0))) then (* ; "We will filter some headers out, so put * in title to show this") (SETQ TITLE (CONCAT "*" TITLE))) (COND ((AND (NOT NEWWINDOWFLG) (SETQ DISPLAYWINDOW (CAR CURRENTWINDOWS))) (MAPC (WINDOWPROP DISPLAYWINDOW (QUOTE EXTRAWINDOWS) NIL) (FUNCTION CLOSEW)) (* ; "Get rid of extra windows produced by attachments") (CLEARW DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW (QUOTE TITLE) TITLE)) (T (SETQ DISPLAYWINDOW (CREATEW (COND ((AND (NOT NEWWINDOWFLG) (PROGN (* ; "This says where we'd like the primary window to be.") (fetch (MAILFOLDER FOLDERDISPLAYREGION) of MAILFOLDER)))) (LAFITE.DISPLAY.SIZE (* ; "Global default") (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) (CDR LAFITE.DISPLAY.SIZE) NIL NIL NIL TITLE))) TITLE)) (WINDOWADDPROP DISPLAYWINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER)) (WINDOWPROP DISPLAYWINDOW (QUOTE TEDIT.MENU.COMMANDS) \LAFITE.DISPLAY.COMMANDS) (COND ((NOT CURRENTWINDOWS) (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER with (if NEWWINDOWFLG then (* ; "not primary, even though no window previously open") (LIST NIL DISPLAYWINDOW) else (LIST DISPLAYWINDOW)))) (NEWWINDOWFLG (RPLACD CURRENTWINDOWS (CONS DISPLAYWINDOW (CDR CURRENTWINDOWS)))) (T (* ; "DIsplaying the primary window for the first time when there are already secondary windows.") (RPLACA CURRENTWINDOWS DISPLAYWINDOW))))) (* ; "Now let TEDIT display it") (COND ((EQ EOF 0) (LAB.PROMPTPRINT MAILFOLDER "Message is empty")) (T (LET (WINDOW) (if (NOT FILTERED) then (* ; "Go ahead and display it right off. ") (SETQ PROPS (NCONC PROPS WINDOWPROPS)) (SETQ WINDOW DISPLAYWINDOW)) (SETQ TEXTSTREAM (OR (CAR (NLSETQ (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL PROPS))) (PROGN (LAB.PROMPTPRINT MAILFOLDER T "Problems displaying message, trying unformatted.") (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL (LIST* (QUOTE CLEARGET) T PROPS)))))) (if FILTERED then (if (NOT (= EOF (GETEOFPTR TEXTSTREAM))) then (* ; "rats, there may have been nschars in the header, so parse it now more carefully") (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTSTREAM \LAPARSE.DONT.DISPLAY.HEADERS 0))) (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) (* ; "Now we can display it without a major glitch") (OPENTEXTSTREAM TEXTSTREAM DISPLAYWINDOW NIL NIL WINDOWPROPS) (TEXTPROP TEXTSTREAM (QUOTE FILTERED) FILTERED) (* ; "Remember what's invisible, so we can easily undo it")) (COND (LAFITEENDOFMESSAGESTR (* ; "Add %"End of message%" token. Have to take away READONLY for a moment here...") (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (SETFILEPTR TEXTSTREAM (SUB1 (SETQ EOF (GETEOFPTR TEXTSTREAM)))) (COND ((NEQ (BIN TEXTSTREAM) (CHARCODE CR)) (* ; "Message doesn't end in CR, so add one before inserting end of message str") (TEDIT.INSERT TEXTSTREAM LAFITEEOL (ADD1 (add EOF 1)) NIL T))) (TEDIT.INSERT TEXTSTREAM LAFITEENDOFMESSAGESTR (ADD1 EOF) LAFITEENDOFMESSAGEFONT T) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (TEDIT.SETSEL TEXTSTREAM 1 0) (\CARET.DOWN) (* ; "Patch around TEdit bug"))))) DISPLAYWINDOW)) -) - -(LA.COPY.MESSAGE.TEXT -(LAMBDA (MAILFOLDER OUTPUTSTREAM MSGDESCRIPTOR) (* ; "Edited 23-Sep-87 18:40 by bvm:") (PROG ((INSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT))) (MAYBEVERIFYMSG MSGDESCRIPTOR MAILFOLDER) (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of MSGDESCRIPTOR) (fetch (LAFITEMSG END) of MSGDESCRIPTOR)))) -) - -(\LAFITE.CLOSE.DISPLAYWINDOWS -(LAMBDA (FOLDER) (* ; "Edited 22-Sep-87 15:36 by bvm:") (* ;; "Called when browser closed, to close associated windows.") (PROG ((WINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER)) W) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (COND (WINDOWS (for WINDOW in (CDR WINDOWS) do (* ; "Leave secondary windows open, but disconnect them from browser") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER))) (COND ((WINDOWP (SETQ W (CAR WINDOWS))) (* ; "Save region for later") (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (APPEND (WINDOWPROP W (QUOTE REGION)))) (WINDOWDELPROP W (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER)) (CLOSEW W))) (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL))))) -) - -(\LAFITE.CLOSE.DISPLAYER -(LAMBDA (WINDOW) (* ; "Edited 16-Aug-89 11:27 by bvm") (* ;; "called via CLOSEFN when a display window is explicitly closed") (MAPC (WINDOWPROP WINDOW (QUOTE EXTRAWINDOWS) NIL) (FUNCTION CLOSEW)) (for FOLDER in \ACTIVELAFITEFOLDERS bind THESEWINDOWS when (MEMB WINDOW (SETQ THESEWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER))) do (* ; "Do we need a monitorlock here?") (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (if (EQ WINDOW (CAR THESEWINDOWS)) then (* ; "the main window--keep its region") (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (APPEND (WINDOWPROP WINDOW (QUOTE REGION)))) (if (CDR THESEWINDOWS) then (RPLACA THESEWINDOWS NIL) else (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL)) else (* ; "floating window, just remove") (RPLACD THESEWINDOWS (DREMOVE WINDOW (CDR THESEWINDOWS)))) (RETURN))) -) -) -(DEFINEQ - -(\LAFITE.UNHIDE.HEADERS -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:48 by bvm:") (LET ((FILTERED (TEXTPROP TEXTSTREAM (QUOTE FILTERED))) START W) (if (OR (NULL FILTERED) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE))) then (PROMPTPRINT "The whole message is already displayed") else (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE OFF)) (ADD1 (SETQ START (CAAR (LAST FILTERED)))) (- (CADAR FILTERED) START)) (TEDIT.SETSEL TEXTSTREAM 1 0) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE) T) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) then (* ; "Remove the * from the title.") (WINDOWPROP W (QUOTE TITLE) (SUBSTRING (WINDOWPROP W (QUOTE TITLE)) 2)))))) -) - -(\LAFITE.HIDE.HEADERS -(LAMBDA (TEXTSTREAM FILTERED) (* ; "Edited 10-Dec-87 19:44 by bvm:") (for PAIR in FILTERED do (* ; "Make each filtered field invisible") (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE ON)) (+ (CAR PAIR) 1) (- (CADR PAIR) (CAR PAIR)))) (TEDIT.SETSEL TEXTSTREAM 1 0)) -) - -(\LAFITE.REHIDE.HEADERS -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:44 by bvm:") (* ;; "Called from display window menu to hide the headers again after having them unhidden.") (LET ((FILTERED (TEXTPROP TEXTSTREAM (QUOTE FILTERED))) START W) (if (NULL FILTERED) then (PROMPTPRINT "No uninteresting header fields were found") elseif (NOT (TEXTPROP TEXTSTREAM (QUOTE VISIBLE))) then (PROMPTPRINT "Uninteresting headers are already hidden") else (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE) NIL) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) then (* ; "Add * back to the title.") (WINDOWPROP W (QUOTE TITLE) (CONCAT "*" (WINDOWPROP W (QUOTE TITLE)))))))) -) - -(LAFITE.EAT.UNDESIRABLE.FIELD -(LAMBDA (STREAM IGNORE) (* ; "Edited 23-Sep-87 13:12 by bvm:") (* ;; "Parser function called when a field to be filtered is found--skip over the field, and push onto the result a pair giving (start stop) of the whole field.") (DECLARE (USEDFREE PARSERESULT PARSEBEGIN)) (* ; "bound in parser") (LA.SKIP.TO.EOL STREAM) (if (AND PARSERESULT (= PARSEBEGIN (CADR (CAR PARSERESULT)))) then (* ; "two in a row--combine them") (CL:SETF (CADR (CAR PARSERESULT)) (GETFILEPTR STREAM)) else (push PARSERESULT (LIST PARSEBEGIN (GETFILEPTR STREAM))))) -) - -(LAFITE.EAT.GVGV -(LAMBDA (STREAM) (* ; "Edited 6-Feb-89 14:18 by bvm") (DECLARE (USEDFREE PARSERESULT)) (* ;; "Called when we get to the CR at the end of the header. Now look for a section of thext beginning and ending in lines of the form GVGVGVGV...") (LET ((HERE (GETFILEPTR STREAM)) GVSTART GVEND) (if (AND (EQ (SKIPSEPRCODES STREAM) (CHARCODE G)) (PROGN (SETQ GVSTART (GETFILEPTR STREAM)) (bind CH until (EQ (SETQ CH (BIN STREAM)) (CHARCODE EOL)) always (OR (EQ CH (CHARCODE G)) (EQ CH (CHARCODE V))))) (SETQ GVEND (FFILEPOS "GVGVGV - -" STREAM NIL NIL NIL T))) then (push PARSERESULT (LIST GVSTART GVEND))) (SETFILEPTR STREAM HERE) (* ; "Return STOP to tell parser to stop") (QUOTE STOP))) -) - -(\LAFITE.HARDCOPY.FROM.DISPLAY -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Jun-88 18:36 by bvm") (* ;; "Hardcopy command on title bar of message display -- like window hardcopy, but gets the title right and omits the end of message string.") (RESETLST (if LAFITEENDOFMESSAGESTR then (* ; "Hide end of message") (LET ((LEN (GETEOFPTR TEXTSTREAM)) (NC (NCHARS LAFITEENDOFMESSAGESTR)) (FIXEDLOOKS (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS)))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (TEXTSTREAM LEN NC FIXEDLOOKS) (LET ((W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) (if (AND W (OPENWP W) (EQ (WINDOWPROP W (QUOTE TEXTSTREAM)) TEXTSTREAM)) then (* ; "Don't screw around if the message isn't in the window anymore") (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE OFF)) (ADD1 (- LEN NC)) NC) (TEDIT.SETSEL TEXTSTREAM 1 0) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if FIXEDLOOKS then (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS (TIMES 8 (CHARWIDTH (CHARCODE X) LAFITEFIXEDWIDTHFONT)))))))) TEXTSTREAM LEN NC FIXEDLOOKS)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE ON)) (ADD1 (- LEN NC)) NC) (if FIXEDLOOKS then (* ; "Change to the hardcopy tab width") (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS (LAFITE.HARDCOPY.TAB.WIDTH))))) (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (LET ((TMP (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) (AND TMP (SETQ TMP (WINDOWPROP TMP (QUOTE TITLE))) (if (EQ (CHCON1 TMP) (CHARCODE *)) then (* ; "Remove the * that says filtered") (SUBSTRING TMP 2) else TMP)))))) -) - -(LAFITE.HARDCOPY.TAB.WIDTH -(LAMBDA NIL (* ; "Edited 10-Jun-88 18:27 by bvm") (FIXR (TIMES (FQUOTIENT (CHARWIDTH (CHARCODE X) (FONTCOPY LAFITEFIXEDWIDTHFONT (QUOTE DEVICE) (QUOTE INTERPRESS))) (CONSTANT (FQUOTIENT 2540 72))) 8))) -) -) -(DEFINEQ - -(\LAFITE.SET.LOOKS.FROM.MENU -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM T))) - -(\LAFITE.SET.DEFAULT.LOOKS -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:33 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM LAFITEDISPLAYFONT)) -) - -(\LAFITE.SET.FIXED.LOOKS -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM LAFITEFIXEDWIDTHFONT)) -) - -(LAFITE.SET.LOOKS -(LAMBDA (TEXTSTREAM NEWLOOKS PARALOOKS OMITHEADER USERFN) (* ; "Edited 3-Nov-89 14:50 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Change the looks of the current selection (if there is an interesting one) or the whole message to be NEWLOOKS. If NEWLOOKS is T, we use TEdit's menu interface. PARALOOKS is for paragraph formatting. USERFN is arbitrary function called with arg textstream & selection set appropriately. Any of NEWLOOKS, PARALOOKS, USERFN can be NIL. If OMITHEADER is true, the header is left out of the modification if user has not selected a region of text already.") (RESETLST (RESETSAVE NIL (LIST (QUOTE TEXTPROP) TEXTSTREAM (QUOTE READONLY) T)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (LET ((SEL (TEDIT.GETSEL TEXTSTREAM)) START LEN WIDTH FIXEDLOOKS) (if (AND (NOT PARALOOKS) (FONTP NEWLOOKS) (EQ (SETQ WIDTH (CHARWIDTH (CHARCODE "i") NEWLOOKS)) (CHARWIDTH (CHARCODE "W") NEWLOOKS))) then (* ; "If font is fixed-width, let's make the tab the right width. Might be nice to restore default tab if it's not fixed-width, but TEdit apparently doesn't support that.") (SETQ FIXEDLOOKS (SETQ PARALOOKS (BQUOTE (TABS ((\, (TIMES WIDTH 8)))))))) (if (> (SETQ LEN (fetch (SELECTION DCH) of SEL)) 1) then (* ; "User has already selected something. Assume any selection greater than a single character is not accidental.") (if (AND FIXEDLOOKS (NEQ (SETQ FIXEDLOOKS (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS))) T)) then (* ;; "Record the portions we have so marked, so hardcopy can work right--T means everything. If FIXEDLOOKS is false, might want to unset, but that's tedious, unlikely to be worth the hairy code") (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS) (CONS (CONS (fetch (SELECTION CH#) of SEL) LEN) FIXEDLOOKS))) else (SETQ START (if OMITHEADER then (* ; "Start after the blank line following the header") (\LAFITE.HEADER.EOF TEXTSTREAM) else 0)) (SETQ LEN (- (GETEOFPTR TEXTSTREAM) (if LAFITEENDOFMESSAGESTR then (NCHARS LAFITEENDOFMESSAGESTR) else 0) START)) (TEDIT.SETSEL TEXTSTREAM (ADD1 START) LEN (QUOTE RIGHT)) (if FIXEDLOOKS then (* ; "The whole thing is fixed now") (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS) T))) (* ;; "Now do the modification") (if (EQ NEWLOOKS T) then (* ; "Use menu") (\TEDIT.LOOKS (TEXTOBJ TEXTSTREAM)) elseif NEWLOOKS then (TEDIT.LOOKS TEXTSTREAM NEWLOOKS)) (if PARALOOKS then (* ; "Paragraph looks") (TEDIT.PARALOOKS TEXTSTREAM PARALOOKS)) (if USERFN then (* ; "Arbitrary user manipulation.") (CL:FUNCALL USERFN TEXTSTREAM)) (* ;; "Finally, set selection back to where it was.") (TEDIT.SETSEL TEXTSTREAM SEL)))) -) - -(LAFITE.SET.TAB.LOOKS -(LAMBDA (TEXTSTREAM FIXEDLOOKS TABWIDTH) (* ; "Edited 11-Jun-88 17:07 by bvm") (LET ((LOOKS (BQUOTE (TABS ((\, TABWIDTH))))) (SEL (TEDIT.GETSEL TEXTSTREAM))) (if (EQ FIXEDLOOKS T) then (TEDIT.PARALOOKS TEXTSTREAM LOOKS 1 (GETEOFPTR TEXTSTREAM)) else (for PAIR in FIXEDLOOKS do (TEDIT.PARALOOKS TEXTSTREAM LOOKS (CAR PAIR) (CDR PAIR)))) (* ; "Finally, restore selection") (TEDIT.SETSEL TEXTSTREAM SEL))) -) - -(LAFITE.SET.PARA.SEPARATION -(LAMBDA (TEXTSTREAM) (* ; "Edited 29-Aug-89 14:53 by bvm") (LAFITE.SET.LOOKS TEXTSTREAM NIL (QUOTE (PARALEADING 10)) T)) -) - -(LAFITE.SET.LOWER.CASE -(LAMBDA (TEXTSTREAM) (* ; "Edited 7-Nov-89 13:06 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Change the current selection (if there is an interesting one) or the whole message to be lowercase.") (LAFITE.SET.LOOKS TEXTSTREAM NIL NIL T (FUNCTION (LAMBDA (TEXTSTREAM) (LET ((STR (TEDIT.SEL.AS.STRING TEXTSTREAM))) (TEDIT.DELETE TEXTSTREAM) (TEDIT.INSERT TEXTSTREAM (L-CASE STR))))))) -) - -(LAFITE.SUBSTITUTE.VP.EOL -(LAMBDA (TEXTSTREAM) (* ; "Edited 4-Aug-89 16:55 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Replace VP eol (29) with ours.") (RESETLST (RESETSAVE NIL (LIST (QUOTE TEXTPROP) TEXTSTREAM (QUOTE READONLY) T)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (LET* ((SEL (TEDIT.GETSEL TEXTSTREAM)) (LEN (fetch (SELECTION DCH) of SEL)) POS) (if (<= LEN 1) then (* ; "If user has already selected something (more than a single character), assume is not accidental.") (SETQ POS (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL NIL NIL NIL T))) (TEDIT.SETSEL TEXTSTREAM POS (- (GETEOFPTR TEXTSTREAM) (if LAFITEENDOFMESSAGESTR then (NCHARS LAFITEENDOFMESSAGESTR) else 0) POS))) (TEDIT.SUBSTITUTE TEXTSTREAM (ALLOCSTRING 1 29) (ALLOCSTRING 1 (CHARCODE EOL))) (if POS then (* ; "Undo the selection") (TEDIT.SETSEL TEXTSTREAM 1 0))))) -) -) - -(RPAQ? \LAFITE.DISPLAY.COMMANDS NIL) - -(ADDTOVAR LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" (QUOTE \LAFITE.SET.LOOKS.FROM.MENU) "Change the appearance of the selected text, or whole message if nothing selected") ("Hardcopy" (QUOTE \LAFITE.HARDCOPY.FROM.DISPLAY) "Hardcopy this message in its current appearance") ("Unhide" (QUOTE \LAFITE.UNHIDE.HEADERS) "Display the header fields that are hidden from view." (SUBITEMS ("Hide" (QUOTE \LAFITE.REHIDE.HEADERS) "Hide uninteresting fields from view again")))) - -(ADDTOVAR LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" (QUOTE LAFITE.SUBSTITUTE.VP.EOL) "Replace the Viewpoint end of line character with ours.") ("Lowercase" (QUOTE LAFITE.SET.LOWER.CASE) "Lowercase the region or whole message.") ("Spread Paragraphs" (QUOTE LAFITE.SET.PARA.SEPARATION) "Separate paragraphs by 10 points (useful for Tioga messages).") ("Default" (QUOTE \LAFITE.SET.DEFAULT.LOOKS) "Change selection (or whole text) back to default font") ("Fixed Width" (QUOTE \LAFITE.SET.FIXED.LOOKS) "Change selection (or whole text) to fixed-width font")) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \LAFITE.DISPLAY.COMMANDS) -) - - - -(* ; "DELETE") - -(DEFINEQ - -(LAFITE.DELETE.MESSAGES -(LAMBDA (FOLDER MESSAGES) (* ; "Edited 31-Aug-88 12:47 by bvm") (* ;; "Programmatic entrypoint to delete a single MSG (# or msg object) from FOLDER. FOLDER must have a browser.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (for MSG inside MESSAGES do (DELETEMESSAGE (if (type? LAFITEMSG MSG) then MSG else (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) MSG)) FOLDER)))) -) - -(\LAFITE.DELETE -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 30-Aug-88 11:42 by bvm") (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (for MSGDESCRIPTOR selectedin MAILFOLDER when (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR)) do (* ; "delete all the currrently selected messages that aren't already deleted") (DELETEMESSAGE MSGDESCRIPTOR MAILFOLDER) finally (SHADEITEM ITEM MENU WHITESHADE) (DISPLAYAFTERDELETE MAILFOLDER WINDOW))))) -) - -(DISPLAYAFTERDELETE -(LAMBDA (FOLDER WINDOW) (* ; "Edited 29-Aug-88 15:34 by bvm") (* ;;; "Maybe select and maybe display the next message after a deletion, according to setting of LAFITEDISPLAYAFTERDELETEFLG --- T means display next if the deleted one is the one currently displayed and the next message is undeleted and unseen --- ALWAYS means display the next undeleted message if the deleted one is the one currently displayed; if it's not currently displayed, merely select the next undeleted message --- MULTIPLE means ALWAYS plus when the selection is multiple, still advance to next undeleted msg.") (COND (LAFITEDISPLAYAFTERDELETEFLG (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) CURRENT LASTMSG# MESSAGES MENU) (COND ((NEQ FIRST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) (* ;; "More than one message was selected. Only do something if flag says MULTIPLE -- select but don't display next message") (COND ((EQ LAFITEDISPLAYAFTERDELETEFLG (QUOTE MULTIPLE)) (\LAFITE.SELECT.NEXT FOLDER FIRST#)))) ((OR (NOT (SETQ CURRENT (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER))) (NEQ FIRST# (fetch (LAFITEMSG %#) of CURRENT))) (* ; "Deleted message is not the one currently displayed") (SELECTQ LAFITEDISPLAYAFTERDELETEFLG ((ALWAYS MULTIPLE) (* ; "select but don't display next message") (\LAFITE.SELECT.NEXT FOLDER FIRST#)) NIL)) ((SELECTQ LAFITEDISPLAYAFTERDELETEFLG ((ALWAYS MULTIPLE) (* ; "Always do it, assuming there's a next message") (\LAFITE.SELECT.NEXT FOLDER FIRST#)) (AND (NEQ FIRST# (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (NOT (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (ADD1 FIRST#)))) (for I from (ADD1 FIRST#) to LASTMSG# bind NEXTMSG do (* ;; "Next message undeleted, so maybe display it. LAFITEDISPLAYAFTERDELETEFLG = T means only do so if it is unexamined. However, messages from us are usually already examined, so pretend the message is unexamined if there is some unexamined message immediately after any from me") (COND ((NOT (fetch (LAFITEMSG SEEN?) of (SETQ NEXTMSG (NTHMESSAGE MESSAGES I)))) (* ; "An unexamined message, ok") (RETURN T)) ((NOT (fetch (LAFITEMSG MSGFROMMEP) of NEXTMSG)) (* ; "Not from me, but examined, so must not be in the stream of new mail") (RETURN NIL)))))) (\LAFITE.DISPLAY WINDOW FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.DISPLAY) (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) MENU))))))) -) - -(\LAFITE.SELECT.NEXT -(LAMBDA (MAILFOLDER AFTER#) (* ; "Edited 23-Aug-88 18:35 by bvm") (* ;;; "Select the next undeleted message in MAILFOLDER following AFTER# and return the msg, or NIL if there are no more") (for N from (ADD1 AFTER#) to (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES N))) do (RETURN (LAB.GO.TO.MESSAGE MAILFOLDER MSG)))) -) - -(\LAFITE.UNDELETE -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "28-Mar-84 14:48") (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (for MSGDESCRIPTOR selectedin MAILFOLDER when (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR) do (UNDELETEMESSAGE MSGDESCRIPTOR MAILFOLDER)))))) -) -) - - - -(* ; "MOVE") - -(DEFINEQ - -(LAFITE.MOVE.MESSAGES -(LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MESSAGES COPYFLG) (* ; "Edited 13-Sep-88 18:38 by bvm") (* ;; "Programmatic entry to move (or copy if COPYFLG true) specified MESSAGES from SOURCEFOLDER to DESTINATIONFOLDER. Returns T on success.") (AND MESSAGES (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER (\COERCE.TO.MSGLST MESSAGES SOURCEFOLDER) NIL NIL COPYFLG)))) -) - -(\COERCE.TO.MSGLST -(LAMBDA (MSGLST FOLDER) (* ; "Edited 30-Aug-88 14:11 by bvm") (* ;; "Accepts a singleton or list of LAFITEMSG objects or numbers relative to FOLDER and returns a list of LAFITEMSG objects") (if (AND (CL:LISTP MSGLST) (for M in MSGLST always (type? LAFITEMSG M))) then MSGLST else (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (for M inside MSGLST collect (if (type? LAFITEMSG M) then M else (NTHMESSAGE MESSAGES M)))))) -) - -(\LAFITE.MOVETO -(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY COPYFLG) (* ; "Edited 13-Sep-88 18:33 by bvm") (PROG ((BROWSERPROMPTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) LONGFORMP TOFILE OUTPUTFILE DESTINATIONFOLDER MIDDLESELECTED) (CLEARW BROWSERPROMPTWINDOW) (COND ((LAB.ASSURE.SELECTIONS MAILFOLDER) (* ; "Nothing to move") (RETURN))) (COND ((AND (EQ KEY (QUOTE MIDDLE)) (SETQ DESTINATIONFOLDER (fetch (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER))) (* ; "Accelerator: don't use menu. We will still re-obtain the destination folder below, since the pointer sitting in the folder may be to a long-closed folder.") (SETQ MIDDLESELECTED T) (SETQ OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of DESTINATIONFOLDER))) (T (CL:MULTIPLE-VALUE-SETQ (TOFILE LONGFORMP) (\LAFITE.PROMPTFORFOLDER BROWSERPROMPTWINDOW)) (if (NULL TOFILE) then (RETURN NIL)) (SETQ OUTPUTFILE (LA.LONGFILENAME TOFILE LAFITEMAIL.EXT)) (COND ((STRING-EQUAL OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of MAILFOLDER)) (LAB.PROMPTPRINT MAILFOLDER T "This IS " TOFILE ", can't move to there.") (RETURN NIL))))) (AND ITEM (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)) (COND (LONGFORMP (* ; "if user had to type file longhand, don't confirm now (but there may be a confirmation for creation later on)")) ((SELECTQ LAFITEMOVETOCONFIRMFLG (NIL (* ; "never confirm") T) (LEFT (* ; "don't confirm when middle selected") MIDDLESELECTED) (MIDDLE (* ; "confirm ONLY when middle selected") (NOT MIDDLESELECTED)) NIL)) ((LAB.MOUSECONFIRM MAILFOLDER "Click LEFT to confirm ~A ~@[of ~D msgs ~]to ~A" (if COPYFLG then "copy" else "move") (AND (< (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (for MSG selectedin MAILFOLDER sum (* ; "Count how many selected") 1)) (if DESTINATIONFOLDER then (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) else (LA.SHORTFILENAME OUTPUTFILE LAFITEMAIL.EXT)))) (T (* ; "abort") (AND ITEM (SHADEITEM ITEM MENU WHITESHADE)) (RETURN NIL))) (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.MOVETO.PROC)) (QUOTE (\, WINDOW)) (QUOTE (\, MAILFOLDER)) (QUOTE (\, OUTPUTFILE)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) NIL (QUOTE (\, COPYFLG)))) (QUOTE LAFITEMOVE)))) -) - -(\LAFITE.COPYTO -(LAMBDA (FOLDER ITEM MENU KEY) (* ; "Edited 13-Sep-88 18:37 by bvm") (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (\LAFITE.MOVETO (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER) FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.MOVETO) MENU) MENU NIL T))) -) - -(\LAFITE.MOVETO.PROC -(LAMBDA (WINDOW SOURCEFOLDER DESTINATIONFULLNAME ITEM MENU FROM.AUTO.MENU COPYFLG) (* ; "Edited 13-Sep-88 18:24 by bvm") (* ;; "Move selected messages from SOURCEFOLDER to the folder named by OUTPUTFILE. If FROM.AUTO.MENU is true, it came from the auxiliary moveto menu. Note that MENU is thus not necessarily SOURCEFOLDER's menu.") (if (RESETLST (LA.RESETSHADE ITEM MENU) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) NIL T) (LET ((DESTINATIONFOLDER (LAFITE.OBTAIN.FOLDER DESTINATIONFULLNAME (QUOTE BOTH) SOURCEFOLDER :CONFIRM))) (if DESTINATIONFOLDER then (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER (LAB.SELECTED.MESSAGES SOURCEFOLDER) FROM.AUTO.MENU T COPYFLG)))) then (if COPYFLG then (LAB.PROMPTPRINT SOURCEFOLDER "Copy completed.") else (DISPLAYAFTERDELETE SOURCEFOLDER WINDOW)))) -) - -(\LAFITE.MOVE.MESSAGES.INTERNAL -(LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MSGLST FROM.AUTO.MENU INTERACTIVE COPYFLG) (* ; "Edited 5-Aug-93 19:50 by bvm") (* ;; "Move the messages in MSGLST from SOURCEFOLDER to DESTINATIONFOLDER. Caller must have acquired the lock on SOURCEFOLDER. FROM.AUTO.MENU means the call was from the auxiliary move menu; INTERACTIVE means it was interactive call vs. programmatic.") (PROG (OUTPUTSTREAM MSGDESCRIPTORS OLDMOVETO) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) T T)) (LAB.PROMPTPRINT SOURCEFOLDER T "Waiting for " (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) " to become available...") (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) NIL T) (LAB.PROMPTPRINT SOURCEFOLDER T))) (COND ((NOT (AND (\LAFITE.OPEN.FOLDER SOURCEFOLDER (QUOTE INPUT) NIL) (SETQ OUTPUTSTREAM (\LAFITE.OPEN.FOLDER DESTINATIONFOLDER (QUOTE BOTH) :OK SOURCEFOLDER)))) (* ; "Failed to open source or dest") (RETURN NIL))) (COND ((NEQ (SETQ OLDMOVETO (fetch (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER)) DESTINATIONFOLDER) (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of SOURCEFOLDER))) (replace (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER with DESTINATIONFOLDER) (WINDOWPROP WINDOW (QUOTE TITLE) (LAB.TITLE.STRING SOURCEFOLDER)) (if (AND OLDMOVETO (NOT FROM.AUTO.MENU) (OR LAFITE.AUTO.MOVE.MENU (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)))) then (\LAFITE.ADD.TO.MOVE.MENU SOURCEFOLDER DESTINATIONFOLDER OLDMOVETO))))) (SETQ MSGDESCRIPTORS (for OLDMSG in MSGLST bind NEWMSG (INSTREAM _ (\LAFITE.OPEN.FOLDER SOURCEFOLDER (QUOTE INPUT))) collect (MAYBEVERIFYMSG OLDMSG SOURCEFOLDER) (SETFILEPTR OUTPUTSTREAM -1) (SETQ NEWMSG (NCREATE (QUOTE LAFITEMSG) OLDMSG)) (* ; "New descriptor looks a lot like old") (replace (LAFITEMSG BEGIN) of NEWMSG with (GETFILEPTR OUTPUTSTREAM)) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of NEWMSG with NIL) (replace (LAFITEMSG MARKSCHANGEDINFILE?) of NEWMSG with NIL) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of NEWMSG with NIL) (replace (LAFITEMSG DELETED?) of NEWMSG with NIL) (replace (LAFITEMSG SELECTED?) of NEWMSG with NIL) (LA.PRINTHEADER OUTPUTSTREAM (- (fetch (LAFITEMSG MESSAGELENGTH) of OLDMSG) (fetch (LAFITEMSG STAMPLENGTH) of OLDMSG)) NEWMSG) (PROGN (* ; "Now the 3 flag bytes") (BOUT OUTPUTSTREAM UNDELETEDFLAG) (BOUT OUTPUTSTREAM (COND ((fetch (LAFITEMSG SEEN?) of OLDMSG) SEENFLAG) (T UNSEENFLAG))) (BOUT OUTPUTSTREAM (fetch (LAFITEMSG MARKCHAR) of OLDMSG)) (BOUT OUTPUTSTREAM (CHARCODE CR))) (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of OLDMSG) (fetch (LAFITEMSG END) of OLDMSG)) (if (NOT COPYFLG) then (MARKMESSAGE OLDMSG SOURCEFOLDER MOVETOMARK) (* ; "delete it") (DELETEMESSAGE OLDMSG SOURCEFOLDER)) NEWMSG)) (* ; "delete them from FROMFILE") (COND ((AND (fetch (MAILFOLDER BROWSERWINDOW) of DESTINATIONFOLDER) (fetch (MAILFOLDER BROWSERREADY) of DESTINATIONFOLDER)) (* ; "now print them in the other window, if up") (LAB.APPENDMESSAGES DESTINATIONFOLDER MSGDESCRIPTORS)) (T (* ; "still have to update eof") (replace (MAILFOLDER FOLDEREOFPTR) of DESTINATIONFOLDER with (GETEOFPTR OUTPUTSTREAM)))) (RETURN T))) -) -) - - - -(* ; "Aux move") - -(DEFINEQ - -(\LAFITE.ENABLE.MOVE.MENU -(LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 12:39 by bvm") (* ;; "Bring up a menu of folders attached to FOLDER's browser for accelerated MoveTo") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (OLDDEFAULT (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER))) (LAB.PROMPTPRINT FOLDER T "Specify which folders to include in the accelerated menu.") (if OLDDEFAULT then (CL:PUSHNEW (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDDEFAULT) ITEMS :TEST (QUOTE STRING-EQUAL))) (if (SETQ ITEMS (LAFITE.SELECT.FOLDERS ITEMS)) then (* ; "Didn't abort") (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER T)) (LAB.PROMPTPRINT FOLDER T))) -) - -(\LAFITE.ADD.TO.MOVE.MENU -(LAMBDA (FOLDER NEWFOLDER OLDFOLDER) (* ; "Edited 31-Aug-88 12:43 by bvm") (* ;; "Add NEWFOLDER to FOLDER's auto move menu, creating it if necessary, in which case also include OLDFOLDER") (PROG* ((NEWNAME (fetch (MAILFOLDER SHORTFOLDERNAME) of NEWFOLDER)) (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (OLDITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (ITEMS OLDITEMS)) (COND ((NULL ITEMS) (SETQ ITEMS (LIST NEWNAME)) (if OLDFOLDER then (push ITEMS (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDFOLDER)))) ((CL:MEMBER NEWNAME ITEMS :TEST (QUOTE STRING-EQUAL)) (* ; "Nothing new to do") (RETURN)) (T (push ITEMS NEWNAME))) (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER (NULL OLDITEMS)))) -) - -(\LAFITE.UPDATE.MOVE.MENU -(LAMBDA (FOLDER FORCE) (* ; "Edited 23-Aug-89 12:21 by bvm") (* ;; "Called when someone has changed the set of folder names in FOLDER's auto move menu. This function creates a new menu. If the menu is not currently open, we don't open one unless FORCE is true.") (PROG* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (MENUW (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.MENU))) HOW POSITION TITLE) (if (NOT (OPENWP WINDOW)) then (* ; "Maybe the browser is shrunk. The system doesn't know how to attach to shrunken windows, so just punt it") (RETURN) elseif MENUW then (* ; "Remove the old window and make a new") (DETACHWINDOW MENUW WINDOW) (CLOSEW MENUW) elseif (NULL FORCE) then (RETURN)) (SETQ POSITION (SELECTQ (SETQ HOW LAFITE.AUTO.MOVE.MENU) ((LEFT RIGHT) (QUOTE TOP)) ((BOTTOM TOP) (QUOTE LEFT)) (PROGN (SETQ HOW (QUOTE RIGHT)) (QUOTE TOP)))) (CL:MULTIPLE-VALUE-BIND (NCOLUMNS ITEMS) (\LAFITE.ARRANGE.MENU (APPEND (SORT (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)) (FUNCTION UALPHORDER)) (AND LAFITE.EXTRA.MOVE.ITEMS (CONS (QUOTE ("" (QUOTE NILL) "")) LAFITE.EXTRA.MOVE.ITEMS))) LAFITE.FOLDER.MENU.FONT (- (LET* ((REG (WINDOWREGION WINDOW)) (BROWSERHEIGHT (fetch (REGION HEIGHT) of REG))) (if (EQ POSITION (QUOTE TOP)) then (* ; "Don't make the menu much taller than the window or below bottom of screen") (MIN (+ BROWSERHEIGHT (IQUOTIENT BROWSERHEIGHT 2)) (fetch (REGION TOP) of REG)) else (* ; "Don't make it taller than the screen") (- SCREENHEIGHT BROWSERHEIGHT))) (FONTPROP WINDOWTITLEFONT (QUOTE HEIGHT))) (SETQ TITLE "Move To:")) (SETQ MENUW (MENUWINDOW (create MENU ITEMS _ ITEMS MENUCOLUMNS _ NCOLUMNS CENTERFLG _ T TITLE _ TITLE WHENHELDFN _ (FUNCTION (LAMBDA (ITEM) (PROMPTPRINT (if (LISTP ITEM) then (CADDR ITEM) else "Move the selected message(s) to this folder")))) WHENSELECTEDFN _ (FUNCTION \LAFITE.HANDLE.AUTO.MOVE) MENUFONT _ LAFITE.FOLDER.MENU.FONT MENUTITLEFONT _ WINDOWTITLEFONT)))) (ATTACHWINDOW MENUW WINDOW HOW POSITION (QUOTE LOCALCLOSE)) (WINDOWADDPROP MENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (* ;; "Remove pointer to me. Note that this fn must come first, before detachwindow") (AND (SETQ W (MAINWINDOW W)) (WINDOWPROP W (QUOTE LAFITE.AUTO.MOVE.MENU) NIL)))) T) (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.MENU) MENUW))) -) - -(\LAFITE.RESTORE.MOVE.MENU -(LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 15:19 by bvm") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)))) (if ITEMS then (* ; "Yes, there was a menu, so bring it up") (\LAFITE.UPDATE.MOVE.MENU FOLDER T) else (* ; "Start from scratch") (\LAFITE.ENABLE.MOVE.MENU FOLDER)))) -) - -(\LAFITE.HANDLE.AUTO.MOVE -(LAMBDA (ITEM MENU KEY) (* ; "Edited 29-Aug-88 15:06 by bvm") (* ;; "Handle the selection of an item from Lafite's auto moveto menu. Just do the specified move") (LET ((MENUW (WFROMMENU MENU)) WINDOW FOLDER) (AND MENUW (SETQ WINDOW (MAINWINDOW MENUW)) (SETQ FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (if (LISTP ITEM) then (* ; "Handle other commands") (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) WINDOW FOLDER ITEM MENU KEY) else (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.MOVETO.PROC)) (QUOTE (\, WINDOW)) (QUOTE (\, FOLDER)) (QUOTE (\, (LA.LONGFILENAME ITEM LAFITEMAIL.EXT))) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) T)) (QUOTE LAFITEMOVE)))))) -) -) - -(ADDTOVAR LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" (QUOTE \LAFITE.ENABLE.MOVE.MENU) "Attach a menu of folders for accelerated MoveTo (or modify existing one)" (SUBITEMS ("Restore MoveTo Menu" (QUOTE \LAFITE.RESTORE.MOVE.MENU) "Just reopen the attached MoveTo menu if it existed."))) ("Copy To" (QUOTE \LAFITE.COPYTO) "Like MoveTo, but don't delete the message(s).")) - -(ADDTOVAR LAFITE.EXTRA.MOVE.ITEMS ("---Display---" (QUOTE \LAFITE.DISPLAY) "Display the next message") ("---Delete---" (QUOTE \LAFITE.DELETE) "Delete the selected message(s)")) - -(RPAQ? LAFITE.AUTO.MOVE.MENU) - - - -(* ; "UPDATE") - -(DEFINEQ - -(\LAFITE.UPDATE -(LAMBDA (WINDOW FOLDER ITEM MENU BUTTONS) (* ; "Edited 25-Apr-89 15:10 by bvm") (LET ((HOWINDEX (LAB.UPDATE.NEEDED? FOLDER)) HOW? HOWSTRING CLOSEFLG CONFIRMFLG) (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) (if (AND (EQ BUTTONS (QUOTE MIDDLE)) LAFITE.MIDDLE.UPDATE) then (* ; "Accelerator: do what this flag says, asking only for confirmation first") (for OP inside LAFITE.MIDDLE.UPDATE do (CASE OP ((:CLOSE :SHRINK) (SETQ CLOSEFLG OP)) ((:UPDATE :EXPUNGE) (SETQ HOWSTRING (if (AND (EQ OP :EXPUNGE) (BITTEST HOWINDEX \EXPUNGE.MENU.BIT)) then (* ; "Expunge is needed and requested") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Expunge" elseif (BITTEST HOWINDEX \SORT.MENU.BIT) then (* ; "Have to do wtih expunge") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Write sorted" elseif (BITTEST HOWINDEX \EXPUNGE&SORT.MENU.BIT) then (* ; "Have to do wtih expunge") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Expunge (write sorted)" elseif (BITTEST HOWINDEX \UPDATE.MENU.BIT) then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC)) "Write out changes" elseif (BITTEST HOWINDEX \TOC.MENU.BIT) then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC)) "Update table of contents")) (if (BITTEST HOWINDEX \HARDCOPY.MENU.BIT) then (* ; "Also might want to hardcopy") (SETQ HOWSTRING (if (NULL HOW?) then (SETQ HOW? (FUNCTION \LAFITE.HARDCOPYONLY.PROC)) "Hardcopy" else (CONCAT "Hardcopy, " HOWSTRING))) elseif (NULL HOW?) then (* ; "Pretend no update is needed, even if left-update would have said Expunge") (SETQ HOWINDEX 0))) (:CONFIRM (SETQ CONFIRMFLG T))))) (if (AND (NULL CLOSEFLG) (EQ 0 HOWINDEX)) then (* ; "We weren't asked to close it, and nothing changed.") (LAB.PROMPTPRINT FOLDER T "No changes since the last Update") elseif (SETQ HOW? (if (OR HOWSTRING CLOSEFLG) then (if (AND (NULL HOWSTRING) (EQ CLOSEFLG :SHRINK)) then (* ; "Accelerator says Shrink, and there is nothing else to do, so just shrink") (FUNCTION \LAFITE.FINISH.UPDATE) elseif (OR (NULL CONFIRMFLG) (LAB.MOUSECONFIRM FOLDER (CONCATLIST (CONS "Click LEFT to confirm " (LET ((CF (AND CLOSEFLG (LIST (L-CASE CLOSEFLG T))))) (if HOWSTRING then (LIST* HOWSTRING (AND CF (CONS " and " CF))) else CF)))))) then (OR HOW? (FUNCTION \LAFITE.FINISH.UPDATE))) else (MENU (LAB.CHOOSE.UPDATE.MENU HOWINDEX)))) then (\LAFITE.PROCESS (LIST HOW? (KWOTE WINDOW) (KWOTE FOLDER) CLOSEFLG (KWOTE ITEM) (KWOTE MENU)) (QUOTE LAFITEUPDATE))))) -) - -(\LAFITE.EXPUNGE.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 1-May-89 12:53 by bvm") (RESETLST (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (CLEARW WINDOW) (\LAFITE.COMPACT.FOLDER MAILFOLDER) (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (COND (CLOSEFLG (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of MAILFOLDER with 0)) (T (LAB.DISPLAYFOLDER MAILFOLDER)))) (* ; "Do the following outside RESETLST so that Update gets unshaded") (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) - -(\LAFITE.UPDATE.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 14-Oct-87 20:00 by bvm:") (RESETLST (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) (COND ((OR (COND ((fetch (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER) (\LAFITE.UPDATE.FOLDER MAILFOLDER) T)) (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) (fetch (MAILFOLDER TOCLASTMESSAGE#) of MAILFOLDER))) (\LAFITE.UPDATE.CONTENTS MAILFOLDER (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))) (T (LAB.PROMPTPRINT MAILFOLDER T "No changes since last update"))) (\LAFITE.CLOSE.FOLDER MAILFOLDER T)) (* ; "Do the following outside RESETLST so that Update gets unshaded") (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) - -(\LAFITE.HARDCOPYONLY.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 29-Aug-88 17:49 by bvm") (* ;; "Called by Update or Close to just do pending hardcopy, nothing else") (RESETLST (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) ITEM MENU) (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER)) (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) - -(LAB.CHOOSE.UPDATE.MENU -(LAMBDA (FOLDER CLOSEFLG) (* ; "Edited 25-Apr-89 15:10 by bvm") (* ;; "Returns a menu for prompting the user about what to do with FOLDER when Update is requested, or if CLOSEFLG is true, if Close/Shrink is requested. Returns NIL if there is no interesting choice.") (LET ((INDEX (OR (FIXP FOLDER) (LAB.UPDATE.NEEDED? FOLDER)))) (if (NEQ INDEX 0) then (CASE CLOSEFLG (:CLOSE (SETQ INDEX (LOGOR INDEX \CLOSE.MENU.BIT))) (:SHRINK (SETQ INDEX (LOGOR INDEX \SHRINK.MENU.BIT)))) (OR (GETHASH INDEX LAFITE.UPDATE.MENU.HASH) (LAB.CREATE.UPDATE.MENU INDEX))))) -) - -(LAB.CREATE.UPDATE.MENU -(LAMBDA (INDEX) (* ; "Edited 25-Apr-89 15:08 by bvm") (* ;; "Create a menu to ask about updating. There is a bit in INDEX for each possible thing you might want to do to update this folder -- Update, Expunge, Update TOC, Hardcopy, Expunge&Sort. Not all bit combinations are possible. In practice, only a small number of combinations actually occur, so we remember menus in a hash table.") (LET* ((LASTITEM NIL) (ITEMS (for ITEM in LAFITEUPDATEMENUITEMS as (BIT _ 1) by (LLSH BIT 1) when (BITTEST INDEX BIT) collect (if (NOT (BITTEST INDEX (LOGOR \CLOSE.MENU.BIT \SHRINK.MENU.BIT))) then (SETQ LASTITEM ITEM)) ITEM)) MENU) (if (STRPOS "Only" (CAR LASTITEM) -4 NIL T NIL UPPERCASEARRAY) then (* ; "Sounds funny if last item says %"Only%"") (RPLACA (FMEMB LASTITEM ITEMS) (CONS (SUBSTRING (CAR LASTITEM) 1 -6) (CDR LASTITEM)))) (SETQ MENU (\LAFITE.CREATE.MENU ITEMS (if (BITTEST INDEX \CLOSE.MENU.BIT) then "Close Options" elseif (BITTEST INDEX \SHRINK.MENU.BIT) then "Shrink Options" else "Update Options"))) (PUTHASH INDEX MENU LAFITE.UPDATE.MENU.HASH) MENU)) -) - -(LAB.UPDATE.NEEDED? -(LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 15:08 by bvm") (* ;; "Returns an integer whose bits indicate the type of updating needed by FOLDER; zero if it needs none.") (LOGOR (COND ((fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER) \HARDCOPY.MENU.BIT) (T 0)) (if (NOT (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER)) then (LOGOR (if (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER) then \UPDATE.MENU.BIT elseif (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER)) then (* ; "Update toc if messages have been appended") \TOC.MENU.BIT else 0) (if (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) then \EXPUNGE.MENU.BIT else 0)) elseif (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) then \EXPUNGE&SORT.MENU.BIT else \SORT.MENU.BIT))) -) - -(\LAFITE.START.UPDATE -(LAMBDA (MAILFOLDER ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") (* ;; "Called under a RESETLST to start an UPDATE or EXPUNGE") (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) ITEM MENU) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (MAILFOLDER) (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with NIL))) MAILFOLDER)) (* ; "Mark folder being updated for benefit of LOGOUT check") (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with T) (* ; "Close all other folders, so MoveTo's are up to date") (\LAFITE.CLOSE.OTHER.FOLDERS MAILFOLDER) (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER MENU)) -) - -(LAB.START.COMMAND -(LAMBDA (MAILFOLDER CMD ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") (* ;; "Shades MAILFOLDER's command implemented by CMD, or ITEM of MENU if supplied and obtains the folder lock. Opens browser window if it is shrunk. Must be called under RESETLST surrounding command execution.") (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER))) (if (AND WINDOW (NOT (OPENWP WINDOW))) then (EXPANDW WINDOW))) (LA.RESETSHADE (OR ITEM (LA.MENU.ITEM CMD (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of MAILFOLDER)))) MENU) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) NIL T) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER)) -) - -(\LAFITE.FINISH.UPDATE -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG) (* ; "Edited 7-Jun-88 14:28 by bvm") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (CASE CLOSEFLG ((:CLOSE :EXIT) (WITH.MONITOR \LAFITE.BROWSELOCK (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (SETQ WINDOW (LAB.FLUSHWINDOW WINDOW MAILFOLDER)) (CLOSEW WINDOW) (COND ((AND (NEQ CLOSEFLG :EXIT) (OR (NOT (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER)) (= (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER) 0)) (EQ (GETFILEINFO (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) (QUOTE LENGTH)) 0)) (* ;; "Folder is empty, and we are explicitly closing it (as opposed to indirectly via the Quit command), so delete underlying file, etc. FOLDEREOFPTR should always be right, but be paranoid and double-check with the file itself before deleting") (DELETEMAILFOLDER MAILFOLDER))))) (:SHRINK (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION LAB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN)) (SHRINKW WINDOW)))) (COND (\LAFITEPROFILECHANGED (\LAFITE.WRITE.PROFILE)))) -) - -(\LAFITE.CLOSE.OTHER.FOLDERS -(LAMBDA (THISFOLDER) (* bvm%: "31-Jul-84 15:17") (* ;; "Closes or flushes output of all Lafite folders except THISFOLDER. If a folder does not have an open browser, the file is closed; else output is flushed") (WITH.MONITOR \LAFITE.MAINLOCK (for FOLDER in \ACTIVELAFITEFOLDERS when (AND (NEQ FOLDER THISFOLDER) (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER)) do (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) (\LAFITE.CLOSE.FOLDER FOLDER (NULL (OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)))))))))) -) -) -(DEFINEQ - -(LAB.FLUSHWINDOW -(LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 18-Jul-88 11:37 by bvm") (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN)) (replace (MAILFOLDER BROWSERREADY) of MAILFOLDER with (replace (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER with (replace (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER with (replace (MAILFOLDER BROWSERMENUWINDOW) of MAILFOLDER with (replace (MAILFOLDER BROWSERWINDOW) of MAILFOLDER with (replace (MAILFOLDER BROWSERMENU) of MAILFOLDER with (replace (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER with NIL))))))) (WINDOWPROP WINDOW (QUOTE MAILFOLDER) NIL) (SETQ \ACTIVELAFITEFOLDERS (DREMOVE MAILFOLDER \ACTIVELAFITEFOLDERS)) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) -) - -(LAB.APPENDMESSAGES -(LAMBDA (FOLDER NEWMESSAGEDESCRIPTORS) (* ; "Edited 28-Apr-89 15:47 by bvm") (* ;; "Append list of message descriptors to folder, adjusting display, etc as needed.") (PROG ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) FIRSTMSG#) (SETQ FIRSTMSG# (ADD1 LASTMSG#)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with (GETEOFPTR (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER))) (for MSGDESCRIPTOR in NEWMESSAGEDESCRIPTORS do (replace (LAFITEMSG %#) of MSGDESCRIPTOR with (add LASTMSG# 1)) (LAFITE.PARSE.MSG.FOR.TOC MSGDESCRIPTOR FOLDER)) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTMSG#) (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER with (\LAFITE.ADDMESSAGES.TO.ARRAY (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) NEWMESSAGEDESCRIPTORS FIRSTMSG# LASTMSG#)) (LET ((EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) (HEIGHT (TIMES LASTMSG# (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) WINDOW) (replace (REGION HEIGHT) of EXTENT with HEIGHT) (replace (REGION BOTTOM) of EXTENT with (- (fetch (MAILFOLDER BROWSERORIGIN) of FOLDER) HEIGHT)) (WINDOWPROP (SETQ WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (QUOTE EXTENT) EXTENT) (COND ((OPENWP WINDOW) (* ; "If window is visible, update it now") (LAB.DISPLAYLINES FOLDER FIRSTMSG#)) ((NULL (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER)) (* ; "Mark browser for display update after being unshrunk") (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with FIRSTMSG#)))))) -) - -(\LAFITE.COMPACT.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") (* ;;; "Expunge deleted messages from MAILFOLDER. We copy undeleted messages after the first deleted one into a scratch file and copy the scratch file back into the main file. Returns the msg # of the last message before the compacted section. This function must also be used if the folder is out of order.") (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (FIRSTCHANGED# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) (LASTGOODMSG# (SUB1 FIRSTCHANGED#)) (LASTLENGTH 0) (LASTBEGIN 0) FOLDERSTREAM MSG TOCSTREAM) (if (> FIRSTCHANGED# 1) then (* ; "Get this loop initialized") (SETQ MSG (NTHMESSAGE MESSAGES LASTGOODMSG#)) (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (* ;; "first see if there are any messages to delete or messages out of order and while doing so collect information for rapidly compacting the file just in case we have to. We check for out of order by maintaining previous pointer and length so as to avoid boxing most of the time.") (for MSG# from (MAX 1 FIRSTCHANGED#) to LASTMSG# until (OR (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) (NOT (= (- (fetch (LAFITEMSG BEGIN) of MSG) LASTBEGIN) LASTLENGTH))) do (COND ((fetch (LAFITEMSG MARKSCHANGEDINFILE?) of MSG) (WRITEFOLDERMARKBYTES MSG FOLDER (OR FOLDERSTREAM (SETQ FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE BOTH) :ABORT)))))) (SETQ LASTGOODMSG# MSG#) (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (COND ((NEQ LASTGOODMSG# LASTMSG#) (SETQ TOCSTREAM (\LAFITE.COMPACT.FOLDER1 FOLDER (OR FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE BOTH) :ABORT)) LASTGOODMSG#)))) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with NIL) (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (\LAFITE.UPDATE.CONTENTS FOLDER LASTGOODMSG# TOCSTREAM))) -) - -(\LAFITE.COMPACT.FOLDER1 -(LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG#) (* ; "Edited 13-Jul-92 16:01 by bvm") (* ;;; "LASTGOODMSG# is the number of the last good message before the region to be compacted. FOLDERSTREAM is open for io.") (LET (SCRATCHFILE STATE ORIGEOF CONDITION TOCSTREAM) (CL:UNWIND-PROTECT (PROG ((*PRINT-BASE* 10) (*UPPER-CASE-FILE-NAMES* NIL) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (OLDLASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (FIRSTSELECTED (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LASTSELECTED (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) COMPACTLENGTH GOODMSGSPTR MSGLIST RESULT NEWDATE) (LAB.PROMPTPRINT FOLDER "Compacting folder... ") (COND ((> LASTSELECTED LASTGOODMSG#) (* ; "There are selections in the compacting region") (COND ((> FIRSTSELECTED LASTGOODMSG#) (* ; "All selections are there, so recompute completely") (SETQ LASTSELECTED (SETQ FIRSTSELECTED NIL))) (T (* ; "Some selections before it, so only Last changes") (SETQ LASTSELECTED (LAB.REV.FIND.SELECTED.MSG FOLDER FIRSTSELECTED LASTGOODMSG#)))))) (SETQ GOODMSGSPTR (COND ((EQ LASTGOODMSG# 0) 0) (T (fetch (LAFITEMSG END) of (NTHMESSAGE MESSAGES LASTGOODMSG#))))) (* ; "End of the region that we leave alone") (SETQ COMPACTLENGTH (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# bind MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) sum (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (COND ((NEQ COMPACTLENGTH 0) (if (if (EQ LASTGOODMSG# 0) then (* ; "WIll have to rewrite whole folder") (SMART-RENAMEFILEP FOLDERSTREAM) elseif (AND (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) (SMART-RENAMEFILEP FOLDERSTREAM)) then (* ; "Will it be faster to write a brand new file and rename it to the destination than to do the overwriting stuff, given the extra messages we'll have to save on the end in case of disaster?") (> (\LAFITE.COMPACT.EXTRA FOLDER LASTGOODMSG# GOODMSGSPTR GOODMSGSPTR) GOODMSGSPTR)) then (SETQ SCRATCHFILE (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERSTREAM (QUOTE EXTENSION)) "-compacted") (QUOTE BODY) FOLDERSTREAM) (QUOTE OUTPUT) (QUOTE NEW) (BQUOTE ((LENGTH (\, (+ GOODMSGSPTR COMPACTLENGTH))) (SEQUENTIAL T) (TYPE LAFITE))))) (COPYBYTES FOLDERSTREAM SCRATCHFILE 0 GOODMSGSPTR) (LINELENGTH T SCRATCHFILE) (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE T)) (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE)) (SETQ NEWDATE (GETFILEINFO SCRATCHFILE (QUOTE ICREATIONDATE))) (SETQ FOLDERSTREAM (FULLNAME FOLDERSTREAM)) (\LAFITE.CLOSE.FOLDER FOLDER T) (SETQ STATE :NEW) (CL:MULTIPLE-VALUE-SETQ (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHFILE FOLDERSTREAM)) (if (NULL RESULT) then (RETURN) else (* ; "Scratch file now gone") (SETQ SCRATCHFILE NIL) (SETQ STATE :OPEN) (* ; "At this point, file is inconsistent with in-core structures.") (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER))) else (SETQ ORIGEOF (GETEOFPTR FOLDERSTREAM)) (* ; "Save info for abort") (SETQ STATE :APPEND) (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR (SETQ SCRATCHFILE (LA.OPENTEMPFILE (QUOTE SCRATCH) (QUOTE BOTH) (QUOTE NEW) COMPACTLENGTH)))) (* ;; "Up til now, you could abort and nothing bad would happen--the folder hasn't been written on yet.") (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) (* ; "set the pointer to the end of the good messages") (SETQ STATE :OPEN) (* ; "We're about to make the world inconsistent") (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER)) (COPYBYTES SCRATCHFILE FOLDERSTREAM 0 -1) (* ; "copy the scratch file to the end of the good messages left in the original file") (FORCEOUTPUT FOLDERSTREAM) (* ; "Ensure that all those writes succeeded, before we update core and truncate the file below.")) (for MSG in MSGLIST do (* ;; "Now that it's all written, update the incore structures") (if (LISTP MSG) then (* ; "Need to fix stamp & msg length") (replace (LAFITEMSG MESSAGELENGTH) of (CAR MSG) with (CADDR MSG)) (replace (LAFITEMSG STAMPLENGTH) of (CAR MSG) with (CADR MSG)) (SETQ MSG (CAR MSG))) (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL) (replace (LAFITEMSG BEGIN) of MSG with GOODMSGSPTR) (add GOODMSGSPTR (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) (replace (LAFITEMSG %#) of MSG with (add LASTGOODMSG# 1)) (SETA MESSAGES LASTGOODMSG# MSG) (COND ((fetch (LAFITEMSG SELECTED?) of MSG) (COND ((NOT FIRSTSELECTED) (SETQ FIRSTSELECTED LASTGOODMSG#))) (SETQ LASTSELECTED LASTGOODMSG#)))) (if (AND (NOT NEWDATE) (NOT (= GOODMSGSPTR (GETFILEPTR FOLDERSTREAM)))) then (HELP "Miscalculation in Lafite Expunge" (LIST GOODMSGSPTR (QUOTE NEQ) (GETFILEPTR FOLDERSTREAM)))))) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTGOODMSG#) (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER with (OR FIRSTSELECTED 1)) (replace (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER with (OR LASTSELECTED 0)) (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# do (* ; "Erase entries beyond the new end of messages") (SETA MESSAGES I NIL)) (if NEWDATE then (* ; "Did via separate file, so get the date right") (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with NEWDATE) else (* ; "Truncate to new length") (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) (SETFILEINFO FOLDERSTREAM (QUOTE LENGTH) GOODMSGSPTR)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with GOODMSGSPTR) (SETQ STATE :END) (RETURN TOCSTREAM)) (* ;; "Cleanup code--this runs even if we are aborted.") (if (NEQ STATE :END) then (LAB.PROMPTPRINT FOLDER " aborted.") (if (EQ STATE :OPEN) then (LAB.PROMPTPRINT FOLDER " Folder is now in an inconsistent state and must be rebrowsed.") else (* ; "We have not yet overwritten anything, so folder is still consistent, mainly") (if (AND (EQ STATE :APPEND) (> (GETEOFPTR FOLDERSTREAM) ORIGEOF)) then (* ; "We have written stuff to end of file--delete it") (SETFILEPTR FOLDERSTREAM ORIGEOF) (SETFILEINFO FOLDERSTREAM (QUOTE LENGTH) ORIGEOF)) (if (EQ STATE :NEW) then (* ; "The RENAMEFILE failed") (LAB.FORMAT FOLDER " Help! Could not replace mail file with compacted file~@[ because ~A~]. The compacted file is stored as ~A. You must rename this file to ~A before proceeding. " CONDITION SCRATCHFILE FOLDERSTREAM) else (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if (OPENWP WINDOW) then (* ; "Window was cleared, so redisplay it now") (REDISPLAYW WINDOW))))) (if TOCSTREAM then (CLOSEF TOCSTREAM))) (\LAFITE.CLOSE.FOLDER FOLDER T) (if SCRATCHFILE then (if (STREAMP SCRATCHFILE) then (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE))) (DELFILE SCRATCHFILE)) (if (AND (EQ STATE :END) (EQ LAFITEVERIFYFLG (QUOTE ALL))) then (VERIFYMAILFOLDER FOLDER))))) -) - -(\LAFITE.COMPACT.FOLDER2 -(LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE NEWFILEP) (* ; "Edited 2-May-89 11:09 by bvm") (* ;; "We want to compact FOLDER's messages beyond LASTGOODMSG#, which ends at GOODMSGSPTR. We map down the messages moving the undeleted ones into SCRATCHFILE (which is a new mail file if NEWFILEP is true). Return a list of the messages written to SCRATCHFILE. If the stamp length of any message changed, the corresponding element is not the message but a list (msg newstamplength newmsglength).") (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (NEXTFILEPTR _ GOODMSGSPTR) MSG TMP unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) collect (MAYBEVERIFYMSG MSG FOLDER) (LET* ((BEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (STAMPLENGTH (fetch (LAFITEMSG STAMPLENGTH) of MSG)) (MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) (BODYLENGTH (- MSGLENGTH STAMPLENGTH)) (NEWSTAMPLENGTH (LA.PRINTHEADER SCRATCHFILE BODYLENGTH))) (WRITEFOLDERMARKBYTES MSG NIL SCRATCHFILE) (BOUT SCRATCHFILE (CHARCODE CR)) (COPYBYTES FOLDERSTREAM SCRATCHFILE (+ BEGIN STAMPLENGTH) (+ BEGIN MSGLENGTH)) (if (NOT NEWFILEP) then (if (< BEGIN NEXTFILEPTR) then (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") (SETFILEPTR FOLDERSTREAM -1) (LA.PRINTHEADER FOLDERSTREAM BODYLENGTH NIL (+ (NCHARS BEGIN) (CONSTANT (ADD1 (NCHARS "*duplicate*"))))) (BOUT FOLDERSTREAM DELETEDFLAG) (* ; "Make message look deleted ordinarily") (BOUT FOLDERSTREAM UNSEENFLAG) (BOUT FOLDERSTREAM DUPLICATEMARK) (BOUT FOLDERSTREAM (CHARCODE CR)) (PRIN3 "*duplicate*" FOLDERSTREAM) (* ; "Mark as duplicate and tell where") (PRIN3 BEGIN FOLDERSTREAM) (BOUT FOLDERSTREAM (CHARCODE CR)) (COPYBYTES SCRATCHFILE FOLDERSTREAM (- (SETQ TMP (GETFILEPTR SCRATCHFILE)) BODYLENGTH) TMP) (SETFILEPTR SCRATCHFILE TMP)) (add NEXTFILEPTR BODYLENGTH NEWSTAMPLENGTH)) (if (EQ STAMPLENGTH NEWSTAMPLENGTH) then (* ; "normal case, no length changed") MSG else (LIST MSG NEWSTAMPLENGTH (+ BODYLENGTH NEWSTAMPLENGTH)))))) -) - -(\LAFITE.COMPACT.EXTRA -(LAMBDA (FOLDER LASTGOODMSG# GOODMSGSPTR STOPAT) (* ; "Edited 5-May-89 11:25 by bvm") (* ;; "Returns an estimate of the length of stuff we'll have to append to folder while compacting it, due to messages being out of order. If the estimate ever exceeds STOPAT we can stop counting and return the current estimate.") (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (NEXTFILEPTR _ GOODMSGSPTR) (EXTRALENGTH _ 0) MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) do (LET ((MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (if (< (fetch (LAFITEMSG BEGIN) of MSG) NEXTFILEPTR) then (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") (if (> (add EXTRALENGTH MSGLENGTH (CONSTANT (+ 6 (NCHARS "*duplicate*")))) STOPAT) then (RETURN EXTRALENGTH))) (add NEXTFILEPTR MSGLENGTH)) finally (RETURN EXTRALENGTH))) -) - -(\LAFITE.INVALIDATE.TOC -(LAMBDA (FOLDER) (* ; "Edited 5-May-89 11:45 by bvm") (* ;; "Invalidate the toc file for this folder by trashing the password. Returns the stream, if any.") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (NAME (INFILEP (TOCFILENAME FOLDER))) TOCSTREAM) (if (AND NAME (SETQ TOCSTREAM (IGNORE-ERRORS (\LAFITE.OPENSTREAM NAME (QUOTE BOTH) (QUOTE OLD) NIL NIL (QUOTE BINARY))))) then (WORDOUT TOCSTREAM (LOGXOR 65535 LAFITETOCPASSWORD)) (FORCEOUTPUT TOCSTREAM) TOCSTREAM))) -) - -(\LAFITE.RENAMEFILE -(LAMBDA (SCRATCHFILE FOLDERNAME) (* ; "Edited 2-May-89 11:33 by bvm") (* ;; "Called to replace FOLDERNAME with SCRATCHFILE, e.g., as a result of a scavenge. On success, returns the new file name, otherwise returns NIL and, if an error was signaled, a CONDITION.") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (IGNORE-ERRORS (DELFILE FOLDERNAME) (RENAMEFILE SCRATCHFILE FOLDERNAME)))) -) - -(SMART-RENAMEFILEP -(LAMBDA (OBJECT) (* ; "Edited 1-May-89 12:31 by bvm") (* ;; "true if RENAMEFILE can be done intelligently on this path/stream/device") (LET ((DEV (CL:TYPECASE OBJECT (FDEV OBJECT) (STREAM (fetch (STREAM DEVICE) of OBJECT)) (T (\GETDEVICEFROMNAME OBJECT T))))) (AND DEV (CASE (fetch (FDEV RENAMEFILE) of DEV) ((NILL \GENERIC.RENAMEFILE) NIL) (T T))))) -) - -(LA.OPENTEMPFILE -(LAMBDA (EXTENSION ACCESS RECOG LENGTH) (* ; "Edited 3-Sep-87 16:29 by bvm:") (LET ((STREAM (OPENSTREAM (PACKFILENAME.STRING (QUOTE HOST) (QUOTE SCRATCH) (QUOTE NAME) (QUOTE LAFITETEMPORARY) (QUOTE EXTENSION) EXTENSION) (OR ACCESS (QUOTE OUTPUT)) (OR RECOG (QUOTE NEW)) NIL (AND LENGTH (LIST (LIST (QUOTE LENGTH) LENGTH)))))) (COND (STREAM (WHENCLOSE STREAM (QUOTE CLOSEALL) (QUOTE NO)) (LINELENGTH MAX.SMALLP STREAM) (if NIL then (* ; "save them so they can be deleted by LAFITE.QUIT") (* ;; "no need to keep list--they vanish via gc") (push \LAFITE.TEMPFILES (FULLNAME STREAM))) STREAM)))) -) -) -(DEFINEQ - -(\LAFITE.UPDATE.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 10:55 by bvm") (* ;;; "Write out any changed marks in MAILFOLDER, but don't expunge deleted messages") (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) OUTSTREAM MSG) (if (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) then (LAB.PROMPTPRINT FOLDER "Folder has been reordered, so can't simply write out changes--must Expunge.")) (LAB.PROMPTPRINT FOLDER "Writing out changes...") (for MSG# from (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) when (fetch (LAFITEMSG MARKSCHANGEDINFILE?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) do (WRITEFOLDERMARKBYTES MSG FOLDER (OR OUTSTREAM (SETQ OUTSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE OUTPUT) :ABORT))))) (\LAFITE.CLOSE.FOLDER FOLDER) (LAB.PROMPTPRINT FOLDER (COND (OUTSTREAM " done. ") (T "nothing changed. "))) (if (NOT (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER)) then (* ; "Everything is up to date now.") (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL))) -) - -(\LAFITE.UPDATE.CONTENTS -(LAMBDA (MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") (* ;;; "Update the TOC file for MAILFOLDER, assuming that entries up to LASTUNCHANGEDMESSAGE# are okay.") (COND ((NLSETQ (\LAFITE.UPDATE.CONTENTS1 MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM)) (LAB.PROMPTPRINT MAILFOLDER " done.")) (T (LAB.PROMPTPRINT MAILFOLDER " failed."))) (* ;; "FOLDERNEEDSUPDATE set to NIL now either because toc was completely written or because toc was deleted on error, in which case 'Update Table of Contents' is still needed") (replace (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER with NIL)) -) - -(\LAFITE.UPDATE.CONTENTS1 -(LAMBDA (FOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") (* ;; "Write the table of contents file for FOLDER. LASTUNCHANGEDMESSAGE# is the last message in the folder before compacting changes set in. Prior to that message, we'll only have to update flag bytes if anything. If TOCSTREAM is supplied, it is a stream already open for i/o on the toc file (from Expunge, which invalidates the toc password before trashing the mail file).") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (TOCSTART LAFITETOCHEADERLENGTH) FIRSTMSG# MSG) (COND ((> LASTMSG# 0) (LAB.PROMPTPRINT FOLDER "Writing table of contents...") (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM FOLDER) (SETQ STREAM (CLOSEF STREAM)) (COND (RESETSTATE (* ; "If we aborted out, assume toc is garbage") (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with 0) (DELFILE (FULLNAME STREAM)))))) (OR TOCSTREAM (SETQ TOCSTREAM (OPENSTREAM (TOCFILENAME FOLDER) (QUOTE BOTH) (QUOTE OLD/NEW) (QUOTE ((TYPE BINARY)))))) FOLDER)) (SETQ LASTUNCHANGEDMESSAGE# (IMIN LASTUNCHANGEDMESSAGE# (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER))) (COND ((EQ (GETEOFPTR TOCSTREAM) 0) (SETQ LASTUNCHANGEDMESSAGE# 0)) ((AND (EQ LASTUNCHANGEDMESSAGE# 0) (NEQ (PROGN (SETFILEPTR TOCSTREAM BYTESPERWORD) (WORDIN TOCSTREAM)) LAFITEVERSION#)) (* ; "A version number change, rewrite entire toc")) (T (* ; "TOC already existed, just update it") (for MSG# from 1 to LASTUNCHANGEDMESSAGE# do (COND ((fetch (LAFITEMSG MARKSCHANGEDINTOC?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) (* ; "Message not compacted out, but its mark bytes have changed") (SETFILEPTR TOCSTREAM TOCSTART) (WRITETOCMARKBYTES MSG TOCSTREAM) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL))) (add TOCSTART (fetch (LAFITEMSG TOCLENGTH) of MSG))))) (SETFILEPTR TOCSTREAM TOCSTART) (for MSG# from (ADD1 LASTUNCHANGEDMESSAGE#) to LASTMSG# do (WRITETOCENTRY (NTHMESSAGE MESSAGES MSG#) TOCSTREAM)) (SETFILEINFO TOCSTREAM (QUOTE LENGTH) (GETFILEPTR TOCSTREAM)) (SETFILEPTR TOCSTREAM 0) (* ; "Now write the header info") (WORDOUT TOCSTREAM LAFITETOCPASSWORD) (WORDOUT TOCSTREAM LAFITEVERSION#) (FIXPOUT TOCSTREAM (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) (WORDOUT TOCSTREAM LASTMSG#)) ((SETQ TOCSTREAM (INFILEP (TOCFILENAME FOLDER))) (LAB.PROMPTPRINT FOLDER "Deleting table of contents...") (DELFILE TOCSTREAM))) (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with LASTMSG#)))) -) - -(WRITETOCENTRY -(LAMBDA (MSG STREAM) (* ; "Edited 28-Apr-89 12:18 by bvm") (* ;;; "Dumps TOC entry for MSG on STREAM") (PROG ((TOCLENGTH 6) (MESSAGELENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) DAT NC) (* ; "TOCLENGTH 6 counts for 3 bytes of message length, 1 byte each of stamplength, flags and mark.") (WRITETOCMARKBYTES MSG STREAM) (COND ((> MESSAGELENGTH MAX.SMALLP) (* ;; "Ugh, length greater than fits in one word. Would be surprised if this ever happens, but file format permits it") (LET ((HIWORD (LRSH MESSAGELENGTH BITSPERWORD))) (if (> HIWORD 254) then (* ; "a very long length, escape to 4 bytes of length") (BOUT STREAM 255) (WORDOUT STREAM HIWORD) (add TOCLENGTH 2) else (BOUT STREAM HIWORD))) (WORDOUT STREAM (LOGAND MESSAGELENGTH MAX.SMALLP))) (T (* ; "Normal case, a small length") (BOUT STREAM 0) (WORDOUT STREAM MESSAGELENGTH))) (BOUT STREAM (fetch (LAFITEMSG STAMPLENGTH) of MSG)) (if (fetch (LAFITEMSG DATEFETCHED?) of MSG) then (* ; "Write 4 bytes of idate") (\BOUTS STREAM MSG (UNFOLD (INDEXF (FETCH (LAFITEMSG IDATE))) BYTESPERWORD) 4) (add TOCLENGTH 4)) (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) then (* ; "Write 6 bytes of ascii string") (PRIN3 (COND ((EQ (SETQ NC (NCHARS (SETQ DAT (fetch (LAFITEMSG DATE) of MSG)))) 6) (* ; "The usual case") DAT) (T (OR (SUBSTRING DAT 1 6) (CONCAT DAT (ALLOCSTRING (IDIFFERENCE 6 NC) (CHARCODE SPACE)))))) STREAM) (add TOCLENGTH 6)) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG SUBJECT) of MSG))) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG FROM) of MSG))) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG TO) of MSG))) (replace (LAFITEMSG TOCLENGTH) of MSG with TOCLENGTH) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL))) -) - -(WRITETOCMARKBYTES -(LAMBDA (MSG STREAM) (* bvm%: "20-Feb-84 12:53") (BOUT STREAM (fetch (LAFITEMSG MSGFLAGBITS) of MSG)) (BOUT STREAM (fetch (LAFITEMSG MARKCHAR) of MSG))) -) - -(WRITEFOLDERMARKBYTES -(LAMBDA (MSG MAILFOLDER OUTSTREAM) (* ; "Edited 21-Apr-89 12:41 by bvm") (* ;;; "Write the three magic flag bytes for MSG onto OUTSTREAM. If MAILFOLDER is supplied, then OUTSTREAM is MAILFOLDER's own file, and we will first position OUTSTREAM accordingly--otherwise caller has positioned us properly.") (COND (MAILFOLDER (MAYBEVERIFYMSG MSG MAILFOLDER) (SETFILEPTR OUTSTREAM (fetch (LAFITEMSG BEGIN) of MSG)) (OR (LA.READSTAMP OUTSTREAM) (HELP)) (COND ((fetch (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG) (* ; "Length is different in core and on file. This is for scavenging purposes") (LET ((LENPOS (GETFILEPTR OUTSTREAM)) LEN) (LA.READCOUNT OUTSTREAM T) (* ; "Skip over current length") (SETQ LEN (- (GETFILEPTR OUTSTREAM) LENPOS 1)) (* ; "Number of bytes of length--have to use the same format when overwriting it") (SETFILEPTR OUTSTREAM LENPOS) (LA.PRINTCOUNT (fetch (LAFITEMSG MESSAGELENGTH) of MSG) OUTSTREAM (BQUOTE (FIX (\, LEN) 10 T))) (BIN OUTSTREAM) (* ; "Skip over terminating space")) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG with NIL)) (T (* ; "Just skip over lengths") (LA.READCOUNT OUTSTREAM T) (LA.READCOUNT OUTSTREAM T))))) (BOUT OUTSTREAM (COND ((fetch (LAFITEMSG DELETED?) of MSG) DELETEDFLAG) (T UNDELETEDFLAG))) (BOUT OUTSTREAM (COND ((fetch (LAFITEMSG SEEN?) of MSG) SEENFLAG) (T UNSEENFLAG))) (BOUT OUTSTREAM (fetch (LAFITEMSG MARKCHAR) of MSG)) (if MAILFOLDER then (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL))) -) -) - - - -(* ; "HARDCOPY") - -(DEFINEQ - -(LAFITE.HARDCOPY.MESSAGES -(CL:LAMBDA (FOLDER MESSAGES &OPTIONAL (BATCHFLG NIL BATCHP)) (* ; "Edited 30-Aug-88 14:13 by bvm") (AND MESSAGES (\LAFITE.HARDCOPY.PROC FOLDER NIL NIL (\COERCE.TO.MSGLST MESSAGES) (if BATCHP then BATCHFLG else LAFITEHARDCOPYBATCHFLG)))) -) - -(\LAFITE.HARDCOPY -(LAMBDA (WINDOW FOLDER ITEM MENU) (* ; "Edited 23-Aug-88 15:45 by bvm") (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.HARDCOPY.PROC)) (QUOTE (\, FOLDER)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) NIL (QUOTE (\, LAFITEHARDCOPYBATCHFLG)))) (QUOTE MESSAGEHARDCOPIER))) -) - -(\LAFITE.HARDCOPY.PROC -(LAMBDA (MAILFOLDER ITEM MENU MSGLST BATCHFLG) (* ; "Edited 23-Aug-88 15:37 by bvm") (PROG (LCASEFILENAME TEXTSTREAM) (RESETLST (LA.RESETSHADE ITEM MENU (AND BATCHFLG LAFITEHARDCOPYBATCHSHADE)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((OR MSGLST (NOT (LAB.ASSURE.SELECTIONS MAILFOLDER))) (LET (CONTINUEFLG) (OR MSGLST (SETQ MSGLST (LAB.SELECTED.MESSAGES MAILFOLDER))) (SETQ LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER))) (SETQ TEXTSTREAM (COND ((AND BATCHFLG (SETQ CONTINUEFLG (fetch (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER)))) ((AND (NOT BATCHFLG) LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) LAFITEHARDCOPY.MIN.TOC)) (\LAFITE.HARDCOPY.HEADERS MAILFOLDER LCASEFILENAME MSGLST)) (T (* ; "Start fresh") (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEHARDCOPYFONT))))) (\LAFITE.HARDCOPY.BODIES MAILFOLDER TEXTSTREAM MSGLST CONTINUEFLG) (COND (BATCHFLG (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYBATCHMARK) (replace (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER with TEXTSTREAM) (replace (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER with (NCONC (fetch (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER) MSGLST)) (SETQ TEXTSTREAM)))))))) (COND (TEXTSTREAM (* ; "Send to printer now...") (\LAFITE.TRANSMIT.HARDCOPY MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME))))) -) - -(\LAFITE.HARDCOPY.HEADERS -(LAMBDA (MAILFOLDER LCASEFILENAME MESSAGES INCLUDE# TEXTSTREAM) (* ; "Edited 3-Jun-88 17:50 by bvm") (PROG ((OUTPUTFILE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW))) TITLELEN TITLE TOCSTART TOCLEN FROMSTR SUBJLEFT DATELEFT TABSTOPS) (LINELENGTH MAX.SMALLP OUTPUTFILE) (for MSG in MESSAGES as N from 1 do (* ;; "Each line consists of [#.]datefromsubject") (OR (fetch (LAFITEMSG PARSED?) of MSG) (LAFITE.PARSE.MSG.FOR.TOC MSG MAILFOLDER)) (POSITION OUTPUTFILE 0) (COND (INCLUDE# (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (CL:FORMAT OUTPUTFILE "~D." N) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)))) (PRIN3 (OR (fetch (LAFITEMSG DATE) of MSG) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (PRIN3 (OR (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (PRIN3 "To: " OUTPUTFILE) (OR (fetch (LAFITEMSG TO) of MSG) (LAFITE.FETCH.TO.FIELD MSG MAILFOLDER))) (T (fetch (LAFITEMSG FROM) of MSG))) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (PRIN3 (OR (fetch (LAFITEMSG SUBJECT) of MSG) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (TERPRI OUTPUTFILE)) (SETQ OUTPUTFILE (OPENSTREAM (CLOSEF OUTPUTFILE) (QUOTE INPUT))) (SETQ TITLE (CL:FORMAT NIL "Messages from ~A~%%Listed on ~A~%%~%%" LCASEFILENAME (DATE))) (SETQ TITLELEN (NCHARS TITLE)) (COND (TEXTSTREAM (* ; "Need to insert all this stuff at beginning of textstream") (TEDIT.INSERT TEXTSTREAM TITLE 1)) (T (SETQ TEXTSTREAM (OPENTEXTSTREAM TITLE (AND NIL (CREATEW NIL "Lafite headers")) NIL NIL (LIST (QUOTE FONT) LAFITEHARDCOPYFONT))))) (PROGN (* ; "Make title centered") (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (QUAD CENTERED)) 1 (SUB1 TITLELEN)) (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (POSTPARALEADING 30)) (- TITLELEN 4) 1)) (PROGN (* ; "Insert toc lines. ") (SETQ TOCLEN (LA.TEDIT.INCLUDE TEXTSTREAM OUTPUTFILE (SETQ TOCSTART (ADD1 TITLELEN)))) (TEDIT.INSERT TEXTSTREAM (CONSTANT (CONCATCODES (CHARCODE (FF)))) (+ TOCSTART TOCLEN))) (* ; "Formfeed after the insertion") (PROGN (* ; "Now give the toc lines the appropriate tab settings.") (SETQ DATELEFT (COND (INCLUDE# 30) (T 0))) (SETQ TABSTOPS (LIST (CONS (+ DATELEFT 50) (QUOTE LEFT)) (CONS (SETQ SUBJLEFT (+ DATELEFT 170)) (QUOTE LEFT)))) (COND (INCLUDE# (push TABSTOPS (QUOTE (20 . RIGHT)) (CONS DATELEFT (QUOTE LEFT))))) (TEDIT.PARALOOKS TEXTSTREAM (BQUOTE (TABS (NIL (\,@ TABSTOPS)) LEFTMARGIN (\, (+ SUBJLEFT 20)))) TOCSTART (SUB1 TOCLEN))) (RETURN TEXTSTREAM))) -) - -(\LAFITE.MARK.HARDCOPIED -(LAMBDA (MAILFOLDER MSGS MARK) (* bvm%: "26-Feb-86 12:34") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (LASTMSG (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) N) (COND (MESSAGES (* ; "If not, folder has been closed") (for MSG in MSGS when (AND (ILEQ (SETQ N (fetch (LAFITEMSG %#) of MSG)) LASTMSG) (EQ MSG (NTHMESSAGE MESSAGES N)) (SELCHARQ (fetch (LAFITEMSG MARKCHAR) of MSG) ((? SPACE H) T) NIL)) do (* ; "If message doesn't already have a more interesting mark, set the hardcopy mark") (MARKMESSAGE MSG MAILFOLDER MARK))))))) -) - -(\LAFITE.TRANSMIT.HARDCOPY -(LAMBDA (MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME) (* bvm%: " 2-Mar-84 13:32") (* ;;; "Sends TEXTSTREAM off to be hardcopied, then deletes it") (WITH.MONITOR \LAFITE.HARDCOPYLOCK (* ; "Because press isn't reentrant yet") (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (CONCAT (COND ((CDR MSGLST) (CONCAT (LENGTH MSGLST) " messages")) (T (CONCAT "Message #" (fetch (LAFITEMSG %#) of (CAR MSGLST))))) " from " (OR LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER)))))) (CLOSEF TEXTSTREAM) (DELFILE TEXTSTREAM) (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYMARK)) -) - -(\LAFITE.HARDCOPY.BODIES -(LAMBDA (MAILFOLDER TEXTSTREAM MESSAGES CONTINUEFLG NEXTMSG#) (* ; "Edited 23-Aug-88 12:50 by bvm") (for MSGDESCRIPTOR in MESSAGES bind (NTHTIME _ CONTINUEFLG) (INPUTFILE _ (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT)) do (COND ((NULL NTHTIME) (SETQ NTHTIME T)) ((OR LAFITENEWPAGEFLG CONTINUEFLG) (\OUTCHAR TEXTSTREAM (CHARCODE FF)) (SETQ CONTINUEFLG)) (T (TERPRI TEXTSTREAM) (COND ((NOT NEXTMSG#) (PRIN3 LAFITEHARDCOPYSEPARATOR TEXTSTREAM) (TERPRI TEXTSTREAM))))) (COND (NEXTMSG# (CL:FORMAT TEXTSTREAM "Message ~D~%%~%%" NEXTMSG#) (add NEXTMSG# 1))) (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM INPUTFILE MSGDESCRIPTOR \LAPARSE.DONT.HARDCOPY.HEADERS) (TEDIT.CARETLOOKS TEXTSTREAM LAFITEHARDCOPYFONT))) -) - -(\LAFITE.APPEND.MESSAGE.BODY -(LAMBDA (TEXTSTREAM MSGSTREAM MSGDESCRIPTOR FILTERS) (* ; "Edited 5-Aug-93 20:20 by bvm") (* ;; "Appends the text of the indicated message to TEXTSTREAM, filtering out any header fields found in FILTERS") (LET ((START (fetch (LAFITEMSG START) of MSGDESCRIPTOR)) (END (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) (EOF (GETEOFPTR TEXTSTREAM)) FILTERED) (if FILTERS then (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER MSGSTREAM FILTERS START END))) (TEDIT.SETSEL TEXTSTREAM (ADD1 EOF) 0 (QUOTE LEFT)) (* ; "Get selection right for TEDIT.INCLUDE") (TEDIT.INCLUDE TEXTSTREAM MSGSTREAM START END) (if FILTERED then (if (NOT (= (GETEOFPTR TEXTSTREAM) (+ EOF (- END START)))) then (* ; "Rats, we have to recalculate more slowly now, since there could be ns chars in header. TEdit counts them differently than the plain text file does") (SETQ FILTERED (LAFITE.PARSE.HEADER TEXTSTREAM FILTERS EOF))) (for PAIR in FILTERED do (* ; "Note: we are depending on the pairs being in reverse order from the parse, so that the deletions do not affect the char count") (TEDIT.DELETE TEXTSTREAM (+ EOF (- (CAR PAIR) START) 1) (- (CADR PAIR) (CAR PAIR))))) (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETEOFPTR TEXTSTREAM)) 0) (SETFILEPTR TEXTSTREAM -1))) -) - -(\LAFITE.DO.PENDING.HARDCOPY -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") (LET ((TEXTSTREAM (fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER)) (MSGLST (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) (COND (TEXTSTREAM (LAB.PROMPTPRINT FOLDER T "Hardcopying... ") (COND ((AND LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) LAFITEHARDCOPY.MIN.TOC)) (\LAFITE.HARDCOPY.HEADERS FOLDER (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER)) MSGLST NIL TEXTSTREAM))) (\LAFITE.TRANSMIT.HARDCOPY FOLDER TEXTSTREAM MSGLST) (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER) (LAB.PROMPTPRINT FOLDER "done. "))))) -) - -(\LAFITE.CANCEL.HARDCOPY -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") (LET ((PENDING (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) (if (NOT PENDING) then (LAB.PROMPTPRINT FOLDER "No messages are queued for hardcopy") elseif (LAB.MOUSECONFIRM FOLDER "Click LEFT to cancel hardcopy of ~D message~:P" (LENGTH PENDING)) then (for MSG in PENDING do (* ; "Set mark back to space") (MARKMESSAGE MSG FOLDER SEENMARK)) (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER)))) -) - -(\LAFITE.CLEAR.HARDCOPY.STATE -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:28 by bvm") (* ;; "Clear all the places that think there is pending hardcopy") (replace (MAILFOLDER HARDCOPYSTREAM) of FOLDER with (replace (MAILFOLDER HARDCOPYMESSAGES) of FOLDER with NIL)) (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (* ; "Take the speckle off the menu") (SHADEITEM (LA.MENU.ITEM (FUNCTION \LAFITE.HARDCOPY) MENU) MENU WHITESHADE))) -) -) - -(ADDTOVAR LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" (QUOTE \LAFITE.CANCEL.HARDCOPY) "Forget about hardcopying the messages so far marked for hardcopy.")) - -(RPAQ? LAFITEHARDCOPYBATCHFLG NIL) - -(RPAQ? LAFITEHARDCOPY.MIN.TOC NIL) - -(RPAQ? LAFITEDISPLAYAFTERDELETEFLG T) - -(RPAQ? LAFITEMOVETOCONFIRMFLG (QUOTE ALWAYS)) - -(RPAQ? LAFITENEWPAGEFLG T) - -(RPAQ? LAFITEENDOFMESSAGESTR "End of message") - -(RPAQ? LAFITEENDOFMESSAGEFONT (FONTCREATE (QUOTE (TIMESROMAN 10 ITALIC)))) - -(RPAQ? LAFITE.DISPLAY.SIZE (QUOTE (500 . 300))) - -(RPAQ? LAFITE.BROWSER.LAYOUTS NIL) - -(RPAQ? LAFITE.MIDDLE.UPDATE (QUOTE (:EXPUNGE :SHRINK :CONFIRM))) - -(RPAQ? LAFITEHARDCOPYBATCHSHADE 1025) - -(RPAQ? LAFITEHARDCOPYSEPARATOR " - Next Message  -") - - - -(* ; "Obsolete") - - -(RPAQ? LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(FILESLOAD (SOURCE) LAFITEDECLS) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA) - -(ADDTOVAR NLAML) - -(ADDTOVAR LAMA LAFITE.HARDCOPY.MESSAGES) -) -(PUTPROPS LAFITECOMMANDS COPYRIGHT ("Xerox Corporation" 1988 1989 1992 1993)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (5158 14810 (\LAFITE.DISPLAY 5168 . 5990) (\LAFITE.DO.DISPLAY 5992 . 7378) ( -SELECTMESSAGETODISPLAY 7380 . 8693) (MESSAGEDISPLAYER 8695 . 12622) (LA.COPY.MESSAGE.TEXT 12624 . -12973) (\LAFITE.CLOSE.DISPLAYWINDOWS 12975 . 13844) (\LAFITE.CLOSE.DISPLAYER 13846 . 14808)) (14811 -19648 (\LAFITE.UNHIDE.HEADERS 14821 . 15546) (\LAFITE.HIDE.HEADERS 15548 . 15836) ( -\LAFITE.REHIDE.HEADERS 15838 . 16622) (LAFITE.EAT.UNDESIRABLE.FIELD 16624 . 17198) (LAFITE.EAT.GVGV -17200 . 17901) (\LAFITE.HARDCOPY.FROM.DISPLAY 17903 . 19410) (LAFITE.HARDCOPY.TAB.WIDTH 19412 . 19646) -) (19649 24617 (\LAFITE.SET.LOOKS.FROM.MENU 19659 . 19785) (\LAFITE.SET.DEFAULT.LOOKS 19787 . 19928) ( -\LAFITE.SET.FIXED.LOOKS 19930 . 20072) (LAFITE.SET.LOOKS 20074 . 22708) (LAFITE.SET.TAB.LOOKS 22710 . -23140) (LAFITE.SET.PARA.SEPARATION 23142 . 23296) (LAFITE.SET.LOWER.CASE 23298 . 23739) ( -LAFITE.SUBSTITUTE.VP.EOL 23741 . 24615)) (25776 30185 (LAFITE.DELETE.MESSAGES 25786 . 26213) ( -\LAFITE.DELETE 26215 . 26799) (DISPLAYAFTERDELETE 26801 . 29281) (\LAFITE.SELECT.NEXT 29283 . 29774) ( -\LAFITE.UNDELETE 29776 . 30183)) (30207 37726 (LAFITE.MOVE.MESSAGES 30217 . 30685) (\COERCE.TO.MSGLST -30687 . 31153) (\LAFITE.MOVETO 31155 . 33401) (\LAFITE.COPYTO 33403 . 33684) (\LAFITE.MOVETO.PROC -33686 . 34543) (\LAFITE.MOVE.MESSAGES.INTERNAL 34545 . 37724)) (37752 42709 (\LAFITE.ENABLE.MOVE.MENU -37762 . 38520) (\LAFITE.ADD.TO.MOVE.MENU 38522 . 39301) (\LAFITE.UPDATE.MOVE.MENU 39303 . 41607) ( -\LAFITE.RESTORE.MOVE.MENU 41609 . 41983) (\LAFITE.HANDLE.AUTO.MOVE 41985 . 42707)) (43312 52878 ( -\LAFITE.UPDATE 43322 . 45704) (\LAFITE.EXPUNGE.PROC 45706 . 46245) (\LAFITE.UPDATE.PROC 46247 . 46942) - (\LAFITE.HARDCOPYONLY.PROC 46944 . 47309) (LAB.CHOOSE.UPDATE.MENU 47311 . 47894) ( -LAB.CREATE.UPDATE.MENU 47896 . 48987) (LAB.UPDATE.NEEDED? 48989 . 49786) (\LAFITE.START.UPDATE 49788 - . 50419) (LAB.START.COMMAND 50421 . 51084) (\LAFITE.FINISH.UPDATE 51086 . 52298) ( -\LAFITE.CLOSE.OTHER.FOLDERS 52300 . 52876)) (52879 69397 (LAB.FLUSHWINDOW 52889 . 53676) ( -LAB.APPENDMESSAGES 53678 . 55164) (\LAFITE.COMPACT.FOLDER 55166 . 57317) (\LAFITE.COMPACT.FOLDER1 -57319 . 63992) (\LAFITE.COMPACT.FOLDER2 63994 . 66324) (\LAFITE.COMPACT.EXTRA 66326 . 67502) ( -\LAFITE.INVALIDATE.TOC 67504 . 67995) (\LAFITE.RENAMEFILE 67997 . 68400) (SMART-RENAMEFILEP 68402 . -68778) (LA.OPENTEMPFILE 68780 . 69395)) (69398 77196 (\LAFITE.UPDATE.FOLDER 69408 . 70575) ( -\LAFITE.UPDATE.CONTENTS 70577 . 71217) (\LAFITE.UPDATE.CONTENTS1 71219 . 73772) (WRITETOCENTRY 73774 - . 75528) (WRITETOCMARKBYTES 75530 . 75707) (WRITEFOLDERMARKBYTES 75709 . 77194)) (77222 86388 ( -LAFITE.HARDCOPY.MESSAGES 77232 . 77500) (\LAFITE.HARDCOPY 77502 . 77787) (\LAFITE.HARDCOPY.PROC 77789 - . 79174) (\LAFITE.HARDCOPY.HEADERS 79176 . 81620) (\LAFITE.MARK.HARDCOPIED 81622 . 82270) ( -\LAFITE.TRANSMIT.HARDCOPY 82272 . 82882) (\LAFITE.HARDCOPY.BODIES 82884 . 83621) ( -\LAFITE.APPEND.MESSAGE.BODY 83623 . 84871) (\LAFITE.DO.PENDING.HARDCOPY 84873 . 85470) ( -\LAFITE.CANCEL.HARDCOPY 85472 . 85942) (\LAFITE.CLEAR.HARDCOPY.STATE 85944 . 86386))))) -STOP diff --git a/library/lafite/LAFITECOMMANDS.~2~ b/library/lafite/LAFITECOMMANDS.~2~ deleted file mode 100644 index ee1ebbac..00000000 --- a/library/lafite/LAFITECOMMANDS.~2~ +++ /dev/null @@ -1,152 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Jun-99 10:23:32" {DSK}medley3.5>library>LAFITECOMMANDS.;4 98281 changes to%: (FNS \LAFITE.DO.DISPLAY) previous date%: "27-Jun-99 22:47:32" {DSK}medley3.5>library>LAFITECOMMANDS.;3) (* ; " Copyright (c) 1988, 1989, 1992, 1993, 1999 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITECOMMANDSCOMS) (RPAQQ LAFITECOMMANDSCOMS [ (* ;; "Handling of the main Lafite browser commands") (COMS (* ; "DISPLAY") (FNS \LAFITE.DISPLAY \LAFITE.DO.DISPLAY SELECTMESSAGETODISPLAY MESSAGEDISPLAYER LA.COPY.MESSAGE.TEXT \LAFITE.CLOSE.DISPLAYWINDOWS \LAFITE.CLOSE.DISPLAYER) (FNS \LAFITE.UNHIDE.HEADERS \LAFITE.HIDE.HEADERS \LAFITE.REHIDE.HEADERS LAFITE.EAT.UNDESIRABLE.FIELD LAFITE.EAT.GVGV \LAFITE.HARDCOPY.FROM.DISPLAY LAFITE.HARDCOPY.TAB.WIDTH) (FNS \LAFITE.SET.LOOKS.FROM.MENU \LAFITE.SET.DEFAULT.LOOKS \LAFITE.SET.FIXED.LOOKS LAFITE.SET.LOOKS LAFITE.SET.TAB.LOOKS LAFITE.SET.PARA.SEPARATION LAFITE.SET.LOWER.CASE LAFITE.SUBSTITUTE.VP.EOL) (INITVARS \LAFITE.DISPLAY.COMMANDS) (ADDVARS [LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" '\LAFITE.SET.LOOKS.FROM.MENU "Change the appearance of the selected text, or whole message if nothing selected" ) ("Hardcopy" '\LAFITE.HARDCOPY.FROM.DISPLAY "Hardcopy this message in its current appearance") ("Unhide" '\LAFITE.UNHIDE.HEADERS "Display the header fields that are hidden from view." (SUBITEMS ("Hide" '\LAFITE.REHIDE.HEADERS "Hide uninteresting fields from view again"] (LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" 'LAFITE.SUBSTITUTE.VP.EOL "Replace the Viewpoint end of line character with ours." ) ("Lowercase" 'LAFITE.SET.LOWER.CASE "Lowercase the region or whole message.") ("Spread Paragraphs" 'LAFITE.SET.PARA.SEPARATION "Separate paragraphs by 10 points (useful for Tioga messages).") ("Default" '\LAFITE.SET.DEFAULT.LOOKS "Change selection (or whole text) back to default font") ("Fixed Width" '\LAFITE.SET.FIXED.LOOKS "Change selection (or whole text) to fixed-width font"))) (GLOBALVARS \LAFITE.DISPLAY.COMMANDS)) (COMS (* ; "DELETE") (FNS LAFITE.DELETE.MESSAGES \LAFITE.DELETE DISPLAYAFTERDELETE \LAFITE.SELECT.NEXT \LAFITE.UNDELETE)) (COMS (* ; "MOVE") (FNS LAFITE.MOVE.MESSAGES \COERCE.TO.MSGLST \LAFITE.MOVETO \LAFITE.COPYTO \LAFITE.MOVETO.PROC \LAFITE.MOVE.MESSAGES.INTERNAL) (* ; "Aux move") (FNS \LAFITE.ENABLE.MOVE.MENU \LAFITE.ADD.TO.MOVE.MENU \LAFITE.UPDATE.MOVE.MENU \LAFITE.RESTORE.MOVE.MENU \LAFITE.HANDLE.AUTO.MOVE) (ADDVARS (LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" '\LAFITE.ENABLE.MOVE.MENU "Attach a menu of folders for accelerated MoveTo (or modify existing one)" (SUBITEMS ("Restore MoveTo Menu" '\LAFITE.RESTORE.MOVE.MENU "Just reopen the attached MoveTo menu if it existed." ))) ("Copy To" '\LAFITE.COPYTO "Like MoveTo, but don't delete the message(s).")) (LAFITE.EXTRA.MOVE.ITEMS ("---Display---" '\LAFITE.DISPLAY "Display the next message") ("---Delete---" '\LAFITE.DELETE "Delete the selected message(s)"))) (INITVARS (LAFITE.AUTO.MOVE.MENU))) (COMS (* ; "UPDATE") (FNS \LAFITE.UPDATE \LAFITE.EXPUNGE.PROC \LAFITE.UPDATE.PROC \LAFITE.HARDCOPYONLY.PROC LAB.CHOOSE.UPDATE.MENU LAB.CREATE.UPDATE.MENU LAB.UPDATE.NEEDED? \LAFITE.START.UPDATE LAB.START.COMMAND \LAFITE.FINISH.UPDATE \LAFITE.CLOSE.OTHER.FOLDERS) (FNS LAB.FLUSHWINDOW LAB.APPENDMESSAGES \LAFITE.COMPACT.FOLDER \LAFITE.COMPACT.FOLDER1 \LAFITE.COMPACT.FOLDER2 \LAFITE.COMPACT.EXTRA \LAFITE.INVALIDATE.TOC \LAFITE.RENAMEFILE SMART-RENAMEFILEP LA.OPENTEMPFILE) (FNS \LAFITE.UPDATE.FOLDER \LAFITE.UPDATE.CONTENTS \LAFITE.UPDATE.CONTENTS1 WRITETOCENTRY WRITETOCMARKBYTES WRITEFOLDERMARKBYTES)) [COMS (* ; "HARDCOPY") (FNS LAFITE.HARDCOPY.MESSAGES \LAFITE.HARDCOPY \LAFITE.HARDCOPY.PROC \LAFITE.HARDCOPY.HEADERS \LAFITE.MARK.HARDCOPIED \LAFITE.TRANSMIT.HARDCOPY \LAFITE.HARDCOPY.BODIES \LAFITE.APPEND.MESSAGE.BODY \LAFITE.DO.PENDING.HARDCOPY \LAFITE.CANCEL.HARDCOPY \LAFITE.CLEAR.HARDCOPY.STATE) (ADDVARS (LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" '\LAFITE.CANCEL.HARDCOPY "Forget about hardcopying the messages so far marked for hardcopy." ] [COMS (INITVARS (LAFITEHARDCOPYBATCHFLG NIL) (LAFITEHARDCOPY.MIN.TOC NIL) (LAFITEDISPLAYAFTERDELETEFLG T) (LAFITEMOVETOCONFIRMFLG 'ALWAYS) (LAFITENEWPAGEFLG T) (LAFITEENDOFMESSAGESTR "End of message") [LAFITEENDOFMESSAGEFONT (FONTCREATE '(TIMESROMAN 10 ITALIC] (LAFITE.DISPLAY.SIZE '(500 . 300)) (LAFITE.BROWSER.LAYOUTS NIL) (LAFITE.MIDDLE.UPDATE '(:EXPUNGE :SHRINK :CONFIRM)) (LAFITEHARDCOPYBATCHSHADE 1025) (LAFITEHARDCOPYSEPARATOR "% - Next Message % -")) (COMS (* ; "Obsolete") (INITVARS (LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335] (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA LAFITE.HARDCOPY.MESSAGES ]) (* ;; "Handling of the main Lafite browser commands") (* ; "DISPLAY") (DEFINEQ (\LAFITE.DISPLAY -(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* ; "Edited 22-Sep-87 14:56 by bvm:") (PROG (DISPLAYWINDOW) (COND ((WINDOWP (SETQ DISPLAYWINDOW (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (LET ((MSGDESCRIPTOR (SELECTMESSAGETODISPLAY WINDOW MAILFOLDER)) W) (COND (MSGDESCRIPTOR (\LAFITE.DO.DISPLAY MAILFOLDER MSGDESCRIPTOR (EQ KEY (QUOTE MIDDLE)))) (T (LAB.PROMPTPRINT MAILFOLDER T "No more messages.") (* ; "But return current display window for topping, just in case it was buried") (CAR (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)))))))))) (* ; "make sure the display window is on top in case SHADEITEM put the browser back on top") (TOTOPW DISPLAYWINDOW))))) -) (\LAFITE.DO.DISPLAY [LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 28-Jun-99 10:22 by rmk:") (* ; "Edited 27-Jun-99 22:44 by rmk:") (* ; "Edited 25-Jun-99 19:05 by rmk:") (* ; "Edited 25-Jun-99 18:31 by rmk:") (* ; "Edited 13-Oct-87 15:56 by bvm:") (* ;;; "Display MSGDESCRIPTOR from MAILFOLDER, using a new window if NEWWINDOWFLG is true, else reusing if possible the primary window. Returns the window.") (* ;;; "") (* ;;; "rmk, 6/99. I modified the interface to LA.COPY.MESSAGE.TEXT to make it easier to replace that function with something that deals with MIME attachments. I moved the MAYBEVERIFYMSG up to this level to eliminate a compile-time dependency on that macro, and this required moving the \LAFITE.OPEN.FOLDER as well. That call is harmlessly repeated in LA.COPY.MESSAGE.TEXT") (PROG (TEMPMSG DISPLAYWINDOW) (LAB.EXPOSEMESSAGE MAILFOLDER MSGDESCRIPTOR) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with NIL) (* ; "Clear it here in case of abort") (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT) (MAYBEVERIFYMSG MSGDESCRIPTOR MAILFOLDER) (SETQ TEMPMSG (LA.COPY.MESSAGE.TEXT MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG)) (SETQ DISPLAYWINDOW (MESSAGEDISPLAYER MAILFOLDER TEMPMSG (CONCAT "Message " (fetch (LAFITEMSG %#) of MSGDESCRIPTOR ) " from " (fetch (MAILFOLDER FULLFOLDERNAME ) of MAILFOLDER) " [" (fetch (LAFITEMSG MESSAGELENGTH ) of MSGDESCRIPTOR ) " chars]") NEWWINDOWFLG)) (SEENMESSAGE MSGDESCRIPTOR MAILFOLDER) (PROGN (* ; "Cache the stream that we copied the message text to, since we might be able to use it to accelerate a Move or Hardcopy. Unfortunately, we can't take advantage of it now, since NODIRCORE doesn't support multiple streams per file.") (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of MAILFOLDER with TEMPMSG) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER with MSGDESCRIPTOR )) (RETURN DISPLAYWINDOW]) (SELECTMESSAGETODISPLAY -(LAMBDA (WINDOW MAILFOLDER) (* bvm%: " 1-Mar-86 18:19") (* ;;; "Laurel acts differently if there is currently only one message selected or many about whether it unselects the one that was displayed before. Lafite will follow the same model") (LET ((CURRENTDISPLAYEDMSG (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) DISPLAYED# MSGDESCRIPTOR) (COND ((IGREATERP FIRST# LAST#) (* ; "Nothing selected, so nothing to display") NIL) ((OR (NULL CURRENTDISPLAYEDMSG) (NOT (fetch (LAFITEMSG SELECTED?) of CURRENTDISPLAYEDMSG))) (* ; "haven't displayed any yet, or displayed one is not part of the selection") (NTHMESSAGE MESSAGES FIRST#)) ((EQ FIRST# LAST#) (* ; "Only one msg selected and it is displayed, so move on to next undeleted msg") (\LAFITE.SELECT.NEXT MAILFOLDER (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG))) (T (* ; "Multiple selections -- Cycle to the next one") (NTHMESSAGE MESSAGES (COND ((EQ (SETQ DISPLAYED# (fetch (LAFITEMSG %#) of CURRENTDISPLAYEDMSG)) LAST#) (* ; "Cycle back to first") FIRST#) (T (LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 DISPLAYED#) LAST#)))))))) -) (MESSAGEDISPLAYER [LAMBDA (MAILFOLDER TEXTFILE TITLE NEWWINDOWFLG) (* ; "Edited 24-Jun-99 15:34 by rmk:") (* ; "Edited 24-Jun-99 15:32 by rmk:") (* ; "Edited 24-Jun-99 15:32 by rmk:") (* ; "Edited 6-Aug-93 18:48 by bvm") (* ;;; "Displayer for individual messages") (LET ((CURRENTWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER)) [PROPS `(FONT ,LAFITEDISPLAYFONT] (WINDOWPROPS '(READONLY T PROMPTWINDOW DON'T)) (EOF (GETEOFPTR TEXTFILE)) TEXTSTREAM DISPLAYWINDOW FILTERED) (* ;; "WINDOWPROPS for when we finally give TEdit a window: READONLY in order to avoid TEdit's odd temptation to display an ugly caret at the start and prevent mouse actions from yielding %"NewEditProcess%" menu; PROMPTWINDOW to inhibit attaching a prompt window. Due to a TEdit bug, you can't give the PROMPTWINDOW prop when opening without a window or it will try to make the symbol DON'T be the promptwindow later on.") (if (AND \LAPARSE.DONT.DISPLAY.HEADERS (NEQ EOF 0) (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTFILE \LAPARSE.DONT.DISPLAY.HEADERS 0))) then (* ;  "We will filter some headers out, so put * in title to show this") (SETQ TITLE (CONCAT "*" TITLE))) [COND ((AND (NOT NEWWINDOWFLG) (SETQ DISPLAYWINDOW (CAR CURRENTWINDOWS))) (MAPC (WINDOWPROP DISPLAYWINDOW 'EXTRAWINDOWS NIL) (FUNCTION CLOSEW)) (* ;  "Get rid of extra windows produced by attachments") (CLEARW DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'TITLE TITLE)) (T (SETQ DISPLAYWINDOW (CREATEW (COND [(AND (NOT NEWWINDOWFLG) (PROGN (* ;  "This says where we'd like the primary window to be.") (fetch (MAILFOLDER FOLDERDISPLAYREGION) of MAILFOLDER] (LAFITE.DISPLAY.SIZE (* ; "Global default") (GETBOXREGION (CAR LAFITE.DISPLAY.SIZE) (CDR LAFITE.DISPLAY.SIZE) NIL NIL NIL TITLE))) TITLE)) (WINDOWADDPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION \LAFITE.CLOSE.DISPLAYER)) (WINDOWPROP DISPLAYWINDOW 'TEDIT.MENU.COMMANDS \LAFITE.DISPLAY.COMMANDS) (COND [(NOT CURRENTWINDOWS) (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of MAILFOLDER with (if NEWWINDOWFLG then (* ;  "not primary, even though no window previously open") (LIST NIL DISPLAYWINDOW) else (LIST DISPLAYWINDOW] [NEWWINDOWFLG (RPLACD CURRENTWINDOWS (CONS DISPLAYWINDOW (CDR CURRENTWINDOWS] (T (* ;  "DIsplaying the primary window for the first time when there are already secondary windows.") (RPLACA CURRENTWINDOWS DISPLAYWINDOW] (* ; "Now let TEDIT display it") [COND ((EQ EOF 0) (LAB.PROMPTPRINT MAILFOLDER "Message is empty")) (T [LET (WINDOW) (if (NOT FILTERED) then (* ;  "Go ahead and display it right off. ") (SETQ PROPS (NCONC PROPS WINDOWPROPS)) (SETQ WINDOW DISPLAYWINDOW)) (SETQ TEXTSTREAM (OR (CAR (NLSETQ (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL PROPS)) ) (PROGN (LAB.PROMPTPRINT MAILFOLDER T "Problems displaying message, trying unformatted." ) (OPENTEXTSTREAM TEXTFILE WINDOW NIL NIL (LIST* 'CLEARGET T PROPS] (if FILTERED then (if (NOT (= EOF (GETEOFPTR TEXTSTREAM))) then (* ;  "rats, there may have been nschars in the header, so parse it now more carefully") (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER TEXTSTREAM \LAPARSE.DONT.DISPLAY.HEADERS 0))) (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) (* ;  "Now we can display it without a major glitch") (OPENTEXTSTREAM TEXTSTREAM DISPLAYWINDOW NIL NIL WINDOWPROPS) (TEXTPROP TEXTSTREAM 'FILTERED FILTERED) (* ;  "Remember what's invisible, so we can easily undo it") ) (COND (LAFITEENDOFMESSAGESTR (* ;  "Add %"End of message%" token. Have to take away READONLY for a moment here...") (TEXTPROP TEXTSTREAM 'READONLY NIL) [SETFILEPTR TEXTSTREAM (SUB1 (SETQ EOF (GETEOFPTR TEXTSTREAM] (COND ((NEQ (BIN TEXTSTREAM) (CHARCODE CR)) (* ;  "Message doesn't end in CR, so add one before inserting end of message str") (TEDIT.INSERT TEXTSTREAM LAFITEEOL (ADD1 (add EOF 1)) NIL T))) (TEDIT.INSERT TEXTSTREAM LAFITEENDOFMESSAGESTR (ADD1 EOF) LAFITEENDOFMESSAGEFONT T) (TEXTPROP TEXTSTREAM 'READONLY T) (TEDIT.SETSEL TEXTSTREAM 1 0) (\CARET.DOWN) (* ; "Patch around TEdit bug") ] DISPLAYWINDOW]) (LA.COPY.MESSAGE.TEXT [LAMBDA (MAILFOLDER MSGDESCRIPTOR NEWWINDOWFLG) (* ; "Edited 27-Jun-99 22:47 by rmk:") (* ; "Edited 27-Jun-99 22:44 by rmk:") (* ; "Edited 25-Jun-99 18:30 by rmk:") (LET (OUTPUTSTREAM (INSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER 'INPUT :ABORT))) (SETQ OUTPUTSTREAM (OPENSTREAM '{NODIRCORE} 'BOTH)) (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of MSGDESCRIPTOR) (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) (CLOSEF OUTPUTSTREAM) (OPENSTREAM OUTPUTSTREAM 'INPUT NIL '((ENDOFSTREAMOP \LAFITE.EOF]) (\LAFITE.CLOSE.DISPLAYWINDOWS -(LAMBDA (FOLDER) (* ; "Edited 22-Sep-87 15:36 by bvm:") (* ;; "Called when browser closed, to close associated windows.") (PROG ((WINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER)) W) (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (COND (WINDOWS (for WINDOW in (CDR WINDOWS) do (* ; "Leave secondary windows open, but disconnect them from browser") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER))) (COND ((WINDOWP (SETQ W (CAR WINDOWS))) (* ; "Save region for later") (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (APPEND (WINDOWPROP W (QUOTE REGION)))) (WINDOWDELPROP W (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSE.DISPLAYER)) (CLOSEW W))) (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL))))) -) (\LAFITE.CLOSE.DISPLAYER -(LAMBDA (WINDOW) (* ; "Edited 16-Aug-89 11:27 by bvm") (* ;; "called via CLOSEFN when a display window is explicitly closed") (MAPC (WINDOWPROP WINDOW (QUOTE EXTRAWINDOWS) NIL) (FUNCTION CLOSEW)) (for FOLDER in \ACTIVELAFITEFOLDERS bind THESEWINDOWS when (MEMB WINDOW (SETQ THESEWINDOWS (fetch (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER))) do (* ; "Do we need a monitorlock here?") (replace (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER with NIL) (replace (MAILFOLDER CURRENTDISPLAYEDSTREAM) of FOLDER with NIL) (if (EQ WINDOW (CAR THESEWINDOWS)) then (* ; "the main window--keep its region") (replace (MAILFOLDER FOLDERDISPLAYREGION) of FOLDER with (APPEND (WINDOWPROP WINDOW (QUOTE REGION)))) (if (CDR THESEWINDOWS) then (RPLACA THESEWINDOWS NIL) else (replace (MAILFOLDER FOLDERDISPLAYWINDOWS) of FOLDER with NIL)) else (* ; "floating window, just remove") (RPLACD THESEWINDOWS (DREMOVE WINDOW (CDR THESEWINDOWS)))) (RETURN))) -) ) (DEFINEQ (\LAFITE.UNHIDE.HEADERS -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:48 by bvm:") (LET ((FILTERED (TEXTPROP TEXTSTREAM (QUOTE FILTERED))) START W) (if (OR (NULL FILTERED) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE))) then (PROMPTPRINT "The whole message is already displayed") else (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE OFF)) (ADD1 (SETQ START (CAAR (LAST FILTERED)))) (- (CADAR FILTERED) START)) (TEDIT.SETSEL TEXTSTREAM 1 0) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE) T) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) then (* ; "Remove the * from the title.") (WINDOWPROP W (QUOTE TITLE) (SUBSTRING (WINDOWPROP W (QUOTE TITLE)) 2)))))) -) (\LAFITE.HIDE.HEADERS -(LAMBDA (TEXTSTREAM FILTERED) (* ; "Edited 10-Dec-87 19:44 by bvm:") (for PAIR in FILTERED do (* ; "Make each filtered field invisible") (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE ON)) (+ (CAR PAIR) 1) (- (CADR PAIR) (CAR PAIR)))) (TEDIT.SETSEL TEXTSTREAM 1 0)) -) (\LAFITE.REHIDE.HEADERS -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Dec-87 19:44 by bvm:") (* ;; "Called from display window menu to hide the headers again after having them unhidden.") (LET ((FILTERED (TEXTPROP TEXTSTREAM (QUOTE FILTERED))) START W) (if (NULL FILTERED) then (PROMPTPRINT "No uninteresting header fields were found") elseif (NOT (TEXTPROP TEXTSTREAM (QUOTE VISIBLE))) then (PROMPTPRINT "Uninteresting headers are already hidden") else (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (\LAFITE.HIDE.HEADERS TEXTSTREAM FILTERED) (TEXTPROP TEXTSTREAM (QUOTE VISIBLE) NIL) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if (SETQ W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM)) then (* ; "Add * back to the title.") (WINDOWPROP W (QUOTE TITLE) (CONCAT "*" (WINDOWPROP W (QUOTE TITLE)))))))) -) (LAFITE.EAT.UNDESIRABLE.FIELD -(LAMBDA (STREAM IGNORE) (* ; "Edited 23-Sep-87 13:12 by bvm:") (* ;; "Parser function called when a field to be filtered is found--skip over the field, and push onto the result a pair giving (start stop) of the whole field.") (DECLARE (USEDFREE PARSERESULT PARSEBEGIN)) (* ; "bound in parser") (LA.SKIP.TO.EOL STREAM) (if (AND PARSERESULT (= PARSEBEGIN (CADR (CAR PARSERESULT)))) then (* ; "two in a row--combine them") (CL:SETF (CADR (CAR PARSERESULT)) (GETFILEPTR STREAM)) else (push PARSERESULT (LIST PARSEBEGIN (GETFILEPTR STREAM))))) -) (LAFITE.EAT.GVGV -(LAMBDA (STREAM) (* ; "Edited 6-Feb-89 14:18 by bvm") (DECLARE (USEDFREE PARSERESULT)) (* ;; "Called when we get to the CR at the end of the header. Now look for a section of thext beginning and ending in lines of the form GVGVGVGV...") (LET ((HERE (GETFILEPTR STREAM)) GVSTART GVEND) (if (AND (EQ (SKIPSEPRCODES STREAM) (CHARCODE G)) (PROGN (SETQ GVSTART (GETFILEPTR STREAM)) (bind CH until (EQ (SETQ CH (BIN STREAM)) (CHARCODE EOL)) always (OR (EQ CH (CHARCODE G)) (EQ CH (CHARCODE V))))) (SETQ GVEND (FFILEPOS "GVGVGV - -" STREAM NIL NIL NIL T))) then (push PARSERESULT (LIST GVSTART GVEND))) (SETFILEPTR STREAM HERE) (* ; "Return STOP to tell parser to stop") (QUOTE STOP))) -) (\LAFITE.HARDCOPY.FROM.DISPLAY -(LAMBDA (TEXTSTREAM) (* ; "Edited 10-Jun-88 18:36 by bvm") (* ;; "Hardcopy command on title bar of message display -- like window hardcopy, but gets the title right and omits the end of message string.") (RESETLST (if LAFITEENDOFMESSAGESTR then (* ; "Hide end of message") (LET ((LEN (GETEOFPTR TEXTSTREAM)) (NC (NCHARS LAFITEENDOFMESSAGESTR)) (FIXEDLOOKS (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS)))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (TEXTSTREAM LEN NC FIXEDLOOKS) (LET ((W (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) (if (AND W (OPENWP W) (EQ (WINDOWPROP W (QUOTE TEXTSTREAM)) TEXTSTREAM)) then (* ; "Don't screw around if the message isn't in the window anymore") (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE OFF)) (ADD1 (- LEN NC)) NC) (TEDIT.SETSEL TEXTSTREAM 1 0) (TEXTPROP TEXTSTREAM (QUOTE READONLY) T) (if FIXEDLOOKS then (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS (TIMES 8 (CHARWIDTH (CHARCODE X) LAFITEFIXEDWIDTHFONT)))))))) TEXTSTREAM LEN NC FIXEDLOOKS)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (TEDIT.LOOKS TEXTSTREAM (QUOTE (INVISIBLE ON)) (ADD1 (- LEN NC)) NC) (if FIXEDLOOKS then (* ; "Change to the hardcopy tab width") (LAFITE.SET.TAB.LOOKS TEXTSTREAM FIXEDLOOKS (LAFITE.HARDCOPY.TAB.WIDTH))))) (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (LET ((TMP (LA.WINDOW.FROM.TEXTSTREAM TEXTSTREAM))) (AND TMP (SETQ TMP (WINDOWPROP TMP (QUOTE TITLE))) (if (EQ (CHCON1 TMP) (CHARCODE *)) then (* ; "Remove the * that says filtered") (SUBSTRING TMP 2) else TMP)))))) -) (LAFITE.HARDCOPY.TAB.WIDTH -(LAMBDA NIL (* ; "Edited 10-Jun-88 18:27 by bvm") (FIXR (TIMES (FQUOTIENT (CHARWIDTH (CHARCODE X) (FONTCOPY LAFITEFIXEDWIDTHFONT (QUOTE DEVICE) (QUOTE INTERPRESS))) (CONSTANT (FQUOTIENT 2540 72))) 8))) -) ) (DEFINEQ (\LAFITE.SET.LOOKS.FROM.MENU -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM T))) (\LAFITE.SET.DEFAULT.LOOKS -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:33 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM LAFITEDISPLAYFONT)) -) (\LAFITE.SET.FIXED.LOOKS -(LAMBDA (TEXTSTREAM) (* ; "Edited 22-Sep-87 12:43 by bvm:") (LAFITE.SET.LOOKS TEXTSTREAM LAFITEFIXEDWIDTHFONT)) -) (LAFITE.SET.LOOKS -(LAMBDA (TEXTSTREAM NEWLOOKS PARALOOKS OMITHEADER USERFN) (* ; "Edited 3-Nov-89 14:50 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Change the looks of the current selection (if there is an interesting one) or the whole message to be NEWLOOKS. If NEWLOOKS is T, we use TEdit's menu interface. PARALOOKS is for paragraph formatting. USERFN is arbitrary function called with arg textstream & selection set appropriately. Any of NEWLOOKS, PARALOOKS, USERFN can be NIL. If OMITHEADER is true, the header is left out of the modification if user has not selected a region of text already.") (RESETLST (RESETSAVE NIL (LIST (QUOTE TEXTPROP) TEXTSTREAM (QUOTE READONLY) T)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (LET ((SEL (TEDIT.GETSEL TEXTSTREAM)) START LEN WIDTH FIXEDLOOKS) (if (AND (NOT PARALOOKS) (FONTP NEWLOOKS) (EQ (SETQ WIDTH (CHARWIDTH (CHARCODE "i") NEWLOOKS)) (CHARWIDTH (CHARCODE "W") NEWLOOKS))) then (* ; "If font is fixed-width, let's make the tab the right width. Might be nice to restore default tab if it's not fixed-width, but TEdit apparently doesn't support that.") (SETQ FIXEDLOOKS (SETQ PARALOOKS (BQUOTE (TABS ((\, (TIMES WIDTH 8)))))))) (if (> (SETQ LEN (fetch (SELECTION DCH) of SEL)) 1) then (* ; "User has already selected something. Assume any selection greater than a single character is not accidental.") (if (AND FIXEDLOOKS (NEQ (SETQ FIXEDLOOKS (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS))) T)) then (* ;; "Record the portions we have so marked, so hardcopy can work right--T means everything. If FIXEDLOOKS is false, might want to unset, but that's tedious, unlikely to be worth the hairy code") (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS) (CONS (CONS (fetch (SELECTION CH#) of SEL) LEN) FIXEDLOOKS))) else (SETQ START (if OMITHEADER then (* ; "Start after the blank line following the header") (\LAFITE.HEADER.EOF TEXTSTREAM) else 0)) (SETQ LEN (- (GETEOFPTR TEXTSTREAM) (if LAFITEENDOFMESSAGESTR then (NCHARS LAFITEENDOFMESSAGESTR) else 0) START)) (TEDIT.SETSEL TEXTSTREAM (ADD1 START) LEN (QUOTE RIGHT)) (if FIXEDLOOKS then (* ; "The whole thing is fixed now") (TEXTPROP TEXTSTREAM (QUOTE LAFITEFIXEDLOOKS) T))) (* ;; "Now do the modification") (if (EQ NEWLOOKS T) then (* ; "Use menu") (\TEDIT.LOOKS (TEXTOBJ TEXTSTREAM)) elseif NEWLOOKS then (TEDIT.LOOKS TEXTSTREAM NEWLOOKS)) (if PARALOOKS then (* ; "Paragraph looks") (TEDIT.PARALOOKS TEXTSTREAM PARALOOKS)) (if USERFN then (* ; "Arbitrary user manipulation.") (CL:FUNCALL USERFN TEXTSTREAM)) (* ;; "Finally, set selection back to where it was.") (TEDIT.SETSEL TEXTSTREAM SEL)))) -) (LAFITE.SET.TAB.LOOKS -(LAMBDA (TEXTSTREAM FIXEDLOOKS TABWIDTH) (* ; "Edited 11-Jun-88 17:07 by bvm") (LET ((LOOKS (BQUOTE (TABS ((\, TABWIDTH))))) (SEL (TEDIT.GETSEL TEXTSTREAM))) (if (EQ FIXEDLOOKS T) then (TEDIT.PARALOOKS TEXTSTREAM LOOKS 1 (GETEOFPTR TEXTSTREAM)) else (for PAIR in FIXEDLOOKS do (TEDIT.PARALOOKS TEXTSTREAM LOOKS (CAR PAIR) (CDR PAIR)))) (* ; "Finally, restore selection") (TEDIT.SETSEL TEXTSTREAM SEL))) -) (LAFITE.SET.PARA.SEPARATION -(LAMBDA (TEXTSTREAM) (* ; "Edited 29-Aug-89 14:53 by bvm") (LAFITE.SET.LOOKS TEXTSTREAM NIL (QUOTE (PARALEADING 10)) T)) -) (LAFITE.SET.LOWER.CASE -(LAMBDA (TEXTSTREAM) (* ; "Edited 7-Nov-89 13:06 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Change the current selection (if there is an interesting one) or the whole message to be lowercase.") (LAFITE.SET.LOOKS TEXTSTREAM NIL NIL T (FUNCTION (LAMBDA (TEXTSTREAM) (LET ((STR (TEDIT.SEL.AS.STRING TEXTSTREAM))) (TEDIT.DELETE TEXTSTREAM) (TEDIT.INSERT TEXTSTREAM (L-CASE STR))))))) -) (LAFITE.SUBSTITUTE.VP.EOL -(LAMBDA (TEXTSTREAM) (* ; "Edited 4-Aug-89 16:55 by bvm") (* ;; "Called from Looks (sub)commands of Lafite display window. Replace VP eol (29) with ours.") (RESETLST (RESETSAVE NIL (LIST (QUOTE TEXTPROP) TEXTSTREAM (QUOTE READONLY) T)) (TEXTPROP TEXTSTREAM (QUOTE READONLY) NIL) (LET* ((SEL (TEDIT.GETSEL TEXTSTREAM)) (LEN (fetch (SELECTION DCH) of SEL)) POS) (if (<= LEN 1) then (* ; "If user has already selected something (more than a single character), assume is not accidental.") (SETQ POS (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL NIL NIL NIL T))) (TEDIT.SETSEL TEXTSTREAM POS (- (GETEOFPTR TEXTSTREAM) (if LAFITEENDOFMESSAGESTR then (NCHARS LAFITEENDOFMESSAGESTR) else 0) POS))) (TEDIT.SUBSTITUTE TEXTSTREAM (ALLOCSTRING 1 29) (ALLOCSTRING 1 (CHARCODE EOL))) (if POS then (* ; "Undo the selection") (TEDIT.SETSEL TEXTSTREAM 1 0))))) -) ) (RPAQ? \LAFITE.DISPLAY.COMMANDS NIL) (ADDTOVAR LAFITE.EXTRA.DISPLAY.COMMANDS ("Looks" '\LAFITE.SET.LOOKS.FROM.MENU "Change the appearance of the selected text, or whole message if nothing selected" ) ("Hardcopy" '\LAFITE.HARDCOPY.FROM.DISPLAY "Hardcopy this message in its current appearance") ("Unhide" '\LAFITE.UNHIDE.HEADERS "Display the header fields that are hidden from view." (SUBITEMS ("Hide" '\LAFITE.REHIDE.HEADERS "Hide uninteresting fields from view again" )))) (ADDTOVAR LAFITE.LOOKS.SUBCOMMANDS ("VP Line Breaks" 'LAFITE.SUBSTITUTE.VP.EOL "Replace the Viewpoint end of line character with ours." ) ("Lowercase" 'LAFITE.SET.LOWER.CASE "Lowercase the region or whole message.") ("Spread Paragraphs" 'LAFITE.SET.PARA.SEPARATION "Separate paragraphs by 10 points (useful for Tioga messages)." ) ("Default" '\LAFITE.SET.DEFAULT.LOOKS "Change selection (or whole text) back to default font" ) ("Fixed Width" '\LAFITE.SET.FIXED.LOOKS "Change selection (or whole text) to fixed-width font")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LAFITE.DISPLAY.COMMANDS) ) (* ; "DELETE") (DEFINEQ (LAFITE.DELETE.MESSAGES -(LAMBDA (FOLDER MESSAGES) (* ; "Edited 31-Aug-88 12:47 by bvm") (* ;; "Programmatic entrypoint to delete a single MSG (# or msg object) from FOLDER. FOLDER must have a browser.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (for MSG inside MESSAGES do (DELETEMESSAGE (if (type? LAFITEMSG MSG) then MSG else (NTHMESSAGE (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) MSG)) FOLDER)))) -) (\LAFITE.DELETE -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 30-Aug-88 11:42 by bvm") (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (for MSGDESCRIPTOR selectedin MAILFOLDER when (NOT (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR)) do (* ; "delete all the currrently selected messages that aren't already deleted") (DELETEMESSAGE MSGDESCRIPTOR MAILFOLDER) finally (SHADEITEM ITEM MENU WHITESHADE) (DISPLAYAFTERDELETE MAILFOLDER WINDOW))))) -) (DISPLAYAFTERDELETE -(LAMBDA (FOLDER WINDOW) (* ; "Edited 29-Aug-88 15:34 by bvm") (* ;;; "Maybe select and maybe display the next message after a deletion, according to setting of LAFITEDISPLAYAFTERDELETEFLG --- T means display next if the deleted one is the one currently displayed and the next message is undeleted and unseen --- ALWAYS means display the next undeleted message if the deleted one is the one currently displayed; if it's not currently displayed, merely select the next undeleted message --- MULTIPLE means ALWAYS plus when the selection is multiple, still advance to next undeleted msg.") (COND (LAFITEDISPLAYAFTERDELETEFLG (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) CURRENT LASTMSG# MESSAGES MENU) (COND ((NEQ FIRST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) (* ;; "More than one message was selected. Only do something if flag says MULTIPLE -- select but don't display next message") (COND ((EQ LAFITEDISPLAYAFTERDELETEFLG (QUOTE MULTIPLE)) (\LAFITE.SELECT.NEXT FOLDER FIRST#)))) ((OR (NOT (SETQ CURRENT (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of FOLDER))) (NEQ FIRST# (fetch (LAFITEMSG %#) of CURRENT))) (* ; "Deleted message is not the one currently displayed") (SELECTQ LAFITEDISPLAYAFTERDELETEFLG ((ALWAYS MULTIPLE) (* ; "select but don't display next message") (\LAFITE.SELECT.NEXT FOLDER FIRST#)) NIL)) ((SELECTQ LAFITEDISPLAYAFTERDELETEFLG ((ALWAYS MULTIPLE) (* ; "Always do it, assuming there's a next message") (\LAFITE.SELECT.NEXT FOLDER FIRST#)) (AND (NEQ FIRST# (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (NOT (fetch (LAFITEMSG DELETED?) of (NTHMESSAGE (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (ADD1 FIRST#)))) (for I from (ADD1 FIRST#) to LASTMSG# bind NEXTMSG do (* ;; "Next message undeleted, so maybe display it. LAFITEDISPLAYAFTERDELETEFLG = T means only do so if it is unexamined. However, messages from us are usually already examined, so pretend the message is unexamined if there is some unexamined message immediately after any from me") (COND ((NOT (fetch (LAFITEMSG SEEN?) of (SETQ NEXTMSG (NTHMESSAGE MESSAGES I)))) (* ; "An unexamined message, ok") (RETURN T)) ((NOT (fetch (LAFITEMSG MSGFROMMEP) of NEXTMSG)) (* ; "Not from me, but examined, so must not be in the stream of new mail") (RETURN NIL)))))) (\LAFITE.DISPLAY WINDOW FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.DISPLAY) (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) MENU))))))) -) (\LAFITE.SELECT.NEXT -(LAMBDA (MAILFOLDER AFTER#) (* ; "Edited 23-Aug-88 18:35 by bvm") (* ;;; "Select the next undeleted message in MAILFOLDER following AFTER# and return the msg, or NIL if there are no more") (for N from (ADD1 AFTER#) to (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES N))) do (RETURN (LAB.GO.TO.MESSAGE MAILFOLDER MSG)))) -) (\LAFITE.UNDELETE -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "28-Mar-84 14:48") (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (OR (LAB.ASSURE.SELECTIONS MAILFOLDER) (for MSGDESCRIPTOR selectedin MAILFOLDER when (fetch (LAFITEMSG DELETED?) of MSGDESCRIPTOR) do (UNDELETEMESSAGE MSGDESCRIPTOR MAILFOLDER)))))) -) ) (* ; "MOVE") (DEFINEQ (LAFITE.MOVE.MESSAGES -(LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MESSAGES COPYFLG) (* ; "Edited 13-Sep-88 18:38 by bvm") (* ;; "Programmatic entry to move (or copy if COPYFLG true) specified MESSAGES from SOURCEFOLDER to DESTINATIONFOLDER. Returns T on success.") (AND MESSAGES (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER (\COERCE.TO.MSGLST MESSAGES SOURCEFOLDER) NIL NIL COPYFLG)))) -) (\COERCE.TO.MSGLST -(LAMBDA (MSGLST FOLDER) (* ; "Edited 30-Aug-88 14:11 by bvm") (* ;; "Accepts a singleton or list of LAFITEMSG objects or numbers relative to FOLDER and returns a list of LAFITEMSG objects") (if (AND (CL:LISTP MSGLST) (for M in MSGLST always (type? LAFITEMSG M))) then MSGLST else (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))) (for M inside MSGLST collect (if (type? LAFITEMSG M) then M else (NTHMESSAGE MESSAGES M)))))) -) (\LAFITE.MOVETO -(LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY COPYFLG) (* ; "Edited 13-Sep-88 18:33 by bvm") (PROG ((BROWSERPROMPTWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) LONGFORMP TOFILE OUTPUTFILE DESTINATIONFOLDER MIDDLESELECTED) (CLEARW BROWSERPROMPTWINDOW) (COND ((LAB.ASSURE.SELECTIONS MAILFOLDER) (* ; "Nothing to move") (RETURN))) (COND ((AND (EQ KEY (QUOTE MIDDLE)) (SETQ DESTINATIONFOLDER (fetch (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER))) (* ; "Accelerator: don't use menu. We will still re-obtain the destination folder below, since the pointer sitting in the folder may be to a long-closed folder.") (SETQ MIDDLESELECTED T) (SETQ OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of DESTINATIONFOLDER))) (T (CL:MULTIPLE-VALUE-SETQ (TOFILE LONGFORMP) (\LAFITE.PROMPTFORFOLDER BROWSERPROMPTWINDOW)) (if (NULL TOFILE) then (RETURN NIL)) (SETQ OUTPUTFILE (LA.LONGFILENAME TOFILE LAFITEMAIL.EXT)) (COND ((STRING-EQUAL OUTPUTFILE (fetch (MAILFOLDER VERSIONLESSFOLDERNAME) of MAILFOLDER)) (LAB.PROMPTPRINT MAILFOLDER T "This IS " TOFILE ", can't move to there.") (RETURN NIL))))) (AND ITEM (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)) (COND (LONGFORMP (* ; "if user had to type file longhand, don't confirm now (but there may be a confirmation for creation later on)")) ((SELECTQ LAFITEMOVETOCONFIRMFLG (NIL (* ; "never confirm") T) (LEFT (* ; "don't confirm when middle selected") MIDDLESELECTED) (MIDDLE (* ; "confirm ONLY when middle selected") (NOT MIDDLESELECTED)) NIL)) ((LAB.MOUSECONFIRM MAILFOLDER "Click LEFT to confirm ~A ~@[of ~D msgs ~]to ~A" (if COPYFLG then "copy" else "move") (AND (< (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER) (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER)) (for MSG selectedin MAILFOLDER sum (* ; "Count how many selected") 1)) (if DESTINATIONFOLDER then (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) else (LA.SHORTFILENAME OUTPUTFILE LAFITEMAIL.EXT)))) (T (* ; "abort") (AND ITEM (SHADEITEM ITEM MENU WHITESHADE)) (RETURN NIL))) (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.MOVETO.PROC)) (QUOTE (\, WINDOW)) (QUOTE (\, MAILFOLDER)) (QUOTE (\, OUTPUTFILE)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) NIL (QUOTE (\, COPYFLG)))) (QUOTE LAFITEMOVE)))) -) (\LAFITE.COPYTO -(LAMBDA (FOLDER ITEM MENU KEY) (* ; "Edited 13-Sep-88 18:37 by bvm") (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (\LAFITE.MOVETO (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of FOLDER) FOLDER (LA.MENU.ITEM (FUNCTION \LAFITE.MOVETO) MENU) MENU NIL T))) -) (\LAFITE.MOVETO.PROC -(LAMBDA (WINDOW SOURCEFOLDER DESTINATIONFULLNAME ITEM MENU FROM.AUTO.MENU COPYFLG) (* ; "Edited 13-Sep-88 18:24 by bvm") (* ;; "Move selected messages from SOURCEFOLDER to the folder named by OUTPUTFILE. If FROM.AUTO.MENU is true, it came from the auxiliary moveto menu. Note that MENU is thus not necessarily SOURCEFOLDER's menu.") (if (RESETLST (LA.RESETSHADE ITEM MENU) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of SOURCEFOLDER) NIL T) (LET ((DESTINATIONFOLDER (LAFITE.OBTAIN.FOLDER DESTINATIONFULLNAME (QUOTE BOTH) SOURCEFOLDER :CONFIRM))) (if DESTINATIONFOLDER then (\LAFITE.MOVE.MESSAGES.INTERNAL SOURCEFOLDER DESTINATIONFOLDER (LAB.SELECTED.MESSAGES SOURCEFOLDER) FROM.AUTO.MENU T COPYFLG)))) then (if COPYFLG then (LAB.PROMPTPRINT SOURCEFOLDER "Copy completed.") else (DISPLAYAFTERDELETE SOURCEFOLDER WINDOW)))) -) (\LAFITE.MOVE.MESSAGES.INTERNAL -(LAMBDA (SOURCEFOLDER DESTINATIONFOLDER MSGLST FROM.AUTO.MENU INTERACTIVE COPYFLG) (* ; "Edited 5-Aug-93 19:50 by bvm") (* ;; "Move the messages in MSGLST from SOURCEFOLDER to DESTINATIONFOLDER. Caller must have acquired the lock on SOURCEFOLDER. FROM.AUTO.MENU means the call was from the auxiliary move menu; INTERACTIVE means it was interactive call vs. programmatic.") (PROG (OUTPUTSTREAM MSGDESCRIPTORS OLDMOVETO) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) T T)) (LAB.PROMPTPRINT SOURCEFOLDER T "Waiting for " (fetch (MAILFOLDER SHORTFOLDERNAME) of DESTINATIONFOLDER) " to become available...") (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of DESTINATIONFOLDER) NIL T) (LAB.PROMPTPRINT SOURCEFOLDER T))) (COND ((NOT (AND (\LAFITE.OPEN.FOLDER SOURCEFOLDER (QUOTE INPUT) NIL) (SETQ OUTPUTSTREAM (\LAFITE.OPEN.FOLDER DESTINATIONFOLDER (QUOTE BOTH) :OK SOURCEFOLDER)))) (* ; "Failed to open source or dest") (RETURN NIL))) (COND ((NEQ (SETQ OLDMOVETO (fetch (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER)) DESTINATIONFOLDER) (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of SOURCEFOLDER))) (replace (MAILFOLDER DEFAULTMOVETOFILE) of SOURCEFOLDER with DESTINATIONFOLDER) (WINDOWPROP WINDOW (QUOTE TITLE) (LAB.TITLE.STRING SOURCEFOLDER)) (if (AND OLDMOVETO (NOT FROM.AUTO.MENU) (OR LAFITE.AUTO.MOVE.MENU (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)))) then (\LAFITE.ADD.TO.MOVE.MENU SOURCEFOLDER DESTINATIONFOLDER OLDMOVETO))))) (SETQ MSGDESCRIPTORS (for OLDMSG in MSGLST bind NEWMSG (INSTREAM _ (\LAFITE.OPEN.FOLDER SOURCEFOLDER (QUOTE INPUT))) collect (MAYBEVERIFYMSG OLDMSG SOURCEFOLDER) (SETFILEPTR OUTPUTSTREAM -1) (SETQ NEWMSG (NCREATE (QUOTE LAFITEMSG) OLDMSG)) (* ; "New descriptor looks a lot like old") (replace (LAFITEMSG BEGIN) of NEWMSG with (GETFILEPTR OUTPUTSTREAM)) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of NEWMSG with NIL) (replace (LAFITEMSG MARKSCHANGEDINFILE?) of NEWMSG with NIL) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of NEWMSG with NIL) (replace (LAFITEMSG DELETED?) of NEWMSG with NIL) (replace (LAFITEMSG SELECTED?) of NEWMSG with NIL) (LA.PRINTHEADER OUTPUTSTREAM (- (fetch (LAFITEMSG MESSAGELENGTH) of OLDMSG) (fetch (LAFITEMSG STAMPLENGTH) of OLDMSG)) NEWMSG) (PROGN (* ; "Now the 3 flag bytes") (BOUT OUTPUTSTREAM UNDELETEDFLAG) (BOUT OUTPUTSTREAM (COND ((fetch (LAFITEMSG SEEN?) of OLDMSG) SEENFLAG) (T UNSEENFLAG))) (BOUT OUTPUTSTREAM (fetch (LAFITEMSG MARKCHAR) of OLDMSG)) (BOUT OUTPUTSTREAM (CHARCODE CR))) (COPYBYTES INSTREAM OUTPUTSTREAM (fetch (LAFITEMSG START) of OLDMSG) (fetch (LAFITEMSG END) of OLDMSG)) (if (NOT COPYFLG) then (MARKMESSAGE OLDMSG SOURCEFOLDER MOVETOMARK) (* ; "delete it") (DELETEMESSAGE OLDMSG SOURCEFOLDER)) NEWMSG)) (* ; "delete them from FROMFILE") (COND ((AND (fetch (MAILFOLDER BROWSERWINDOW) of DESTINATIONFOLDER) (fetch (MAILFOLDER BROWSERREADY) of DESTINATIONFOLDER)) (* ; "now print them in the other window, if up") (LAB.APPENDMESSAGES DESTINATIONFOLDER MSGDESCRIPTORS)) (T (* ; "still have to update eof") (replace (MAILFOLDER FOLDEREOFPTR) of DESTINATIONFOLDER with (GETEOFPTR OUTPUTSTREAM)))) (RETURN T))) -) ) (* ; "Aux move") (DEFINEQ (\LAFITE.ENABLE.MOVE.MENU -(LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 12:39 by bvm") (* ;; "Bring up a menu of folders attached to FOLDER's browser for accelerated MoveTo") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (OLDDEFAULT (fetch (MAILFOLDER DEFAULTMOVETOFILE) of FOLDER))) (LAB.PROMPTPRINT FOLDER T "Specify which folders to include in the accelerated menu.") (if OLDDEFAULT then (CL:PUSHNEW (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDDEFAULT) ITEMS :TEST (QUOTE STRING-EQUAL))) (if (SETQ ITEMS (LAFITE.SELECT.FOLDERS ITEMS)) then (* ; "Didn't abort") (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER T)) (LAB.PROMPTPRINT FOLDER T))) -) (\LAFITE.ADD.TO.MOVE.MENU -(LAMBDA (FOLDER NEWFOLDER OLDFOLDER) (* ; "Edited 31-Aug-88 12:43 by bvm") (* ;; "Add NEWFOLDER to FOLDER's auto move menu, creating it if necessary, in which case also include OLDFOLDER") (PROG* ((NEWNAME (fetch (MAILFOLDER SHORTFOLDERNAME) of NEWFOLDER)) (WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (OLDITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES))) (ITEMS OLDITEMS)) (COND ((NULL ITEMS) (SETQ ITEMS (LIST NEWNAME)) (if OLDFOLDER then (push ITEMS (fetch (MAILFOLDER SHORTFOLDERNAME) of OLDFOLDER)))) ((CL:MEMBER NEWNAME ITEMS :TEST (QUOTE STRING-EQUAL)) (* ; "Nothing new to do") (RETURN)) (T (push ITEMS NEWNAME))) (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES) ITEMS) (\LAFITE.UPDATE.MOVE.MENU FOLDER (NULL OLDITEMS)))) -) (\LAFITE.UPDATE.MOVE.MENU -(LAMBDA (FOLDER FORCE) (* ; "Edited 23-Aug-89 12:21 by bvm") (* ;; "Called when someone has changed the set of folder names in FOLDER's auto move menu. This function creates a new menu. If the menu is not currently open, we don't open one unless FORCE is true.") (PROG* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (MENUW (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.MENU))) HOW POSITION TITLE) (if (NOT (OPENWP WINDOW)) then (* ; "Maybe the browser is shrunk. The system doesn't know how to attach to shrunken windows, so just punt it") (RETURN) elseif MENUW then (* ; "Remove the old window and make a new") (DETACHWINDOW MENUW WINDOW) (CLOSEW MENUW) elseif (NULL FORCE) then (RETURN)) (SETQ POSITION (SELECTQ (SETQ HOW LAFITE.AUTO.MOVE.MENU) ((LEFT RIGHT) (QUOTE TOP)) ((BOTTOM TOP) (QUOTE LEFT)) (PROGN (SETQ HOW (QUOTE RIGHT)) (QUOTE TOP)))) (CL:MULTIPLE-VALUE-BIND (NCOLUMNS ITEMS) (\LAFITE.ARRANGE.MENU (APPEND (SORT (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)) (FUNCTION UALPHORDER)) (AND LAFITE.EXTRA.MOVE.ITEMS (CONS (QUOTE ("" (QUOTE NILL) "")) LAFITE.EXTRA.MOVE.ITEMS))) LAFITE.FOLDER.MENU.FONT (- (LET* ((REG (WINDOWREGION WINDOW)) (BROWSERHEIGHT (fetch (REGION HEIGHT) of REG))) (if (EQ POSITION (QUOTE TOP)) then (* ; "Don't make the menu much taller than the window or below bottom of screen") (MIN (+ BROWSERHEIGHT (IQUOTIENT BROWSERHEIGHT 2)) (fetch (REGION TOP) of REG)) else (* ; "Don't make it taller than the screen") (- SCREENHEIGHT BROWSERHEIGHT))) (FONTPROP WINDOWTITLEFONT (QUOTE HEIGHT))) (SETQ TITLE "Move To:")) (SETQ MENUW (MENUWINDOW (create MENU ITEMS _ ITEMS MENUCOLUMNS _ NCOLUMNS CENTERFLG _ T TITLE _ TITLE WHENHELDFN _ (FUNCTION (LAMBDA (ITEM) (PROMPTPRINT (if (LISTP ITEM) then (CADDR ITEM) else "Move the selected message(s) to this folder")))) WHENSELECTEDFN _ (FUNCTION \LAFITE.HANDLE.AUTO.MOVE) MENUFONT _ LAFITE.FOLDER.MENU.FONT MENUTITLEFONT _ WINDOWTITLEFONT)))) (ATTACHWINDOW MENUW WINDOW HOW POSITION (QUOTE LOCALCLOSE)) (WINDOWADDPROP MENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (* ;; "Remove pointer to me. Note that this fn must come first, before detachwindow") (AND (SETQ W (MAINWINDOW W)) (WINDOWPROP W (QUOTE LAFITE.AUTO.MOVE.MENU) NIL)))) T) (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.MENU) MENUW))) -) (\LAFITE.RESTORE.MOVE.MENU -(LAMBDA (FOLDER) (* ; "Edited 31-Aug-88 15:19 by bvm") (LET* ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (ITEMS (WINDOWPROP WINDOW (QUOTE LAFITE.AUTO.MOVE.NAMES)))) (if ITEMS then (* ; "Yes, there was a menu, so bring it up") (\LAFITE.UPDATE.MOVE.MENU FOLDER T) else (* ; "Start from scratch") (\LAFITE.ENABLE.MOVE.MENU FOLDER)))) -) (\LAFITE.HANDLE.AUTO.MOVE -(LAMBDA (ITEM MENU KEY) (* ; "Edited 29-Aug-88 15:06 by bvm") (* ;; "Handle the selection of an item from Lafite's auto moveto menu. Just do the specified move") (LET ((MENUW (WFROMMENU MENU)) WINDOW FOLDER) (AND MENUW (SETQ WINDOW (MAINWINDOW MENUW)) (SETQ FOLDER (WINDOWPROP WINDOW (QUOTE MAILFOLDER))) (fetch (MAILFOLDER BROWSERREADY) of FOLDER) (if (LISTP ITEM) then (* ; "Handle other commands") (CL:FUNCALL (EXTRACTMENUCOMMAND ITEM) WINDOW FOLDER ITEM MENU KEY) else (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.MOVETO.PROC)) (QUOTE (\, WINDOW)) (QUOTE (\, FOLDER)) (QUOTE (\, (LA.LONGFILENAME ITEM LAFITEMAIL.EXT))) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) T)) (QUOTE LAFITEMOVE)))))) -) ) (ADDTOVAR LAFITEEXTRAMENUITEMS ("Enable MoveTo Menu" '\LAFITE.ENABLE.MOVE.MENU "Attach a menu of folders for accelerated MoveTo (or modify existing one)" (SUBITEMS ("Restore MoveTo Menu" '\LAFITE.RESTORE.MOVE.MENU "Just reopen the attached MoveTo menu if it existed." ))) ("Copy To" '\LAFITE.COPYTO "Like MoveTo, but don't delete the message(s).")) (ADDTOVAR LAFITE.EXTRA.MOVE.ITEMS ("---Display---" '\LAFITE.DISPLAY "Display the next message") ("---Delete---" '\LAFITE.DELETE "Delete the selected message(s)")) (RPAQ? LAFITE.AUTO.MOVE.MENU ) (* ; "UPDATE") (DEFINEQ (\LAFITE.UPDATE -(LAMBDA (WINDOW FOLDER ITEM MENU BUTTONS) (* ; "Edited 25-Apr-89 15:10 by bvm") (LET ((HOWINDEX (LAB.UPDATE.NEEDED? FOLDER)) HOW? HOWSTRING CLOSEFLG CONFIRMFLG) (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER) (if (AND (EQ BUTTONS (QUOTE MIDDLE)) LAFITE.MIDDLE.UPDATE) then (* ; "Accelerator: do what this flag says, asking only for confirmation first") (for OP inside LAFITE.MIDDLE.UPDATE do (CASE OP ((:CLOSE :SHRINK) (SETQ CLOSEFLG OP)) ((:UPDATE :EXPUNGE) (SETQ HOWSTRING (if (AND (EQ OP :EXPUNGE) (BITTEST HOWINDEX \EXPUNGE.MENU.BIT)) then (* ; "Expunge is needed and requested") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Expunge" elseif (BITTEST HOWINDEX \SORT.MENU.BIT) then (* ; "Have to do wtih expunge") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Write sorted" elseif (BITTEST HOWINDEX \EXPUNGE&SORT.MENU.BIT) then (* ; "Have to do wtih expunge") (SETQ HOW? (FUNCTION \LAFITE.EXPUNGE.PROC)) "Expunge (write sorted)" elseif (BITTEST HOWINDEX \UPDATE.MENU.BIT) then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC)) "Write out changes" elseif (BITTEST HOWINDEX \TOC.MENU.BIT) then (SETQ HOW? (FUNCTION \LAFITE.UPDATE.PROC)) "Update table of contents")) (if (BITTEST HOWINDEX \HARDCOPY.MENU.BIT) then (* ; "Also might want to hardcopy") (SETQ HOWSTRING (if (NULL HOW?) then (SETQ HOW? (FUNCTION \LAFITE.HARDCOPYONLY.PROC)) "Hardcopy" else (CONCAT "Hardcopy, " HOWSTRING))) elseif (NULL HOW?) then (* ; "Pretend no update is needed, even if left-update would have said Expunge") (SETQ HOWINDEX 0))) (:CONFIRM (SETQ CONFIRMFLG T))))) (if (AND (NULL CLOSEFLG) (EQ 0 HOWINDEX)) then (* ; "We weren't asked to close it, and nothing changed.") (LAB.PROMPTPRINT FOLDER T "No changes since the last Update") elseif (SETQ HOW? (if (OR HOWSTRING CLOSEFLG) then (if (AND (NULL HOWSTRING) (EQ CLOSEFLG :SHRINK)) then (* ; "Accelerator says Shrink, and there is nothing else to do, so just shrink") (FUNCTION \LAFITE.FINISH.UPDATE) elseif (OR (NULL CONFIRMFLG) (LAB.MOUSECONFIRM FOLDER (CONCATLIST (CONS "Click LEFT to confirm " (LET ((CF (AND CLOSEFLG (LIST (L-CASE CLOSEFLG T))))) (if HOWSTRING then (LIST* HOWSTRING (AND CF (CONS " and " CF))) else CF)))))) then (OR HOW? (FUNCTION \LAFITE.FINISH.UPDATE))) else (MENU (LAB.CHOOSE.UPDATE.MENU HOWINDEX)))) then (\LAFITE.PROCESS (LIST HOW? (KWOTE WINDOW) (KWOTE FOLDER) CLOSEFLG (KWOTE ITEM) (KWOTE MENU)) (QUOTE LAFITEUPDATE))))) -) (\LAFITE.EXPUNGE.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 1-May-89 12:53 by bvm") (RESETLST (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (CLEARW WINDOW) (\LAFITE.COMPACT.FOLDER MAILFOLDER) (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (COND (CLOSEFLG (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of MAILFOLDER with 0)) (T (LAB.DISPLAYFOLDER MAILFOLDER)))) (* ; "Do the following outside RESETLST so that Update gets unshaded") (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) (\LAFITE.UPDATE.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 14-Oct-87 20:00 by bvm:") (RESETLST (\LAFITE.START.UPDATE MAILFOLDER ITEM MENU) (COND ((OR (COND ((fetch (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER) (\LAFITE.UPDATE.FOLDER MAILFOLDER) T)) (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER) (fetch (MAILFOLDER TOCLASTMESSAGE#) of MAILFOLDER))) (\LAFITE.UPDATE.CONTENTS MAILFOLDER (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER))) (T (LAB.PROMPTPRINT MAILFOLDER T "No changes since last update"))) (\LAFITE.CLOSE.FOLDER MAILFOLDER T)) (* ; "Do the following outside RESETLST so that Update gets unshaded") (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) (\LAFITE.HARDCOPYONLY.PROC -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG ITEM MENU) (* ; "Edited 29-Aug-88 17:49 by bvm") (* ;; "Called by Update or Close to just do pending hardcopy, nothing else") (RESETLST (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) ITEM MENU) (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER)) (\LAFITE.FINISH.UPDATE WINDOW MAILFOLDER CLOSEFLG)) -) (LAB.CHOOSE.UPDATE.MENU -(LAMBDA (FOLDER CLOSEFLG) (* ; "Edited 25-Apr-89 15:10 by bvm") (* ;; "Returns a menu for prompting the user about what to do with FOLDER when Update is requested, or if CLOSEFLG is true, if Close/Shrink is requested. Returns NIL if there is no interesting choice.") (LET ((INDEX (OR (FIXP FOLDER) (LAB.UPDATE.NEEDED? FOLDER)))) (if (NEQ INDEX 0) then (CASE CLOSEFLG (:CLOSE (SETQ INDEX (LOGOR INDEX \CLOSE.MENU.BIT))) (:SHRINK (SETQ INDEX (LOGOR INDEX \SHRINK.MENU.BIT)))) (OR (GETHASH INDEX LAFITE.UPDATE.MENU.HASH) (LAB.CREATE.UPDATE.MENU INDEX))))) -) (LAB.CREATE.UPDATE.MENU -(LAMBDA (INDEX) (* ; "Edited 25-Apr-89 15:08 by bvm") (* ;; "Create a menu to ask about updating. There is a bit in INDEX for each possible thing you might want to do to update this folder -- Update, Expunge, Update TOC, Hardcopy, Expunge&Sort. Not all bit combinations are possible. In practice, only a small number of combinations actually occur, so we remember menus in a hash table.") (LET* ((LASTITEM NIL) (ITEMS (for ITEM in LAFITEUPDATEMENUITEMS as (BIT _ 1) by (LLSH BIT 1) when (BITTEST INDEX BIT) collect (if (NOT (BITTEST INDEX (LOGOR \CLOSE.MENU.BIT \SHRINK.MENU.BIT))) then (SETQ LASTITEM ITEM)) ITEM)) MENU) (if (STRPOS "Only" (CAR LASTITEM) -4 NIL T NIL UPPERCASEARRAY) then (* ; "Sounds funny if last item says %"Only%"") (RPLACA (FMEMB LASTITEM ITEMS) (CONS (SUBSTRING (CAR LASTITEM) 1 -6) (CDR LASTITEM)))) (SETQ MENU (\LAFITE.CREATE.MENU ITEMS (if (BITTEST INDEX \CLOSE.MENU.BIT) then "Close Options" elseif (BITTEST INDEX \SHRINK.MENU.BIT) then "Shrink Options" else "Update Options"))) (PUTHASH INDEX MENU LAFITE.UPDATE.MENU.HASH) MENU)) -) (LAB.UPDATE.NEEDED? -(LAMBDA (FOLDER) (* ; "Edited 25-Apr-89 15:08 by bvm") (* ;; "Returns an integer whose bits indicate the type of updating needed by FOLDER; zero if it needs none.") (LOGOR (COND ((fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER) \HARDCOPY.MENU.BIT) (T 0)) (if (NOT (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER)) then (LOGOR (if (fetch (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER) then \UPDATE.MENU.BIT elseif (NEQ (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER)) then (* ; "Update toc if messages have been appended") \TOC.MENU.BIT else 0) (if (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) then \EXPUNGE.MENU.BIT else 0)) elseif (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER) then \EXPUNGE&SORT.MENU.BIT else \SORT.MENU.BIT))) -) (\LAFITE.START.UPDATE -(LAMBDA (MAILFOLDER ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") (* ;; "Called under a RESETLST to start an UPDATE or EXPUNGE") (LAB.START.COMMAND MAILFOLDER (FUNCTION \LAFITE.UPDATE) ITEM MENU) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (MAILFOLDER) (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with NIL))) MAILFOLDER)) (* ; "Mark folder being updated for benefit of LOGOUT check") (replace (MAILFOLDER FOLDERBEINGUPDATED) of MAILFOLDER with T) (* ; "Close all other folders, so MoveTo's are up to date") (\LAFITE.CLOSE.OTHER.FOLDERS MAILFOLDER) (\LAFITE.DO.PENDING.HARDCOPY MAILFOLDER MENU)) -) (LAB.START.COMMAND -(LAMBDA (MAILFOLDER CMD ITEM MENU) (* ; "Edited 18-Jul-88 11:56 by bvm") (* ;; "Shades MAILFOLDER's command implemented by CMD, or ITEM of MENU if supplied and obtains the folder lock. Opens browser window if it is shrunk. Must be called under RESETLST surrounding command execution.") (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of MAILFOLDER))) (if (AND WINDOW (NOT (OPENWP WINDOW))) then (EXPANDW WINDOW))) (LA.RESETSHADE (OR ITEM (LA.MENU.ITEM CMD (SETQ MENU (fetch (MAILFOLDER BROWSERMENU) of MAILFOLDER)))) MENU) (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) NIL T) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER)) -) (\LAFITE.FINISH.UPDATE -(LAMBDA (WINDOW MAILFOLDER CLOSEFLG) (* ; "Edited 7-Jun-88 14:28 by bvm") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge.") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (CASE CLOSEFLG ((:CLOSE :EXIT) (WITH.MONITOR \LAFITE.BROWSELOCK (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (SETQ WINDOW (LAB.FLUSHWINDOW WINDOW MAILFOLDER)) (CLOSEW WINDOW) (COND ((AND (NEQ CLOSEFLG :EXIT) (OR (NOT (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER)) (= (fetch (MAILFOLDER FOLDEREOFPTR) of MAILFOLDER) 0)) (EQ (GETFILEINFO (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER) (QUOTE LENGTH)) 0)) (* ;; "Folder is empty, and we are explicitly closing it (as opposed to indirectly via the Quit command), so delete underlying file, etc. FOLDEREOFPTR should always be right, but be paranoid and double-check with the file itself before deleting") (DELETEMAILFOLDER MAILFOLDER))))) (:SHRINK (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (\LAFITE.CLOSE.FOLDER MAILFOLDER T) (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION LAB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION LAB.SHRINKFN)) (SHRINKW WINDOW)))) (COND (\LAFITEPROFILECHANGED (\LAFITE.WRITE.PROFILE)))) -) (\LAFITE.CLOSE.OTHER.FOLDERS -(LAMBDA (THISFOLDER) (* bvm%: "31-Jul-84 15:17") (* ;; "Closes or flushes output of all Lafite folders except THISFOLDER. If a folder does not have an open browser, the file is closed; else output is flushed") (WITH.MONITOR \LAFITE.MAINLOCK (for FOLDER in \ACTIVELAFITEFOLDERS when (AND (NEQ FOLDER THISFOLDER) (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER)) do (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) T T) (\LAFITE.CLOSE.FOLDER FOLDER (NULL (OPENWP (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)))))))))) -) ) (DEFINEQ (LAB.FLUSHWINDOW -(LAMBDA (WINDOW MAILFOLDER) (* ; "Edited 18-Jul-88 11:37 by bvm") (\LAFITE.CLOSE.DISPLAYWINDOWS MAILFOLDER) (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION LAB.CLOSEFN)) (replace (MAILFOLDER BROWSERREADY) of MAILFOLDER with (replace (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER with (replace (MAILFOLDER DEFAULTMOVETOFILE) of MAILFOLDER with (replace (MAILFOLDER BROWSERMENUWINDOW) of MAILFOLDER with (replace (MAILFOLDER BROWSERWINDOW) of MAILFOLDER with (replace (MAILFOLDER BROWSERMENU) of MAILFOLDER with (replace (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER with NIL))))))) (WINDOWPROP WINDOW (QUOTE MAILFOLDER) NIL) (SETQ \ACTIVELAFITEFOLDERS (DREMOVE MAILFOLDER \ACTIVELAFITEFOLDERS)) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) -) (LAB.APPENDMESSAGES -(LAMBDA (FOLDER NEWMESSAGEDESCRIPTORS) (* ; "Edited 28-Apr-89 15:47 by bvm") (* ;; "Append list of message descriptors to folder, adjusting display, etc as needed.") (PROG ((LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) FIRSTMSG#) (SETQ FIRSTMSG# (ADD1 LASTMSG#)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with (GETEOFPTR (fetch (MAILFOLDER FOLDERSTREAM) of FOLDER))) (for MSGDESCRIPTOR in NEWMESSAGEDESCRIPTORS do (replace (LAFITEMSG %#) of MSGDESCRIPTOR with (add LASTMSG# 1)) (LAFITE.PARSE.MSG.FOR.TOC MSGDESCRIPTOR FOLDER)) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTMSG#) (replace (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER with (\LAFITE.ADDMESSAGES.TO.ARRAY (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) NEWMESSAGEDESCRIPTORS FIRSTMSG# LASTMSG#)) (LET ((EXTENT (fetch (MAILFOLDER BROWSEREXTENT) of FOLDER)) (HEIGHT (TIMES LASTMSG# (fetch (MAILFOLDER BROWSERFONTHEIGHT) of FOLDER))) WINDOW) (replace (REGION HEIGHT) of EXTENT with HEIGHT) (replace (REGION BOTTOM) of EXTENT with (- (fetch (MAILFOLDER BROWSERORIGIN) of FOLDER) HEIGHT)) (WINDOWPROP (SETQ WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER)) (QUOTE EXTENT) EXTENT) (COND ((OPENWP WINDOW) (* ; "If window is visible, update it now") (LAB.DISPLAYLINES FOLDER FIRSTMSG#)) ((NULL (fetch (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER)) (* ; "Mark browser for display update after being unshrunk") (replace (MAILFOLDER BROWSERUPDATEFROMHERE) of FOLDER with FIRSTMSG#)))))) -) (\LAFITE.COMPACT.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 10-May-89 12:42 by bvm") (* ;;; "Expunge deleted messages from MAILFOLDER. We copy undeleted messages after the first deleted one into a scratch file and copy the scratch file back into the main file. Returns the msg # of the last message before the compacted section. This function must also be used if the folder is out of order.") (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (FIRSTCHANGED# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) (LASTGOODMSG# (SUB1 FIRSTCHANGED#)) (LASTLENGTH 0) (LASTBEGIN 0) FOLDERSTREAM MSG TOCSTREAM) (if (> FIRSTCHANGED# 1) then (* ; "Get this loop initialized") (SETQ MSG (NTHMESSAGE MESSAGES LASTGOODMSG#)) (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (* ;; "first see if there are any messages to delete or messages out of order and while doing so collect information for rapidly compacting the file just in case we have to. We check for out of order by maintaining previous pointer and length so as to avoid boxing most of the time.") (for MSG# from (MAX 1 FIRSTCHANGED#) to LASTMSG# until (OR (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) (NOT (= (- (fetch (LAFITEMSG BEGIN) of MSG) LASTBEGIN) LASTLENGTH))) do (COND ((fetch (LAFITEMSG MARKSCHANGEDINFILE?) of MSG) (WRITEFOLDERMARKBYTES MSG FOLDER (OR FOLDERSTREAM (SETQ FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE BOTH) :ABORT)))))) (SETQ LASTGOODMSG# MSG#) (SETQ LASTBEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (SETQ LASTLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (COND ((NEQ LASTGOODMSG# LASTMSG#) (SETQ TOCSTREAM (\LAFITE.COMPACT.FOLDER1 FOLDER (OR FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE BOTH) :ABORT)) LASTGOODMSG#)))) (replace (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER with NIL) (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with NIL) (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (\LAFITE.UPDATE.CONTENTS FOLDER LASTGOODMSG# TOCSTREAM))) -) (\LAFITE.COMPACT.FOLDER1 -(LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG#) (* ; "Edited 13-Jul-92 16:01 by bvm") (* ;;; "LASTGOODMSG# is the number of the last good message before the region to be compacted. FOLDERSTREAM is open for io.") (LET (SCRATCHFILE STATE ORIGEOF CONDITION TOCSTREAM) (CL:UNWIND-PROTECT (PROG ((*PRINT-BASE* 10) (*UPPER-CASE-FILE-NAMES* NIL) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (OLDLASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (FIRSTSELECTED (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LASTSELECTED (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)) COMPACTLENGTH GOODMSGSPTR MSGLIST RESULT NEWDATE) (LAB.PROMPTPRINT FOLDER "Compacting folder... ") (COND ((> LASTSELECTED LASTGOODMSG#) (* ; "There are selections in the compacting region") (COND ((> FIRSTSELECTED LASTGOODMSG#) (* ; "All selections are there, so recompute completely") (SETQ LASTSELECTED (SETQ FIRSTSELECTED NIL))) (T (* ; "Some selections before it, so only Last changes") (SETQ LASTSELECTED (LAB.REV.FIND.SELECTED.MSG FOLDER FIRSTSELECTED LASTGOODMSG#)))))) (SETQ GOODMSGSPTR (COND ((EQ LASTGOODMSG# 0) 0) (T (fetch (LAFITEMSG END) of (NTHMESSAGE MESSAGES LASTGOODMSG#))))) (* ; "End of the region that we leave alone") (SETQ COMPACTLENGTH (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# bind MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) sum (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (COND ((NEQ COMPACTLENGTH 0) (if (if (EQ LASTGOODMSG# 0) then (* ; "WIll have to rewrite whole folder") (SMART-RENAMEFILEP FOLDERSTREAM) elseif (AND (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) (SMART-RENAMEFILEP FOLDERSTREAM)) then (* ; "Will it be faster to write a brand new file and rename it to the destination than to do the overwriting stuff, given the extra messages we'll have to save on the end in case of disaster?") (> (\LAFITE.COMPACT.EXTRA FOLDER LASTGOODMSG# GOODMSGSPTR GOODMSGSPTR) GOODMSGSPTR)) then (SETQ SCRATCHFILE (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERSTREAM (QUOTE EXTENSION)) "-compacted") (QUOTE BODY) FOLDERSTREAM) (QUOTE OUTPUT) (QUOTE NEW) (BQUOTE ((LENGTH (\, (+ GOODMSGSPTR COMPACTLENGTH))) (SEQUENTIAL T) (TYPE LAFITE))))) (COPYBYTES FOLDERSTREAM SCRATCHFILE 0 GOODMSGSPTR) (LINELENGTH T SCRATCHFILE) (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE T)) (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE)) (SETQ NEWDATE (GETFILEINFO SCRATCHFILE (QUOTE ICREATIONDATE))) (SETQ FOLDERSTREAM (FULLNAME FOLDERSTREAM)) (\LAFITE.CLOSE.FOLDER FOLDER T) (SETQ STATE :NEW) (CL:MULTIPLE-VALUE-SETQ (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHFILE FOLDERSTREAM)) (if (NULL RESULT) then (RETURN) else (* ; "Scratch file now gone") (SETQ SCRATCHFILE NIL) (SETQ STATE :OPEN) (* ; "At this point, file is inconsistent with in-core structures.") (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER))) else (SETQ ORIGEOF (GETEOFPTR FOLDERSTREAM)) (* ; "Save info for abort") (SETQ STATE :APPEND) (SETQ MSGLIST (\LAFITE.COMPACT.FOLDER2 FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR (SETQ SCRATCHFILE (LA.OPENTEMPFILE (QUOTE SCRATCH) (QUOTE BOTH) (QUOTE NEW) COMPACTLENGTH)))) (* ;; "Up til now, you could abort and nothing bad would happen--the folder hasn't been written on yet.") (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) (* ; "set the pointer to the end of the good messages") (SETQ STATE :OPEN) (* ; "We're about to make the world inconsistent") (SETQ TOCSTREAM (\LAFITE.INVALIDATE.TOC FOLDER)) (COPYBYTES SCRATCHFILE FOLDERSTREAM 0 -1) (* ; "copy the scratch file to the end of the good messages left in the original file") (FORCEOUTPUT FOLDERSTREAM) (* ; "Ensure that all those writes succeeded, before we update core and truncate the file below.")) (for MSG in MSGLIST do (* ;; "Now that it's all written, update the incore structures") (if (LISTP MSG) then (* ; "Need to fix stamp & msg length") (replace (LAFITEMSG MESSAGELENGTH) of (CAR MSG) with (CADDR MSG)) (replace (LAFITEMSG STAMPLENGTH) of (CAR MSG) with (CADR MSG)) (SETQ MSG (CAR MSG))) (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL) (replace (LAFITEMSG BEGIN) of MSG with GOODMSGSPTR) (add GOODMSGSPTR (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) (replace (LAFITEMSG %#) of MSG with (add LASTGOODMSG# 1)) (SETA MESSAGES LASTGOODMSG# MSG) (COND ((fetch (LAFITEMSG SELECTED?) of MSG) (COND ((NOT FIRSTSELECTED) (SETQ FIRSTSELECTED LASTGOODMSG#))) (SETQ LASTSELECTED LASTGOODMSG#)))) (if (AND (NOT NEWDATE) (NOT (= GOODMSGSPTR (GETFILEPTR FOLDERSTREAM)))) then (HELP "Miscalculation in Lafite Expunge" (LIST GOODMSGSPTR (QUOTE NEQ) (GETFILEPTR FOLDERSTREAM)))))) (replace (MAILFOLDER %#OFMESSAGES) of FOLDER with LASTGOODMSG#) (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER with (OR FIRSTSELECTED 1)) (replace (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER with (OR LASTSELECTED 0)) (for I from (ADD1 LASTGOODMSG#) to OLDLASTMSG# do (* ; "Erase entries beyond the new end of messages") (SETA MESSAGES I NIL)) (if NEWDATE then (* ; "Did via separate file, so get the date right") (replace (MAILFOLDER FOLDERCREATIONDATE) of FOLDER with NEWDATE) else (* ; "Truncate to new length") (SETFILEPTR FOLDERSTREAM GOODMSGSPTR) (SETFILEINFO FOLDERSTREAM (QUOTE LENGTH) GOODMSGSPTR)) (replace (MAILFOLDER FOLDEREOFPTR) of FOLDER with GOODMSGSPTR) (SETQ STATE :END) (RETURN TOCSTREAM)) (* ;; "Cleanup code--this runs even if we are aborted.") (if (NEQ STATE :END) then (LAB.PROMPTPRINT FOLDER " aborted.") (if (EQ STATE :OPEN) then (LAB.PROMPTPRINT FOLDER " Folder is now in an inconsistent state and must be rebrowsed.") else (* ; "We have not yet overwritten anything, so folder is still consistent, mainly") (if (AND (EQ STATE :APPEND) (> (GETEOFPTR FOLDERSTREAM) ORIGEOF)) then (* ; "We have written stuff to end of file--delete it") (SETFILEPTR FOLDERSTREAM ORIGEOF) (SETFILEINFO FOLDERSTREAM (QUOTE LENGTH) ORIGEOF)) (if (EQ STATE :NEW) then (* ; "The RENAMEFILE failed") (LAB.FORMAT FOLDER " Help! Could not replace mail file with compacted file~@[ because ~A~]. The compacted file is stored as ~A. You must rename this file to ~A before proceeding. " CONDITION SCRATCHFILE FOLDERSTREAM) else (LET ((WINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if (OPENWP WINDOW) then (* ; "Window was cleared, so redisplay it now") (REDISPLAYW WINDOW))))) (if TOCSTREAM then (CLOSEF TOCSTREAM))) (\LAFITE.CLOSE.FOLDER FOLDER T) (if SCRATCHFILE then (if (STREAMP SCRATCHFILE) then (SETQ SCRATCHFILE (CLOSEF SCRATCHFILE))) (DELFILE SCRATCHFILE)) (if (AND (EQ STATE :END) (EQ LAFITEVERIFYFLG (QUOTE ALL))) then (VERIFYMAILFOLDER FOLDER))))) -) (\LAFITE.COMPACT.FOLDER2 -(LAMBDA (FOLDER FOLDERSTREAM LASTGOODMSG# GOODMSGSPTR SCRATCHFILE NEWFILEP) (* ; "Edited 2-May-89 11:09 by bvm") (* ;; "We want to compact FOLDER's messages beyond LASTGOODMSG#, which ends at GOODMSGSPTR. We map down the messages moving the undeleted ones into SCRATCHFILE (which is a new mail file if NEWFILEP is true). Return a list of the messages written to SCRATCHFILE. If the stamp length of any message changed, the corresponding element is not the message but a list (msg newstamplength newmsglength).") (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (NEXTFILEPTR _ GOODMSGSPTR) MSG TMP unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) collect (MAYBEVERIFYMSG MSG FOLDER) (LET* ((BEGIN (fetch (LAFITEMSG BEGIN) of MSG)) (STAMPLENGTH (fetch (LAFITEMSG STAMPLENGTH) of MSG)) (MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) (BODYLENGTH (- MSGLENGTH STAMPLENGTH)) (NEWSTAMPLENGTH (LA.PRINTHEADER SCRATCHFILE BODYLENGTH))) (WRITEFOLDERMARKBYTES MSG NIL SCRATCHFILE) (BOUT SCRATCHFILE (CHARCODE CR)) (COPYBYTES FOLDERSTREAM SCRATCHFILE (+ BEGIN STAMPLENGTH) (+ BEGIN MSGLENGTH)) (if (NOT NEWFILEP) then (if (< BEGIN NEXTFILEPTR) then (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") (SETFILEPTR FOLDERSTREAM -1) (LA.PRINTHEADER FOLDERSTREAM BODYLENGTH NIL (+ (NCHARS BEGIN) (CONSTANT (ADD1 (NCHARS "*duplicate*"))))) (BOUT FOLDERSTREAM DELETEDFLAG) (* ; "Make message look deleted ordinarily") (BOUT FOLDERSTREAM UNSEENFLAG) (BOUT FOLDERSTREAM DUPLICATEMARK) (BOUT FOLDERSTREAM (CHARCODE CR)) (PRIN3 "*duplicate*" FOLDERSTREAM) (* ; "Mark as duplicate and tell where") (PRIN3 BEGIN FOLDERSTREAM) (BOUT FOLDERSTREAM (CHARCODE CR)) (COPYBYTES SCRATCHFILE FOLDERSTREAM (- (SETQ TMP (GETFILEPTR SCRATCHFILE)) BODYLENGTH) TMP) (SETFILEPTR SCRATCHFILE TMP)) (add NEXTFILEPTR BODYLENGTH NEWSTAMPLENGTH)) (if (EQ STAMPLENGTH NEWSTAMPLENGTH) then (* ; "normal case, no length changed") MSG else (LIST MSG NEWSTAMPLENGTH (+ BODYLENGTH NEWSTAMPLENGTH)))))) -) (\LAFITE.COMPACT.EXTRA -(LAMBDA (FOLDER LASTGOODMSG# GOODMSGSPTR STOPAT) (* ; "Edited 5-May-89 11:25 by bvm") (* ;; "Returns an estimate of the length of stuff we'll have to append to folder while compacting it, due to messages being out of order. If the estimate ever exceeds STOPAT we can stop counting and return the current estimate.") (for I from (ADD1 LASTGOODMSG#) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) bind (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (NEXTFILEPTR _ GOODMSGSPTR) (EXTRALENGTH _ 0) MSG unless (fetch (LAFITEMSG DELETED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) do (LET ((MSGLENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG))) (if (< (fetch (LAFITEMSG BEGIN) of MSG) NEXTFILEPTR) then (* ;; "By the time we get to copying this message to the main file, we will already have overwritten at least part of the original message. That means we could lose messages if a crash occurs here. So instead, copy this message to after the eof as a saving place") (if (> (add EXTRALENGTH MSGLENGTH (CONSTANT (+ 6 (NCHARS "*duplicate*")))) STOPAT) then (RETURN EXTRALENGTH))) (add NEXTFILEPTR MSGLENGTH)) finally (RETURN EXTRALENGTH))) -) (\LAFITE.INVALIDATE.TOC -(LAMBDA (FOLDER) (* ; "Edited 5-May-89 11:45 by bvm") (* ;; "Invalidate the toc file for this folder by trashing the password. Returns the stream, if any.") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (NAME (INFILEP (TOCFILENAME FOLDER))) TOCSTREAM) (if (AND NAME (SETQ TOCSTREAM (IGNORE-ERRORS (\LAFITE.OPENSTREAM NAME (QUOTE BOTH) (QUOTE OLD) NIL NIL (QUOTE BINARY))))) then (WORDOUT TOCSTREAM (LOGXOR 65535 LAFITETOCPASSWORD)) (FORCEOUTPUT TOCSTREAM) TOCSTREAM))) -) (\LAFITE.RENAMEFILE -(LAMBDA (SCRATCHFILE FOLDERNAME) (* ; "Edited 2-May-89 11:33 by bvm") (* ;; "Called to replace FOLDERNAME with SCRATCHFILE, e.g., as a result of a scavenge. On success, returns the new file name, otherwise returns NIL and, if an error was signaled, a CONDITION.") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (IGNORE-ERRORS (DELFILE FOLDERNAME) (RENAMEFILE SCRATCHFILE FOLDERNAME)))) -) (SMART-RENAMEFILEP -(LAMBDA (OBJECT) (* ; "Edited 1-May-89 12:31 by bvm") (* ;; "true if RENAMEFILE can be done intelligently on this path/stream/device") (LET ((DEV (CL:TYPECASE OBJECT (FDEV OBJECT) (STREAM (fetch (STREAM DEVICE) of OBJECT)) (T (\GETDEVICEFROMNAME OBJECT T))))) (AND DEV (CASE (fetch (FDEV RENAMEFILE) of DEV) ((NILL \GENERIC.RENAMEFILE) NIL) (T T))))) -) (LA.OPENTEMPFILE -(LAMBDA (EXTENSION ACCESS RECOG LENGTH) (* ; "Edited 3-Sep-87 16:29 by bvm:") (LET ((STREAM (OPENSTREAM (PACKFILENAME.STRING (QUOTE HOST) (QUOTE SCRATCH) (QUOTE NAME) (QUOTE LAFITETEMPORARY) (QUOTE EXTENSION) EXTENSION) (OR ACCESS (QUOTE OUTPUT)) (OR RECOG (QUOTE NEW)) NIL (AND LENGTH (LIST (LIST (QUOTE LENGTH) LENGTH)))))) (COND (STREAM (WHENCLOSE STREAM (QUOTE CLOSEALL) (QUOTE NO)) (LINELENGTH MAX.SMALLP STREAM) (if NIL then (* ; "save them so they can be deleted by LAFITE.QUIT") (* ;; "no need to keep list--they vanish via gc") (push \LAFITE.TEMPFILES (FULLNAME STREAM))) STREAM)))) -) ) (DEFINEQ (\LAFITE.UPDATE.FOLDER -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 10:55 by bvm") (* ;;; "Write out any changed marks in MAILFOLDER, but don't expunge deleted messages") (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) OUTSTREAM MSG) (if (fetch (MAILFOLDER FOLDEROUTOFORDER) of FOLDER) then (LAB.PROMPTPRINT FOLDER "Folder has been reordered, so can't simply write out changes--must Expunge.")) (LAB.PROMPTPRINT FOLDER "Writing out changes...") (for MSG# from (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) when (fetch (LAFITEMSG MARKSCHANGEDINFILE?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) do (WRITEFOLDERMARKBYTES MSG FOLDER (OR OUTSTREAM (SETQ OUTSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE OUTPUT) :ABORT))))) (\LAFITE.CLOSE.FOLDER FOLDER) (LAB.PROMPTPRINT FOLDER (COND (OUTSTREAM " done. ") (T "nothing changed. "))) (if (NOT (fetch (MAILFOLDER FOLDERNEEDSEXPUNGE) of FOLDER)) then (* ; "Everything is up to date now.") (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with (ADD1 (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) (replace (MAILFOLDER FOLDERNEEDSUPDATE) of FOLDER with NIL))) -) (\LAFITE.UPDATE.CONTENTS -(LAMBDA (MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") (* ;;; "Update the TOC file for MAILFOLDER, assuming that entries up to LASTUNCHANGEDMESSAGE# are okay.") (COND ((NLSETQ (\LAFITE.UPDATE.CONTENTS1 MAILFOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM)) (LAB.PROMPTPRINT MAILFOLDER " done.")) (T (LAB.PROMPTPRINT MAILFOLDER " failed."))) (* ;; "FOLDERNEEDSUPDATE set to NIL now either because toc was completely written or because toc was deleted on error, in which case 'Update Table of Contents' is still needed") (replace (MAILFOLDER FOLDERNEEDSUPDATE) of MAILFOLDER with NIL)) -) (\LAFITE.UPDATE.CONTENTS1 -(LAMBDA (FOLDER LASTUNCHANGEDMESSAGE# TOCSTREAM) (* ; "Edited 1-May-89 13:02 by bvm") (* ;; "Write the table of contents file for FOLDER. LASTUNCHANGEDMESSAGE# is the last message in the folder before compacting changes set in. Prior to that message, we'll only have to update flag bytes if anything. If TOCSTREAM is supplied, it is a stream already open for i/o on the toc file (from Expunge, which invalidates the toc password before trashing the mail file).") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) (MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (TOCSTART LAFITETOCHEADERLENGTH) FIRSTMSG# MSG) (COND ((> LASTMSG# 0) (LAB.PROMPTPRINT FOLDER "Writing table of contents...") (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM FOLDER) (SETQ STREAM (CLOSEF STREAM)) (COND (RESETSTATE (* ; "If we aborted out, assume toc is garbage") (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with 0) (DELFILE (FULLNAME STREAM)))))) (OR TOCSTREAM (SETQ TOCSTREAM (OPENSTREAM (TOCFILENAME FOLDER) (QUOTE BOTH) (QUOTE OLD/NEW) (QUOTE ((TYPE BINARY)))))) FOLDER)) (SETQ LASTUNCHANGEDMESSAGE# (IMIN LASTUNCHANGEDMESSAGE# (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER))) (COND ((EQ (GETEOFPTR TOCSTREAM) 0) (SETQ LASTUNCHANGEDMESSAGE# 0)) ((AND (EQ LASTUNCHANGEDMESSAGE# 0) (NEQ (PROGN (SETFILEPTR TOCSTREAM BYTESPERWORD) (WORDIN TOCSTREAM)) LAFITEVERSION#)) (* ; "A version number change, rewrite entire toc")) (T (* ; "TOC already existed, just update it") (for MSG# from 1 to LASTUNCHANGEDMESSAGE# do (COND ((fetch (LAFITEMSG MARKSCHANGEDINTOC?) of (SETQ MSG (NTHMESSAGE MESSAGES MSG#))) (* ; "Message not compacted out, but its mark bytes have changed") (SETFILEPTR TOCSTREAM TOCSTART) (WRITETOCMARKBYTES MSG TOCSTREAM) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL))) (add TOCSTART (fetch (LAFITEMSG TOCLENGTH) of MSG))))) (SETFILEPTR TOCSTREAM TOCSTART) (for MSG# from (ADD1 LASTUNCHANGEDMESSAGE#) to LASTMSG# do (WRITETOCENTRY (NTHMESSAGE MESSAGES MSG#) TOCSTREAM)) (SETFILEINFO TOCSTREAM (QUOTE LENGTH) (GETFILEPTR TOCSTREAM)) (SETFILEPTR TOCSTREAM 0) (* ; "Now write the header info") (WORDOUT TOCSTREAM LAFITETOCPASSWORD) (WORDOUT TOCSTREAM LAFITEVERSION#) (FIXPOUT TOCSTREAM (fetch (MAILFOLDER FOLDEREOFPTR) of FOLDER)) (WORDOUT TOCSTREAM LASTMSG#)) ((SETQ TOCSTREAM (INFILEP (TOCFILENAME FOLDER))) (LAB.PROMPTPRINT FOLDER "Deleting table of contents...") (DELFILE TOCSTREAM))) (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with LASTMSG#)))) -) (WRITETOCENTRY -(LAMBDA (MSG STREAM) (* ; "Edited 28-Apr-89 12:18 by bvm") (* ;;; "Dumps TOC entry for MSG on STREAM") (PROG ((TOCLENGTH 6) (MESSAGELENGTH (fetch (LAFITEMSG MESSAGELENGTH) of MSG)) DAT NC) (* ; "TOCLENGTH 6 counts for 3 bytes of message length, 1 byte each of stamplength, flags and mark.") (WRITETOCMARKBYTES MSG STREAM) (COND ((> MESSAGELENGTH MAX.SMALLP) (* ;; "Ugh, length greater than fits in one word. Would be surprised if this ever happens, but file format permits it") (LET ((HIWORD (LRSH MESSAGELENGTH BITSPERWORD))) (if (> HIWORD 254) then (* ; "a very long length, escape to 4 bytes of length") (BOUT STREAM 255) (WORDOUT STREAM HIWORD) (add TOCLENGTH 2) else (BOUT STREAM HIWORD))) (WORDOUT STREAM (LOGAND MESSAGELENGTH MAX.SMALLP))) (T (* ; "Normal case, a small length") (BOUT STREAM 0) (WORDOUT STREAM MESSAGELENGTH))) (BOUT STREAM (fetch (LAFITEMSG STAMPLENGTH) of MSG)) (if (fetch (LAFITEMSG DATEFETCHED?) of MSG) then (* ; "Write 4 bytes of idate") (\BOUTS STREAM MSG (UNFOLD (INDEXF (FETCH (LAFITEMSG IDATE))) BYTESPERWORD) 4) (add TOCLENGTH 4)) (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) then (* ; "Write 6 bytes of ascii string") (PRIN3 (COND ((EQ (SETQ NC (NCHARS (SETQ DAT (fetch (LAFITEMSG DATE) of MSG)))) 6) (* ; "The usual case") DAT) (T (OR (SUBSTRING DAT 1 6) (CONCAT DAT (ALLOCSTRING (IDIFFERENCE 6 NC) (CHARCODE SPACE)))))) STREAM) (add TOCLENGTH 6)) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG SUBJECT) of MSG))) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG FROM) of MSG))) (add TOCLENGTH (LA.PRINTSHORTSTRING STREAM (fetch (LAFITEMSG TO) of MSG))) (replace (LAFITEMSG TOCLENGTH) of MSG with TOCLENGTH) (replace (LAFITEMSG MARKSCHANGEDINTOC?) of MSG with NIL))) -) (WRITETOCMARKBYTES -(LAMBDA (MSG STREAM) (* bvm%: "20-Feb-84 12:53") (BOUT STREAM (fetch (LAFITEMSG MSGFLAGBITS) of MSG)) (BOUT STREAM (fetch (LAFITEMSG MARKCHAR) of MSG))) -) (WRITEFOLDERMARKBYTES -(LAMBDA (MSG MAILFOLDER OUTSTREAM) (* ; "Edited 21-Apr-89 12:41 by bvm") (* ;;; "Write the three magic flag bytes for MSG onto OUTSTREAM. If MAILFOLDER is supplied, then OUTSTREAM is MAILFOLDER's own file, and we will first position OUTSTREAM accordingly--otherwise caller has positioned us properly.") (COND (MAILFOLDER (MAYBEVERIFYMSG MSG MAILFOLDER) (SETFILEPTR OUTSTREAM (fetch (LAFITEMSG BEGIN) of MSG)) (OR (LA.READSTAMP OUTSTREAM) (HELP)) (COND ((fetch (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG) (* ; "Length is different in core and on file. This is for scavenging purposes") (LET ((LENPOS (GETFILEPTR OUTSTREAM)) LEN) (LA.READCOUNT OUTSTREAM T) (* ; "Skip over current length") (SETQ LEN (- (GETFILEPTR OUTSTREAM) LENPOS 1)) (* ; "Number of bytes of length--have to use the same format when overwriting it") (SETFILEPTR OUTSTREAM LENPOS) (LA.PRINTCOUNT (fetch (LAFITEMSG MESSAGELENGTH) of MSG) OUTSTREAM (BQUOTE (FIX (\, LEN) 10 T))) (BIN OUTSTREAM) (* ; "Skip over terminating space")) (replace (LAFITEMSG MESSAGELENGTHCHANGED?) of MSG with NIL)) (T (* ; "Just skip over lengths") (LA.READCOUNT OUTSTREAM T) (LA.READCOUNT OUTSTREAM T))))) (BOUT OUTSTREAM (COND ((fetch (LAFITEMSG DELETED?) of MSG) DELETEDFLAG) (T UNDELETEDFLAG))) (BOUT OUTSTREAM (COND ((fetch (LAFITEMSG SEEN?) of MSG) SEENFLAG) (T UNSEENFLAG))) (BOUT OUTSTREAM (fetch (LAFITEMSG MARKCHAR) of MSG)) (if MAILFOLDER then (replace (LAFITEMSG MARKSCHANGEDINFILE?) of MSG with NIL))) -) ) (* ; "HARDCOPY") (DEFINEQ (LAFITE.HARDCOPY.MESSAGES -(CL:LAMBDA (FOLDER MESSAGES &OPTIONAL (BATCHFLG NIL BATCHP)) (* ; "Edited 30-Aug-88 14:13 by bvm") (AND MESSAGES (\LAFITE.HARDCOPY.PROC FOLDER NIL NIL (\COERCE.TO.MSGLST MESSAGES) (if BATCHP then BATCHFLG else LAFITEHARDCOPYBATCHFLG)))) -) (\LAFITE.HARDCOPY -(LAMBDA (WINDOW FOLDER ITEM MENU) (* ; "Edited 23-Aug-88 15:45 by bvm") (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION \LAFITE.HARDCOPY.PROC)) (QUOTE (\, FOLDER)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) NIL (QUOTE (\, LAFITEHARDCOPYBATCHFLG)))) (QUOTE MESSAGEHARDCOPIER))) -) (\LAFITE.HARDCOPY.PROC -(LAMBDA (MAILFOLDER ITEM MENU MSGLST BATCHFLG) (* ; "Edited 23-Aug-88 15:37 by bvm") (PROG (LCASEFILENAME TEXTSTREAM) (RESETLST (LA.RESETSHADE ITEM MENU (AND BATCHFLG LAFITEHARDCOPYBATCHSHADE)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((OR MSGLST (NOT (LAB.ASSURE.SELECTIONS MAILFOLDER))) (LET (CONTINUEFLG) (OR MSGLST (SETQ MSGLST (LAB.SELECTED.MESSAGES MAILFOLDER))) (SETQ LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER))) (SETQ TEXTSTREAM (COND ((AND BATCHFLG (SETQ CONTINUEFLG (fetch (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER)))) ((AND (NOT BATCHFLG) LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) LAFITEHARDCOPY.MIN.TOC)) (\LAFITE.HARDCOPY.HEADERS MAILFOLDER LCASEFILENAME MSGLST)) (T (* ; "Start fresh") (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEHARDCOPYFONT))))) (\LAFITE.HARDCOPY.BODIES MAILFOLDER TEXTSTREAM MSGLST CONTINUEFLG) (COND (BATCHFLG (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYBATCHMARK) (replace (MAILFOLDER HARDCOPYSTREAM) of MAILFOLDER with TEXTSTREAM) (replace (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER with (NCONC (fetch (MAILFOLDER HARDCOPYMESSAGES) of MAILFOLDER) MSGLST)) (SETQ TEXTSTREAM)))))))) (COND (TEXTSTREAM (* ; "Send to printer now...") (\LAFITE.TRANSMIT.HARDCOPY MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME))))) -) (\LAFITE.HARDCOPY.HEADERS -(LAMBDA (MAILFOLDER LCASEFILENAME MESSAGES INCLUDE# TEXTSTREAM) (* ; "Edited 3-Jun-88 17:50 by bvm") (PROG ((OUTPUTFILE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW))) TITLELEN TITLE TOCSTART TOCLEN FROMSTR SUBJLEFT DATELEFT TABSTOPS) (LINELENGTH MAX.SMALLP OUTPUTFILE) (for MSG in MESSAGES as N from 1 do (* ;; "Each line consists of [#.]datefromsubject") (OR (fetch (LAFITEMSG PARSED?) of MSG) (LAFITE.PARSE.MSG.FOR.TOC MSG MAILFOLDER)) (POSITION OUTPUTFILE 0) (COND (INCLUDE# (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (CL:FORMAT OUTPUTFILE "~D." N) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)))) (PRIN3 (OR (fetch (LAFITEMSG DATE) of MSG) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (PRIN3 (OR (COND ((fetch (LAFITEMSG MSGFROMMEP) of MSG) (PRIN3 "To: " OUTPUTFILE) (OR (fetch (LAFITEMSG TO) of MSG) (LAFITE.FETCH.TO.FIELD MSG MAILFOLDER))) (T (fetch (LAFITEMSG FROM) of MSG))) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (\OUTCHAR OUTPUTFILE (CHARCODE TAB)) (PRIN3 (OR (fetch (LAFITEMSG SUBJECT) of MSG) UNSUPPLIEDFIELDSTR) OUTPUTFILE) (TERPRI OUTPUTFILE)) (SETQ OUTPUTFILE (OPENSTREAM (CLOSEF OUTPUTFILE) (QUOTE INPUT))) (SETQ TITLE (CL:FORMAT NIL "Messages from ~A~%%Listed on ~A~%%~%%" LCASEFILENAME (DATE))) (SETQ TITLELEN (NCHARS TITLE)) (COND (TEXTSTREAM (* ; "Need to insert all this stuff at beginning of textstream") (TEDIT.INSERT TEXTSTREAM TITLE 1)) (T (SETQ TEXTSTREAM (OPENTEXTSTREAM TITLE (AND NIL (CREATEW NIL "Lafite headers")) NIL NIL (LIST (QUOTE FONT) LAFITEHARDCOPYFONT))))) (PROGN (* ; "Make title centered") (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (QUAD CENTERED)) 1 (SUB1 TITLELEN)) (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (POSTPARALEADING 30)) (- TITLELEN 4) 1)) (PROGN (* ; "Insert toc lines. ") (SETQ TOCLEN (LA.TEDIT.INCLUDE TEXTSTREAM OUTPUTFILE (SETQ TOCSTART (ADD1 TITLELEN)))) (TEDIT.INSERT TEXTSTREAM (CONSTANT (CONCATCODES (CHARCODE (FF)))) (+ TOCSTART TOCLEN))) (* ; "Formfeed after the insertion") (PROGN (* ; "Now give the toc lines the appropriate tab settings.") (SETQ DATELEFT (COND (INCLUDE# 30) (T 0))) (SETQ TABSTOPS (LIST (CONS (+ DATELEFT 50) (QUOTE LEFT)) (CONS (SETQ SUBJLEFT (+ DATELEFT 170)) (QUOTE LEFT)))) (COND (INCLUDE# (push TABSTOPS (QUOTE (20 . RIGHT)) (CONS DATELEFT (QUOTE LEFT))))) (TEDIT.PARALOOKS TEXTSTREAM (BQUOTE (TABS (NIL (\,@ TABSTOPS)) LEFTMARGIN (\, (+ SUBJLEFT 20)))) TOCSTART (SUB1 TOCLEN))) (RETURN TEXTSTREAM))) -) (\LAFITE.MARK.HARDCOPIED -(LAMBDA (MAILFOLDER MSGS MARK) (* bvm%: "26-Feb-86 12:34") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (LET ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (LASTMSG (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) N) (COND (MESSAGES (* ; "If not, folder has been closed") (for MSG in MSGS when (AND (ILEQ (SETQ N (fetch (LAFITEMSG %#) of MSG)) LASTMSG) (EQ MSG (NTHMESSAGE MESSAGES N)) (SELCHARQ (fetch (LAFITEMSG MARKCHAR) of MSG) ((? SPACE H) T) NIL)) do (* ; "If message doesn't already have a more interesting mark, set the hardcopy mark") (MARKMESSAGE MSG MAILFOLDER MARK))))))) -) (\LAFITE.TRANSMIT.HARDCOPY -(LAMBDA (MAILFOLDER TEXTSTREAM MSGLST LCASEFILENAME) (* bvm%: " 2-Mar-84 13:32") (* ;;; "Sends TEXTSTREAM off to be hardcopied, then deletes it") (WITH.MONITOR \LAFITE.HARDCOPYLOCK (* ; "Because press isn't reentrant yet") (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (CONCAT (COND ((CDR MSGLST) (CONCAT (LENGTH MSGLST) " messages")) (T (CONCAT "Message #" (fetch (LAFITEMSG %#) of (CAR MSGLST))))) " from " (OR LCASEFILENAME (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of MAILFOLDER)))))) (CLOSEF TEXTSTREAM) (DELFILE TEXTSTREAM) (\LAFITE.MARK.HARDCOPIED MAILFOLDER MSGLST HARDCOPYMARK)) -) (\LAFITE.HARDCOPY.BODIES -(LAMBDA (MAILFOLDER TEXTSTREAM MESSAGES CONTINUEFLG NEXTMSG#) (* ; "Edited 23-Aug-88 12:50 by bvm") (for MSGDESCRIPTOR in MESSAGES bind (NTHTIME _ CONTINUEFLG) (INPUTFILE _ (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT)) do (COND ((NULL NTHTIME) (SETQ NTHTIME T)) ((OR LAFITENEWPAGEFLG CONTINUEFLG) (\OUTCHAR TEXTSTREAM (CHARCODE FF)) (SETQ CONTINUEFLG)) (T (TERPRI TEXTSTREAM) (COND ((NOT NEXTMSG#) (PRIN3 LAFITEHARDCOPYSEPARATOR TEXTSTREAM) (TERPRI TEXTSTREAM))))) (COND (NEXTMSG# (CL:FORMAT TEXTSTREAM "Message ~D~%%~%%" NEXTMSG#) (add NEXTMSG# 1))) (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM INPUTFILE MSGDESCRIPTOR \LAPARSE.DONT.HARDCOPY.HEADERS) (TEDIT.CARETLOOKS TEXTSTREAM LAFITEHARDCOPYFONT))) -) (\LAFITE.APPEND.MESSAGE.BODY -(LAMBDA (TEXTSTREAM MSGSTREAM MSGDESCRIPTOR FILTERS) (* ; "Edited 5-Aug-93 20:20 by bvm") (* ;; "Appends the text of the indicated message to TEXTSTREAM, filtering out any header fields found in FILTERS") (LET ((START (fetch (LAFITEMSG START) of MSGDESCRIPTOR)) (END (fetch (LAFITEMSG END) of MSGDESCRIPTOR)) (EOF (GETEOFPTR TEXTSTREAM)) FILTERED) (if FILTERS then (SETQ FILTERED (LAFITE.NEW.PARSE.HEADER MSGSTREAM FILTERS START END))) (TEDIT.SETSEL TEXTSTREAM (ADD1 EOF) 0 (QUOTE LEFT)) (* ; "Get selection right for TEDIT.INCLUDE") (TEDIT.INCLUDE TEXTSTREAM MSGSTREAM START END) (if FILTERED then (if (NOT (= (GETEOFPTR TEXTSTREAM) (+ EOF (- END START)))) then (* ; "Rats, we have to recalculate more slowly now, since there could be ns chars in header. TEdit counts them differently than the plain text file does") (SETQ FILTERED (LAFITE.PARSE.HEADER TEXTSTREAM FILTERS EOF))) (for PAIR in FILTERED do (* ; "Note: we are depending on the pairs being in reverse order from the parse, so that the deletions do not affect the char count") (TEDIT.DELETE TEXTSTREAM (+ EOF (- (CAR PAIR) START) 1) (- (CADR PAIR) (CAR PAIR))))) (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETEOFPTR TEXTSTREAM)) 0) (SETFILEPTR TEXTSTREAM -1))) -) (\LAFITE.DO.PENDING.HARDCOPY -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") (LET ((TEXTSTREAM (fetch (MAILFOLDER HARDCOPYSTREAM) of FOLDER)) (MSGLST (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) (COND (TEXTSTREAM (LAB.PROMPTPRINT FOLDER T "Hardcopying... ") (COND ((AND LAFITEHARDCOPY.MIN.TOC (>= (LENGTH MSGLST) LAFITEHARDCOPY.MIN.TOC)) (\LAFITE.HARDCOPY.HEADERS FOLDER (L-CASE (fetch (MAILFOLDER FULLFOLDERNAME) of FOLDER)) MSGLST NIL TEXTSTREAM))) (\LAFITE.TRANSMIT.HARDCOPY FOLDER TEXTSTREAM MSGLST) (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER) (LAB.PROMPTPRINT FOLDER "done. "))))) -) (\LAFITE.CANCEL.HARDCOPY -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:29 by bvm") (LET ((PENDING (fetch (MAILFOLDER HARDCOPYMESSAGES) of FOLDER))) (if (NOT PENDING) then (LAB.PROMPTPRINT FOLDER "No messages are queued for hardcopy") elseif (LAB.MOUSECONFIRM FOLDER "Click LEFT to cancel hardcopy of ~D message~:P" (LENGTH PENDING)) then (for MSG in PENDING do (* ; "Set mark back to space") (MARKMESSAGE MSG FOLDER SEENMARK)) (\LAFITE.CLEAR.HARDCOPY.STATE FOLDER)))) -) (\LAFITE.CLEAR.HARDCOPY.STATE -(LAMBDA (FOLDER) (* ; "Edited 20-Jan-89 14:28 by bvm") (* ;; "Clear all the places that think there is pending hardcopy") (replace (MAILFOLDER HARDCOPYSTREAM) of FOLDER with (replace (MAILFOLDER HARDCOPYMESSAGES) of FOLDER with NIL)) (LET ((MENU (fetch (MAILFOLDER BROWSERMENU) of FOLDER))) (* ; "Take the speckle off the menu") (SHADEITEM (LA.MENU.ITEM (FUNCTION \LAFITE.HARDCOPY) MENU) MENU WHITESHADE))) -) ) (ADDTOVAR LAFITEEXTRAMENUITEMS ("Cancel Pending Hardcopy" '\LAFITE.CANCEL.HARDCOPY "Forget about hardcopying the messages so far marked for hardcopy." )) (RPAQ? LAFITEHARDCOPYBATCHFLG NIL) (RPAQ? LAFITEHARDCOPY.MIN.TOC NIL) (RPAQ? LAFITEDISPLAYAFTERDELETEFLG T) (RPAQ? LAFITEMOVETOCONFIRMFLG 'ALWAYS) (RPAQ? LAFITENEWPAGEFLG T) (RPAQ? LAFITEENDOFMESSAGESTR "End of message") (RPAQ? LAFITEENDOFMESSAGEFONT (FONTCREATE '(TIMESROMAN 10 ITALIC))) (RPAQ? LAFITE.DISPLAY.SIZE '(500 . 300)) (RPAQ? LAFITE.BROWSER.LAYOUTS NIL) (RPAQ? LAFITE.MIDDLE.UPDATE '(:EXPUNGE :SHRINK :CONFIRM)) (RPAQ? LAFITEHARDCOPYBATCHSHADE 1025) (RPAQ? LAFITEHARDCOPYSEPARATOR "% - Next Message % -") (* ; "Obsolete") (RPAQ? LAFITEDISPLAYREGION (CREATEREGION 375 25 600 335)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) LAFITEDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA LAFITE.HARDCOPY.MESSAGES) ) (PUTPROPS LAFITECOMMANDS COPYRIGHT ("Xerox Corporation" 1988 1989 1992 1993 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7817 24106 (\LAFITE.DISPLAY 7827 . 8649) (\LAFITE.DO.DISPLAY 8651 . 12800) ( SELECTMESSAGETODISPLAY 12802 . 14115) (MESSAGEDISPLAYER 14117 . 21521) (LA.COPY.MESSAGE.TEXT 21523 . 22269) (\LAFITE.CLOSE.DISPLAYWINDOWS 22271 . 23140) (\LAFITE.CLOSE.DISPLAYER 23142 . 24104)) (24107 28944 (\LAFITE.UNHIDE.HEADERS 24117 . 24842) (\LAFITE.HIDE.HEADERS 24844 . 25132) ( \LAFITE.REHIDE.HEADERS 25134 . 25918) (LAFITE.EAT.UNDESIRABLE.FIELD 25920 . 26494) (LAFITE.EAT.GVGV 26496 . 27197) (\LAFITE.HARDCOPY.FROM.DISPLAY 27199 . 28706) (LAFITE.HARDCOPY.TAB.WIDTH 28708 . 28942) ) (28945 33913 (\LAFITE.SET.LOOKS.FROM.MENU 28955 . 29081) (\LAFITE.SET.DEFAULT.LOOKS 29083 . 29224) ( \LAFITE.SET.FIXED.LOOKS 29226 . 29368) (LAFITE.SET.LOOKS 29370 . 32004) (LAFITE.SET.TAB.LOOKS 32006 . 32436) (LAFITE.SET.PARA.SEPARATION 32438 . 32592) (LAFITE.SET.LOWER.CASE 32594 . 33035) ( LAFITE.SUBSTITUTE.VP.EOL 33037 . 33911)) (35983 40392 (LAFITE.DELETE.MESSAGES 35993 . 36420) ( \LAFITE.DELETE 36422 . 37006) (DISPLAYAFTERDELETE 37008 . 39488) (\LAFITE.SELECT.NEXT 39490 . 39981) ( \LAFITE.UNDELETE 39983 . 40390)) (40414 47933 (LAFITE.MOVE.MESSAGES 40424 . 40892) (\COERCE.TO.MSGLST 40894 . 41360) (\LAFITE.MOVETO 41362 . 43608) (\LAFITE.COPYTO 43610 . 43891) (\LAFITE.MOVETO.PROC 43893 . 44750) (\LAFITE.MOVE.MESSAGES.INTERNAL 44752 . 47931)) (47959 52916 (\LAFITE.ENABLE.MOVE.MENU 47969 . 48727) (\LAFITE.ADD.TO.MOVE.MENU 48729 . 49508) (\LAFITE.UPDATE.MOVE.MENU 49510 . 51814) ( \LAFITE.RESTORE.MOVE.MENU 51816 . 52190) (\LAFITE.HANDLE.AUTO.MOVE 52192 . 52914)) (53898 63464 ( \LAFITE.UPDATE 53908 . 56290) (\LAFITE.EXPUNGE.PROC 56292 . 56831) (\LAFITE.UPDATE.PROC 56833 . 57528) (\LAFITE.HARDCOPYONLY.PROC 57530 . 57895) (LAB.CHOOSE.UPDATE.MENU 57897 . 58480) ( LAB.CREATE.UPDATE.MENU 58482 . 59573) (LAB.UPDATE.NEEDED? 59575 . 60372) (\LAFITE.START.UPDATE 60374 . 61005) (LAB.START.COMMAND 61007 . 61670) (\LAFITE.FINISH.UPDATE 61672 . 62884) ( \LAFITE.CLOSE.OTHER.FOLDERS 62886 . 63462)) (63465 79983 (LAB.FLUSHWINDOW 63475 . 64262) ( LAB.APPENDMESSAGES 64264 . 65750) (\LAFITE.COMPACT.FOLDER 65752 . 67903) (\LAFITE.COMPACT.FOLDER1 67905 . 74578) (\LAFITE.COMPACT.FOLDER2 74580 . 76910) (\LAFITE.COMPACT.EXTRA 76912 . 78088) ( \LAFITE.INVALIDATE.TOC 78090 . 78581) (\LAFITE.RENAMEFILE 78583 . 78986) (SMART-RENAMEFILEP 78988 . 79364) (LA.OPENTEMPFILE 79366 . 79981)) (79984 87782 (\LAFITE.UPDATE.FOLDER 79994 . 81161) ( \LAFITE.UPDATE.CONTENTS 81163 . 81803) (\LAFITE.UPDATE.CONTENTS1 81805 . 84358) (WRITETOCENTRY 84360 . 86114) (WRITETOCMARKBYTES 86116 . 86293) (WRITEFOLDERMARKBYTES 86295 . 87780)) (87808 96974 ( LAFITE.HARDCOPY.MESSAGES 87818 . 88086) (\LAFITE.HARDCOPY 88088 . 88373) (\LAFITE.HARDCOPY.PROC 88375 . 89760) (\LAFITE.HARDCOPY.HEADERS 89762 . 92206) (\LAFITE.MARK.HARDCOPIED 92208 . 92856) ( \LAFITE.TRANSMIT.HARDCOPY 92858 . 93468) (\LAFITE.HARDCOPY.BODIES 93470 . 94207) ( \LAFITE.APPEND.MESSAGE.BODY 94209 . 95457) (\LAFITE.DO.PENDING.HARDCOPY 95459 . 96056) ( \LAFITE.CANCEL.HARDCOPY 96058 . 96528) (\LAFITE.CLEAR.HARDCOPY.STATE 96530 . 96972))))) STOP \ No newline at end of file diff --git a/library/lafite/LAFITEDECLS.~1~ b/library/lafite/LAFITEDECLS.~1~ deleted file mode 100644 index 3a093dd0..00000000 --- a/library/lafite/LAFITEDECLS.~1~ +++ /dev/null @@ -1,223 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Jun-89 12:10:42" {POOH/N}LAFITE>SOURCES>LAFITEDECLS;9 24176 - - changes to%: (VARS LAFITE.PROCLAMATIONS) - - previous date%: " 8-May-89 16:49:04" {POOH/N}LAFITE>SOURCES>LAFITEDECLS;8) - - -(* " -Copyright (c) 1985, 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITEDECLSCOMS) - -(RPAQQ LAFITEDECLSCOMS ((RECORDS LAFITEOPS LAFITEMODEDATA LAFITEMSG MAILFOLDER FOLDERGROUP DEFAULTHOST&DIR MAILSERVER MAILSERVEROPS OPENEDMAILBOX OUTBOX PROFILEVAR) (COMS (* ; "characteristics of standard Laurel messages") (CONSTANTS (LAFITEBASICSTAMPLENGTH 19) (LAFITESTAMPLENGTH 24) (DELETEDFLAG (CHARCODE D)) (UNDELETEDFLAG (CHARCODE U)) (SEENFLAG (CHARCODE S)) (UNSEENFLAG (CHARCODE U)) (DUPLICATEMARK 128))) (COMS (* ; "Stuff for table of contents") (CONSTANTS LAFITETOCPASSWORD LAFITETOCHEADERLENGTH)) (COMS (* ; "Browser status values. %"Ready%" values have low bit 1.") (CONSTANTS LAS.READY LAS.LOGGED.OUT) (CONSTANTS LAS.PARSING LAS.FLUSHED LAS.OUT.OF.DATE)) (COMS (* ; "Bits for figuring out which menu to use on Update, etc.") (CONSTANTS (\HARDCOPY.MENU.BIT 1) (\UPDATE.MENU.BIT 2) (\TOC.MENU.BIT 4) (\EXPUNGE.MENU.BIT 8) (\SORT.MENU.BIT 16) (\EXPUNGE&SORT.MENU.BIT 32) (\CLOSE.MENU.BIT 64) (\SHRINK.MENU.BIT 128))) (COMS (* ; "For iterating over the selected messages of a browser") (I.S.OPRS SELECTEDIN)) (MACROS WORDIN FIXPIN WORDOUT FIXPOUT UCASECODE NTHMESSAGE .LAFITEMENU. MAYBEVERIFYMSG UNSEENMARKP) (COMS (GLOBALVARS * LAFITEGLOBALS) (P (COND ((< (IDATE TEDITSYSTEMDATE) (IDATE "1-mar-88 00:00")) (* ; "Bug in older TEXTPROP--just compile it closed.") (REMPROP (QUOTE TEXTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAFITE-MODE-DATA* *UPPER-CASE-FILE-NAMES* \#DISPLAYLINES)))) (* ; "LAFITE.PROCLAMATIONS are exported to user in file LAFITE--these are the documented variables") (P * LAFITE.PROCLAMATIONS)) (COMS (* ; "For debugging with Masterscope, here are fns not called from code") (VARS LAFITE.CALLED.FROM.LITERALS LAFITE.PROGRAMMER.ENTRIES) (COMMANDS WHONOTLAFITE CHECKLAFITE)) (DECLARE%: DONTEVAL@COMPILE (TEMPLATES WINDOWPROP WINDOWADDPROP WINDOWDELPROP PROCESSPROP TEXTPROP)))) -(DECLARE%: EVAL@COMPILE - -(RECORD LAFITEOPS (LAFITEMODE MODEINDEX SENDPARSER SENDER ANSWERER AUTHENTICATOR MESSAGEP MESSAGE-FROM-SELFP LOGIN) -) - -(RECORD LAFITEMODEDATA (LAFITEOPS (FULLUSERNAME CREDENTIALS UNPACKEDUSERNAME SHORTUSERNAME FROMFIELD) MAILSERVERS) -) - -(DATATYPE LAFITEMSG ((PARSED? FLAG) (* ; "True if we have parsed the message, and thus filled in the fields DATE, FROM, SUBJECT below.") (DELETED? FLAG) (* ; "True if message marked for deletion") (SEEN? FLAG) (* ; "True if message is examined.") (DATEKNOWN? FLAG) (* ; "True if DATE field correctly parsed into IDATE [formerly formatted? flag]") (DATEFETCHED? FLAG) (* ; "True if IDATE field contains a date (could be guess)") (MODEBITS BITS 3) (* ; "Mode in which the message was received") (BEGIN POINTER) (* ; "Start of the whole message") (MARKCHAR BYTE) (* ; "Arbitrary mark byte") (MESSAGELENGTH POINTER) (* ; "Lengfth of whole message") (%# WORD) (* ; "Ordinal number of message") (STAMPLENGTH WORD) (* ; "Number of bytes in file header (usually 24)") (TOCLENGTH WORD) (* ; "Number of bytes this message consumes on toc") (NIL WORD) (MESSAGELENGTHCHANGED? FLAG) (* ; "True if we have decided that the true length of this message is different from what the file says") (NIL FLAG) (SELECTED? FLAG) (* ; "True if msg currently selected") (MSGFROMMECHECKED? FLAG) (* ; "True if we have tested whether this message is from self") (MSGFROMMETRUTH FLAG) (* ; "Is it?") (MARKSCHANGEDINFILE? FLAG) (MARKSCHANGEDINTOC? FLAG) (NIL FLAG) (DATE POINTER) (* ; "The fields of the parse (strings)") (FROM POINTER) (SUBJECT POINTER) (TO POINTER) (IDATE FIXP) (* ; "Integer form of DATE (for sorting)")) - (* ;; "BEGIN is the only absolute pointer into the message file -- all other positions are relative to BEGIN -- see the ACCESSFNS") - (BLOCKRECORD LAFITEMSG ((PARSED&DELETED&SEENBITS BITS 3) (* ; "For toc version 8") (DATEBITS BITS 2) (* ; "For toc version 10") (NIL BITS 3) (NIL POINTER))) - (BLOCKRECORD LAFITEMSG ((MSGFLAGBITS BITS 8) (NIL POINTER) (NIL BYTE) (NIL POINTER) (NIL WORD) (NIL WORD) (NIL WORD) (NIL WORD) (NIL BITS 5) (MARKSCHANGEDBITS BITS 2) (NIL BITS 1) (NIL 4 POINTER) (IDATEHI WORD) (IDATELO WORD))) - (ACCESSFNS LAFITEMSG ((END (+ (fetch (LAFITEMSG MESSAGELENGTH) of DATUM) (fetch (LAFITEMSG BEGIN) of DATUM))) (START (+ (fetch (LAFITEMSG BEGIN) of DATUM) (fetch (LAFITEMSG STAMPLENGTH) of DATUM))) (MSGFROMMEP (COND ((fetch (LAFITEMSG MSGFROMMECHECKED?) of DATUM) (fetch (LAFITEMSG MSGFROMMETRUTH) of DATUM)) (T (LA.MSGFROMMEP DATUM))) (PROG1 (replace (LAFITEMSG MSGFROMMETRUTH) of DATUM with NEWVALUE) (replace (LAFITEMSG MSGFROMMECHECKED?) of DATUM with T))) (MARKSCHANGED? (NEQ 0 (fetch (LAFITEMSG MARKSCHANGEDBITS) of DATUM)) (replace (LAFITEMSG MARKSCHANGEDBITS) of DATUM with 3)) (MODE (CL:NTH (fetch (LAFITEMSG MODEBITS) of DATUM) *LAFITE-WELL-KNOWN-MODES*) (replace (LAFITEMSG MODEBITS) of DATUM WITH (OR (CL:POSITION NEWVALUE *LAFITE-WELL-KNOWN-MODES*) 0))))) -) - -(DATATYPE MAILFOLDER ((BROWSERPROMPTDIRTY FLAG) (* ; "Something's been printed in prompt window") (BROWSERPROMPTGREW FLAG) (* ; "Browser prompt window has expanded") (FOLDERNEEDSUPDATE FLAG) (* ; "Something changed") (FOLDERNEEDSEXPUNGE FLAG) (* ; "True if deleted msgs") (FOLDERBEINGUPDATED FLAG) (* ; "True during Update cmd") (BROWSERSTATUS BITS 3) (* ; "Ready, etc.") (FULLFOLDERNAME POINTER) (* ; "Full name of actual file") (FOLDEROKTOSHRINK FLAG) (* ; "Kludge to allow you to call SHRINKW without invoking the Update? question") (FOLDERGETSMAIL FLAG) (* ; "True if GetMail ok") (FOLDEROUTOFORDER FLAG) (* ; "True if folder has been sorted") (NIL 5 FLAG) (VERSIONLESSFOLDERNAME POINTER) (* ; "Versionless for conflict check") (SHORTFOLDERNAME POINTER) (* ; "Normal name displayed to user") (FOLDERSTREAM POINTER) (* ; "Stream open on the file, or NIL") (MESSAGEDESCRIPTORS POINTER) (* ; "Array of LAFITEMSG") (FOLDERLOCK POINTER) (* ; "Monitor lock for all access") (%#OFMESSAGES WORD) (TOCLASTMESSAGE# WORD) (* ; "Last message that is in TOC file") (BROWSERFONTHEIGHT WORD) (* ; "Cached info about browser font") (BROWSERFONTASCENT WORD) (BROWSERFONTDESCENT WORD) (BROWSERMAXXPOS WORD) (* ; "For extent computations") (ORDINALXPOS WORD) (* ; "Where msg # starts") (DATEXPOS WORD) (* ; "Where msg date starts") (FROMXPOS WORD) (* ; "Where msg From starts") (FROMMAXXPOS WORD) (* ; "Beyond here, From is truncated") (SUBJECTXPOS WORD) (* ; "Where msg subject starts") (BROWSERDIGITWIDTH WORD) (FIRSTSELECTEDMESSAGE WORD) (* ; "First/last msgs currently selected") (LASTSELECTEDMESSAGE WORD) (FIRSTCHANGEDMESSAGE WORD) (* ; "First message with any change--not currently used") (CURRENTPROMPTLINE WORD) (* ; "Value of \currentdisplayline for browser prompt") (CURRENTDISPLAYEDSTREAM POINTER) (* ; "The backing core file for the current message (not used interestingly)") (BROWSEREXTENT POINTER) (BROWSERORIGIN POINTER) (FOLDERDISPLAYREGION POINTER) (* ; "Region of display window (valid when browser shrunk)") (BROWSERWINDOW POINTER) (* ; "The browser window and various pieces...") (BROWSERMENU POINTER) (BROWSERMENUWINDOW POINTER) (BROWSERPROMPTWINDOW POINTER) (ORIGINALBROWSERTITLE POINTER) (* ; "Original title before we added %"default move to%"") (FOLDERDISPLAYWINDOWS POINTER) (* ; "WIndows currently displaying messages from this folder. First element is %"primary%" display window, or NIL") (FOLDEREOFPTR POINTER) (* ; "Length of file") (DEFAULTMOVETOFILE POINTER) (* ; "Folder we last moved to, or NIL") (CURRENTDISPLAYEDMESSAGE POINTER) (* ; "Message descriptor of most recently displayed message") (BROWSERUPDATEFROMHERE POINTER) (* ; "First potentially changed message, from which redisplay needs to occur when icon expands.") (BROWSERLAYOUT POINTER) (* ; "The element of LAFITEBROWSERLAYOUTS used to build this window, if any") (FOLDERCREATIONDATE POINTER) (* ; "the ICREATIONDATE of the file") (HARDCOPYMESSAGES POINTER) (* ; "List of msg descriptors being hardcopied") (HARDCOPYSTREAM POINTER) (* ; "A Textstream for pending hardcopy")) - (BLOCKRECORD MAILFOLDER ((NIL 5 FLAG) (NIL BITS 2) (BROWSERREADYBIT FLAG) (* ; "Low bit of status on means ready"))) - (ACCESSFNS MAILFOLDER ((BROWSERREADY (fetch (MAILFOLDER BROWSERREADYBIT) of DATUM) (REPLACE (MAILFOLDER BROWSERSTATUS) OF DATUM WITH (COND (NEWVALUE LAS.READY) (T LAS.PARSING)))))) -) - -(RECORD FOLDERGROUP (FGNAME (FGTOPLEVEL . FGSUBGROUPS) . FGFOLDERS)) - -(RECORD DEFAULTHOST&DIR (PACKEDHOST&DIR . UNPACKEDHOST&DIR) (PROPRECORD UNPACKEDHOST&DIR (DEFAULTDIR DEFAULTHOST DEFAULTDEV)) -) - -(RECORD MAILSERVER (MAILSERVEROPS MAILPORT MAILSERVERNAME CONTINUANCE NEWMAILP . MAILSTATE)) - -(RECORD MAILSERVEROPS (POLLNEWMAIL OPENMAILBOX NEXTMESSAGE RETRIEVEMESSAGE CLOSEMAILBOX SERVERPORTFROMNAME) -) - -(RECORD OPENEDMAILBOX (MAILBOX . PROPERTIES) (PROPRECORD PROPERTIES (%#OFMESSAGES))) - -(RECORD OUTBOX (OBWINDOW OBSIZE OBHEIGHT OBDESCENT OBORIGIN OBITEMS)) - -(RECORD PROFILEVAR (PFVARNAME PFRECONCILIATIONFN PFLOADFN PFDUMPFN)) -) - -(/DECLAREDATATYPE (QUOTE LAFITEMSG) (QUOTE (FLAG FLAG FLAG FLAG FLAG (BITS 3) POINTER BYTE POINTER WORD WORD WORD WORD FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER FIXP)) (QUOTE ((LAFITEMSG 0 (FLAGBITS . 0)) (LAFITEMSG 0 (FLAGBITS . 16)) (LAFITEMSG 0 (FLAGBITS . 32)) (LAFITEMSG 0 (FLAGBITS . 48)) (LAFITEMSG 0 (FLAGBITS . 64)) (LAFITEMSG 0 (BITS . 82)) (LAFITEMSG 0 POINTER) (LAFITEMSG 2 (BITS . 7)) (LAFITEMSG 2 POINTER) (LAFITEMSG 4 (BITS . 15)) (LAFITEMSG 5 (BITS . 15)) (LAFITEMSG 6 (BITS . 15)) (LAFITEMSG 7 (BITS . 15)) (LAFITEMSG 8 (FLAGBITS . 0)) (LAFITEMSG 8 (FLAGBITS . 16)) (LAFITEMSG 8 (FLAGBITS . 32)) (LAFITEMSG 8 (FLAGBITS . 48)) (LAFITEMSG 8 (FLAGBITS . 64)) (LAFITEMSG 8 (FLAGBITS . 80)) (LAFITEMSG 8 (FLAGBITS . 96)) (LAFITEMSG 8 (FLAGBITS . 112)) (LAFITEMSG 8 POINTER) (LAFITEMSG 10 POINTER) (LAFITEMSG 12 POINTER) (LAFITEMSG 14 POINTER) (LAFITEMSG 16 FIXP))) (QUOTE 18)) - -(/DECLAREDATATYPE (QUOTE MAILFOLDER) (QUOTE (FLAG FLAG FLAG FLAG FLAG (BITS 3) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((MAILFOLDER 0 (FLAGBITS . 0)) (MAILFOLDER 0 (FLAGBITS . 16)) (MAILFOLDER 0 (FLAGBITS . 32)) (MAILFOLDER 0 (FLAGBITS . 48)) (MAILFOLDER 0 (FLAGBITS . 64)) (MAILFOLDER 0 (BITS . 82)) (MAILFOLDER 0 POINTER) (MAILFOLDER 2 (FLAGBITS . 0)) (MAILFOLDER 2 (FLAGBITS . 16)) (MAILFOLDER 2 (FLAGBITS . 32)) (MAILFOLDER 2 (FLAGBITS . 48)) (MAILFOLDER 2 (FLAGBITS . 64)) (MAILFOLDER 2 (FLAGBITS . 80)) (MAILFOLDER 2 (FLAGBITS . 96)) (MAILFOLDER 2 (FLAGBITS . 112)) (MAILFOLDER 2 POINTER) (MAILFOLDER 4 POINTER) (MAILFOLDER 6 POINTER) (MAILFOLDER 8 POINTER) (MAILFOLDER 10 POINTER) (MAILFOLDER 12 (BITS . 15)) (MAILFOLDER 13 (BITS . 15)) (MAILFOLDER 14 (BITS . 15)) (MAILFOLDER 15 (BITS . 15)) (MAILFOLDER 16 (BITS . 15)) (MAILFOLDER 17 (BITS . 15)) (MAILFOLDER 18 (BITS . 15)) (MAILFOLDER 19 (BITS . 15)) (MAILFOLDER 20 (BITS . 15)) (MAILFOLDER 21 (BITS . 15)) (MAILFOLDER 22 (BITS . 15)) (MAILFOLDER 23 (BITS . 15)) (MAILFOLDER 24 (BITS . 15)) (MAILFOLDER 25 (BITS . 15)) (MAILFOLDER 26 (BITS . 15)) (MAILFOLDER 27 (BITS . 15)) (MAILFOLDER 28 POINTER) (MAILFOLDER 30 POINTER) (MAILFOLDER 32 POINTER) (MAILFOLDER 34 POINTER) (MAILFOLDER 36 POINTER) (MAILFOLDER 38 POINTER) (MAILFOLDER 40 POINTER) (MAILFOLDER 42 POINTER) (MAILFOLDER 44 POINTER) (MAILFOLDER 46 POINTER) (MAILFOLDER 48 POINTER) (MAILFOLDER 50 POINTER) (MAILFOLDER 52 POINTER) (MAILFOLDER 54 POINTER) (MAILFOLDER 56 POINTER) (MAILFOLDER 58 POINTER) (MAILFOLDER 60 POINTER) (MAILFOLDER 62 POINTER))) (QUOTE 64)) - - - -(* ; "characteristics of standard Laurel messages") - -(DECLARE%: EVAL@COMPILE - -(RPAQQ LAFITEBASICSTAMPLENGTH 19) - -(RPAQQ LAFITESTAMPLENGTH 24) - -(RPAQ DELETEDFLAG (CHARCODE D)) - -(RPAQ UNDELETEDFLAG (CHARCODE U)) - -(RPAQ SEENFLAG (CHARCODE S)) - -(RPAQ UNSEENFLAG (CHARCODE U)) - -(RPAQQ DUPLICATEMARK 128) - - -(CONSTANTS (LAFITEBASICSTAMPLENGTH 19) (LAFITESTAMPLENGTH 24) (DELETEDFLAG (CHARCODE D)) (UNDELETEDFLAG (CHARCODE U)) (SEENFLAG (CHARCODE S)) (UNSEENFLAG (CHARCODE U)) (DUPLICATEMARK 128)) -) - - - -(* ; "Stuff for table of contents") - -(DECLARE%: EVAL@COMPILE - -(RPAQQ LAFITETOCPASSWORD 45610) - -(RPAQQ LAFITETOCHEADERLENGTH 10) - - -(CONSTANTS LAFITETOCPASSWORD LAFITETOCHEADERLENGTH) -) - - - -(* ; "Browser status values. %"Ready%" values have low bit 1.") - -(DECLARE%: EVAL@COMPILE - -(RPAQQ LAS.READY 1) - -(RPAQQ LAS.LOGGED.OUT 3) - - -(CONSTANTS LAS.READY LAS.LOGGED.OUT) -) -(DECLARE%: EVAL@COMPILE - -(RPAQQ LAS.PARSING 0) - -(RPAQQ LAS.FLUSHED 2) - -(RPAQQ LAS.OUT.OF.DATE 4) - - -(CONSTANTS LAS.PARSING LAS.FLUSHED LAS.OUT.OF.DATE) -) - - - -(* ; "Bits for figuring out which menu to use on Update, etc.") - -(DECLARE%: EVAL@COMPILE - -(RPAQQ \HARDCOPY.MENU.BIT 1) - -(RPAQQ \UPDATE.MENU.BIT 2) - -(RPAQQ \TOC.MENU.BIT 4) - -(RPAQQ \EXPUNGE.MENU.BIT 8) - -(RPAQQ \SORT.MENU.BIT 16) - -(RPAQQ \EXPUNGE&SORT.MENU.BIT 32) - -(RPAQQ \CLOSE.MENU.BIT 64) - -(RPAQQ \SHRINK.MENU.BIT 128) - - -(CONSTANTS (\HARDCOPY.MENU.BIT 1) (\UPDATE.MENU.BIT 2) (\TOC.MENU.BIT 4) (\EXPUNGE.MENU.BIT 8) (\SORT.MENU.BIT 16) (\EXPUNGE&SORT.MENU.BIT 32) (\CLOSE.MENU.BIT 64) (\SHRINK.MENU.BIT 128)) -) - - - -(* ; "For iterating over the selected messages of a browser") - -(DECLARE%: EVAL@COMPILE - -(I.S.OPR (QUOTE SELECTEDIN) NIL (QUOTE (bind ($$MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of BODY)) ($$MSG# _ (SUB1 (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of BODY))) ($$MSGLAST _ (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of BODY)) until (IGREATERP (add $$MSG# 1) $$MSGLAST) when (fetch (LAFITEMSG SELECTED?) of (SETQ I.V. (NTHMESSAGE $$MESSAGES $$MSG#)))))) -) -(DECLARE%: EVAL@COMPILE - -(PROGN (PUTPROPS WORDIN DMACRO (= . \WIN)) (PUTPROPS WORDIN MACRO (= . \WIN))) - -(PUTPROPS FIXPIN DMACRO (OPENLAMBDA (STREAM) (\MAKENUMBER (WORDIN STREAM) (WORDIN STREAM)))) - -(PUTPROPS WORDOUT DMACRO (= . \WOUT)) - -(PUTPROPS FIXPOUT DMACRO (OPENLAMBDA (STREAM N) (PROGN (WORDOUT STREAM (LRSH N 16)) (WORDOUT STREAM (LOGAND N 65535))))) - -(PUTPROPS UCASECODE MACRO (OPENLAMBDA (CHAR) (COND ((AND (IGEQ CHAR (CHARCODE a)) (ILEQ CHAR (CHARCODE z))) (LOGAND CHAR 95)) (T CHAR)))) - -(PUTPROPS NTHMESSAGE MACRO (= . ELT)) - -(PUTPROPS .LAFITEMENU. MACRO ((NAME ITEMS TITLE) (PROGN (DECLARE (GLOBALVARS NAME)) (OR NAME (SETQ NAME (\LAFITE.CREATE.MENU ITEMS TITLE)))))) - -(PUTPROPS MAYBEVERIFYMSG MACRO ((MSG MAILFOLDER) (AND LAFITEVERIFYFLG (\LAFITE.VERIFYMSG MSG MAILFOLDER)))) - -(PUTPROPS UNSEENMARKP MACRO (OPENLAMBDA (MK) (OR (EQ MK UNSEENMARK) (EQ MK HEARDMARK)))) -) - -(RPAQQ LAFITEGLOBALS (*LAFITE-WELL-KNOWN-MODES* ANOTHERFOLDERMENUITEM AROUNDEXITFNS BackgroundMenu BackgroundMenuCommands FORWARDMARK HARDCOPYBATCHMARK HARDCOPYMARK HEARDMARK LA.CROSSCURSOR LA.SELECTION.BITMAP LAFITE.PERSONAL.VARS LAFITE.UPDATE.MENU.HASH LAFITE.USER.INFO LAFITEEOL LAFITEFOLDERSMENU LAFITEFORMSMENU LAFITEITEMBUSYSHADE LAFITEMAILFOLDERS LAFITEMAINMENU LAFITEMULTIPLEFOLDERSMENU LAFITEPROFILERDTBL LAFITESTATUSWINDOW LAFITESUBBROWSEMENU LAFITESUBQUITMENU LAFITESYSTEMDATE LAFITEVERSION# LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY LOGINHOST/DIR PROMPTWINDOW SCREENHEIGHT SCREENWIDTH SEENMARK UNSEENMARK UNSUPPLIEDFIELDSTR UPPERCASEARRAY WINDOWTITLEFONT \ACTIVELAFITEFOLDERS \AFTERLOGINFNS \LAFITE.ACTIVE \LAFITE.ACTIVE.MODES \LAFITE.BROWSELOCK \LAFITE.CURRENT.USER \LAFITE.HARDCOPYLOCK \LAFITE.LAST.STATUS \LAFITE.MAILSERVERLOCK \LAFITE.MAINLOCK \LAFITE.MODE.CHOICES \LAFITE.OUTBOX \LAFITE.PROFILELOCK \LAFITE.PSEUDO.DEVICES \LAFITE.READY \LAFITE.TEMPFILES \LAFITEDEFAULTHOST&DIR \LAFITEMODE \LAFITEPROFILECHANGED \LAFITEPROFILEDATE \LAPARSE.DONT.DISPLAY.HEADERS \LAPARSE.DONT.FORWARD.HEADERS \LAPARSE.DONT.HARDCOPY.HEADERS LAFITE.FOLDER.STRUCTURE LAFITE.SPACER.MENU.ITEM)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *LAFITE-WELL-KNOWN-MODES* ANOTHERFOLDERMENUITEM AROUNDEXITFNS BackgroundMenu BackgroundMenuCommands FORWARDMARK HARDCOPYBATCHMARK HARDCOPYMARK HEARDMARK LA.CROSSCURSOR LA.SELECTION.BITMAP LAFITE.PERSONAL.VARS LAFITE.UPDATE.MENU.HASH LAFITE.USER.INFO LAFITEEOL LAFITEFOLDERSMENU LAFITEFORMSMENU LAFITEITEMBUSYSHADE LAFITEMAILFOLDERS LAFITEMAINMENU LAFITEMULTIPLEFOLDERSMENU LAFITEPROFILERDTBL LAFITESTATUSWINDOW LAFITESUBBROWSEMENU LAFITESUBQUITMENU LAFITESYSTEMDATE LAFITEVERSION# LASTMOUSEBUTTONS LASTMOUSEX LASTMOUSEY LOGINHOST/DIR PROMPTWINDOW SCREENHEIGHT SCREENWIDTH SEENMARK UNSEENMARK UNSUPPLIEDFIELDSTR UPPERCASEARRAY WINDOWTITLEFONT \ACTIVELAFITEFOLDERS \AFTERLOGINFNS \LAFITE.ACTIVE \LAFITE.ACTIVE.MODES \LAFITE.BROWSELOCK \LAFITE.CURRENT.USER \LAFITE.HARDCOPYLOCK \LAFITE.LAST.STATUS \LAFITE.MAILSERVERLOCK \LAFITE.MAINLOCK \LAFITE.MODE.CHOICES \LAFITE.OUTBOX \LAFITE.PROFILELOCK \LAFITE.PSEUDO.DEVICES \LAFITE.READY \LAFITE.TEMPFILES \LAFITEDEFAULTHOST&DIR \LAFITEMODE \LAFITEPROFILECHANGED \LAFITEPROFILEDATE \LAPARSE.DONT.DISPLAY.HEADERS \LAPARSE.DONT.FORWARD.HEADERS \LAPARSE.DONT.HARDCOPY.HEADERS LAFITE.FOLDER.STRUCTURE LAFITE.SPACER.MENU.ITEM) -) - -(COND ((< (IDATE TEDITSYSTEMDATE) (IDATE "1-mar-88 00:00")) (* ; "Bug in older TEXTPROP--just compile it closed.") (REMPROP (QUOTE TEXTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) - -(CL:PROCLAIM (QUOTE (CL:SPECIAL *LAFITE-MODE-DATA* *UPPER-CASE-FILE-NAMES* \#DISPLAYLINES))) - - - -(* ; "LAFITE.PROCLAMATIONS are exported to user in file LAFITE--these are the documented variables") - - -(RPAQQ LAFITE.PROCLAMATIONS ((CL:PROCLAIM (QUOTE (GLOBAL ANSWERMARK BROWSERMARKXPOSITION DEFAULTMAILFOLDERNAME LAFITE.2COLUMN.MENU.MIN.ITEMS LAFITE.AUTO.MOVE.MENU LAFITE.BACKGROUND.ITEM LAFITE.BROWSER.ICON.PREFERENCE LAFITE.BROWSER.LAYOUTS LAFITE.DISPLAY.SIZE LAFITE.DONT.DISPLAY.HEADERS LAFITE.DONT.FORWARD.HEADERS LAFITE.DONT.HARDCOPY.HEADERS LAFITE.DUMMY.HALF.SHADE LAFITE.DUMMY.SHADE LAFITE.EDITOR.LAYOUTS LAFITE.EDITOR.SIZE LAFITE.EXTRA.DISPLAY.COMMANDS LAFITE.EXTRA.MOVE.ITEMS LAFITE.FOLDER.ICON LAFITE.FOLDER.MENU.FONT LAFITE.HOST.ABBREVS LAFITE.LOOKS.SUBCOMMANDS LAFITE.MIDDLE.UPDATE LAFITE.PROFILE.VARS LAFITE.SIGNATURE LAFITE.USE.ALL.MODES LAFITEBROWSERFONT LAFITEBROWSERICONMENU LAFITEBROWSERICONMENUITEMS LAFITEBROWSERMENUITEMS LAFITEBROWSERREGION LAFITEBUFFERSIZE LAFITEBUSYWAITTIME LAFITECLOSEITEM LAFITECOMMANDMENUITEMS LAFITEDEFAULTHOST&DIR LAFITEDELETEDLINEHEIGHT LAFITEDISPLAYAFTERDELETEFLG LAFITEDISPLAYFONT LAFITEDISPLAYREGION LAFITEDL.EXT LAFITEDLDIRECTORIES LAFITEENDOFMESSAGEFONT LAFITEENDOFMESSAGESTR LAFITEEXTRAMENUFLG LAFITEEXTRAMENUITEMS LAFITEFIXEDWIDTHFONT LAFITEFORM.EXT LAFITEFORMFILES LAFITEFROMFRACTION LAFITEHARDCOPY.MIN.TOC LAFITEHARDCOPYBATCHFLG LAFITEHARDCOPYBATCHSHADE LAFITEHARDCOPYFONT LAFITEHARDCOPYSEPARATOR LAFITEIFFROMMETHENSEENFLG LAFITEINFO.NAME LAFITEMAIL.EXT LAFITEMENUFONT LAFITEMENUVARS LAFITEMINFROMCHARS LAFITEMODEDEFAULT LAFITEMODELST LAFITEMOVETOCONFIRMFLG LAFITEMSGICONFONT LAFITENEWPAGEFLG LAFITESHOWMODEFLG LAFITESTATUSWINDOWMINWIDTH LAFITESTATUSWINDOWPOSITION LAFITESUBBROWSEMENUITEMS LAFITESUBQUITMENUITEMS LAFITETITLEFONT LAFITETOC.EXT LAFITEUPDATEMENUITEMS MOVETOMARK))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LAFITEVERIFYFLG))))) - -(CL:PROCLAIM (QUOTE (GLOBAL ANSWERMARK BROWSERMARKXPOSITION DEFAULTMAILFOLDERNAME LAFITE.2COLUMN.MENU.MIN.ITEMS LAFITE.AUTO.MOVE.MENU LAFITE.BACKGROUND.ITEM LAFITE.BROWSER.ICON.PREFERENCE LAFITE.BROWSER.LAYOUTS LAFITE.DISPLAY.SIZE LAFITE.DONT.DISPLAY.HEADERS LAFITE.DONT.FORWARD.HEADERS LAFITE.DONT.HARDCOPY.HEADERS LAFITE.DUMMY.HALF.SHADE LAFITE.DUMMY.SHADE LAFITE.EDITOR.LAYOUTS LAFITE.EDITOR.SIZE LAFITE.EXTRA.DISPLAY.COMMANDS LAFITE.EXTRA.MOVE.ITEMS LAFITE.FOLDER.ICON LAFITE.FOLDER.MENU.FONT LAFITE.HOST.ABBREVS LAFITE.LOOKS.SUBCOMMANDS LAFITE.MIDDLE.UPDATE LAFITE.PROFILE.VARS LAFITE.SIGNATURE LAFITE.USE.ALL.MODES LAFITEBROWSERFONT LAFITEBROWSERICONMENU LAFITEBROWSERICONMENUITEMS LAFITEBROWSERMENUITEMS LAFITEBROWSERREGION LAFITEBUFFERSIZE LAFITEBUSYWAITTIME LAFITECLOSEITEM LAFITECOMMANDMENUITEMS LAFITEDEFAULTHOST&DIR LAFITEDELETEDLINEHEIGHT LAFITEDISPLAYAFTERDELETEFLG LAFITEDISPLAYFONT LAFITEDISPLAYREGION LAFITEDL.EXT LAFITEDLDIRECTORIES LAFITEENDOFMESSAGEFONT LAFITEENDOFMESSAGESTR LAFITEEXTRAMENUFLG LAFITEEXTRAMENUITEMS LAFITEFIXEDWIDTHFONT LAFITEFORM.EXT LAFITEFORMFILES LAFITEFROMFRACTION LAFITEHARDCOPY.MIN.TOC LAFITEHARDCOPYBATCHFLG LAFITEHARDCOPYBATCHSHADE LAFITEHARDCOPYFONT LAFITEHARDCOPYSEPARATOR LAFITEIFFROMMETHENSEENFLG LAFITEINFO.NAME LAFITEMAIL.EXT LAFITEMENUFONT LAFITEMENUVARS LAFITEMINFROMCHARS LAFITEMODEDEFAULT LAFITEMODELST LAFITEMOVETOCONFIRMFLG LAFITEMSGICONFONT LAFITENEWPAGEFLG LAFITESHOWMODEFLG LAFITESTATUSWINDOWMINWIDTH LAFITESTATUSWINDOWPOSITION LAFITESUBBROWSEMENUITEMS LAFITESUBQUITMENUITEMS LAFITETITLEFONT LAFITETOC.EXT LAFITEUPDATEMENUITEMS MOVETOMARK))) - -(CL:PROCLAIM (QUOTE (CL:SPECIAL LAFITEVERIFYFLG))) - - - -(* ; "For debugging with Masterscope, here are fns not called from code") - - -(RPAQQ LAFITE.CALLED.FROM.LITERALS (GV.CLOSEMAILBOX GV.INIT.MAIL.USER GV.MAKEANSWERFORM GV.NEXTMESSAGE GV.OPENMAILBOX GV.POLLNEWMAIL GV.PORTFROMNAME GV.RETRIEVEMESSAGE LAFITE.COMPUTE.CACHED.VARS LAFITE.GRAB.DATE LAFITE.ON.FROM.BACKGROUND LAFITE.PARSE.DATE.FIELD.ONLY LAFITE.READ.FORMAT LAFITE.READ.LINE.FOR.TOC LAFITE.READ.NAME.FIELD LAFITE.READ.ONE.LINE.FOR.TOC LAFITE.RENAME.GROUP MAKELAFITESUPPORTFORM MAKELISPSUPPORTFORM SET.LAFITE.MODE.INTERACTIVELY \GV.MESSAGE.FROM.SELF.P \GV.MESSAGE.P \GV.SEND.PARSE \GV.SENDMESSAGE \LAFITE.ANSWER \LAFITE.BROWSE \LAFITE.BROWSE.FORGET \LAFITE.BROWSE.PROC \LAFITE.CANCEL.HARDCOPY \LAFITE.COPYTO \LAFITE.DELETE \LAFITE.DELETE.GROUP \LAFITE.DESCRIBE.FOLDER \LAFITE.DISPLAY \LAFITE.EDIT.HIERARCHY \LAFITE.ENABLE.MOVE.MENU \LAFITE.EXPUNGE.PROC \LAFITE.FIND \LAFITE.FIND.AGAIN \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD \LAFITE.FORWARD \LAFITE.GC.FOLDERS \LAFITE.GETMAIL \LAFITE.GETMAIL.FROM.ICON \LAFITE.GLOBAL.INIT \LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST \LAFITE.HARDCOPY \LAFITE.HARDCOPY.FROM.DISPLAY \LAFITE.HARDCOPYONLY.PROC \LAFITE.LOGIN.NORESTART \LAFITE.MERGE.FOLDERS \LAFITE.MERGE.NAMELISTS \LAFITE.MERGE.STRUCTURES \LAFITE.MESSAGEFORM \LAFITE.MOVETO \LAFITE.NOTICE.FOLDERS \LAFITE.QUIT \LAFITE.QUIT \LAFITE.REAUTHENTICATE \LAFITE.REHIDE.HEADERS \LAFITE.RENAME.FOLDER \LAFITE.RESTART \LAFITE.RESTORE.MOVE.MENU \LAFITE.SET.DEFAULT.LOOKS \LAFITE.SET.FIXED.LOOKS \LAFITE.SET.LOOKS.FROM.MENU \LAFITE.SORT.BY.DATE.REGION \LAFITE.UNCACHE.FOLDER \LAFITE.UNCACHE.MESSAGEFORM \LAFITE.UNDELETE \LAFITE.UNHIDE.HEADERS \LAFITE.UPDATE \LAFITE.UPDATE.PROC \LAFITE.UPDATE.PROC \MAILOBJ.EXPAND \MAILOBJ.FB \MAILOBJ.HARDCOPY \MAILOBJ.INIT \MAILOBJ.PUT.FILE \MAILOBJ.VIEW \NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM \NSMAIL.AUTHENTICATE \NSMAIL.LOGIN \NSMAIL.MAKEANSWERFORM \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.MESSAGE.P \NSMAIL.SEND \NSMAIL.SEND.PARSE \SENDMSG.CHANGE.MODE \SENDMSG.DELIVER \SENDMSG.SAVE.FORM)) - -(RPAQQ LAFITE.PROGRAMMER.ENTRIES (LAFITEDEFAULTHOST&DIR LOAD-LAFITE LAFITE.SENDMESSAGE BUILD.LAFITE.LAYOUTS LAB.SELECTED.MESSAGES LAFITE.DELETE.MESSAGES LAFITE.MOVE.MESSAGES LAFITE.HARDCOPY.MESSAGES LAFITE.OBTAIN.FOLDER MAILSCAVENGE MS.EXPAND GV.READTOC GV.WRITETOC GV.DELETEMESSAGE)) - -(DEFCOMMAND (WHONOTLAFITE :HISTORY) NIL (QUOTE ((CL:SET-DIFFERENCE (CL:SET-DIFFERENCE (%. WHO ON ANY IN LAFITEFILES IS NOT CALLED) LAFITE.CALLED.FROM.LITERALS) LAFITE.PROGRAMMER.ENTRIES)))) - -(DEFCOMMAND (CHECKLAFITE :HISTORY) NIL (QUOTE ((FOR FILE IN LAFITEFILES DO (EVAL (BQUOTE (%. CHECK (\, FILE)))))))) -(DECLARE%: DONTEVAL@COMPILE - -(SETTEMPLATE (QUOTE WINDOWPROP) (QUOTE (EVAL PROP EVAL . PPE))) - -(SETTEMPLATE (QUOTE WINDOWADDPROP) (QUOTE (EVAL PROP EVAL EVAL . PPE))) - -(SETTEMPLATE (QUOTE WINDOWDELPROP) (QUOTE (EVAL PROP EVAL . PPE))) - -(SETTEMPLATE (QUOTE PROCESSPROP) (QUOTE (EVAL PROP EVAL . PPE))) - -(SETTEMPLATE (QUOTE TEXTPROP) (QUOTE (EVAL PROP EVAL . PPE))) -) -(PUTPROPS LAFITEDECLS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/library/lafite/LAFITEFIND.~1~ b/library/lafite/LAFITEFIND.~1~ deleted file mode 100644 index 09e8722e..00000000 --- a/library/lafite/LAFITEFIND.~1~ +++ /dev/null @@ -1,97 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "23-Aug-88 18:58:15" {ERIS}SOURCES>LAFITEFIND.;13 12215 - - changes to%: (VARS LAFITEFINDCOMS) (FNS \LAFITE.GO.TO.LAST \LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE) - - previous date%: "29-Jul-88 11:59:44" {ERIS}SOURCES>LAFITEFIND.;12) - - -(* " -Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITEFINDCOMS) - -(RPAQQ LAFITEFINDCOMS ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD \LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT \LAFITE.DO.FIND \LAFITE.FIND.START) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE) (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)) (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS) (ADDVARS (LAFITEEXTRAMENUITEMS ("Find" (QUOTE \LAFITE.FIND) "Search mail for something") ("Find Related" (QUOTE \LAFITE.FIND.RELATED) "Find all messages from here on in reply to this message" (SUBITEMS ("Find Related Forward" (QUOTE \LAFITE.FIND.RELATED)) ("Find Related Backward" (QUOTE \LAFITE.FIND.RELATED.BACKWARD)))) ("Find Again" (QUOTE \LAFITE.FIND.AGAIN) "Repeat previous search") ("Go to #" (QUOTE \LAFITE.GO.TO.INTERACTIVE) "Scroll to and select a specific message by number." (SUBITEMS ("Go to First" (QUOTE \LAFITE.GO.TO.FIRST) "Scroll to and select first message.") ("Go to Last" (QUOTE \LAFITE.GO.TO.LAST) "Scroll to and select last message.")))) (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)) (VARS (\LAFITE.LAST.SEARCH)))) -(DEFINEQ - -(\LAFITE.FIND -(LAMBDA (MAILFOLDER) (* bvm%: "25-Feb-86 14:29") (* ; "Invoked by Find command") (PROG (SEARCHDIRECTION SEARCHAREA SEARCHSTRING) (OR (SETQ SEARCHDIRECTION (MENU (OR LAFITEFINDTYPEMENU (SETQ LAFITEFINDTYPEMENU (create MENU ITEMS _ LAFITEFINDTYPEMENUITEMS MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))))) (RETURN)) (OR (SETQ SEARCHAREA (MENU (OR LAFITEFINDAREAMENU (SETQ LAFITEFINDAREAMENU (create MENU ITEMS _ LAFITEFINDAREAMENUITEMS MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))))) (RETURN)) (COND ((EQ SEARCHAREA (QUOTE Related)) (SETQ SEARCHSTRING (fetch (LAFITEMSG SUBJECT) of (NTHMESSAGE (fetch MESSAGEDESCRIPTORS of MAILFOLDER) (fetch LASTSELECTEDMESSAGE of MAILFOLDER)))) (COND ((STRING-EQUAL (SUBSTRING SEARCHSTRING 1 4) "Re: ") (SETQ SEARCHSTRING (SUBSTRING SEARCHSTRING 5)))) (SETQ SEARCHAREA (QUOTE Subject))) ((SETQ SEARCHSTRING (\LAFITE.FIND.PROMPT MAILFOLDER SEARCHAREA))) (T (RETURN))) (\LAFITE.DO.FIND MAILFOLDER (CAR SEARCHDIRECTION) SEARCHAREA SEARCHSTRING NIL (EQ (CADR SEARCHDIRECTION) (QUOTE ALL))))) -) - -(\LAFITE.FIND.RELATED -(LAMBDA (MAILFOLDER DIRECTION) (* bvm%: "25-Feb-86 12:42") (* ;;; "Find message that shares subject with this one.") (OR DIRECTION (SETQQ DIRECTION FORWARD)) (LET* ((FROM# (\LAFITE.FIND.START MAILFOLDER DIRECTION)) (SEARCHSTRING (fetch (LAFITEMSG SUBJECT) of (NTHMESSAGE (fetch MESSAGEDESCRIPTORS of MAILFOLDER) FROM#)))) (COND ((OR (NULL SEARCHSTRING) (EQ (NCHARS SEARCHSTRING) 0)) (LAB.PROMPTPRINT MAILFOLDER " can't--message has no Subject")) (T (COND ((STRING-EQUAL (SUBSTRING SEARCHSTRING 1 4) "Re: ") (SETQ SEARCHSTRING (SUBSTRING SEARCHSTRING 5)))) (\LAFITE.DO.FIND MAILFOLDER DIRECTION (QUOTE Subject) SEARCHSTRING FROM# T T))))) -) - -(\LAFITE.FIND.RELATED.BACKWARD -(LAMBDA (MAILFOLDER) (* bvm%: " 5-Mar-84 17:28") (\LAFITE.FIND.RELATED MAILFOLDER (QUOTE BACKWARD)))) - -(\LAFITE.GO.TO.FIRST -(LAMBDA (FOLDER) (* ; "Edited 23-Aug-88 18:35 by bvm") (AND (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) (LAB.GO.TO.MESSAGE FOLDER 1))) -) - -(\LAFITE.GO.TO.INTERACTIVE -(LAMBDA (FOLDER) (* ; "Edited 23-Aug-88 18:35 by bvm") (* ;; "Called from title menu to go to some user specified message.") (ALLOW.BUTTON.EVENTS) (LET ((N (PROGN (TTY.PROCESS (THIS.PROCESS)) (LAB.PROMPTPRINT FOLDER "Type or select number of message.") (PROG1 (RNUMBER "Message#" NIL NIL NIL T NIL T T) (TTY.PROCESS T)))) MAX) (if (AND N (> N 0)) then (if (> N (SETQ MAX (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) then (LAB.FORMAT FOLDER T "There are only ~D messages in this folder." MAX) (SETQ N MAX) else (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER)) (LAB.GO.TO.MESSAGE FOLDER N)))) -) - -(\LAFITE.GO.TO.LAST -(LAMBDA (FOLDER) (* ; "Edited 23-Aug-88 18:35 by bvm") (AND (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) (LAB.GO.TO.MESSAGE FOLDER (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) -) - -(\LAFITE.FIND.AGAIN -(LAMBDA (MAILFOLDER) (* bvm%: "25-Feb-86 12:42") (LET ((LASTSEARCH \LAFITE.LAST.SEARCH)) (COND (LASTSEARCH (\LAFITE.DO.FIND MAILFOLDER (fetch SEARCHDIRECTION of LASTSEARCH) (fetch SEARCHAREA of LASTSEARCH) (fetch SEARCHSTRING of LASTSEARCH))) (T (\LAFITE.FIND MAILFOLDER))))) -) - -(\LAFITE.FIND.PROMPT -(LAMBDA (MAILFOLDER SEARCHAREA) (* ; "Edited 14-Jun-88 11:15 by bvm") (* ;;; "prompt for search string for a search of the indicated area. Return NIL if aborted.") (RESETLST (LET ((WINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) (LASTSEARCH \LAFITE.LAST.SEARCH) RESULT) (CLEARW WINDOW) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (W) (COND (RESETSTATE (printout W "...aborted"))) (WINDOWPROP W (QUOTE PROCESS) NIL))) WINDOW)) (COND ((COND ((EQ SEARCHAREA (QUOTE Mark)) (LAB.PROMPTPRINT MAILFOLDER T "Find message marked: ") (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (< (SETQ RESULT (\GETKEY)) (CHARCODE SPACE))) (T (NULL (SETQ RESULT (TTYINPROMPTFORWORD (CONCAT "Find " SEARCHAREA " string: ") (AND LASTSEARCH (NOT (fetch SEARCHREPLYTO of LASTSEARCH)) (EQ SEARCHAREA (fetch SEARCHAREA of LASTSEARCH)) (fetch SEARCHSTRING of LASTSEARCH)) NIL WINDOW NIL NIL (CHARCODE (CR))))))) (ERROR!))) RESULT))) -) - -(\LAFITE.DO.FIND -(LAMBDA (MAILFOLDER DIRECTION AREA SEARCHSTRING FROM# ALLFLG REPLYTO?) (* ; "Edited 23-Sep-87 18:35 by bvm:") (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) MSG MSG# ADDFLG %#FOUND FIRSTFOUND# INSTREAM CURRENT LASTSEL MARK) (SELECTQ AREA (Body (ALLOW.BUTTON.EVENTS) (* ; "Could take a while") (SETQ INSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT))) (Mark (SETQ SEARCHSTRING (UCASECODE SEARCHSTRING))) NIL) (COND ((NOT FROM#) (SETQ FROM# (\LAFITE.FIND.START MAILFOLDER DIRECTION)))) (SETQ MSG# (COND (ALLFLG (* ; "Be sure to include starting message, assuming it matches") (SELECTQ DIRECTION (FORWARD (SUB1 FROM#)) (ADD1 FROM#))) (T FROM#))) LP (until (SELECTQ DIRECTION (FORWARD (> (add MSG# 1) LASTMSG#)) (<= (add MSG# -1) 0)) do (SETQ MSG (NTHMESSAGE MESSAGES MSG#)) (COND ((SELECTQ AREA (From (* ; "Include the To: field in messages from self") (OR (STRPOS SEARCHSTRING (fetch (LAFITEMSG FROM) of MSG) 1 NIL NIL NIL UPPERCASEARRAY) (AND (fetch (LAFITEMSG MSGFROMMEP) of MSG) (STRPOS SEARCHSTRING (fetch (LAFITEMSG TO) of MSG) 1 NIL NIL NIL UPPERCASEARRAY)))) (Subject (STRPOS SEARCHSTRING (fetch (LAFITEMSG SUBJECT) of MSG) 1 NIL NIL NIL UPPERCASEARRAY)) (Body (FILEPOS SEARCHSTRING INSTREAM (fetch (LAFITEMSG START) of MSG) (fetch (LAFITEMSG END) of MSG) NIL NIL UPPERCASEARRAY)) (Mark (OR (EQ (SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG)) SEARCHSTRING) (EQ (UCASECODE MARK) SEARCHSTRING))) (SHOULDNT)) (COND ((NOT ADDFLG) (UNSELECTALLMESSAGES MAILFOLDER) (SETQ ADDFLG T))) (LA.SELECTRANGE MAILFOLDER MSG# MSG# T) (LA.SHOW.SELECTION MAILFOLDER MSG (QUOTE REPLACE)) (COND ((NOT %#FOUND) (SETQ %#FOUND 1) (COND ((NOT ALLFLG) (LAB.PROMPTPRINT MAILFOLDER "Found in message " MSG#) (LAB.EXPOSEMESSAGE MAILFOLDER MSG) (RETURN))) (SETQ FIRSTFOUND# MSG#)) (T (add %#FOUND 1)))))) (COND ((OR (NULL %#FOUND) (AND (EQ %#FOUND 1) (EQ FIRSTFOUND# FROM#))) (* ; "Didn't find it, or found it only in the starting message (in the case of ALLFLG)") (COND (REPLYTO? (LAB.PROMPTPRINT MAILFOLDER "No related message found")) (T (LAB.PROMPTPRINT MAILFOLDER "%"" (COND ((FIXP SEARCHSTRING) (CHARACTER SEARCHSTRING)) (T SEARCHSTRING)) "%" not found")))) (ALLFLG (* ; "Multiple find") (LAB.PROMPTPRINT MAILFOLDER "Found in " %#FOUND " messages") (LAB.EXPOSEMESSAGE MAILFOLDER (NTHMESSAGE MESSAGES (COND ((AND (SETQ CURRENT (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER)) (fetch (LAFITEMSG SELECTED?) of CURRENT)) (* ; "Scroll to message that would be displayed if user clicked 'Display' now") (COND ((EQ (fetch (LAFITEMSG %#) of CURRENT) (SETQ LASTSEL (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER))) (* ; "Currently displaying the last one, so cycle back to first") (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) (T (LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 (fetch (LAFITEMSG %#) of CURRENT)) LASTSEL)))) (T (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER))))))) (SETQ \LAFITE.LAST.SEARCH (create SEARCHSTATE SEARCHSTRING _ SEARCHSTRING SEARCHDIRECTION _ DIRECTION SEARCHAREA _ AREA SEARCHREPLYTO _ REPLYTO?)))) -) - -(\LAFITE.FIND.START -(LAMBDA (MAILFOLDER DIRECTION) (* bvm%: "25-Feb-86 12:33") (* ;; "Return the message to start searching from. Forward searches start from last selected message, backward from first. However, if that message is not visible, but some other message is, start from the visible message and print warning") (LET ((LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) VIS) (LAB.PROMPTPRINT MAILFOLDER T "Searching") (COND ((AND (NEQ LAST# FIRST#) (SELECTQ DIRECTION (BACKWARD (< (SETQ LAST# FIRST#) (SETQ VIS (FIRSTVISIBLEMESSAGE MAILFOLDER)))) (> LAST# (SETQ VIS (LASTVISIBLEMESSAGE MAILFOLDER))))) (* ; "Extreme selected message not visible, so tell user where search will start") (COND ((SETQ VIS (SELECTQ DIRECTION (BACKWARD (LAB.FIND.SELECTED.MSG MAILFOLDER VIS (LASTVISIBLEMESSAGE MAILFOLDER))) (LAB.REV.FIND.SELECTED.MSG MAILFOLDER (FIRSTVISIBLEMESSAGE MAILFOLDER) VIS))) (SETQ LAST# VIS))) (LAB.PROMPTPRINT MAILFOLDER " from msg " LAST#))) (LAB.PROMPTPRINT MAILFOLDER (QUOTE |...|)) LAST#)) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD SEARCHSTATE (SEARCHSTRING SEARCHDIRECTION SEARCHAREA SEARCHREPLYTO)) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) -) - - -(FILESLOAD (SOURCE) LAFITEDECLS) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) - -(RPAQ? LAFITEFINDTYPEMENU NIL) - -(RPAQ? LAFITEFINDAREAMENU NIL) - -(RPAQQ LAFITEFINDAREAMENUITEMS ((From (QUOTE From) "Search From: field for string (or To: if from self)") (Subject (QUOTE Subject) "Search Subject: field for string") (Body (QUOTE Body) "Search message bodies for string") (Mark (QUOTE Mark) "Search for messages with specified mark character") (Related (QUOTE Related) "Search for a message with same Subject, modulo Re:"))) - -(RPAQQ LAFITEFINDTYPEMENUITEMS (("Find Next One" (QUOTE (FORWARD ONE)) "Search forward from selected message") ("Find Next All" (QUOTE (FORWARD ALL)) "Search forward from selected message") ("Find Previous One" (QUOTE (BACKWARD ONE)) "Search backward from selected message") ("Find Previous All" (QUOTE (BACKWARD ALL)) "Search backward from selected message"))) - -(ADDTOVAR LAFITEEXTRAMENUITEMS ("Find" (QUOTE \LAFITE.FIND) "Search mail for something") ("Find Related" (QUOTE \LAFITE.FIND.RELATED) "Find all messages from here on in reply to this message" (SUBITEMS ("Find Related Forward" (QUOTE \LAFITE.FIND.RELATED)) ("Find Related Backward" (QUOTE \LAFITE.FIND.RELATED.BACKWARD)))) ("Find Again" (QUOTE \LAFITE.FIND.AGAIN) "Repeat previous search") ("Go to #" (QUOTE \LAFITE.GO.TO.INTERACTIVE) "Scroll to and select a specific message by number." (SUBITEMS ("Go to First" (QUOTE \LAFITE.GO.TO.FIRST) "Scroll to and select first message.") ("Go to Last" (QUOTE \LAFITE.GO.TO.LAST) "Scroll to and select last message.")))) - -(ADDTOVAR LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) - -(RPAQQ \LAFITE.LAST.SEARCH NIL) -(PUTPROPS LAFITEFIND COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1823 10123 (\LAFITE.FIND 1833 . 2865) (\LAFITE.FIND.RELATED 2867 . 3532) ( -\LAFITE.FIND.RELATED.BACKWARD 3534 . 3670) (\LAFITE.GO.TO.FIRST 3672 . 3839) ( -\LAFITE.GO.TO.INTERACTIVE 3841 . 4453) (\LAFITE.GO.TO.LAST 4455 . 4663) (\LAFITE.FIND.AGAIN 4665 . -4966) (\LAFITE.FIND.PROMPT 4968 . 5899) (\LAFITE.DO.FIND 5901 . 9052) (\LAFITE.FIND.START 9054 . 10121 -))))) -STOP diff --git a/library/lafite/LAFITEFIND.~2~ b/library/lafite/LAFITEFIND.~2~ deleted file mode 100644 index c94c7d0d..00000000 --- a/library/lafite/LAFITEFIND.~2~ +++ /dev/null @@ -1,191 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Jun-92 10:10:41" {DSK}local>users>welch>lisp>lafite>LAFITEFIND.;2 15951 - - previous date%: "15-Jun-90 16:06:40" {DSK}local>users>welch>lisp>lafite>LAFITEFIND.;1) - - -(* ; " -Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITEFINDCOMS) - -(RPAQQ LAFITEFINDCOMS ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD - \LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST - \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT \LAFITE.DO.FIND - \LAFITE.FIND.START) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE) - (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS - LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU - LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) - (FILES (SOURCE) - LAFITEDECLS) - (LOCALVARS . T)) - (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) - (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS) - (ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND - "Search mail for something") - ["Find Related" '\LAFITE.FIND.RELATED - "Find all messages from here on in reply to this message" - (SUBITEMS ("Find Related Forward" - '\LAFITE.FIND.RELATED) - ("Find Related Backward" - '\LAFITE.FIND.RELATED.BACKWARD] - ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search" - ) - ("Go to #" '\LAFITE.GO.TO.INTERACTIVE - "Scroll to and select a specific message by number." - (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST - "Scroll to and select first message." - ) - ("Go to Last" '\LAFITE.GO.TO.LAST - "Scroll to and select last message."] - (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)) - (VARS (\LAFITE.LAST.SEARCH)))) -(DEFINEQ - -(\LAFITE.FIND -(LAMBDA (MAILFOLDER) (* bvm%: "25-Feb-86 14:29") (* ; "Invoked by Find command") (PROG (SEARCHDIRECTION SEARCHAREA SEARCHSTRING) (OR (SETQ SEARCHDIRECTION (MENU (OR LAFITEFINDTYPEMENU (SETQ LAFITEFINDTYPEMENU (create MENU ITEMS _ LAFITEFINDTYPEMENUITEMS MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))))) (RETURN)) (OR (SETQ SEARCHAREA (MENU (OR LAFITEFINDAREAMENU (SETQ LAFITEFINDAREAMENU (create MENU ITEMS _ LAFITEFINDAREAMENUITEMS MENUFONT _ LAFITEMENUFONT CENTERFLG _ T))))) (RETURN)) (COND ((EQ SEARCHAREA (QUOTE Related)) (SETQ SEARCHSTRING (fetch (LAFITEMSG SUBJECT) of (NTHMESSAGE (fetch MESSAGEDESCRIPTORS of MAILFOLDER) (fetch LASTSELECTEDMESSAGE of MAILFOLDER)))) (COND ((STRING-EQUAL (SUBSTRING SEARCHSTRING 1 4) "Re: ") (SETQ SEARCHSTRING (SUBSTRING SEARCHSTRING 5)))) (SETQ SEARCHAREA (QUOTE Subject))) ((SETQ SEARCHSTRING (\LAFITE.FIND.PROMPT MAILFOLDER SEARCHAREA))) (T (RETURN))) (\LAFITE.DO.FIND MAILFOLDER (CAR SEARCHDIRECTION) SEARCHAREA SEARCHSTRING NIL (EQ (CADR SEARCHDIRECTION) (QUOTE ALL))))) -) - -(\LAFITE.FIND.RELATED -(LAMBDA (MAILFOLDER DIRECTION) (* bvm%: "25-Feb-86 12:42") (* ;;; "Find message that shares subject with this one.") (OR DIRECTION (SETQQ DIRECTION FORWARD)) (LET* ((FROM# (\LAFITE.FIND.START MAILFOLDER DIRECTION)) (SEARCHSTRING (fetch (LAFITEMSG SUBJECT) of (NTHMESSAGE (fetch MESSAGEDESCRIPTORS of MAILFOLDER) FROM#)))) (COND ((OR (NULL SEARCHSTRING) (EQ (NCHARS SEARCHSTRING) 0)) (LAB.PROMPTPRINT MAILFOLDER " can't--message has no Subject")) (T (COND ((STRING-EQUAL (SUBSTRING SEARCHSTRING 1 4) "Re: ") (SETQ SEARCHSTRING (SUBSTRING SEARCHSTRING 5)))) (\LAFITE.DO.FIND MAILFOLDER DIRECTION (QUOTE Subject) SEARCHSTRING FROM# T T))))) -) - -(\LAFITE.FIND.RELATED.BACKWARD -(LAMBDA (MAILFOLDER) (* bvm%: " 5-Mar-84 17:28") (\LAFITE.FIND.RELATED MAILFOLDER (QUOTE BACKWARD)))) - -(\LAFITE.GO.TO.FIRST -(LAMBDA (FOLDER) (* ; "Edited 23-Aug-88 18:35 by bvm") (AND (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) (LAB.GO.TO.MESSAGE FOLDER 1))) -) - -(\LAFITE.GO.TO.INTERACTIVE -(LAMBDA (FOLDER) (* ; "Edited 23-Aug-88 18:35 by bvm") (* ;; "Called from title menu to go to some user specified message.") (ALLOW.BUTTON.EVENTS) (LET ((N (PROGN (TTY.PROCESS (THIS.PROCESS)) (LAB.PROMPTPRINT FOLDER "Type or select number of message.") (PROG1 (RNUMBER "Message#" NIL NIL NIL T NIL T T) (TTY.PROCESS T)))) MAX) (if (AND N (> N 0)) then (if (> N (SETQ MAX (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) then (LAB.FORMAT FOLDER T "There are only ~D messages in this folder." MAX) (SETQ N MAX) else (\LAFITE.MAYBE.CLEAR.PROMPT FOLDER)) (LAB.GO.TO.MESSAGE FOLDER N)))) -) - -(\LAFITE.GO.TO.LAST -(LAMBDA (FOLDER) (* ; "Edited 23-Aug-88 18:35 by bvm") (AND (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER) (LAB.GO.TO.MESSAGE FOLDER (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))) -) - -(\LAFITE.FIND.AGAIN - [LAMBDA (MAILFOLDER) (* ; "Edited 15-Jun-90 16:03 by jds") - (LET ((LASTSEARCH \LAFITE.LAST.SEARCH)) - (COND - (LASTSEARCH (\LAFITE.DO.FIND MAILFOLDER (fetch (SEARCHSTATE SEARCHDIRECTION) - of LASTSEARCH) - (fetch (SEARCHSTATE SEARCHAREA) of LASTSEARCH) - (fetch (SEARCHSTATE SEARCHSTRING) of LASTSEARCH))) - (T (\LAFITE.FIND MAILFOLDER]) - -(\LAFITE.FIND.PROMPT - [LAMBDA (MAILFOLDER SEARCHAREA) (* ; "Edited 15-Jun-90 16:03 by jds") - -(* ;;; "prompt for search string for a search of the indicated area. Return NIL if aborted.") - - (RESETLST - (LET ((WINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of MAILFOLDER)) - (LASTSEARCH \LAFITE.LAST.SEARCH) - RESULT) - (CLEARW WINDOW) - (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (W) - (COND - (RESETSTATE (printout W "...aborted"))) - (WINDOWPROP W 'PROCESS NIL] - WINDOW)) - (COND - ([COND - ((EQ SEARCHAREA 'Mark) - (LAB.PROMPTPRINT MAILFOLDER T "Find message marked: ") - (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) - (< (SETQ RESULT (\GETKEY)) - (CHARCODE SPACE))) - (T (NULL (SETQ RESULT (TTYINPROMPTFORWORD (CONCAT "Find " SEARCHAREA " string: ") - (AND LASTSEARCH (NOT (fetch (SEARCHSTATE - SEARCHREPLYTO - ) - of LASTSEARCH)) - (EQ SEARCHAREA (fetch (SEARCHSTATE - SEARCHAREA) - of LASTSEARCH)) - (fetch (SEARCHSTATE SEARCHSTRING) - of LASTSEARCH)) - NIL WINDOW NIL NIL (CHARCODE (CR] - (ERROR!))) - RESULT))]) - -(\LAFITE.DO.FIND -(LAMBDA (MAILFOLDER DIRECTION AREA SEARCHSTRING FROM# ALLFLG REPLYTO?) (* ; "Edited 23-Sep-87 18:35 by bvm:") (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) MSG MSG# ADDFLG %#FOUND FIRSTFOUND# INSTREAM CURRENT LASTSEL MARK) (SELECTQ AREA (Body (ALLOW.BUTTON.EVENTS) (* ; "Could take a while") (SETQ INSTREAM (\LAFITE.OPEN.FOLDER MAILFOLDER (QUOTE INPUT) :ABORT))) (Mark (SETQ SEARCHSTRING (UCASECODE SEARCHSTRING))) NIL) (COND ((NOT FROM#) (SETQ FROM# (\LAFITE.FIND.START MAILFOLDER DIRECTION)))) (SETQ MSG# (COND (ALLFLG (* ; "Be sure to include starting message, assuming it matches") (SELECTQ DIRECTION (FORWARD (SUB1 FROM#)) (ADD1 FROM#))) (T FROM#))) LP (until (SELECTQ DIRECTION (FORWARD (> (add MSG# 1) LASTMSG#)) (<= (add MSG# -1) 0)) do (SETQ MSG (NTHMESSAGE MESSAGES MSG#)) (COND ((SELECTQ AREA (From (* ; "Include the To: field in messages from self") (OR (STRPOS SEARCHSTRING (fetch (LAFITEMSG FROM) of MSG) 1 NIL NIL NIL UPPERCASEARRAY) (AND (fetch (LAFITEMSG MSGFROMMEP) of MSG) (STRPOS SEARCHSTRING (fetch (LAFITEMSG TO) of MSG) 1 NIL NIL NIL UPPERCASEARRAY)))) (Subject (STRPOS SEARCHSTRING (fetch (LAFITEMSG SUBJECT) of MSG) 1 NIL NIL NIL UPPERCASEARRAY)) (Body (FILEPOS SEARCHSTRING INSTREAM (fetch (LAFITEMSG START) of MSG) (fetch (LAFITEMSG END) of MSG) NIL NIL UPPERCASEARRAY)) (Mark (OR (EQ (SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG)) SEARCHSTRING) (EQ (UCASECODE MARK) SEARCHSTRING))) (SHOULDNT)) (COND ((NOT ADDFLG) (UNSELECTALLMESSAGES MAILFOLDER) (SETQ ADDFLG T))) (LA.SELECTRANGE MAILFOLDER MSG# MSG# T) (LA.SHOW.SELECTION MAILFOLDER MSG (QUOTE REPLACE)) (COND ((NOT %#FOUND) (SETQ %#FOUND 1) (COND ((NOT ALLFLG) (LAB.PROMPTPRINT MAILFOLDER "Found in message " MSG#) (LAB.EXPOSEMESSAGE MAILFOLDER MSG) (RETURN))) (SETQ FIRSTFOUND# MSG#)) (T (add %#FOUND 1)))))) (COND ((OR (NULL %#FOUND) (AND (EQ %#FOUND 1) (EQ FIRSTFOUND# FROM#))) (* ; "Didn't find it, or found it only in the starting message (in the case of ALLFLG)") (COND (REPLYTO? (LAB.PROMPTPRINT MAILFOLDER "No related message found")) (T (LAB.PROMPTPRINT MAILFOLDER "%"" (COND ((FIXP SEARCHSTRING) (CHARACTER SEARCHSTRING)) (T SEARCHSTRING)) "%" not found")))) (ALLFLG (* ; "Multiple find") (LAB.PROMPTPRINT MAILFOLDER "Found in " %#FOUND " messages") (LAB.EXPOSEMESSAGE MAILFOLDER (NTHMESSAGE MESSAGES (COND ((AND (SETQ CURRENT (fetch (MAILFOLDER CURRENTDISPLAYEDMESSAGE) of MAILFOLDER)) (fetch (LAFITEMSG SELECTED?) of CURRENT)) (* ; "Scroll to message that would be displayed if user clicked 'Display' now") (COND ((EQ (fetch (LAFITEMSG %#) of CURRENT) (SETQ LASTSEL (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of MAILFOLDER))) (* ; "Currently displaying the last one, so cycle back to first") (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER)) (T (LAB.FIND.SELECTED.MSG MAILFOLDER (ADD1 (fetch (LAFITEMSG %#) of CURRENT)) LASTSEL)))) (T (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of MAILFOLDER))))))) (SETQ \LAFITE.LAST.SEARCH (create SEARCHSTATE SEARCHSTRING _ SEARCHSTRING SEARCHDIRECTION _ DIRECTION SEARCHAREA _ AREA SEARCHREPLYTO _ REPLYTO?)))) -) - -(\LAFITE.FIND.START -(LAMBDA (MAILFOLDER DIRECTION) (* bvm%: "25-Feb-86 12:33") (* ;; "Return the message to start searching from. Forward searches start from last selected message, backward from first. However, if that message is not visible, but some other message is, start from the visible message and print warning") (LET ((LAST# (fetch LASTSELECTEDMESSAGE of MAILFOLDER)) (FIRST# (fetch FIRSTSELECTEDMESSAGE of MAILFOLDER)) VIS) (LAB.PROMPTPRINT MAILFOLDER T "Searching") (COND ((AND (NEQ LAST# FIRST#) (SELECTQ DIRECTION (BACKWARD (< (SETQ LAST# FIRST#) (SETQ VIS (FIRSTVISIBLEMESSAGE MAILFOLDER)))) (> LAST# (SETQ VIS (LASTVISIBLEMESSAGE MAILFOLDER))))) (* ; "Extreme selected message not visible, so tell user where search will start") (COND ((SETQ VIS (SELECTQ DIRECTION (BACKWARD (LAB.FIND.SELECTED.MSG MAILFOLDER VIS (LASTVISIBLEMESSAGE MAILFOLDER))) (LAB.REV.FIND.SELECTED.MSG MAILFOLDER (FIRSTVISIBLEMESSAGE MAILFOLDER) VIS))) (SETQ LAST# VIS))) (LAB.PROMPTPRINT MAILFOLDER " from msg " LAST#))) (LAB.PROMPTPRINT MAILFOLDER (QUOTE |...|)) LAST#)) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD SEARCHSTATE (SEARCHSTRING SEARCHDIRECTION SEARCHAREA SEARCHREPLYTO)) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU - LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) -) - - -(FILESLOAD (SOURCE) - LAFITEDECLS) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) - -(RPAQ? LAFITEFINDTYPEMENU NIL) - -(RPAQ? LAFITEFINDAREAMENU NIL) - -(RPAQQ LAFITEFINDAREAMENUITEMS ((From 'From "Search From: field for string (or To: if from self)" - ) - (Subject 'Subject "Search Subject: field for string") - (Body 'Body "Search message bodies for string") - (Mark 'Mark "Search for messages with specified mark character") - (Related 'Related - "Search for a message with same Subject, modulo Re:"))) - -(RPAQQ LAFITEFINDTYPEMENUITEMS (("Find Next One" '(FORWARD ONE) - "Search forward from selected message") - ("Find Next All" '(FORWARD ALL) - "Search forward from selected message") - ("Find Previous One" '(BACKWARD ONE) - "Search backward from selected message") - ("Find Previous All" '(BACKWARD ALL) - "Search backward from selected message"))) - -(ADDTOVAR LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something") - ["Find Related" '\LAFITE.FIND.RELATED - "Find all messages from here on in reply to this message" - (SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED) - ("Find Related Backward" - '\LAFITE.FIND.RELATED.BACKWARD] - ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search") - ("Go to #" '\LAFITE.GO.TO.INTERACTIVE - "Scroll to and select a specific message by number." - (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST - "Scroll to and select first message.") - ("Go to Last" '\LAFITE.GO.TO.LAST - "Scroll to and select last message.")))) - -(ADDTOVAR LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) - -(RPAQQ \LAFITE.LAST.SEARCH NIL) -(PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3089 12861 (\LAFITE.FIND 3099 . 4131) (\LAFITE.FIND.RELATED 4133 . 4798) ( -\LAFITE.FIND.RELATED.BACKWARD 4800 . 4936) (\LAFITE.GO.TO.FIRST 4938 . 5105) ( -\LAFITE.GO.TO.INTERACTIVE 5107 . 5719) (\LAFITE.GO.TO.LAST 5721 . 5929) (\LAFITE.FIND.AGAIN 5931 . -6513) (\LAFITE.FIND.PROMPT 6515 . 8637) (\LAFITE.DO.FIND 8639 . 11790) (\LAFITE.FIND.START 11792 . -12859))))) -STOP diff --git a/library/lafite/LAFITESEND.LCOM.~1~ b/library/lafite/LAFITESEND.LCOM.~1~ deleted file mode 100644 index 280a2e248357551d76753e3b65856cc55ab959f3..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 44962 zcmeHweQ;dYb>HrSlqgxC0ScmNnxU?ikqNTG2D=M@A6BS+SS+{?*bi`bArd4d3dAn8 zOMn0afL0jWYV7eJ`J*4MCzjkKO(t$V>7+>u0>q3Ze{9ptWUS02X{XXevS-qnHpz56 zZH6AD)Ao;={hf2}eeb@v3rSYXS@(99(Sral^j0SJ4g*=QLC1lQ1Mi1$hr06 z(5VrXOrIVZIX!$bt_I@^D>rVomKt@nvaI5&_cIgK>CZjA*jj$^OylQouB@(~S!%7_ zTv%CcoLQQ`)>?0zxjDbOfJV*~oJqHqtL91*iBBbuq4|?TQ@575`4gv8Cr^)z#nn}6 zed%ajwU$+Hyx6EOHEt`vVj_`ncv>JTYsZ@KFKbLH| zSUsk0t~Ng1TDi5xgG04=dU&Wfe|zZEuu6`dPK}*TCx4u-M~?MQl>I*3(phvD!Gao0sp;IDN~&V6G^>Uc09!nEOhr=BNTkPkD1v`4($B;6(;toGx#*2VeRF`z z^G>FD@ZiCZ(Bo!bWN>6m%~Z+M?486F-^(oc$h z(%xKyvs9CqZv}W%tJcssCVe~-jl^c|9?dw{c|y(uG%cRz!2TD!>n11kS}t2Vu3XHLA7l$Tr!+e=gdr8H$1(d9uQo2yvig&1L~1fnylPk*UO52h zN^DmoT45CE?~gKIDpgwlX8qv7+QEfAl`4aY0aWb{J${QTa$&z$Q31 z^sG~urEM^@I~I$yGX1gWZ2uFxc!hY$`DYJpgZ5895Z%{2xbO%+#F_!SX}mmKK|qxP zc#6+rz%`Ww?swbIKBNGok(4@J0%|%1f^4X@oq=fJml9~mR3;0~Spq{+9p}B4n*ac+ zIbgj3jXh;-5xo^$LkMZpXnIB4Bh(6D^mtD+($n7;VRWw^?C+1c44!=qk$ZQ0@_@>F z&Kpw#Z8TFpVK0O|W^3lvvx$jZ!F@JY@hDnaws1-iHGuGD0z}QTu}EZBzlvsfjC1_k zUZItAdGEEI4FA3Gby?nw!_&x)J9*mOn!aO3V}>$gEJW54;O`)ABT1F3RLYenRG4(n zfXn4ninxMXN~+`t_9RHYt4`7;$3%-WnimiXoKjC7IYO9nn(~JcjQ2*`;7oE9^a0WW);$Fb zNdt1N&doB>grEbl z7$^#AENxp&U~qmJplJ7ktqic8Ql%30TfZ(p#0CzP0O|b_+N_}8@e3C&#KFnp z)%j01)UD-uV^uBB-)KOL#om?bi9A$?TqTh!PkP&7*xIs0t{w&2L^I9n&3dbsg@|Y@ zy7)FB4MCkCnP9r2+d9?@cFn?|eh7IpSE(f`IS8P&ve!*oN#E3UO6A?N`2zk2yc8o* zcoaX2QS8d_=5b!Yb%YT=yZx|G(W?*e{rKIFXR=EVziI8ARxkEuB!ck*u>}=L$jm{a z7*izyaoP|S8LLW-8ho$;1TipME`fIgz@tf3k>MI3d93zqj@A^5J@{=QpBP4z}yYPjVpay2Qp25ZHnQ`FSqYRey_X_Fn9RLB0uS`^p_88_k7__2NE08{y}4Bjcn7t041-{CvWJIj4ofpWZj zu)Lqw>P>FRW~^6~21dJl;5W(#%8Kii55GlIEynKr=mp45Nl;kX{bR#~_{5|1_8&cU zLhp3g3Px3Rc3fz?8a?5?G&%}t-G2ajD@{Nq%t1FEB^kU{nJHJ*C~qEW9z-YMR1>gJqJSPTVsM;&1lz*jP|*7Z#|}qv;S+PLG^4!%wFn%6g+r zCvhi(N`qqvF@rcrESmQ{2;T`k4^1Oe(3`srG70mMOqfQlk|#_xZ6wfxOO9bEh110O z9Fo?OJ5Zh^;MbidCBfT6CJW3$XlBxXNvvB5E~j2>1xJr%)Xb8|H^fL5=17)vDivoA z;stneZW7`%xWQ+4^ztUAcPkiYisi_Hq?!kdPB9= z)bh$pFxjOcs>P4tFVKqqrcRww@j?7Wck$W^F3>RSd<$`(L&c9l8$7Avy}faWI_M}n zzkGCE&EHyYHkQ|03oyy4TWgRTV7GhO;SN!8_=Jj=8ZYTvaM5_J*;s9;dHlb;qE_(o zDnDGal>`gJ4W|HZ6YeO%`!L7P^gu&kY9@q~X+ZxIu}pq(oaNiOyH5ylbA@`pIVa^8 z?>^*Cxo?4V64R#@VEL2q6fn}8o|exqhdgFjJ4-JBG@wFrRdKL!lA?OO$ru!8Wy;J2 zIv08=SF}V5(^&QFG0_?XIfiJphltOT!Z41>#f1L^xnF-&Cet5{O>IBs2oDkkf$3ad zG!~1#mT{J1Y@XQx*Rd%6w!>7r?=5>rycZ6R016)fGkmFX2EvX5DV=tqC-6bKCy0rm zx+}N=I)_HBV(J9C|%w=;FM)O&C1C0sDE zzp(gD;KBZO<^^gozxa03aNe-?nHk@HkSkr6#xI~IFV4k!^pY^`dz+t{2KcA32Ahv% z9MQh|7VC_gckX}2&EMaAG?Uj|FZIgBbj)3R`@j^iF$GpLUIt-Lg2ez9q*2V&pjk1| zAT-tdBYDCX(hM}25wJ?8r8isbhM8uBlz52K+#uvP-99@GlEY>nXdZ|5t^UDV{CA=F zTaRE(kc}edAopS}i=_o?G7JE9Nty-%T_%GVkCFsP@FkM%lY)LS*2!5|@{(k$(^KFY zP$GdS6*X|16e_0~Gx0JqXy zYyRfV)s>s8E%275+lhED7^{lsc?3KtR#ey4S61q$)st~cRn6whFy|ydSG6s{qAUU0 zo3vIx%vAm}t-7o=`A@#ii`XXxn;(@aYXhe`Gz#x z4489(Y$*@`XB>7Q7z%Csgu{*ikcX4XEy8~U9g@u|#=Mb)T?fR$DU{38Fs?xOBB@;8 z!R9E0KqN>J`-Y7Nz%L}>tExa#J8B#IlY)46+Nn;H>p{~V;!eI4AO^=>UMLS$Q3*i<*>*VkcB#Y5;B@WC#xW9O`? z)(yyaYbb^M7>5A1rW!xL4)-OtCES*)^9$>cu+|#ur~&&JH;TPH|KjTW&8FRKFSrGG zH+6aqZDVswpRJW;yb3FaCrjdX7{sE|paED-*snZ;&8PuUbf#hTDZu*&v#jUUG2|D% zkeUNT2yedUv9n@~vi!qjv;W-gjI+J_`qdcU$_{ki`qtueg?G1}$Y)^h-`=%!{F@hL zR}Q{5HBF*VySVt~#-E9(^&!MKVglLJ7&{OX*0}65G!MhAYkI{)ldl_cFB;q0& zdJ5zf(3Hstf#V`cWM9oT89Hr8X8gtjO`$6CJ13>t?Okr4BNaFPXJin_gIUrnv;`H2 z%sWUdsnAW~$Ss!=NW*X!bedOaeFl41R95|8_SG6WrZWnmk}~L1sL* zC}ROZdV)@m;EFQa{@^1Yh!Atp<6^92Srk|a+6bA60IeVH zQ9m}7Y5@&1nW+MvR8DYwlk_Jo4*zaD14D}=rqHXA79)uxJmcu^v>DVq*0%VXjzZ7M zZ^i{3=QKmy-tBIP%q;rIMpn13pYx25ZvBij7rn6gDS2OS-O264Q(Tklkt++9t&GzY zrL9j&Wl4Wv4TzZ?-}9iExj|sm*a+=dyReccLBF-xgv<^BV8Rtj6p3SG$f95r^yIM5 z=s-El``{6#2KGv=Hs=Qk7`0IdgV;YO;0QUzG{ho?VocR+6YH3Qk>5r(ko+L_f!Z6! z#)gFCs9`U1OC!;Cg(PGq?;2ZEvv8>gL=q}3w=f5os^Br!6PRqw127Tm0oh{0!4Z)5 zv1gvm0T!4GrVFcqsDu<&qi)Q%mefnF_2$Ygm=9EeLxk7{;5!O6k+he>Y^^jSEh95* z0=6FA4Y!r?lpnVo^2b#4cOQs?g0}j{cQd*$LP>N;dpzG97i0|JDoajRceS@}`)}}T znfm6VknDaZ-M9S_DFC`U;X((6;P5L(?H=bJ1edfVMR!ngbq zqBfp|7r!kcQ}r)th4(k|<5U!jKF94`{^Fhp{(W;Q7DaJX zB6Hf)U%T_8f5Zde9yQSO+r5RYN5^?U8;=UjX>a`1c)rL@6+jn9EKiFwiJk2E)JNDk zO&W1%r;R|mWS)LrrBCseqWC5ve$XVq@l4DQI6hSDe0jDoQG&J#>zhpxhE)mzsc>JY z-28fK4A^Gxbr^wI*ah#v9`k&n6#WwPf0$gkL3dyQ5O&Gri zTmXv1#364%nXuIjNW|#?)RNssPfpo$vxv!JYo=U5?2`*<=YfvwHGp=lZ;8#qI@<{u z*cdHh$~Yv}U|_Trg4X$F2eVI@DH=N2DJ;Q>2InkqJthlGG)Ul}V7g-YS&|?;vq4w5 z8lKSYVdsb})HQ>GP)RPrlnK$nCStodOrS#YwLlU(ff4Rv^3nfK9&)w@nX_MwwX>T) z#ig73#oUtR2SS@;?Qsc^fk*0>U8XLMCY?-I;A?waq~GV|sXQ!k&DNdhWb}EVaSWY* z0q@VoAM-Q5k6!*-Ya^Z)p0KN+|NixF7n&t$r}c%xH=19*6WyIJ`AT=Y#9iNs{1wCf z%D$fMCz{*BLbk4Q+0rgW6&Yy+9&Y z!mr4^-=r)8w=l5Z?UMKo5Ed$d%q4_Y#|Nnq z$UvbIkiH-v7=hr0u0V{va40wq!flVhjUMc6gv8PSV@N~wN6ZVNmvR%*M-@y9`WVMz zlP+e;!MjFbwj%$KJ1JFF8ngrB(DO}!{^3rZd7-)~)XAMg;LTa6r)1cnM$dyp<((OX zK0#0$QJ6cceMvAbF)zz4Oaq+_CNZrprJ&6+5j{3|jkqU{MO9#>;c0>u2VpU40FUTO z<87f(G@+FgLUf+v2oe;1Nn}PIV89e(N1cHhk=IqfAj~6Cg+W@4!r!q&?CvOZL!Ry^ zG}#U=HVXMeGhO&;eUtkvVpdA<2g6LJMqwDC3qW%O7ADVJM!{t;Mm~d5*sLVf4ETlc zGmckt3I(&|&w-VStSwJjJWT8alZYEj~H|A%wogFQXvVqicw=xC?Z;IK-l;bQ=<_*Y?YgC7-ghHpK~!N|R`3iDW3yk(sorV$k>!NwC| zn)i5}{|xME*IN`xA$NTybYj1`Q0C%L`+9x(@87SpYJp(jeBB**xZM|FlM5z_R1s&k zz_!*rq6i3C3DGE^A5@IIH9Kq&Z_No3ET?&KU1W|xNE6y0on}(S!~uJO#(7f2c;t#L$riq(?xNXmk1evr=Go(OsZEKjb-+4z$`m7 zBu=XJ6?JXt)>;$3l-n=O-?rQr0riH{AuL-?*Q^f?k(KZu=8G8yO~zqd;cLK!;!Hf1 z2d1qM(G6sBc+xqorWHERi5Ebgz>{9Ie2io7}F0AOQZ)FPnv|ZlIqiq+;d!?Wl zkP`iNwvR1G|C;M={2+SKFaMP(66EfWweH+cxv@LxV0CjCRxE_ZC&7AeCjn*s^NwnacC#FVt(J2vkOS?hC$5_l@sIWh%$z# zGwhWVd`lMlNP+J_@WMU<+aQ^80wNiO8&e&Qed?sqWGV28bkf_P^opj%zEBd_kwQUW zh6_++1@URT{90*H@MsbPc`` zhex+T{wZ}0H3rv?!LJPFmx4xZm?8xg#g9FMLU`q@3KyG-d6W|$vUOAsg z7zd*yr%-+He7Hcj2qTeIagu6 zIm2+iZX$u|e9N!>GGBtPLbyc))#<8RoI&y}X79)LgA!^W1OjkiVbo4Vj<|u;0hkl1 zpj&_m*1OJ4sK{g~tAsuf=0__i&FW$aj>FD0OG`m5Ahp4W8F2nkLAZt&@1uv~BW_^T zWWgxgg+a~9n4G)C%V&X~leZ|~M>60jN6W$!%G2^59#fGgkf9aL+&x@{V~N*+(Vc(T zia|MSB+W<)9Cu?f*I@QDnQIIk&Nv8+nK2CzhTz&QQ%x_H5N(gMAk@jcO-g_rw<=)r8Zk#+LZ?gNMB){rQ5&_^8J65erc^378>G!$w350bVFv_ zGOgDbCU8w1L;04&;Z#W=I3gdA8X8Erq|GjCiI%#pJ!NFd5>ra1R-QXHJp7IwnVHet zBT=IW^nZSjC^NU1Z&NTw zrvxy?8R#zmf2Upw$p6!xCJ;T)zHFsaAW7mJOtVOp=Z-IbSW9=}b#^O*YX=4bhay>z$?;jDXad zh7H7%zG1zvjC-lBdE4ah5gQXn{fiQif(jYHDyAV2$q~<`Er$?it+vrfhcrRidEF@+ zv}QxuU|f(sK&-3$rmuZLn|{FK1yUH}gJ1|LNTIcQ*$z2zqAx?i1ukxE8P&3Zn>9 zq94I<3tX}hK!Hbk=!FNMNmy@|zvPu}CAx2CT@X5YAQO94Xx2f=Xv-gD0w<=KOH&`;_zw_| z$&`!K6-3I&94K@~r+!kzS=?Rz^!!q*t`H&Iy4gZD336DFV1l4V0Eu%dAhO1v;`vyT zncinUI(D^;sfcG@VyqJnmTej1FrmK@(-?1j!7FVc5bq7cnl#7A4mJ!IoF;nieIOD$i5Msv2V|Y*y!1$IaqsUlGSW;)lQ;;%a|$n}Mgv;014EE>|+{Jqi2Q zcVZBuJOJ=uA7H-#61q#mSTL=dmRXGFi|Kt|E~5SMp1gZ+>uI^oA85PzA8saeErP`* zW>)!kE?)oPrW_MRAc{>3!HgZSf?Y)xCy*rJO0B?&!7#w7SQL!wEe^#$V;_}Z&IQJL zzV;5WY9I!%3n_4g8h1?iMTRC|URK9C>lZvKX@+fKOSHU~wwD}|!z+&F_hj7YJ+R#(-V<4RNlY4=c_s;ed`O- z!^T&6cvR;A>bT_tyL+~uE==G1@}2uHPi+o#HtQA(mzc9hFNS-(bAOtrwE25ecgbs{ zcsNs0ndia!-Nz7z`n!l&m2;rV6orcaxK@jQS;A;{c6#SW|B=*7;Gu@Tk2Pt^BhuIj z?n@z#P#r0KZD!6g2azgsdGcb8#Pt;UpE?>!!JSV#C}nLezZ*(E7C#elMbi>xsC2f3 z2p(d+6FD3rLje%g8asgJ#lw$_Ykd#_WVqi%_gmhpxtNKHvj#3c1d zy+SY^^O6s9fn#7x+k46EjvY4e&w@+#Fqa(P{FuFizxPg_(Y@_}c`&}Umty+D!B&w= z%`C)B08On5Pa6)v0U)*I08)_V6Cvj4Inm4jJu7#>OiaA;Uq5KL+V+FIYx?IO$k!3> z_balapJ)8OSkK3z|L5JU*|spaQtbHy?R<1jGr%e0fX{u8o`Eb~cCQzTZ#Iili|>4o z5ubl_GVXOeY!;;iT}L8cSbY1UX;t#cxkrbb2L}&c(x)dK$WM#SiP;4m7^G3$UXCOp zh%c8&A)=#`fM$G5BJj!(Ja%f0PmjAbl)%SkFp_qeZck)Ztay@>Mwm1b`_WXA#5l=L z3Ns13f=-iaka{H-3H+*XTJjk1mqR2bpb~m#|5)LfY(alNi!q(nw!;xv?{TgnhD+X5 zG7hsrhJyD6=Mg8cy{jh@t-V^C6&!>T^(?Q{_p)to7=ls-x}@{^Zi%b*WJByTc2o(TKnsAV4Oz5*FNvQJ_Qu~ zS5tmR+~}okiRj#Xl7}hk7T00g+Tu&zS(mnt^9{e&w%U=bPrqHQAoA!haxpi}Kiufn zPs!UlAs~2wm#~D_xV9TkMIa@=ITbFYGiC6f<_vykd?nhY0ORgs^0(7KOM74h^v-Yw z5L(NZF#_4dnEXZ{6Zw1sp?xrH5pgiQgp8V|6;5hqe>GVz{bR={^q}LAF^W9URLG}C z;1?$D0BnX%oFM<3sHa_m1c*4p8%8M;dP^ku2Sy2wO2sC!R&Idy*!H} z^dKuEQ@cbdKrm>?fxUDC=d~DgFd^!J9Wh{Cyaymgnn}xcmxD_%1TV{gG)9wgpobxB z7?XZhZ*b)AQQ9kJ-DQ--8etlO@al_NMiJwH?Gd<(%`&B-t`oyUY${&yQl-*7;3^&a zsu^G!@r^u{G@|Z>6H@e`zM@or%a{X2!f1o+vgNr`ih`az07RhCNmR^kWsX#vo?vbu zcO7LgBm^9?DX8Fb*jfr|cSm)A(l3(()F7_N>S*0J#UU}i{S8^qoQ>fJ0H-i)zZK+w z!mnPgxO5&If_(ia+&-oH!b68NRFbkOw|BfefpdLXULh+nO)$_#=NMsrN8Sd`WUA#! zwXPJ898r|w#*vafI3X^DiUcX3+DSQ1WXQTsf!{#rPq;Ql2PQO0v0ogZ8RsPYYb!{@ zhfNwA#0z<&SP3%Up=cIC5R}tT*~BnOU&A2*e6};ka8OhRnVJoT+gpdlfe+(chIq(! z6EGU>5+MJR<}5*1^CTSx%7k?52vhy7Lwv`Sm^lUCGQsV8AAdBowU84ICqjAtXpo>T zlN4SG8ezzjp-Gk~4XT4&C)$R9JCHHl3DzlqpID^8y~q1?6Lg?)ym)JEowCAB`dyLE z2hwLZP?jDA@=&54*2a%hrKlh}yb%cITQv7a@XrSo!;85ZsmchU1x>`^g4U}fu9%IA z6L~?FSnTlZOwtMA7_8co9cV@Yo!e^2A47j|46uCV|~b-NFrhvX*>F_oPQU1)GYD@H{~H;vsA^^ zzQ`4J9xGRO|BH4u+p~}-OZWdmKkG6yuEGP`xsHCV%iB^kUAWE*%0t#Btm%S;g7O0$ zASPnql|C)1ZSOD3CD$ne69y)y`{afZW#e7Aa46qSCrpolsu@{e41O9NFD)ngjDh5v zqw>Hf<(XT`7G_~O8e^G@^E7pBNM2e98)G4eP8uFXe5WoPg=}XoaXyU@$x+U@7Mmnk zAr;n2vxvb&W-@kN0SC~QD|0&6!w7z(kiASxl#JuO(-1>+vuT(}q*=;B zHCK>LqzwwREKZ9I1D-5nPeLCwBc$W`-tV{?gF z>E~EQI(~^#hj>mR^U&&$uw&{Y>_pf17LS5+_2VQKPac!o17bgd(fGJ2%$JVc@I`&7 zqQ*6dlSUxSiZqf4stOQ0r8y51fCy3ocZ3;}eLe?hana4f5(VA~TMY?Vp!Q>)n8>2- z7$ijLPi}c(Bnfj2LbiwLSOz(gZww=ps}Zc187ow7utuco@@gZJ*w$5okE}CQ!*7wn zOHV%ZD2-9?^a!g(Y!-Y-#BC@S`d*9*p1>%f_u_kjFvu4W;{)OX4i*U9!*&(8XC$$t zU*NwU7sC%MpN>Bvt~yGm3Z6Mrr*mTHYauwx>FQF0guu0h)z-~*oGkP7({S~|KOCQ2 zZT#G=#`41L)9TC_-`4_+i0j4KR}^g_yk@S&==*VX}@2@IdwN+B9N-cbm5 zYJ6dVo+k;qH99yL+Xuby1r{S-y><0Ej@qJoC=+pb)#;lobb1!We8@oz2oAvMi}Uq5 zpT^}KF~n`D_-B?^>aA7!fXnAF7h1y_=Gag;7VO46poMr6y_SHg2#6uImt=SLcmDz0 z0wNuDmp9-qVBRN2L}6BoZ_hEW)iy>cv}%c0X2++@MgvdviM^eTa)}&?U|w*!jD;tg zY35m)4Ig8N)z!={sfl9BNp6}p{% zlXoiBhH5C!d`_qtVUiB22H9jg1!9Cj8KfrgCP;I!LCG^Mgp4u|tjJ>jBy*%po-M)e zTY>Ky*rQ34RS5gN*4emaoPX?Esacc;!fqx&{ewMj5$4-JD zU|I-a5sQb>c}RU?g9RS?n(r)fTafw-;|`lpJROU^^rN*{{~JFQ*y<$!iN{Qy?fRy} z^JDRw1y(WsiD%iLdfuH{spiOxm1dz6V!yD8L)#pf17m@n_{5n2XFgGhw>q)GUB zSFn=>Qxz#{!<>x_vf&3L?z9-#nKs`h(17y9vrDaoMYiHl+#gPnyVhd6j85K>JR6f* zbM$5BC<745I+BTlqZ|WOEZE5*$czh~&J4i>N84fpo{X3c_+Azkaj!D)7>^md30meb zGT2iz=GnGT*iU>TMJGjo=r2SNa*>cy00RWk1`mZr2kyJ=Rt`s-S#5oq&N>E8k%Pq_D8#cXx0dQ`iPZ^daYd&{>hv_qWb??I?=`V74hw)C8tr+IFp6=7F=_{S4S6fq z`FUPlT#DcOohclpym>UQaJ{MWi$;QDde_#6;mXGk#7?x>zwd#3K~8mgZnGw-vc<)> zi%XMlGmbvL`3#;fzFp$GtyI3GUze)-u$6o9zdy(jGl9S01+W(>$4tKbC=$n3tlc0=--LAaYnJ;aSD`KPjlGI&F&-Sqfe-1`hgc z2?|IzCi{lLR-jrytfLf2sUb(x2anahT~!C4gIzxQ+p14d-RvHZ3~l%d|hWk|=y+Ac$i zKh>g^Ocj%*;5qstB2)}sJOq)pKmG`Sb@ zrTiG*U4$5d!?^|SoXiI4#t-!cx-Iu0$y7d{_{JkmUIZpMRc5gAyH(H?9+tn~#Wzdz z)hGIUaQyq5b5lRuI-~ z2n8yVqnHt5kmDxD!23uAJf*%Zsp!m&=lJlj3W15v|GHhv`*`eSHBH?5OyF@E zG*W%^6n>1aX<`|FI)-Je2#k>q!RyE?$Ul3q!T3Xp#4IF7PWLio@=yU^lZWcd=iQN! z9Ku20J2neVE7<0HK}vro^}}E^*{8jgqP)#8Mvq4UigV&CurXQ}Jxsdi-6tyfiX<&W z887eM{b=PJONxyBgrzVeB4~PAZ+A)oBMjXM)nIE7Xwf@l#qbdixN8mh!yuQXooK3w zTt~?hvrh>{p)5oPD$z$i8RsNekbKl#@DSQ5yo~0XpR5V_v;w|qtS%esa|1eS!>mwub#qBfh^?P3x;qc;i(!rg5tO{3Z%Ta`k@6n4aXt3<6 zU8nv14-~gQDs{xW*GH+&lr67cH%i3%qQ6bC1b6gS?RPeXo+Z=A@yG zceN9jo{0mOXc8DgSU7_(#`y0j*wA=2%;CTywNYFWsVn2G#3LjSE*HaLgT5Hp!>O7u z3{vfo-9;L6u!zt^3({w2Vb|gy2C_mxpF?~vR+LhI^wySab#JHht*2;-YXLOG8#r58 z#Z3clr@P^5aEzJ7KA$TThNes9^CeEv2YcZ8aqcDT5~M-FS*PHJ0b$LZN6I=#^fy4easeI|1gs z1SDnf6<(SIe_1&}>+g|1j*6nMD`WR@z9i@W4Z*4q%k;yR0PAS8FFLpRiK$;@gqB3d z&$lkNUAaUQ?1hc*!xSn$xHKKlN4=#@VjqM+N!imF0DZOqCB~2dmQ&3BMGo%-jEi(M zujDb|>nB+dNPGek8Mz!7tN1{4j8+c7AdR&M-@*etx*c@Y{-~GX!_~BnKePS!>|5E~ zqMhm*&US)pY^3XpOFhiP_@1}>)*FGknT^-95dWkRCWnY>O;ZEyT1Zg=A!=)7@SMTFyp zbeS})B<6cqkOZ}Hh7NtAMT27)3Y(=ak``_1z$9ZXJ^yvck8GZMh9EidoP8s#6N|${ zdsz@miQc5&B&7lJ2#A>JE6^Byg=v7=bUmAeKBWqD68u-5n;aWhj|L=7TJgGoWNRgS zb#tmvI)K*kV1?1*4!W>D{bo5;C_TcigD{Jr0|gqS>>pc;_FX2FkFQ-Olrm}jfq*@T zl>Uegr~|nOK`)NdXF|weSz!+&`IzVux;5M_ICyCl)C=U$T^@qZ(0rB@L2U3)4sr>Z zjCHf*P1#vneNykIVaUQ53=jyXos{>sr4Bt#`0(t=?smQ6w1Ci*A zQ3oWK`do$S;tW$5`P~|*&4^61@Gz6lg$Gzyg|J5=oNko{M_5F1gJ`F@3F81m>WDnh zM-bTBtLGy^xJ8Hd%3dK$p#ti6S7&$BL-pu9sQ*nG48rg%>|`(y5I;=3`0kz>jxr>E zd@(Oy#rUpPvwm%=%Cwz9+;(Fd??BO_m`h*L0x5VeMGGWO4@opFlIyg1L{O?`Pvi}pliE!|(kfS2Q75%4pj}B^ZAdkPEy5^AknhPD23(@7lK_O@U(KQ&=7}u|L?4Bk^pq~$2>wXuFS(`V z{13$Yvt()PksdrrMEe{-(c>^s_{SHex{GY%(f;&q!SO$gM6Ta^bxKQ{5ae8@GAs|t zC8PdtOYJuvxwLguQcxD({uV#cCy7dq@3*JrosIo2x1is8cv>_ydDCjUu(dzf8n5ZM z2ln{eBIz-l+Q@plbN?4eKqq01JP7gWW7*xX@vm4>sAn+mC69R0g#Pep737ArD?dTpX zWpEt+S%t9b`+Nn`=1%nj?R)M}3zU#|C43R*naMFr0bddX+LxVPiXpPRDB7bR8-(zO+UvZ?6;s58+LubL}<#M?vlawli;P zzl^@xLU>j5cC#QCzWX`p6^RoO($P#|4$8IPg(>m+lte4B*m#BPbCW|R17ns0-wYKo z-=HOMp$mF@^h%9!kd{mM zP6J1Z1*X6e5nT`M^45V~m6NVa4_(fN3d~+kH3IZ3>@MG0zq<1Ch#K7=!gjk2!8g*2v`y&x;io7=}UI}?gaA-dXS zoVXRrWukhaP+h-4kh)MTrGZJe;6x9hB-X(Q4FL)yN?VXB>FQL^4|g*i`2i|k^8r79 z5PorSCm8HAjYz3S^DLhOE1z=DGcW6j-ZleyM27b>ysMg zn65wxuP1flEt}P|-?2Qk%Ko@p8F~an{5hbJt7$_0U zJSagHgOmZ4poD9tUed9tXuhK&jrfyb-1EghyAQp9bdWmr>k}{Qk1OWHz%{91iKBR``VNF^|kD8sViwKMAlC`BDO%4GRh` zyIcf5U)LboN*WBO?i=9*atdYgH}C}`e86?NzVZ@NZIElYCTlC5jcKid8grM|8msiZ zSFSw-hH$ObK-?;~>AOR@!EAGW`Nak&b9J_9DJImeu1n*(LD^V?{CQd920faF$lm1RZ1EFur?7=H&Mus*a)tWAN{p;4I+PUr;+pYK2;qqy^z$klwcq2|{X z^+a!iCSJR(hqyd{gO6U|2^dZguddH8*XLKgE&^OUC?6sV4orMusWBfEQoB#X7DQ+s z1oTNnz~j^P7@a2O9=utDCE6zyXO`%D@-=+E-l{=?&Q!yZ} zKz0Ra4i&{`Bns|$`Zq-X)Oh1Xbc!*)1bFykT$9JJ9|UTbFgP=f?lp2UsL7<{3FG1^jEuqw6PMON#q6c*TmHHv-wQ77qX>HCfntOavtyTPoOcWN-qWf>88<1;Gb#P3BKTX zBRL!B+Q0K_pgsF-(;{^f=*?>~6C9oYLTEPT)~_H#H?R8*O1bVXT-^+>qq-hnxywJA zbeCdYxNhxG{bB%8G$efS6TgKZXi<{Qb9pwj7MW6p%VC8I{KJH}JaaZsOt(@VoH4yF zk;|Wy{{#*;Qv4mqhaL9OPWx_$eQNJ60-o8|f!#S?ZCx2>p|RgsCA+@%*m?3{qS+ z?7=jqtC!2c7r<`Kzd+Y#O)37GCh*s)9vG`#-Fm_6R9f?Tuo~w}J-JYIZ>-_!dU74r z^$VTV<%MqLG^C%D%Ub>f4nKi|!GWLb3xUMnWjOSz!ISDFWv!&gV1Gx%$1HtXYQ{Ki zNrhD8<&_|t!T5#7DjeR~l~tUkG|wI@9KnPvRs4+7&lvrjpr4cUa|%C*jKWVEtwTNR F{lEX;)vo{m diff --git a/library/lafite/LAFITESEND.LCOM.~2~ b/library/lafite/LAFITESEND.LCOM.~2~ deleted file mode 100644 index dae40cc7c323e947e2e6b5bb9588fa6d27286b17..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 45033 zcmeHweQ;dYb>HrSlqgxC0ScmNnxU?imI<=L2D=M@A5x@!SS+{?*bi`bArd4d3dAn8 zOMn0afL0jWYV7eJ`J*4MCzjkKjVEqB>7+>u0>q3Ze{9ptWUS02X{XXevS-qnHpz56 zZH6AD)Ao;={hf2}eeb@v3rSYXS@(99(Sral^j0SJ4g*=QLC1lP;r$WnrJKx zrG|%xRdVF?X!>+I9an?#g_Y|!T1$<(T3JS=&rDROKljv))s<_Fh4rVeH|k4`Tj|8; z(@U)@tMjY3o-R0(ZY@{Ml_nBTjvZ6Iadm3Qxv{F7J$ZUKc{-hnt1GJwuieHk+*nr|>rra4)zoO3D@)mp_Zov9vEH&z>;Zmry0gJM6emH$PIea=f7FWGL2@pq*^-h$1sG_56xma{c6YBKD$=<<&8ceC_+?-0PVy-l+ zh84hHJa$Y)Qqf4H$9W)ve=pL{gY?rMjpVuLjYNHOfXnkvrg`w-!H>}6W?y7*WK7Le z%Gq4Cns8=j3UewoqAt0m>TD%<&Mi%p&#C07I+Lr(&1^MSLG>9ms?JSTFft4ROOeJq zgak!21H4SQCAa1R&wzKT=(r_$85NK9cCF_C3zPJdqMx)k*WfJGB<5QIw$-XNG>%Ch zk3=J}nL9@_&NZHpb01BM=Q*(d1@F4a4>8&FDKlA~1V&fQI}He2UAMy_gQX_vbfP(3-;1wl@v0-y%uJx~LAa_4Im zCtD-*(fAF>olL449$7U zTb<*sRWjWjOGDWAK5Hn;Hv`c7sHkSJB)n$!O3Yxvh&G?kyVV-1B=xd7wQPQ;D zN<*}Xj^mkL@`>4EagG*zC`+|y(MPQ|Ce;|XQ7T{)oE>`BDa_I~7}_0+MOvBuSai1k zv0c1EyyX0|hqgicllMjUH4iR4#1FA%z-}5Z4_6RSr2wAdvlwtqC4u|h_OlNu0BIzp zPM3h1PJtjBYHepA8u+CI8Zwp1f^&wzkW|NcujM8HfNBm{Z$M*D8Cyhe1=kQl+BBM8 z(e?#mXq-##N_{KX1dyWR%EqnK__ zh9|~9LgL4H;=<_!kqZvMTywH{J-Jj0En=35v$L2g*q0!NGckeT&tROO`$AeqRkl#B z<|a$QMXNf`<`P6sf1+grs;1QO*_oLf?cS;u*oe+ok7G$+-;E{ZC6p=gH2PD!++TAU zC;9%hOy1qTpKI}KFV=bKr`qQ`UYPhC)GwQ?%da+P0o$=lSFAx+&Rj+V# z1Ov!9m2+x@-*BoVy%5s|t|l~9NGCf-(M_@;^x%$3u%!W2S~rsi0lzI-7S& zXCO%@$I_bHP;Gir1*S#%uAotouCUY-ARL)~1iH&)g1{PhN8S?pb@ zp2$P5$W;=#@}##NhOI42W7dwbCp`6l7j$RD|_9fmGn(rr&QiOlP}lhUrEz2F*3kNj0Ge4Xh-BydNr1uB1qCgjd)$toe+*;a z;)$D$3_LWn9~{5?3Xl?@pMdHoNbFBcI5h|I2NCP?_!R9E zgSEx-1VnwIUlwXVQ+X6Y6#lwOo z(lkHb_{QR!0NL$(lhN-wC2y>N&i84gmk+lwW&-ej*>#WB%ZCQ;YuC$%2OetI7ysl? z1iu4^+V$mo_XZBO>(~Bd043bPz(5;{$hYd#1ATPy?RsHgFDeYg=qJ*a8N{3QdY#w1 z_kLRS%Lg}K0GP^$W$;cpzF0oE_zvG`-dXO$3Y6pJgXR6aR&R1kHeD$Dj?KRPkOi#6kRuXXlrXuB-W*>&?dUdTRkjI(2gmas%vm zFFV{JDh{7e@lxX@eG4ucuQeO14KNgO{Ngyvw{v$M6XNCy^?q|s$}ik`z@2j60_h~CPbNrUI1u7h32Z_VB;i3^?H*rD9*~1nG19-^a3LyTW7$+i`6s7L~9V_7^2l4 zB0ftB!#E}v6aEwAe*ICIOn)>swf%@AJV+D-rgMGKSSblQcUzz6A`ASPDquHXV(-r0pk@6YsPexJC(zsxLs zLT2r3Rx^v&n6L2Kw*_|X%r$=A&eYXX@7=AJaKXg>{Ng)-2m9NZ7pTSj;@eHbdBfUg zW_Ci^8<;Zaz5;@K0k6HXq42qJ8x())_Z%-}{W4zqk2tCa=3* z>XnP>n7jD)fhk~P3an8E7&iV3kZuZ?@PC zGtCGo@errELC9~qefBCOhs{3FJPz$!{e!po??Umn9>JO*8%4}P?uA?yOAFRy7y#;$ zGz|p0LF~Ro``h`& zB@s>-8F_*E$Ctav@(vzu^Pow`EhvCov)r*$=4uqM_W1M2h@nnkdW*~h*>bhFF zs+x^?D2Gp|`QBj0&HUHv#YxxP)SXyhSM!mI;H^8kl*P6cpkJF9S7I@3jtwg*Rj8(<+ zJOUmRE2?YjD=YQW>hZXxs%G+V05Mq<&8zuvq(&QG^L#(x+mL_uSF z3*YBOJihy?i1iz3e*Nw%{BYy(@MH1p-2Dna{v!YK50e~zl?kG5^y|0p-6H%;LFlv* zkR>B62&F&^G$JN}Qf4dKB2?OwK_EY{I3jzKd_$UT2Fy7?wiF0}GY&ft428CR!eK`M z$iqqH7U4gF4#{Q}W8O%@t^?xW6w2jk7*`;CkyNhlU~?2gArhpBeZ$5B;1`ncRaKy= z9kq@9NkP0j?Nq19^`L1FaVOs_r65{$e*i+({Q-nlyFZBH3@V+7(m;vw`5xM!Ewv2)f`>pJASHIzbrj6(ohQ;lC(Z@_|6 zClBW8{K7gUthL5EYQR3mjbbm)zqmSoqiHwW3vL14O`Tpv+t}RFXKQ5{ufodV$&$Do z2C=9#XaH6d_AAd|GipE-ooQHo3h@5HEbDo74EcpGq~-t-!kh1T?5r50EdMas>_59Z z<81G~b|uEQvICvBzPg@n<3``Hcbb z0pv1lmx8VeUMDdE)7tnP4lKnct0UGcSTVS~+!ASDzzE&WDUjn@9%A5UO63W+l7%1f zbEs)7AzC6N^wfLIfI^&k@H4~EV{{_XUWS=3iMU9Ho&tFVG-WbE;J8Q<*;lhohECg& z8NYE~Q>cpk&Pi!@dzahiNX3o+85sofV3srsZ9xSh^9~YADs)pga?7Ozxv9WW&fpr# zXGq%uC7?#g@@sqsrnOF=fwBB`(Y_2o$lg`0!m`YNlfV(1b`v0mm_%>KnSy#wZbv{d zUVlX{ntjeVlfaEXgP)u2zuis41b4TTCJ&fgkQt9H%2+^hQ? z!@t|kz|i7|DfCLD#Yo}^&p7%!Z3Z=uwJpA;qtLVRn{h$MIn5Bace@)RGmAd5k=3p1 z=RD)1TR$t!MbB?ODevp8JGp&$ifeK`a%I7?m2sM)wDn1;Ea?xe0Wq`Vdmc11HwcUx z8=)O*7gq8l=(jeTkl7&sOt?acB5?o>Srm+doAzoYw?5x){`1zw zjgwO`=(gXSs((oGZ#G33Rw)Ri!hNA~^XsWGV4JcBbd1 zhw<+O-GK!_*l}w|j<6Y!o@4LwUDB$Z0tpabd5Z0{>@A0(66$#X4zMS8^qcBNB~oCr zLP%s2Pr`Z%(cvVvH(hvoL3XxM$sxMY+UZq1HUfCp$4SU?0Vom^hr9)4!d5pR5vK!C zOLiMQIc3kzA|{KinQ{fOPcERH2RgFX0NS;_B{mD|Y$s%3W3-4VoU^?3m@F{SAc2E|>5AoNNrLdq23_H5ctW>_og=bP*9;0mCAkPw zCPW9Di0$GqfeOjj0!i!yM!1W~NB=*0z}XsP&VD7<&Tjq;mu~JCb4!*V2yKqF$0a}p z9;sh(nYuWdbTVCmukBHhexH}8^034;TeqW=(dUK6F?9X~ygwU%%+L5fdg<$}jd)&o z!mfh;``5o+XqKd%))xxjY<~H6ba%ewE8Xo9cYQnZR}A;d`+Bw?Yi3wM}~!ZJyQN&Fv+axI?E_a5ZYzD30`;!6xz z0jkh=&6uV(4+{vzSJ>7!v8aakBDcvm@`&N6AM$ng0*PD+zasa3ld=fh!oYsFPbMHb z;q7~eVaJDi0yJ&Bd|qoRqtNJrWOx)pSf~Utmk?SVAEZVg1BFUJ`ht951cDd30x|Z& zq2M?Ow><(kda$<<5=#S&Aq~|ZF)xT-%1uZgRWL2+V;rbWx|k^k?;3^Kiu^14&o>47hdX)Zh3ckICwCTsH)o)pl3|A$JqHq%cV-a!1VL>?VeYK9=QxfaLD82) zX5;||Ofh!U8K@C?UG)pXJQ7tHq}3?=9XrJCjzTx&>5f8^?cidgkUuojg`d_pxz8eI zr38O4%w%d5h7q~|G)G`z^2}uvTn1z0Gbn}4NejpQdlqYHG?*jG|4?-+zU;jM-4KILgF-Ixi2&x3uNcF4fb{?lOdFg!|e z_r|a)!LiC9U_yk!gIAmsD7gTskPFPjf)9Bzt=m)3lmLY>{2>Mgbc2p|N(~OHgc?2u z;EI101~>RoA!qp3vmA`vE2}V%b;VoO*%!12M3|wXmy)Zp9}q;(=ZT#$DbIMli6$J)eY8Cu+w=!uVc) zg*nr2Hv5>jwnRZ=hVs?Cs0&TukEAJ_5?Q=M9l-W3gB;QZbs>=n%?!|PD9B>74rvmQ zkvb?H(HNp76q_!Jv%Eye06g{VrDRgQ(r7HRe*)9uUdoN#zW2#k6q@vpOuO8%Xzgk*;XOixdc?SXfD2HqA25 zA?m41)NTqS6x$X7l@L?Xe(%`4Gi13Bb4Z9U7-3**L&cvhQNo;w7dF9Fh>Ku?gs|b! zPKHbX2ncG>y)S`*Lb^;~Itkhzo~KKXy;M$&qa(@~qRy~aQt&NV>>~xf1HlXX2yBC7 z$_a>M6mCp)IQFTNMw6w$C(=o8gVHOS7W+a;U`GlCff+79krmjxn9&SxW;GRnhD3va zr-DoI*WeGJYDCh~fK&V`jCYMXJXC4GDqde%hS82?fjB(64f0Q^tEe%!b_{-HFuxQu zYQq#Ms3?By85F`RNA<}Ad<(AO>o@Rf0}kVf6?JRnCVbBDKY=>dsmTU=gx3(4TxVYs zIicAzZJfk|@Czqlxf~pnF*MX9Mi5su?!z>oM@7*|FEv{W&0rhktSCeqT#VNlC?XFPhQ`g}=ft(aGet6^H2p1PO8a(EQBG@vcVS#W)6((4U zw3%Td0zVkjFN-5Gc?cK!!OP(0ER}F;Fnx7P%OWh++;}pF45I`>3#JgnMzTuB-p2BW z1xjBOsGebom#j8eV6spN8-!@CJ0Lea)d}#7K(CxnB#eVml2fQYcs^X9TZEBFMiDj` z{3tNJaN5OeBo+}~F~dYvewh}toJ5ImXAdsKq@1fT-<)AMUo(+Fb-v}-euXc=S0UUY zg6eeDEzTe_7qiF4*RlPegc=Be0328twNsHJZXk64=0qy!7GQ$)u5%MAGFi$hp$~-l z(F#hlx>$naurtllQcw#>Z7^a6oIg|$uHnV|=;8Q?8(1}2Fv@meP;)XS=Wg-xS>Wg7 zEeiON3^>ZsvhalRw7iGMROB&aXhk!34p-q=;&otj=O4CWP!1bOGm-+w-I&ZZnEg!V z8bgOO4gzClOap`=xOU4_(~D&}*F141XrtmO9hd5%a6N>j>3pp#k)49^`;$HS`sODn zK=1X;;?&-`J0H#CCKmlx#$Ad{Q#K{pk@awZ99HN(LZXZvcr@fm!o>WI$-(%P$6(_0 zgAU7K0>vr(VAnDY`Y<~Wd3qf%P?V$*T3_aUcmO*HheA?1qZR>?H4@z&iJs-@!-rd` z%~qFootZ6TvNwTzU6Q@RT2n} z$Ooi`1`;l5v&&kdrEY6a8JV)gl#;0}Kph(%e#ef?%xLbRs8Iy^Kfgzm8Dj-KD$>13 z-gZ{Y+?Q`heuIVI+mSZ{Hqz+D&6mr4uTM9%jgqPLqxJVw0+`|qbeI3XTQ3FV|7lMX zh#qKPveGG#Bykp|S)@wz_dUQJpF4n5(~pz~n2ecR(_Q6#`<~n0!$bPz=yRI~_)3Bn z+QnC8&c(hd9uxDNuNKU7rlq?kn`otmXiDVuPE!mx^ z7bavtu%?FOZQTt=pm;d|7_CpC;gn1J@-oykBVv;r9iP9lLgAJiAC~f}QMfK-UxyxQ z`IN6oJ{1W&Br!u0?L~TuichjIPm*>=6hFD*k#pHq7c&BDXLwH0KjHy={7G1_O#Ebj z)CA>hKYH!WypPa-I(O~e&4CPpo*BRU1o;uJ1uTZbD8iKJM=;z1muv)3;E^7B;Q?q8 z)|=%od8Hf5KyKiNz#d<&A%>p_gz#`;G$hw9QAeYgSd6!-L{Q;Gh0L}@aq0~1ykuuL z^>n0kWP35`}JX(lvOrsK3PFDZa}0H=qP;)z_y)MI$SdWl?fV z$gy@O5W1ChXI$8;tCn0tjK4}@Kr={xj3V2-e|T4BuZ4Z*g^nJ`#9kGebx<Nx zcb7jsztpNLLQ;+zVItnnv!K9*#r_nD85T`glO;+dBi>%@a) zTgEs{=x@X{#v5PoN?QoTd&96M%`x&r2!|2mEWCg}kvskTXD+So-0xod5saIBe_s3I zE?%qiy}w!9>FWoLGg{5ez1WJ}H&pCypZn@Nc26Pr05wxuUrJ;RjN$9fNoHs?CSzZ(h-6|rH zf_zU&Xo?mzjNc7<9bjYbup>;J@!499ok>Y}#N;OTEH*DW>)?km)hL4o7CS11JV=0Q{ZzP&cab4~cT);+9ew*i2J8olGjM0l^PvHnxaYjQqEk8JlE)N^ zYYEAJ>{2Bft%F64))E4~KRSUUjcyMJK~#=dFdiCDI?{7sM&(V@thH&3kcZ=OZL`rh zu_&e<#GLZcyLU#ew zJZLm^;=mL-QX{K{Z+`4LaD(Ay;At{=!P}V2m5h5&!v6K07{n+K06f?S*e`;F?vgMT zOzVba7UTJ1dOwhhXn(vX@7~>dN^bK9+HU?wn+aWuU~!R|RsNj|*M77q$3zi`V$(t} zV+X8YSCPdDBuThZD{x{k3~(wI1><^)L-EhpMPzekGp%Ms1Ld~Fb2OkA^mG2ueE5yO>6^A0f>0Bf79YMVV-pk=N z_9i<8gxifx)*sF0ukn70j?-3}`##-7-+Zg-PW0X%!M_P+L3i(b#6&+co?)sQhymOaVO!V|E$^l6C5Pnj%J=`fUYA!n`rMs888>o32T_b~(A94PNC?<@Dc`Bv#q7vH{A9(Z^2>8Z_+ zxl_|1EEfN5H!n&^&(i&Wae4o>yIWr>@88|?Rh^Q)^#$o+Q}guMnvR=FX4Ah>4hKy?5c@tAg+`+nXv{qy(b>j?MzRoT(cGk#yF=VQ_T^X}Gc zTNqp^_WXf%K02ov;1qGd=e|$RK$b4K*9yfqo5iWccfQYv&p$dD_Zl8Hi&BEFBatsG zzJ0;8D*5ExqeISvg9k6_(~}P5r^V*P?1Byq(kN~(M-malmrA4%(a}jjGd?B}cx4D4 zJGI8A$K4uA;A1lwNxMw9Co(HmJjqETOd5&(Xevo!oMb13nFL-zr%5$Py^@OrepNUv zc?|f=Arcc%3B9v_tnf^>pueBRm`-ck;RvkvIM)!vC2uMjhuI)Q!TW;qh!fb})f0)< zUaidv4nm1~mRIKPtBeY-ZG46a==RUDUc~Fd1^mPB@DD%bE7noC-W+f!dO=+OcYn3b z?OmvE4fl!p{;Tb4?%uhrPc%iX{S7%VPNU#!pLbuM0t)`CDZe9b^y0QebZ$P*!xVLk z>o9F?@g?u9i`&QfhF@!2?MT+A->y~=dGr^!n49JwZglHsw!Yfox(-ej|{Hd_IBD zJ{Y!$I2c|+MorTSCpELbnyi=pv11f^&~eBZMILA>?G>}`GD>2N zFbzR?^+heCh;hL72;9YHnbJ_#iQyqO6|Z=yQfVG=m5zPY3^0xOMxII+^4uv!K~Ek4BGBk0DrUDbN2*OvFgK99jxrb$0uI>}RB$Gw7-*w&j4;0=Zv$sC)$*iTSBgiDC`xhTNJ$@@5SKzl zf)r5gq#P$QWL>AgZy@w1TpObU6Pl#hFAmU*a}xg56{O+ACXEf^g}hO$1exzpG>aez z%IT+UVwj|_;*bD3IY8nsC@O5G7>#xbkpD?@mY}P7k`4o9 zLb`Q?ss7d>zGF(voPuwe;P$lDCGEK=a!Y!Au1Mzt>9ZRsOOFD1C{Yh<s1n0%tpnDydX;~c6fFs>4b0$R&B`+ zG^2pdZ8hYNp+7hVSuS)h!Qma-Y))z^K&)c>}%bW@1kCJGmm?+&b zh%QiQW@cwVO`VCkV=DG<9{`3ico@I|<*NEn z8o3TVYxXq}_xOCz_WjK(v5jv*YmGj~jeG@8$mqs@FU2={m6r$hS{?`Y2p%uo zT%R)vbyi!A^&xj6iHKdK?dZR9{$1cvv&aJsR?zjvHy_XF2Rs;kJszxVKjN`*qKY?5GwR9Gv`A_fzg$=G!T96(#H z%;{VYBlwL%_A)I|GLH9>mmWR>*6bCJz&9YhjexD`7e_$hbs_XMab>|ng=i{byZLgp z#?lUnu?2B4lLT8tMh^_76a|kH6AYzKLk!W)rePwHW+@BRTtPOGHYm`tI4v>^c(RN= z34PFvkdEh*w^DqXE<+{-sX`Z?G@~YgN0$L^x_6R|%_U}~pJNs2_$5jm;yH=TL#so= zj;W8Z6J6h1JPOX$kCRwDc}#8(i2VpgL{Hm z`1I3tIwyucB!aV?t}Hc32wYoOZQWSM$udtp1y?Wp!|}=0#?RkuEHB(Tt)6~bIZMcg zSVJi7G7hh~-de|bHaI$}yu8p*Pd(M^UcZ4;ZMfp({QCUT6RO%+rSES%p-7Bb#c5Gb zC}(+j-81HAg{H4kh`aQiukRcND^%8edqT=ShNYjSddR_CYUv zfyIbdZ(gB~w9q}2i8#FKHxL;@r)N>jhaAL!-~gPyIA5>xXB$Yj(oa4MAZPnrNh$YRp@s5P2Q*o^^Eshrgh@K6 z8f2606o?T9WssV{n;^}_1|`q55HiXtERw3;7T4w`? zq66Ih023+zOSaoJE!cDjwih_eiC!dWw+V8ez?I-O0B2(~?u;_P$}MIWvTztH@-Tc} zg&7Qj496}7w)iXC@9fI=&UqBw zZz=y4818dcBW76A0W4N>OaQ4k1{3(;Th1B6Y{INVj=J#eB4JAkhd>z?)A+`a#1W*R%h!>&j&R?M;X9CG1WR(Cynfd4( zs1LLVCps75&QT^l?WRyG7N1)TVZOYxM`#%!4I&ZhlP2NkUBONkOjV?)4Rba!$c7(~ zxYJ@_XWD$5Km*DX&n~qV7TJnJaep{P?rMweGCFxj@@!0M&C!>gqYOYK>qsIEj&clC zv0x{MATus_Ix_?l9BqpYcrs!(;CoqE#J$SEV?1W;CTN+%$Y4*=m}lEUVL$PW6rB_S zqQ4M9$VEa*0SpjC8$1*i9k}ndTR9wUX0`QcI_nrXMJ6sFVSElbOHKN40(dG;tK`Q9 zgoI!mrlQB)HOtPYS%d{*Nq}8=Cl3nX`OkU)PYHrxNFi0i3aY%YU6p4{%lOAvWJ90z zVDw}_zn6ufC9aRHU$?4<=!fmNV8<6$O~V~xk-qY+?sT#%fI)j4l;5ZdHjmS64^#uF zFL0xek`bR|ITw0Q=(8YLS31Hau#ia*>tF$MT}y(c0NOweh)sce2&jR3uw9?<2;Bnz z?M}A<1ivnmeZnHmI^_EwKwq&)2Q02q7veO6Wa!%5PG4vju=KVcN(ijXhHm>r}xWUpLfyvwT#OYytEGlc_{ zH;?8Ot~XVF(a3R3_1gMKT=@ioSc?|>_uZE-$k|TMZPxOPO2x&ui%XMlbHC4TK7;3r zZfQqrA%8MXpn zJ%_m<(6Z?6gpD*?vOoLcB``NARl+sKCBSbveHjvwpuZ*Z(H^F3L5j^l04H-M>}9AK z)yC3QQq<@u1>E8STP@Bdcqtx30pjE1QT$CJ=ACUSq@dfWmBGdG@!U5z5I>p%^N#l8 zL}$jlMU&lke!DMYA06J;^W}W>o0HTO4W0LPl>U!On(UtN8}U5 zs6h31V4U{j<~{=!yo<-3sekYj>q0f@@VRW*OPoa^{(Db1Fx%HuUU$G2F!)(6Zro*x0W}JQOt)2#P?jR_gg2DoOl7*qfHaH zJ|B3T28|RTJ%yj(E1OuxPsXr}6@f9*BzPTp1^H(WHW+_kk=Tdi&gou;OnxfhYw}Zl zxxG6wlA}22lgDPEX$9MSFG%U{r+yfWCcCw_Qk2gb#^~`VKyg-l2sTFRq6bMQz4KTl zUy)>nDC6bbJ0Go_WeJk8pRg3>MFdk%>+MddVT7SOp&D!u0xf!ntQ$V!0e7t-e;DMl zv=&V@kpn6DWA^ExD3pchKqdP4C*zz15t8q^3m!sih4;~X3zRh^pH{$Ut#zH?r!DQp z0A`p5fRiqrWC~99Z2x0DJ0ax0`khZnDAS$8{c874)p$K*!a*dXEFFWm6muz1PlOOR zO$!o;>44xv0AQGyEda5~Yyr=59BwHItfmzC4s0jBA8L^|K#0y6t{=eS5TxCJzbfM5h3%w+JNvj5uGE$z3K`#{ z7g*3>X;!;b`}^-JZhutjh}W-=QlKdX9A9ji-urxgb4V{*S|1~L$@uIZk@E+6A?3SY zC2`qFLmTgE=Po@H$1c$%FodwU1|N;_>roJ*@phO)gGG*`cqLL}##y;Xs2~JZg9AYy z4eaDpO&A8Le8~DDO*&XaXrfW*%q;9(9Na+G3Fvu<`^AcqNUXQEWU+fYoo_t_Ok572 zA>P2*`YP@la68=%SA)aMEcUrvp)fREDxWKH>OR;5&yRC5VXq*~3QjzoA9-3We1I<< zL2QomA;wQ?1JnF1*2!L4SzW}*CJ2v#s&=lmw1m^1)?Sj&B#}uTQr@}w)n#}pPOBPy zaKji5Uc!+itBv*5R)Y>7kxw$tlihtCZigjqd*LQNs$s!UK9@O z^yd2k=Dh^8LGTq`ngoAwIYI01kv@)=qOUGv_vz1@V?PYR+7Qc-jR98EW?yt}^Al6Q z#t1D5ke_c|XuEQW=-BfcKY)o;d~<0!wvT#Cn}k0Ifs)FnF#wuH0cwpQ0W7DO{fpe* z2^bye$X>~B!dFqUAdvVpBr)#=@_jXj6s@g5k80ecyv2xul-Rk^M|Wx+ka;J z@7cGqxkX>qHJt4P*Vstc7ngdNhw(jc_pLVqbu$~U>9_1g?Q4BvzxGbpPqKVw=NFlB z7{`Q|Xk<_mn}_V`6VOj`dv!bdk5ugHO5tX=AxQECx66b?t223>wA$YIPu%XtKhXK) zw2BDR3+XaxSWnD%vLFd+qYWJfMT-W9F%)UbBavdwNPN^#CQWtEuO0F)o9CW^NKQg$ zp9%K2er&uih_OU((r=Q|19=2Q%=8s#jK0D&KyA97*+M!d&`I!LdG2#;VBH-^nzZ6| z0m;@%1Ov(k=`1J;r3q*q57rqi?w||nlW>-^h0-SMItafAI#!@T%KowRY6@f3t`y4C z*RB*wr8Is*z#c?Oe_RLD0eUoyQSqbn`4BQ>R@n1Mz9+hb9SLq29LTf^>IHJ>E)T(% zXg*hp;5K+J2f2hy$+}tcexgas2`MfcL-4V`&p8$UOJ7>r@sw9fhWlHuyz04rXzf+M z&uS`*IUykOgAWvrPXUlDit1CM>C5t@6-}btf;b(Wq~j#zm=9Et^Y&S*)d8>+o^Pf$ z0lff{ROD3TzDRV&r~{H?eYV1MafT_3{B8}@W<;i0c#z5G!hNi(Lf9h_PPa;fBP=4h zLA2A{gmH`^r9>X+qX}&7)$<)845LGPWp9zCPyzM3tFt@mp?Y*4)c+<824Q#>b}|?U zh#w?gd}mJ$M;sDAzL1x%WqePoS-(D2W!lalZo9FKcc5rdET*q$ffT%#q6HGCha{R7 z$#q&hA}fJ~Ga#fNOpUj}C-Mf)PZg{TD(YJ03M=ZQb_KL6iMI`@X0SyVC)x&Om^KmXBmFqrc zuwAOL$|X<;t6aXKBqx0l_(=dK@@e59d@Dhn3$FaI&IME>W*SLjhw6 zHObT{ykm{jCg*}64}c|0V~_OUNg~?k0E!-mfxO@NG=)me_Lw5@zBMsqmr7k`1ZH?i9TUea(}-wE$?jXcew@q)`QccsmYsG z+l8(D!Pa<9zauYm^Nay}6&1}(I!%uEKengTvwiAez9&6TdY0zgf~1*g8O-gIhi!S< z-uQjQ^tQ`=ugJ^4+`{4Ta;aM}72SM!FF&xy-xf)a;nYSp-0ge6NCG+uYh<$KZ#2qB z)aaYBTF9Yq1si@N$t8vaCpbYN4VlMO)gD#|`+l@aO1tt<$YP;o98dXiD1(Z`ojU5@a>Il}M< z>Fq6_qy(??PWjYNv{D8!+!$R$4@mIVawb9$g=mMX;CvaaeEE?){^vNtwL#!RvL^)C zP>JW|Boi>D;@VL^Sjyly{4)$;)%W=dq|Ke`1={!Aq!uV4@3Kz`YkFFaU$VVRB+$O> z^ipgQ{`BI12)q<_XyWG}-Cle-bMa*d6`p(9c@Cj-5Qi-xmb6x=&V%^ADn54t#hGxW zrpHTZOem`2d1b~qdp1-IPZd2?gU8jAXf%*rfw00-b*JODZMqH>8DC%{mA6-lfroJ4 z(Rufp{-Ypw9^08WwO>YGb0NGcdYCE5h3|n*dPU+^gmg4hn1gcdcVSArJ|zK5EH+*t z``qO4$-tQ9AULxl%(rO?TQxZ6~*N2gP zT&$@YIMq^P9HiyagfXStBjremu7`Pf>p-u{30S6wE@wvBZOZXW;N~`Vmv63LS@{J- z!z?Vqq(z755@>sa3CmvoGK+KGojI1qR0i(pV{QBrj?Np3ag52WzeK*MC$qi7pF}`W2)H;R;-|p zX?BJbmqK*4%Q&Gcl;cG8LLt0Ce5gGy%NR+l9Rnpa|o*xEh zI`RWoyygRb{viC~;+QblXBv@GkLFq43syemp2ykMM5=+_#aq0Ure%hT%WJ`*FYC`nlZxn zy%8m(2N)<3jLk~)qD@&_%k^3vDVI+Xo2VfB>LND|A@N4TguU@6s zEnMYqo%12%V7O;W(ZicV<)uUcHHJ67wx&<&>z>FL17z^nw|{$8>+mqo?G zwZgQ`qGEmnA@q_qcA%O8@}+A^>M^EaVIL7NkVf`4SvVL(ISap}DQ`La!3C1|^>VYo z#(WSb6Xpp1ObXOswLDwFF<1I+T2EM62l=o*Ui5^bpf{~>Jfo`xBp1;|p7Ge7kzYDg zlmJJOk0{Wwu^{5I(M9I-)eR!Aq{MJmzmZQMs!)=D10OfSw_TU(D=#tO2E~SVvbNIM zm{u&PF?V^bu}YtU<=R8w30GSUgtT&-zDJZB%r@tjUu5Ox~v-H zFV7lJ=rM)QGhh-cNQ39e_&p`KEBfj~XCIzA#bBVIZ*E`vR50Xu{s0ECH?@Q~@m1kK_y56eSml{J?ZmzGdEGq(L5h-%V_!AL<^`Tv2Z3?UojmmtBLN8GG=m#1Z zg`~ek-sUR}HNUo~Cwc>9@#-x-#O3+xd@2J^z%YY&b$x!hKELX95n$v&5fKS;;NuHR zjrpLQ+I_lVlNonyjm~5yS*%vZ_J;P!=OVnXEM~o;DVTkL$KP(5tYdB;TsRApzK{fK9t+62 zF|rU{rClf@TJTkGcXp|-<;36%9gNWy)Phy1?JnY4XQi;r7OY_evK=M2?$vGiEm*_s zqo5EMtYeFE-V=+Zl3ZiTEtVP->r90pqwSFGOf`!G2PHgHLG$JJlk+~TnAaO-#sQhf zpRu7wzJM@zlDVGa@0)2BPpXv5Owv@?aySz}&<30WfG$vK) zrQko^G&%|VGc7y87aVUSX98XOcYY1DXTNP)q;3Mec}-@5qw`+~&BomN6=dk(+ z-|etZ?cGJdGy6KQ8|i_j1A$)o1*RK2(V3m-(vEbj%L7`+UiJUZ%Fr|oIP@<|JyI8; ze=?9THH1Z;|8;;tipz#Qn8tMVayj?{*sb{&==zK)#b46|{#w-oW3{VWFL<3wYhDjl z<9w+n7pm@!HC$a!uA{nsp|iTY(5;+?^wV-#%b&vGr*JSh@Y8)Ekoda{hh8;!Qk|sa zmGl_fl8~s3@PQfQyCpSJk+WA~Z3g4#8>{epXIEBn*wQ>Zu8`M_WL5l(($5(EoS>hR b^m7V72#~@L!j?`U3?_vPRG72)dx!rQjJV;n diff --git a/library/lafite/LAFITESEND.~1~ b/library/lafite/LAFITESEND.~1~ deleted file mode 100644 index 9a346728..00000000 --- a/library/lafite/LAFITESEND.~1~ +++ /dev/null @@ -1,436 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 6-Aug-93 15:48:00" {DSK}lafite>sources>lafitesend.;15 58121 - - changes to%: (VARS LAFITESENDCOMS) - - previous date%: "30-May-90 16:26:31" {DSK}lafite>sources>lafitesend.;14) - - -(* ; " -Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1993 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITESENDCOMS) - -(RPAQQ LAFITESENDCOMS ((COMS (* ; "Sending mail") (FNS DOLAFITESENDINGCOMMAND \SENDMESSAGE.INITIATE \SENDMSG.DELIVER \SENDMSG.EXIT.TEDIT \SENDMSG.SAVE.FORM \LAFITE.HEADER.EOF \LAFITE.INSERT.REPLYTO \SENDMSG.REPLYTO \SENDMSG.CHANGE.MODE \SENDMSG.FIND.FIELD \SENDMESSAGE.PARSE \LAFITE.PREPARE.SEND \LAFITE.PREPARE.ERROR \LAFITE.CHOOSE.MSG.FORMAT LAFITE.MAKE.PLAIN.TEXTSTREAM \SENDMESSAGE.MENUPROMPT \SENDMESSAGE.PROMPT \SENDMESSAGEFAIL) (FNS \SENDMESSAGE \SENDMESSAGE.RESTARTABLE \SENDMESSAGE.CLEANUP \SENDMESSAGE.MAKEWINDOW MAKELAFITEDELIVERMENU \LAFITE.CLOSEMSG? \LAFITE.AFTER.DELIVER \LAFITE.UNSENT.ICON \LAFITE.FETCH.SUBJECT LAFITE.SENDMESSAGE \SENDMESSAGE0 LA.ASSURE.PROMPT.WINDOW \LAFITE.SEND.FAIL \LAFITE.INVALID.RECIPIENTS \SENDMESSAGE.ABORT)) (COMS (* ; "Outbox hacking") (FNS \OUTBOX.CREATE \OUTBOX.RESET \OUTBOX.CLOSEFN \OUTBOX.REPAINTFN \OUTBOX.RESHAPEFN \OUTBOX.SHADEITEM \OUTBOX.BUTTONFN \OUTBOX.DISPLAYLINE \OUTBOX.ADD.ITEM) (INITVARS (LAFITEOUTBOXSIZE 2) (\LAFITE.OUTBOX)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS OUTBOXITEM) (GLOBALVARS LAFITEOUTBOXSIZE))) (COMS (* ; "Built-in message forms") (FNS \LAFITE.MESSAGEFORM MAKELAFITESUPPORTFORM MAKELISPSUPPORTFORM MAKEXXXSUPPORTFORM MAKENEWMESSAGEFORM MAKELAFITEPRIVATEFORMSITEMS \LAFITE.UNCACHE.MESSAGEFORM \LAFITE.DELETE.MESSAGEFORM \LAFITE.SELECT.FORM \LAFITE.DELETE.FORM.INTERNAL \LAFITE.READ.FORM \LAFITE.FIND.TEMPLATE)) (COMS (* ; "ANSWER") (FNS \LAFITE.ANSWER \LAFITE.ANSWER.PROC MAKEANSWERFORM LA.PRINT.COMMA.LIST LAFITE.FILL.IN.ANSWER.FORM)) (COMS (* ; "FORWARD") (FNS \LAFITE.FORWARD \LAFITE.FORWARD.PROC MAKEFORWARDFORM)) (COMS (VARS LAFITESENDINGMENUITEMS LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS) (ADDVARS (\SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) (LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) "A form to report a Lisp bug or suggestion") ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) "A form to report a Lafite bug or suggestion")) (LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU)) (INITVARS (\LAFITE.REPORT.MACHINE) (LAFITECURRENTEDITORWINDOWS) (LAFITEFORMFILES) (LAFITEFORMSMENU) (LAFITEFORMATMENU)) (INITVARS (LAFITEEDITORFONT LAFITEDISPLAYFONT) (LAFITEFORM.EXT "Lafite-form") (LAFITEFORMDIRECTORIES NIL) (LAFITE.EDITOR.SIZE (QUOTE (470 . 300))) (LAFITE.EDITOR.LAYOUTS NIL) (LAFITEFORWARDSUBJECTSTR NIL) (LAFITESUPPORT NIL) (LISPSUPPORT NIL) (MESSAGESTR ">>Message<<") (RECIPIENTSSTR ">>Recipients<<") (SUBJECTSTR ">>Subject<<") (LAFITE.SEND.FORMATTED (QUOTE ((NSCHARS :ASK) (CHARLOOKS :ASK) (PARALOOKS :ASK) (IMAGEOBJ T)))))) (COMS (* ; "Obsolete") (INITVARS (LAFITEEDITORREGION NIL))) (COMS (* ; "ICON stuff") (VARS LAFITE.MSG.ICON)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SENDINGCOMMAND) (GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES LAFITE.SEND.FORMATTED) (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)))) - - - -(* ; "Sending mail") - -(DEFINEQ - -(DOLAFITESENDINGCOMMAND -(LAMBDA (ITEM MENU KEY) (* bvm%: "31-Jul-84 15:03") (* ;;; "this function is invoked by buttoning the menu on top of the 'sending' window") (PROG ((WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) PROC) (AND (SETQ PROC (WINDOWPROP WINDOW (QUOTE PROCESS))) (PROCESS.APPLY PROC (FUNCTION \SENDMESSAGE.INITIATE) (LIST WINDOW MENU ITEM))))) -) - -(\SENDMESSAGE.INITIATE -(LAMBDA (WINDOW MENU ITEM) (* ; "Edited 31-Jan-89 16:59 by bvm") (* ;; "Called by selecting a menu command from a message composition window") (ERSETQ (RESETLST (LET ((COMMAND (EXTRACTMENUCOMMAND ITEM))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (ITEM MENU) (COND (RESETSTATE (* ; "In case of error/abort, set menu & proc back to normal") (SHADEITEM ITEM MENU WHITESHADE) (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) NIL))))) ITEM MENU)) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (* ; "Now disable the menu") (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION NILL)) (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) (QUOTE DON'T)) (* ; "Don't let anyone logout now!") (CL:FUNCALL COMMAND WINDOW (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)) MENU ITEM))))) -) - -(\SENDMSG.DELIVER -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 31-Jan-89 16:41 by bvm") (LET (PARSE) (printout (GETPROMPTWINDOW WINDOW) T "Parsing...") (OR (SETQ PARSE (\SENDMESSAGE.PARSE TEXTSTREAM WINDOW)) (ERROR!)) (\SENDMSG.EXIT.TEDIT WINDOW TEXTSTREAM (create SENDINGCOMMAND COMMAND _ (QUOTE %##SEND##) ITEM _ ITEM MENU _ MENU MESSAGE _ TEXTSTREAM MESSAGEPARSE _ PARSE)))) -) - -(\SENDMSG.EXIT.TEDIT -(LAMBDA (WINDOW TEXTSTREAM VALUE) (* ; "Edited 31-Jan-89 16:39 by bvm") (WINDOWADDPROP WINDOW (QUOTE CLOSEFN) (QUOTE DON'T)) (* ; "Keep TEDIT.QUIT from closing the window") (TEDIT.QUIT TEXTSTREAM VALUE) (LA.DETACH.TEDIT TEXTSTREAM)) -) - -(\SENDMSG.SAVE.FORM -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 15:33 by bvm") (* ;; "Shortcut to TEdit Put that saves on mail directory and remembers it as a %"Saved Form%"") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (PROMPT "Save under name: ") (FORMNAME (WINDOWPROP WINDOW (QUOTE LAFITEFORM))) PWINDOW FORMFILE) (COND (FORMNAME (SETQ FORMNAME (LA.SHORTFILENAME FORMNAME LAFITEFORM.EXT)))) (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW WINDOW PROMPT (OR FORMNAME "XXX"))) (* ; "Kludge to keep it small") (CLEARW PWINDOW) (COND ((SETQ FORMFILE (PROMPTFORFILENAME PWINDOW FORMNAME PROMPT)) (SETQ FORMNAME (LA.SHORTFILENAME (TEDIT.PUT TEXTSTREAM (LA.LONGFILENAME FORMFILE LAFITEFORM.EXT) NIL (if (EQ (TEDIT.FORMATTEDFILEP TEXTSTREAM) (QUOTE NSCHARS)) then (* ; "Force no formatting--TEdit defaultly saves formatting even if only ns chars") T)) LAFITEFORM.EXT)) (WINDOWPROP WINDOW (QUOTE LAFITEFORM) FORMNAME) (COND ((NOT (CL:MEMBER FORMNAME LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (SETQ LAFITEFORMFILES (APPEND LAFITEFORMFILES (LIST FORMNAME))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU))))) (* ;; "Exit with error to restore window state (what a kludge)") (ERROR!))) -) - -(\LAFITE.HEADER.EOF -(LAMBDA (TEXTSTREAM) (* ; "Edited 3-Nov-89 14:29 by bvm") (* ;; "Return the character number in TEXTSTREAM of the blank line following the header") (ADD1 (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL 0 NIL NIL T)))) -) - -(\LAFITE.INSERT.REPLYTO -(LAMBDA (TEXTSTREAM NAME HIGHLIGHT HEADEREOF) (* ; "Edited 3-Nov-89 12:57 by bvm") (* ;; "Insert a %"Reply-to: name%" field in this message. If HIGHLIGHT, leave the name pending-delete selected for potential replacement.") (TEDIT.INSERT TEXTSTREAM (CONCAT "Reply-to: " NAME LAFITEEOL) (OR HEADEREOF (SETQ HEADEREOF (\LAFITE.HEADER.EOF TEXTSTREAM)))) (if HIGHLIGHT then (TEDIT.SETSEL TEXTSTREAM (+ HEADEREOF (CONSTANT (NCHARS "Reply-to: "))) (NCHARS NAME) (QUOTE RIGHT) T))) -) - -(\SENDMSG.REPLYTO -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 14:03 by bvm") (* ;; "Add a Reply-to field to the message") (\LAFITE.INSERT.REPLYTO TEXTSTREAM (fetch (LAFITEMODEDATA FULLUSERNAME) of (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE)))) T) (* ;; "Exit with error to restore window state (what a kludge)") (ERROR!)) -) - -(\SENDMSG.CHANGE.MODE -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 5-Jan-90 18:06 by bvm") (LET* ((OLDMODE (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE))) (OTHERMODES (for MODE in LAFITEMODELST unless (OR (EQ (fetch (LAFITEOPS LAFITEMODE) of MODE) OLDMODE) (NLISTP (CDR MODE))) collect (fetch (LAFITEOPS LAFITEMODE) of MODE))) (NEWMODE (if (NULL OTHERMODES) then (\SENDMESSAGE.PROMPT WINDOW "There are no other modes") elseif (CDR OTHERMODES) then (MENU (\LAFITE.CREATE.MENU OTHERMODES "New mode")) else (CAR OTHERMODES)))) (if NEWMODE then (LET* ((TITLE (WINDOWPROP WINDOW (QUOTE TITLE))) (OLDMODEDATA (\LAFITE.GET.USER.DATA OLDMODE)) (NEWMODEDATA (\LAFITE.GET.USER.DATA NEWMODE)) N N2) (if (NULL NEWMODEDATA) then (\SENDMESSAGE.PROMPT WINDOW (CL:FORMAT NIL "Can't authenticate user in ~A mode" NEWMODE)) else (LET ((OLDNAME (fetch (LAFITEMODEDATA FULLUSERNAME) of OLDMODEDATA)) (END (TEDIT.FIND TEXTSTREAM " - -" 1)) START N LEN NEW OLDSEL) (if END then (add END 1)) (* ; "Don't search past end of header. END now points at second cr.") (for FIELD in (QUOTE ("cc" "Reply-to")) when (AND (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM FIELD END)) (PROGN (SETQ LEN (CADR N)) (SETQ N (CAR N)) (SETQ START (STRPOS OLDNAME (SETQ OLDSEL (TEDIT.SEL.AS.STRING TEXTSTREAM (create SELECTION CH# _ N DCH _ LEN))) NIL NIL NIL NIL UPPERCASEARRAY)))) do (* ; "Change field containing old user name to new. This is much more complicated than it needs to be because TEDIT.FIND is case sensitive.") (TEDIT.DELETE TEXTSTREAM N LEN) (TEDIT.INSERT TEXTSTREAM (SETQ NEW (CONCAT (OR (SUBSTRING OLDSEL 1 (SUB1 START)) "") (fetch (LAFITEMODEDATA FULLUSERNAME) of NEWMODEDATA) (OR (SUBSTRING OLDSEL (+ START (NCHARS OLDNAME))) ""))) N) (AND END (add END (- (NCHARS NEW) LEN)))) (if (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM "To" END)) then (* ; "Leave the To field selected for address modification") (TEDIT.SETSEL TEXTSTREAM (CAR N) (CADR N) (QUOTE RIGHT) T)) (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE) NEWMODE) (if (SETQ N (STRPOS (CONCAT "(" OLDMODE ")") TITLE)) then (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT (SUBSTRING TITLE 1 N) NEWMODE ")"))) (\SENDMESSAGE.PROMPT WINDOW "Message mode is now " NEWMODE))))) (* ;; "Exit with error so that the window is restored to previous state") (ERROR!))) -) - -(\SENDMSG.FIND.FIELD -(LAMBDA (TEXTSTREAM FIELD END) (* ; "Edited 5-Jan-90 17:54 by bvm") (* ;; "Find and select the header field beginning with %"FIELD:%". Return starting index.") (LET* ((STR (CONCAT " -" FIELD ": ")) (N (TEDIT.FIND TEXTSTREAM STR 1 END)) N2) (if (AND N (SETQ N2 (TEDIT.FIND TEXTSTREAM " -" (add N (NCHARS STR)) END))) then (LIST N (- N2 N)))))) - -(\SENDMESSAGE.PARSE -(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 10-Aug-89 17:25 by bvm") (* ;; "Parse MSG in the current mode, returning a parse structure that the corresponding sender will be happy with") (LET* ((MODE (TEXTPROP MSG (QUOTE LAFITEMODE))) (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE))) (if *LAFITE-MODE-DATA* then (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) MSG EDITORWINDOW) else (\SENDMESSAGE.PROMPT EDITORWINDOW (CL:FORMAT NIL "Can't authenticate user in ~A mode" MODE))))) -) - -(\LAFITE.PREPARE.SEND -(LAMBDA (MSG EDITORWINDOW PARSETABLE) (* bvm%: "13-Nov-84 12:50") (* ;; "Does generic things to MSG, a textstream about to be sent as a message: makes sure it ends in a CR, has no leading CRs, and parses it according to PARSETABLE which defaults to \LAPARSE.FULL -- returns a parse, whose first element tries to be (EOF end-of-header-position)") (PROG (MSGEOF HEADEREOF MSGFIELDS EOFINFO) (COND ((NOT (TYPENAMEP MSG (QUOTE STREAM))) (RETURN (LISPERROR "ILLEGAL ARG" MSG)))) (COND (EDITORWINDOW (* ; "Scroll so that beginning of message is visible") (TEDIT.SETSEL MSG 1 0 (QUOTE LEFT)) (TEDIT.NORMALIZECARET MSG) (first (SETFILEPTR MSG 0) until (NEQ (BIN MSG) (CHARCODE EOL)) do (* ; "hack to get rid of leading CRs") (TEDIT.DELETE MSG 1 1)) (SETFILEPTR MSG (SUB1 (SETQ MSGEOF (GETEOFPTR MSG)))) (COND ((NEQ (BIN MSG) (CHARCODE EOL)) (* ; "Make sure message ends in eol") (TEDIT.INSERT MSG LAFITEEOL (ADD1 MSGEOF) NIL T))))) (SETFILEINFO MSG (QUOTE ENDOFSTREAMOP) (FUNCTION \LAFITE.EOF)) (* ; "Avoid parsing failure if header-only message") (SETQ MSGFIELDS (LAFITE.PARSE.HEADER MSG (OR PARSETABLE \LAPARSE.FULL) 0 (SETQ MSGEOF (GETEOFPTR MSG)) NIL T)) (COND ((EQ (CAR (SETQ EOFINFO (CAR MSGFIELDS))) (QUOTE EOF)) (SETQ HEADEREOF (CADR EOFINFO)) (COND ((CADDR EOFINFO) (* ; "Error") (RETURN (\LAFITE.PREPARE.ERROR MSG EDITORWINDOW HEADEREOF)))) (COND ((= HEADEREOF MSGEOF) (* ; "Parse ended at eof, so message does not end in double CR -- add another") (SETFILEPTR MSG MSGEOF) (BOUT MSG (CHARCODE CR)))) (RPLACA (CDR EOFINFO) (SETQ HEADEREOF (ADD1 HEADEREOF))) (* ; "Add one for tedit fileptr one-based nonsense"))) (RETURN MSGFIELDS))) -) - -(\LAFITE.PREPARE.ERROR -(LAMBDA (MSG EDITORWINDOW HEADEREOF) (* bvm%: "13-Nov-84 12:53") (* ;;; "Called when header of MSG contained a line not conforming to spec. Most likely cause is user deleted the blank line between header and message. Print a suitable error message") (PROG (LINE) (SETFILEPTR MSG HEADEREOF) (SETQ LINE (LAFITE.READ.TO.EOL MSG)) (SETFILEPTR MSG HEADEREOF) (BOUT MSG (CHARCODE CR)) (\SENDMESSAGEFAIL EDITORWINDOW (CONCAT "Header not understood: %"" (COND ((> (NCHARS LINE) 30) (CONCAT (SUBSTRING LINE 1 30) (QUOTE ...))) (T LINE))) "%". Assumed this was not part of header, and inserted blank line before it. If this is correct, press 'Deliver' again, else edit the message appropriately."))) -) - -(\LAFITE.CHOOSE.MSG.FORMAT -(LAMBDA (TEXTSTREAM HEADEREOF EDITORWINDOW) (* ; "Edited 3-Feb-89 18:36 by bvm") (* ;; "Ask if user intends to retain formatting info, and if so, send formatted") (LET ((FORMATTING (TEDIT.FORMATTEDFILEP TEXTSTREAM)) TMP) (COND ((NULL FORMATTING) (* ; "It's just plain text") (QUOTE TEXT)) ((AND (TEXTSTREAMP TEXTSTREAM) (TEXTPROP TEXTSTREAM (QUOTE LAFITEFORMAT)))) ((NULL EDITORWINDOW) (* ; "Nobody to interact with") (QUOTE TEDIT)) (T (SELECTQ (COND ((NLISTP LAFITE.SEND.FORMATTED) LAFITE.SEND.FORMATTED) ((SETQ TMP (ASSOC FORMATTING LAFITE.SEND.FORMATTED)) (CADR TMP)) (T :ASK)) (T (* ; "Send formatted") (QUOTE TEDIT)) (NIL (* ; "Send unformatted") (QUOTE TEXT)) (SELECTQ (SETQ TMP (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (OR LAFITEFORMATMENU (SETQ LAFITEFORMATMENU (\LAFITE.CREATE.MENU LAFITEFORMATMENUITEMS "Retain formatting information?" T))) (CONCAT "Message " (SELECTQ FORMATTING (CHARLOOKS "has font information") (PARALOOKS "has paragraph formatting") (NSCHARS "uses extended character set") (IMAGEOBJ "contains images") "has unknown formatting") ".") (QUOTE LAFITEFORMATMENU))) (ABORT NIL) TMP)))))) -) - -(LAFITE.MAKE.PLAIN.TEXTSTREAM -(LAMBDA (TEXTSTREAM START) (* ; "Edited 24-Sep-87 16:48 by bvm:") (* ;; "Coerces TEXTSTREAM to a %"plain text%" stream, returning the new stream. If START is specified, only copies from that file pointer onward.") (LET ((PLAIN (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (SETFILEPTR TEXTSTREAM (OR START (SETQ START 0))) (* ;; "TEXT streams return character codes on BIN, so we have to translate to bytes on output side to handle fat chars correctly and avoid image objects") (to (- (GETEOFPTR TEXTSTREAM) START) do (\OUTCHAR PLAIN (OR (FIXP (BIN TEXTSTREAM)) (CHARCODE *)))) (* ; "Reopen to avoid core bug") (OPENSTREAM (CLOSEF PLAIN) (QUOTE INPUT)))) -) - -(\SENDMESSAGE.MENUPROMPT -(LAMBDA (EDITWINDOW MENU PROMPT MENUVAR) (* ; "Edited 20-Apr-89 19:37 by bvm") (* ;; "Prompt with MENU at the upper left corner of EDITWINDOW, printing PROMPT in the prompt window. If MENUVAR is specified, it is the global variable that holds this menu, which we smash to NIL while inside MENU, lest someone else try to use it") (LET ((PWINDOW (GETPROMPTWINDOW EDITWINDOW)) RESULT) (CLEARW PWINDOW) (printout PWINDOW PROMPT) (if MENUVAR then (SET MENUVAR NIL)) (SETQ RESULT (MENU MENU (LA.POSITION.FROM.REGION (WINDOWPROP PWINDOW (QUOTE REGION)) NIL T) T)) (CLEARW PWINDOW) (if MENUVAR then (SET MENUVAR MENU)) RESULT)) -) - -(\SENDMESSAGE.PROMPT -(LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:03 by bvm") (* ;; "Display message MESS1 & optionally MESS2 in the prompt window of EDITORWINDOW. Returns NIL always") (LET ((PWINDOW (COND (EDITORWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MESS1 MESS2)) (T PROMPTWINDOW)))) (CLEARW PWINDOW) (PRIN3 MESS1 PWINDOW) (COND (MESS2 (PRIN3 MESS2 PWINDOW))) NIL)) -) - -(\SENDMESSAGEFAIL -(LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:02 by bvm") (\SENDMESSAGE.PROMPT EDITORWINDOW MESS1 MESS2) (RETFROM (QUOTE \SENDMESSAGE.PARSE))) -) -) -(DEFINEQ - -(\SENDMESSAGE -(LAMBDA (FORM TEDITPROPS FORMNAME) (* ; "Edited 10-Feb-89 12:22 by bvm") (* ;;; "FORM can be a string, file, or stream --- The value of \SENDMESSAGE is T only if the message was actually sent") (OR (TEXTSTREAMP FORM) (SETQ FORM (OPENTEXTSTREAM FORM NIL NIL NIL TEDITPROPS))) (TEDIT.STREAMCHANGEDP FORM T) (* ; "Clear the changed bit") (if (NOT (LISTGET TEDITPROPS (QUOTE LEAVETTY))) then (* ; "Take control of the keyboard") (TTY.PROCESS (THIS.PROCESS))) (PROG ((MODE (LISTGET TEDITPROPS (QUOTE LAFITEMODE)))) (* ; "Old way of specifying mode") (if MODE then (TEXTPROP FORM (QUOTE LAFITEMODE) MODE) elseif (TEXTPROP FORM (QUOTE LAFITEMODE)) elseif (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)) then (TEXTPROP FORM (QUOTE LAFITEMODE) MODE) else (PRINTOUT PROMPTWINDOW T "Can't send mail without a Lafite mode.") (RETURN NIL)) (RETURN (\SENDMESSAGE.RESTARTABLE FORM TEDITPROPS NIL FORMNAME)))) -) - -(\SENDMESSAGE.RESTARTABLE -(LAMBDA (FORM TEDITPROPS EDITORWINDOW FORMNAME) (* ; "Edited 3-Nov-89 15:06 by bvm") (bind (CURRENTMESSAGE _ FORM) (FIRSTTIME _ T) EDITORRESULT DONE SENTOK PARSE do (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) NIL) (* ; "Allow LOGOUT until delivery is attempted. Need to do this if we loop or restart") (COND ((NULL (PROG1 EDITORWINDOW (SETQ EDITORWINDOW (\SENDMESSAGE.MAKEWINDOW CURRENTMESSAGE NIL EDITORWINDOW (TEXTPROP FORM (QUOTE LAFITEMODE)))))) (* ; "First time thru. Fix it so that we can restart if aborted") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTFORM) (LIST (FUNCTION \SENDMESSAGE.RESTARTABLE) (KWOTE FORM) (KWOTE TEDITPROPS) (KWOTE EDITORWINDOW))) (* ; "If process is reset or aborted, this is how to resurrect") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTABLE) T) (WINDOWPROP EDITORWINDOW (QUOTE LAFITEFORM) FORMNAME))) (COND (FIRSTTIME (RESETSAVE NIL (LIST (FUNCTION \SENDMESSAGE.CLEANUP) EDITORWINDOW)) (push LAFITECURRENTEDITORWINDOWS EDITORWINDOW) (SETQ FIRSTTIME))) (SETQ EDITORRESULT (TEDIT FORM EDITORWINDOW T (APPEND TEDITPROPS (LIST (QUOTE FONT) LAFITEEDITORFONT)))) (COND ((TTY.PROCESSP) (* ; "give back the keyboard") (TTY.PROCESS T))) (WINDOWDELPROP EDITORWINDOW (QUOTE CLOSEFN) (QUOTE DON'T)) (* ; "let the window close") (COND ((NOT (type? SENDINGCOMMAND EDITORRESULT)) (* ; "get out anyway since the user used the TEDIT `quit' command instead of one of the sending commands") (SETQ DONE T)) (T (* ; "the user used the lafite menu to get out rather than the TEDIT menu so we have to do something") (* ; "make sure CURRENTMESSAGE is always a string") (SETQ CURRENTMESSAGE (fetch (SENDINGCOMMAND MESSAGE) of EDITORRESULT)) (SETQ DONE (SELECTQ (AND EDITORRESULT (fetch (SENDINGCOMMAND COMMAND) of EDITORRESULT)) (%##SEND## (SETQ SENTOK (\SENDMESSAGE0 CURRENTMESSAGE EDITORWINDOW (SETQ PARSE (fetch (SENDINGCOMMAND MESSAGEPARSE) of EDITORRESULT))))) (SHOULDNT))) (SHADEITEM (fetch (SENDINGCOMMAND ITEM) of EDITORRESULT) (fetch (SENDINGCOMMAND MENU) of EDITORRESULT) WHITESHADE) (* ; "Unshade command. DOLAFITESENDINGCOMMAND shaded it to begin with"))) (COND (DONE (* ; "Message successfully dispatched") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTABLE) NIL) (* ; "Don't try to restart if there's any sort of error now") (COND (CURRENTMESSAGE (* ; "Mark text unchanged now, so no trouble closing icon") (TEDIT.STREAMCHANGEDP CURRENTMESSAGE T))) (COND ((NULL SENTOK) (CLOSEW EDITORWINDOW)) (T (* ; "shrink the window") (\LAFITE.AFTER.DELIVER EDITORWINDOW CURRENTMESSAGE PARSE))) (RETURN SENTOK)) (T (* ; "Loop if deliver failed or \LAFITE.SAVE.FORM was aborted."))))) -) - -(\SENDMESSAGE.CLEANUP -(LAMBDA (EDITORWINDOW) (* ; "Edited 6-Oct-87 15:58 by bvm:") (SETQ LAFITECURRENTEDITORWINDOWS (REMOVE EDITORWINDOW LAFITECURRENTEDITORWINDOWS))) -) - -(\SENDMESSAGE.MAKEWINDOW -(LAMBDA (MESSAGEFORM TITLE WINDOW MODE) (* ; "Edited 3-Nov-89 16:16 by bvm") (* ;;; "Editor for Mail system Lafite -- Handles the process mechanism right") (* ;;; "Assumes that it's running in a separate process created above") (PROG ((MENU (MAKELAFITEDELIVERMENU)) EDITWINDOW LAYOUT REGION) (COND ((NOT TITLE) (SETQ TITLE "Message Editor") (if (AND MODE (LAFITE.SHOW.MODE.P)) then (SETQ TITLE (CONCAT TITLE " (" MODE ")"))))) (COND ((WINDOWP (SETQ EDITWINDOW WINDOW)) (WINDOWPROP EDITWINDOW (QUOTE TITLE) TITLE) (for W in (ATTACHEDWINDOWS EDITWINDOW) when (WINDOWPROP W (QUOTE MENUWINDOW)) do (* ; "there's already an attached window menu, make sure we have a delivery menu in it.") (LET ((OLDMENU (CAR (WINDOWPROP W (QUOTE MENU))))) (if (if (NULL OLDMENU) then (* ; "E.g., after ABORT got removed") T elseif (NOT (EQUAL (fetch (MENU ITEMS) of MENU) (fetch (MENU ITEMS) of OLDMENU))) then (DELETEMENU OLDMENU NIL W) (* ; "Get rid of different menu") T else (SETQ MENU OLDMENU) (* ; "They're the same, don't fuss") NIL) else (ADDMENU MENU W (QUOTE (0 . 0))) (* ; "Now make it fit") (MENUWRESHAPEFN W))) (RETURN) finally (* ; "No attached menu yet") (ATTACHWINDOW (SETQ W (MENUWINDOW MENU)) EDITWINDOW (QUOTE TOP)) (WINDOWPROP W (QUOTE MENUWINDOW) T))) (T (SETQ REGION (if (for old LAYOUT in LAFITE.EDITOR.LAYOUTS unless (for WINDOW in LAFITECURRENTEDITORWINDOWS thereis (EQ (WINDOWPROP WINDOW (QUOTE LAFITE.LAYOUT)) LAYOUT)) do (* ; "Use first layout not already in use") (RETURN (CAR LAYOUT))) elseif (AND (NULL LAFITECURRENTEDITORWINDOWS) (type? REGION LAFITEEDITORREGION)) then (* ; "Old way of doing this for a single window") LAFITEEDITORREGION elseif LAFITE.EDITOR.SIZE then (* ; "Get window of appropriate size") (GETBOXREGION (CAR LAFITE.EDITOR.SIZE) (CDR LAFITE.EDITOR.SIZE)) else (GETREGION))) (SETQ EDITWINDOW (CREATEMENUEDWINDOW MENU TITLE (QUOTE TOP) (create REGION using REGION HEIGHT _ (- (fetch (REGION HEIGHT) of REGION) (HEIGHTIFWINDOW (FONTPROP LAFITEEDITORFONT (QUOTE HEIGHT))))))) (WINDOWPROP (CAR (ATTACHEDWINDOWS EDITWINDOW)) (QUOTE MENUWINDOW) T) (if LAYOUT then (WINDOWPROP EDITWINDOW (QUOTE LAFITE.LAYOUT) LAYOUT) (WINDOWPROP EDITWINDOW (QUOTE ICONPOSITION) (CADR LAYOUT))))) (GETPROMPTWINDOW EDITWINDOW 1 LAFITEEDITORFONT) (COND (NIL (* ; "don't let TEDIT close the window") (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (QUOTE DON'T)))) (PROGN (WINDOWDELPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION CLOSEATTACHEDWINDOWS)) (* ; "On closing, get rid of attachments, don't just close them") (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION DETACHALLWINDOWS)) (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSEMSG?) T)) (WINDOWPROP EDITWINDOW (QUOTE ICONFN) (FUNCTION \LAFITE.UNSENT.ICON)) (WINDOWPROP EDITWINDOW (QUOTE PROCESS) (THIS.PROCESS)) (* ; "Associate this process with the edit window") (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) (* ; "Enable the menu") (RETURN EDITWINDOW))) -) - -(MAKELAFITEDELIVERMENU -(LAMBDA NIL (* bvm%: "28-Mar-84 12:47") (create MENU ITEMS _ LAFITESENDINGMENUITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT WHENSELECTEDFN _ (FUNCTION DOLAFITESENDINGCOMMAND))) -) - -(\LAFITE.CLOSEMSG? -(LAMBDA (WINDOW) (* ; "Edited 3-Sep-87 17:21 by bvm:") (* ;; "This is the first CLOSEFN on a message sending window. If contents have changed, get confirmation") (LET ((TEXTSTREAM (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)))) (COND ((OR (NULL TEXTSTREAM) (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ; "TEXTSTREAM is null once TEdit's gotten thru with it.") NIL) ((MOUSECONFIRM "Message has been edited -- LEFT to flush anyway" T (GETPROMPTWINDOW WINDOW)) (TEDIT.STREAMCHANGEDP TEXTSTREAM T) (* ; "Reset bit so question doesn't get asked a second time") NIL) (T (QUOTE DON'T))))) -) - -(\LAFITE.AFTER.DELIVER -(LAMBDA (EDITORWINDOW TEXTSTREAM PARSE) (* ; "Edited 30-May-90 16:25 by bvm") (TEDIT.ASSURE.NO.BACKING.FILE TEXTSTREAM) (* ; "In case the backing file gets deleted") (\OUTBOX.ADD.ITEM TEXTSTREAM (OR (CAR PARSE) UNSUPPLIEDFIELDSTR)) (LET ((FORMNAME (WINDOWPROP EDITORWINDOW (QUOTE LAFITEFORM) NIL))) (if (AND FORMNAME (EQ (CAR (UNPACKFILENAME.STRING FORMNAME)) (QUOTE NAME))) then (* ;; "See if user wants to keep the form, or if it was saved just as a checkpoint. Do this only for files saved in primary directory") (LET* ((PWINDOW (GETPROMPTWINDOW EDITORWINDOW)) (MENUW (find W in (ATTACHEDWINDOWS EDITORWINDOW) suchthat (WINDOWPROP W (QUOTE MENUWINDOW)))) (MENU (create MENU ITEMS _ (QUOTE (("Delete File" T "Delete the file(s) in which this message was earlier saved.") ("Retain Saved Form" NIL "Don't delete the saved form, I want to use it again."))) WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU KEY) (LET ((W (WFROMMENU MENU))) (WINDOWPROP W (QUOTE RESULT) ITEM) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)))) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T ITEMWIDTH _ (IQUOTIENT (WINDOWPROP PWINDOW (QUOTE WIDTH)) 2) MENUROWS _ 1)) RESULT (MSG (CONCAT "Delivery complete. Do you want to delete the saved form of this message (" FORMNAME ")?"))) (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MSG) (TERPRI PWINDOW) (PRIN3 MSG PWINDOW) (ADDMENU MENU MENUW (QUOTE (0 . 0))) (until (SETQ RESULT (WINDOWPROP MENUW (QUOTE RESULT))) do (BLOCK 500)) (if (CADR RESULT) then (PRINTOUT PWINDOW T "Deleting file(s)... " (if (\LAFITE.DELETE.FORM.INTERNAL FORMNAME) then "done." else "failed.")))))) (DETACHALLWINDOWS EDITORWINDOW) (CLOSEW EDITORWINDOW)) -) - -(\LAFITE.UNSENT.ICON -(LAMBDA (WINDOW OLDICON) (* ; "Edited 24-Sep-87 16:58 by bvm:") (TITLEDICONW LAFITE.MSG.ICON (\LAFITE.FETCH.SUBJECT (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) LAFITEMSGICONFONT (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) T)) -) - -(\LAFITE.FETCH.SUBJECT -(LAMBDA (TEXTSTREAM) (* bvm%: " 2-Mar-86 16:27") (COND (TEXTSTREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION SETFILEINFO) TEXTSTREAM (QUOTE ENDOFSTREAMOP) (GETFILEINFO TEXTSTREAM (QUOTE ENDOFSTREAMOP)))) (SETFILEINFO TEXTSTREAM (QUOTE ENDOFSTREAMOP) (FUNCTION \LAFITE.EOF)) (LET ((STR (LAFITE.PARSE.HEADER TEXTSTREAM \LAPARSE.SUBJECTFIELD 0 NIL T))) (COND ((STRING-EQUAL STR SUBJECTSTR) UNSUPPLIEDFIELDSTR) (T STR))))))) -) - -(LAFITE.SENDMESSAGE -(LAMBDA (MESSAGEFORM) (* ; "Edited 12-Sep-88 14:07 by bvm") (* ;;; "this is the external interface to sending a message") (SETQ MESSAGEFORM (OPENTEXTSTREAM MESSAGEFORM)) (LET* ((MODE (TEXTPROP MESSAGEFORM (QUOTE LAFITEMODE))) (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) PARSE) (AND *LAFITE-MODE-DATA* (SETQ PARSE (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) MESSAGEFORM)) (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) MESSAGEFORM PARSE)))) -) - -(\SENDMESSAGE0 -(LAMBDA (TEXTSTREAM WINDOW PARSE) (* ; "Edited 12-Sep-88 14:04 by bvm") (PROG ((PWINDOW (GETPROMPTWINDOW WINDOW)) *LAFITE-MODE-DATA* MENUW OLDMENU ABORTMENU RESULT) (for W in (ATTACHEDWINDOWS WINDOW) when (SETQ OLDMENU (CAR (WINDOWPROP W (QUOTE MENU)))) do (SETQ MENUW W) (DELETEMENU OLDMENU NIL MENUW) (* ; "Remove Deliver menu, add Abort menu") (ADDMENU (SETQ ABORTMENU (create MENU ITEMS _ (QUOTE (("Abort" NIL "Abort delivery of this message"))) WHENSELECTEDFN _ (FUNCTION \SENDMESSAGE.ABORT) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T ITEMWIDTH _ (fetch ITEMWIDTH of OLDMENU))) MENUW (QUOTE (0 . 0))) (RETURN)) (if (NULL (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE))))) then (printout PWINDOW "Failed to authenticate user.") else (SETQ RESULT (ERSETQ (RESETLST (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) TEXTSTREAM PARSE WINDOW MENUW)))) (COND ((NULL RESULT) (printout PWINDOW "aborted.")) ((SETQ RESULT (CAR RESULT)) (printout PWINDOW "done.")))) (RETURN (COND (RESULT (* ; "Success") (CLOSEF TEXTSTREAM) (* ; "Explicit Close here after successful delivery so that TEdit can close any files it might have open") RESULT) (T (* ; "Restore Deliver menu") (COND ((WINDOWPROP MENUW (QUOTE MENU)) (DELETEMENU ABORTMENU NIL MENUW))) (ADDMENU OLDMENU MENUW (QUOTE (0 . 0)) NIL) (WINDOWPROP MENUW (QUOTE ABORT) NIL) NIL))))) -) - -(LA.ASSURE.PROMPT.WINDOW -(LAMBDA (MAINWINDOW MESS1 MESS2) (* bvm%: "24-Feb-85 18:33") (* ;;; "Returns prompt window for MAINWINDOW assuring that it is big enough to print MESS1 and MESS2") (LET ((PWINDOW (GETPROMPTWINDOW MAINWINDOW)) %#LINES) (COND ((> (SETQ %#LINES (QUOTIENT (+ (STRINGWIDTH MESS1 PWINDOW) (COND (MESS2 (STRINGWIDTH MESS2 PWINDOW)) (T 0))) (WINDOWPROP PWINDOW (QUOTE WIDTH)))) 0) (* ; "Make sure prompt window is big enough") (GETPROMPTWINDOW MAINWINDOW (ADD1 %#LINES))) (T PWINDOW)))) -) - -(\LAFITE.SEND.FAIL -(LAMBDA (EDITORWINDOW ERRMSG) (* bvm%: "24-Feb-85 18:38") (* ;; "Print a message explaining why delivery failed") (LET ((FULLMSG (CONCAT "Delivery failed -- " ERRMSG)) PWINDOW) (COND (EDITORWINDOW (CLEARW (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW FULLMSG)))) (T (TERPRI (SETQ PWINDOW PROMPTWINDOW)))) (PRIN3 FULLMSG PWINDOW) NIL)) -) - -(\LAFITE.INVALID.RECIPIENTS -(LAMBDA (NAMES) (* bvm%: " 5-Nov-84 15:26") (* ;;; "Returns an 'invalid recipients' error string") (PROG (NAME) (SETQ NAME (for RECIPIENT in NAMES join (LIST ", " RECIPIENT))) (RPLACA NAME ": ") (COND ((CDR NAMES) (push NAME "s"))) (RETURN (CONCATLIST (CONS "Invalid recipient" NAME))))) -) - -(\SENDMESSAGE.ABORT -(LAMBDA (ITEM MENU KEY) (* bvm%: " 1-Jun-84 12:21") (* ; "The WHENSELECTEDFN for the Abort menu") (PROG ((W (WFROMMENU MENU))) (WINDOWPROP W (QUOTE ABORT) T) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE))) -) -) - - - -(* ; "Outbox hacking") - -(DEFINEQ - -(\OUTBOX.CREATE -(LAMBDA NIL (* bvm%: "21-Dec-84 22:35") (PROG (FONT NLINES W FONTHEIGHT) (OR (AND LAFITESTATUSWINDOW (FIXP (SETQ NLINES LAFITEOUTBOXSIZE)) (IGREATERP NLINES 0)) (RETURN)) (SETQ FONTHEIGHT (FONTPROP (SETQ FONT LAFITEBROWSERFONT) (QUOTE HEIGHT))) (SETQ W (CREATEW (CREATEREGION 0 0 (WINDOWPROP LAFITESTATUSWINDOW (QUOTE WIDTH)) (HEIGHTIFWINDOW (ITIMES NLINES FONTHEIGHT) T)) "Delivered Messages" NIL T)) (ATTACHWINDOW W LAFITESTATUSWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (DSPFONT FONT W) (WINDOWADDPROP W (QUOTE CLOSEFN) (FUNCTION \OUTBOX.CLOSEFN)) (WINDOWPROP W (QUOTE REPAINTFN) (FUNCTION \OUTBOX.REPAINTFN)) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION \OUTBOX.BUTTONFN)) (WINDOWPROP W (QUOTE RESHAPEFN) (FUNCTION \OUTBOX.RESHAPEFN)) (WINDOWPROP W (QUOTE MINSIZE) (CONS 0 (HEIGHTIFWINDOW FONTHEIGHT T))) (RETURN (SETQ \LAFITE.OUTBOX (\OUTBOX.RESET (create OUTBOX OBWINDOW _ W OBSIZE _ NLINES OBHEIGHT _ FONTHEIGHT OBDESCENT _ (FONTPROP FONT (QUOTE DESCENT)))))))) -) - -(\OUTBOX.RESET -(LAMBDA (OUTBOX) (* bvm%: " 9-Nov-84 16:29") (PROG ((WINDOW (fetch OBWINDOW of OUTBOX))) (CLEARW WINDOW) (LINELENGTH MAX.SMALLP WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (replace OBORIGIN of OUTBOX with (IPLUS (DSPYPOSITION NIL WINDOW) (fetch OBHEIGHT of OUTBOX))) (RETURN OUTBOX))) -) - -(\OUTBOX.CLOSEFN -(LAMBDA (WINDOW) (* bvm%: " 8-Nov-84 16:02") (SETQ \LAFITE.OUTBOX))) - -(\OUTBOX.REPAINTFN -(LAMBDA (WINDOW REGION) (* bvm%: "13-Nov-84 10:57") (PROG ((OUTBOX \LAFITE.OUTBOX)) (OR (EQ WINDOW (fetch OBWINDOW of OUTBOX)) (RETURN)) (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) (fetch OBHEIGHT of OUTBOX)) WINDOW) (for ITEM in (fetch OBITEMS of OUTBOX) do (\OUTBOX.DISPLAYLINE OUTBOX ITEM) (TERPRI WINDOW)))) -) - -(\OUTBOX.RESHAPEFN -(LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* bvm%: "13-Nov-84 10:57") (COND ((EQ WINDOW (fetch OBWINDOW of \LAFITE.OUTBOX)) (PROG ((NLINES (IQUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) (fetch OBHEIGHT of \LAFITE.OUTBOX))) (OLDSIZE (fetch OBSIZE of \LAFITE.OUTBOX)) N ITEMS) (COND ((NEQ NLINES OLDSIZE) (replace OBSIZE of \LAFITE.OUTBOX with NLINES) (COND ((AND (ILESSP NLINES OLDSIZE) (IGREATERP (SETQ N (IDIFFERENCE (LENGTH (SETQ ITEMS (fetch OBITEMS of \LAFITE.OUTBOX))) NLINES)) 0)) (replace OBITEMS of \LAFITE.OUTBOX with (CDR (NTH ITEMS N))))))) (\OUTBOX.RESET \LAFITE.OUTBOX) (REDISPLAYW WINDOW))))) -) - -(\OUTBOX.SHADEITEM -(LAMBDA (OUTBOX ITEM N SHADE OPERATION) (* ; "Edited 3-Sep-87 17:24 by bvm:") (* ;;; "Shade the indicated ITEM in OUTBOX using texture SHADE blted with OPERATION") (PROG ((W (fetch OBWINDOW of OUTBOX)) HEIGHT) (BLTSHADE SHADE W 0 (- (fetch OBORIGIN of OUTBOX) (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) (fetch OBDESCENT of OUTBOX))) NIL HEIGHT OPERATION) (COND ((EQ OPERATION (QUOTE REPLACE)) (\OUTBOX.DISPLAYLINE OUTBOX ITEM N))))) -) - -(\OUTBOX.BUTTONFN -(LAMBDA (WINDOW) (* bvm%: "13-Nov-84 10:58") (* ;;; "BUTTONEVENTFN for the outbox. If a message is selected, edit it") (PROG ((SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (OUTBOX \LAFITE.OUTBOX) SELECTED SEL# NEWSEL# ITEMS HEIGHT ORIGIN DESCENT LASTX LASTY MAXITEM) (COND ((OR (NOT (SETQ ITEMS (fetch OBITEMS of OUTBOX))) (NEQ WINDOW (fetch OBWINDOW of OUTBOX))) (* ; "Nothing to select") (RETURN))) (SETQ MAXITEM (LENGTH ITEMS)) (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX)) (SETQ DESCENT (fetch OBDESCENT of OUTBOX)) (SETQ ORIGIN (fetch OBORIGIN of OUTBOX)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((OR (NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (> (SETQ NEWSEL# (ADD1 (QUOTIENT (- ORIGIN (+ LASTY DESCENT)) HEIGHT))) MAXITEM)) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)) (SETQ SELECTED (SETQ SEL# NIL)))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Let mouse up while over a selection. Do it") (COND (SELECTED (\LAFITE.PROCESS (LIST (FUNCTION \SENDMESSAGE) (KWOTE (COPYTEXTSTREAM (fetch OBITEXT of SELECTED)))) (QUOTE MESSAGESENDER) T (QUOTE NO)) (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)))) (RETURN)) ((NEQ NEWSEL# SEL#) (COND (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)))) (\OUTBOX.SHADEITEM OUTBOX (SETQ SELECTED (CAR (NTH ITEMS (SETQ SEL# NEWSEL#)))) SEL# BLACKSHADE (QUOTE INVERT))))))) -) - -(\OUTBOX.DISPLAYLINE -(LAMBDA (OUTBOX ITEM N) (* bvm%: " 8-Nov-84 21:35") (PROG ((W (fetch OBWINDOW of OUTBOX))) (COND (N (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) (ITIMES N (fetch OBHEIGHT of OUTBOX))) W))) (printout W (fetch OBIDATE of ITEM) %,, (fetch OBISUBJECT of ITEM)))) -) - -(\OUTBOX.ADD.ITEM -(LAMBDA (TEXTSTREAM SUBJECT) (* ; "Edited 3-Sep-87 18:08 by bvm:") (PROG ((OUTBOX (OR \LAFITE.OUTBOX (\OUTBOX.CREATE))) W N ITEM BOTTOM HEIGHT ITEMS) (OR OUTBOX (RETURN)) (COND ((>= (SETQ N (LENGTH (SETQ ITEMS (fetch OBITEMS of OUTBOX)))) (fetch OBSIZE of OUTBOX)) (replace OBITEMS of OUTBOX with (SETQ ITEMS (CDR ITEMS))) (BITBLT (SETQ W (fetch OBWINDOW of OUTBOX)) 0 (SETQ BOTTOM (- (fetch OBORIGIN of OUTBOX) (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) (fetch OBDESCENT of OUTBOX)))) W 0 (+ BOTTOM HEIGHT) NIL (ITIMES HEIGHT (SUB1 N)) (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE W 0 BOTTOM NIL HEIGHT (QUOTE REPLACE))) (T (SETQ N (ADD1 N)))) (replace OBITEMS of OUTBOX with (NCONC1 ITEMS (SETQ ITEM (create OUTBOXITEM OBITEXT _ TEXTSTREAM OBIDATE _ (DATE (DATEFORMAT NO.DATE NO.SECONDS)) OBISUBJECT _ SUBJECT)))) (\OUTBOX.DISPLAYLINE OUTBOX ITEM N))) -) -) - -(RPAQ? LAFITEOUTBOXSIZE 2) - -(RPAQ? \LAFITE.OUTBOX) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD OUTBOXITEM (OBITEXT OBIDATE OBISUBJECT OBIWINDOW)) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS LAFITEOUTBOXSIZE) -) -) - - - -(* ; "Built-in message forms") - -(DEFINEQ - -(\LAFITE.MESSAGEFORM -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 23-Feb-89 12:50 by bvm") (COND ((NULL (OR \LAFITEMODE (\LAFITE.INFER.MODE))) (printout PROMPTWINDOW T "Must set Lafite Mode before sending mail")) (T (RESETLST (AND ITEM (LA.RESETSHADE ITEM MENU)) (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FORM FORMNAME FULLFORMNAME) (COND ((EQ BUTTON (QUOTE LEFT)) (SETQ FORM (MAKENEWMESSAGEFORM))) ((NOT (SETQ FORM (MENU (.LAFITEMENU. LAFITEFORMSMENU (APPEND (MAKELAFITEPRIVATEFORMSITEMS "Use the form defined in this file.") LAFITESPECIALFORMS LAFITEFORMSMENUITEMS) "Message Forms")))) (RETURN)) ((EQ FORM (QUOTE %##ANOTHERFORM##)) (* ; "user buttoned 'Another Form'") (OR (SETQ FORMNAME (PROMPTFORFILENAME)) (RETURN))) ((DEFINEDP FORM) (OR (SETQ FORM (CL:FUNCALL FORM)) (RETURN))) ((BOUNDP FORM) (SETQ FORM (OR (EVALV FORM) (MAKENEWMESSAGEFORM)))) (T (* ; "other private form") (SETQ FORMNAME FORM))) (COND ((NULL FORMNAME) (* ; "Have form already")) ((OR (SETQ FULLFORMNAME (INFILEP (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT))) (AND LAFITEFORMDIRECTORIES (SETQ FULLFORMNAME (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FORMNAME (QUOTE EXTENSION) LAFITEFORM.EXT) T LAFITEFORMDIRECTORIES)))) (* ; "read the form and return it") (COND ((NOT (CL:MEMBER (SETQ FORMNAME (LA.SHORTFILENAME FULLFORMNAME LAFITEFORM.EXT)) LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (push LAFITEFORMFILES FORMNAME) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU))) (SETQ FORM (\LAFITE.READ.FORM FULLFORMNAME))) (T (printout PROMPTWINDOW T FORMNAME " not found.") (RETURN))) (ADD.PROCESS (LIST (FUNCTION \SENDMESSAGE) (KWOTE FORM) NIL (KWOTE FORMNAME)) (QUOTE NAME) (QUOTE MESSAGESENDER) (QUOTE RESTARTABLE) (QUOTE NO)) (* ; "Finally, start authenticating if we haven't yet.") (\LAFITE.GET.USER.DATA (AND (TEXTSTREAMP FORM) (TEXTPROP FORM (QUOTE LAFITEMODE))))))))) -) - -(MAKELAFITESUPPORTFORM -(LAMBDA NIL (* bvm%: "12-Mar-85 00:39") (MAKEXXXSUPPORTFORM "Lafite" LAFITESUPPORT LAFITESYSTEMDATE))) - -(MAKELISPSUPPORTFORM -(LAMBDA NIL (* bvm%: "12-Mar-85 00:39") (MAKEXXXSUPPORTFORM "Lisp" LISPSUPPORT))) - -(MAKEXXXSUPPORTFORM -(LAMBDA (SYSTEMNAME ADDRESS SYSTEMDATE) (* ; "Edited 3-May-89 18:37 by bvm") (PROG ((SUBJFIELD ">>Terse summary of problem<<") (UCODEVERSION (MICROCODEVERSION)) (SCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH))) TEXTSTREAM SELECTPOSITION MODE) (COND ((LISTP ADDRESS) (* ; "Mode-dependent address. Pick the first address that's in a mode we know how to send") (SETQ ADDRESS (for PAIR in ADDRESS when (\LAFITE.GET.USER.DATA (SETQ MODE (CAR PAIR))) do (RETURN (CADR PAIR))))) (T (* ; "Just send in current mode") (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)))) (COND ((NOT ADDRESS) (printout PROMPTWINDOW T "Can't -- no address known for " SYSTEMNAME " report.") (RETURN))) (SETQ TEXTSTREAM (OPENTEXTSTREAM (CONCAT "Subject: " SYSTEMNAME ": ") NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) (SETQ SELECTPOSITION (ADD1 (GETEOFPTR TEXTSTREAM))) (PROGN (* ; "Now write the main stuff to a scratch stream. faster than bouting a byte at a time to tedit") (printout SCRATCH SUBJFIELD T) (printout SCRATCH "To: " ADDRESS T) (printout SCRATCH "cc: " (FULLUSERNAME NIL MODE) T T) (COND (SYSTEMDATE (printout SCRATCH SYSTEMNAME " System Date: " SYSTEMDATE T))) (printout SCRATCH "Lisp System Date: " MAKESYSDATE " (" (L-CASE (MKSTRING MAKESYSNAME) T) ")" T) (printout SCRATCH "Machine: " (OR \LAFITE.REPORT.MACHINE (PROGN (SETQ \LAFITE.REPORT.MACHINE (L-CASE (MACHINETYPE) T)) (COND ((EQ \PUP.READY T) (SETQ \LAFITE.REPORT.MACHINE (CONCAT \LAFITE.REPORT.MACHINE " (" (ETHERHOSTNAME NIL T) ")")))) \LAFITE.REPORT.MACHINE)) T) (printout SCRATCH "Microcode version: " .I1.8 (fetch HIBYTE of UCODEVERSION) "," .I1.8 (fetch LOBYTE of UCODEVERSION) T) (printout SCRATCH "Memory size: " .I4.8 (REALMEMORYSIZE) T) (printout SCRATCH "Frequency: >> Always, Intermittent, Once << -Impact: >> Fatal, Serious, Moderate, Annoying, Minor <<" T T) (printout SCRATCH ">>detailed problem description<<" T)) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION 0 (QUOTE RIGHT)) (TEDIT.INCLUDE TEXTSTREAM SCRATCH) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION (NCHARS SUBJFIELD) (QUOTE RIGHT) T) (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE) MODE) (RETURN TEXTSTREAM))) -) - -(MAKENEWMESSAGEFORM -(LAMBDA NIL (* ; "Edited 6-Jun-88 12:22 by bvm") (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) SELECTPOSITION) (printout OUTSTREAM "Subject: ") (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) (printout OUTSTREAM SUBJECTSTR T) (printout OUTSTREAM "To: " RECIPIENTSSTR T) (printout OUTSTREAM "cc: " (FULLUSERNAME) T T) (printout OUTSTREAM MESSAGESTR T) (if LAFITE.SIGNATURE then (* ; "Pre-sign it") (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS SUBJECTSTR) (QUOTE RIGHT) T) OUTSTREAM)) -) - -(MAKELAFITEPRIVATEFORMSITEMS -(LAMBDA (HELPSTR) (* ; "Edited 23-Feb-89 12:38 by bvm") (for FORMFILE in (SORT LAFITEFORMFILES) when FORMFILE collect (BQUOTE ((\, (if (U-CASEP FORMFILE) then (CL:STRING-CAPITALIZE FORMFILE) else FORMFILE)) (QUOTE (\, FORMFILE)) (\, HELPSTR))))) -) - -(\LAFITE.UNCACHE.MESSAGEFORM -(LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") (LET ((FORM (\LAFITE.SELECT.FORM "Forget about this message form"))) (COND (FORM (SETQ LAFITEFORMFILES (DREMOVE FORM LAFITEFORMFILES)) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU) (printout PROMPTWINDOW T FORM " forgotten."))))) -) - -(\LAFITE.DELETE.MESSAGEFORM -(LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") (LET ((FORM (\LAFITE.SELECT.FORM "Delete this saved message"))) (if (AND FORM (PROGN (CLRPROMPT) (MOUSECONFIRM (CL:FORMAT NIL "Click LEFT to confirm deleting saved message '~A'" FORM) T PROMPTWINDOW))) then (\LAFITE.DELETE.FORM.INTERNAL FORM)))) -) - -(\LAFITE.SELECT.FORM -(LAMBDA (MSG) (* ; "Edited 8-Nov-89 12:37 by bvm") (COND ((NULL LAFITEFORMFILES) (printout PROMPTWINDOW T "You have no private message forms")) (T (MENU (\LAFITE.CREATE.MENU (MAKELAFITEPRIVATEFORMSITEMS MSG) "Private Forms"))))) -) - -(\LAFITE.DELETE.FORM.INTERNAL -(LAMBDA (FORMNAME) (* ; "Edited 8-Nov-89 12:34 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LONGNAME (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT)) FULL) (while (SETQ FULL (FULLNAME LONGNAME (QUOTE OLDEST))) do (if (NOT (DELFILE FULL)) then (PRINTOUT PROMPTWINDOW T "Could not delete " FULL) (RETURN NIL)) finally (SETQ LAFITEFORMFILES (CL:DELETE FORMNAME LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU) (PRINTOUT PROMPTWINDOW T FORMNAME " deleted.") (RETURN T)))) -) - -(\LAFITE.READ.FORM -(LAMBDA (FILE) (* ; "Edited 2-Nov-89 15:55 by bvm") (* ;;; "copies the messaage form in the FILE into a text stream") (PROG ((TEXTSTREAM (OPENTEXTSTREAM (OPENSTREAM FILE (QUOTE INPUT)) NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) NAME CH) (SETFILEPTR TEXTSTREAM 0) (COND ((OR (EQ (SETQ CH (BIN TEXTSTREAM)) (CHARCODE %")) (AND (EQ CH (CHARCODE CR)) (EQ (BIN TEXTSTREAM) (CHARCODE %")))) (* ; "Old-style form, get rid of surrounding double quotes") (TEDIT.DELETE TEXTSTREAM 1 (ADD1 (GETFILEPTR TEXTSTREAM))) (TEDIT.DELETE TEXTSTREAM (GETEOFPTR TEXTSTREAM) 1))) (bind (OPENMARKER _ (CONSTANT (ALLOCSTRING 1 (CHARCODE ^A)))) J (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM OPENMARKER I)) do (* ; "Change Laurel forms into Lafite forms") (COND ((AND (SETQ J (TEDIT.FIND TEXTSTREAM (CONSTANT (ALLOCSTRING 1 (CHARCODE ^B))) (ADD1 I) (IPLUS I 70))) (NOT (TEDIT.FIND TEXTSTREAM OPENMARKER (ADD1 I) J))) (TEDIT.DELETE TEXTSTREAM J 1) (TEDIT.INSERT TEXTSTREAM "<<" J) (TEDIT.DELETE TEXTSTREAM I 1) (TEDIT.INSERT TEXTSTREAM ">>" I) (SETQ I J)) (T (RETURN)))) (bind (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM ">>Self<<" I)) do (* ; "Replace '>>Self<<' with user name") (OR NAME (SETQ NAME (FULLUSERNAME))) (TEDIT.DELETE TEXTSTREAM I 8) (TEDIT.INSERT TEXTSTREAM NAME I) (SETFILEPTR TEXTSTREAM I) (* ; "Patch around tedit bug...")) (\LAFITE.FIND.TEMPLATE TEXTSTREAM) (RETURN TEXTSTREAM))) -) - -(\LAFITE.FIND.TEMPLATE -(LAMBDA (TEXTSTREAM) (* bvm%: "22-Apr-84 23:59") (LET (SELECTSTART) (COND ((SETQ SELECTSTART (TEDIT.FIND TEXTSTREAM ">>*<<" 1 NIL T)) (* ; "Wait until TEDIT.FIND gets fixed") (* ; "highlight the first 'blank' to fill in") (COND ((LISTP SELECTSTART) (SETQ SELECTSTART (CAR SELECTSTART)))) (TEDIT.SETSEL TEXTSTREAM SELECTSTART (+ 2 (- (TEDIT.FIND TEXTSTREAM "<<" SELECTSTART) SELECTSTART)) (QUOTE RIGHT) T) T) (T (TEDIT.SETSEL TEXTSTREAM 1 0 (QUOTE LEFT)))))) -) -) - - - -(* ; "ANSWER") - -(DEFINEQ - -(\LAFITE.ANSWER -(LAMBDA (WINDOW FOLDERDATA ITEM MENU) (* bvm%: " 1-Feb-84 15:08") (ADD.PROCESS (LIST (FUNCTION \LAFITE.ANSWER.PROC) (KWOTE WINDOW) (KWOTE FOLDERDATA) (KWOTE ITEM) (KWOTE MENU)) (QUOTE NAME) (QUOTE MESSAGEANSWERER) (QUOTE RESTARTABLE) (QUOTE NO))) -) - -(\LAFITE.ANSWER.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "29-May-84 15:59") (PROG (MSGDESCRIPTOR FORM) (SETQ FORM (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (MAKEANSWERFORM (SETQ MSGDESCRIPTOR (find MSGDESCRIPTOR selectedin MAILFOLDER suchthat T)) MAILFOLDER)))))) (COND ((AND FORM (\SENDMESSAGE FORM)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) (COND ((AND MESSAGES (EQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES (fetch (LAFITEMSG %#) of MSGDESCRIPTOR)))) (* ; "If message got expunged since we constructed the answer form, we can't do anything") (MARKMESSAGE MSGDESCRIPTOR MAILFOLDER ANSWERMARK))))))))) -) - -(MAKEANSWERFORM -(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 10-Aug-89 17:28 by bvm") (LET* ((FIRSTMSG (if (LISTP MSGDESCRIPTORS) then (CAR MSGDESCRIPTORS) else MSGDESCRIPTORS)) (MODEBITS (fetch (LAFITEMSG MODEBITS) of FIRSTMSG)) (MODE (CL:NTH MODEBITS *LAFITE-WELL-KNOWN-MODES*))) (if (NULL MODE) then (if (OR (NEQ MODEBITS 0) (NULL (SETQ MODE (\LAFITE.GUESS.MODE FIRSTMSG)))) then (LAB.PROMPTPRINT MAILFOLDER (if (EQ MODEBITS 0) then "Message of unknown protocol." else "Warning: This message was retrieved under a protocol not currently enabled.")) (LAB.PROMPTPRINT MAILFOLDER "Will answer in " (SETQ MODE (fetch (LAFITEOPS LAFITEMODE) of \LAFITEMODE)) " mode; this may not work. "))) (* ;; "Currently we only pay attention to the first message. If we ever do otherwise, we'll want to notice whether the other messages are in the same mode") (LET ((*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) MSG) (* ;; "Before returning the form, tag it with a mail mode") (if (NULL *LAFITE-MODE-DATA*) then (LAB.FORMAT MAILFOLDER "Failed: can't authenticate user in ~A mode" MODE) elseif (SETQ MSG (CL:FUNCALL (fetch (LAFITEMODEDATA ANSWERER) of *LAFITE-MODE-DATA*) MSGDESCRIPTORS MAILFOLDER)) then (if (TEXTSTREAMP MSG) then (TEXTPROP MSG (QUOTE LAFITEMODE) MODE) MSG else (OPENTEXTSTREAM MSG NIL NIL NIL (BQUOTE (LAFITEMODE (\, MODE))))))))) -) - -(LA.PRINT.COMMA.LIST -(LAMBDA (STRINGS STREAM) (* ; "Edited 6-Jun-88 12:50 by bvm") (for STR in STRINGS bind NTHTIME when STR do (COND (NTHTIME (PRIN3 ", " STREAM)) (T (SETQ NTHTIME T))) (PRIN3 STR STREAM))) -) - -(LAFITE.FILL.IN.ANSWER.FORM -(LAMBDA (SUBJECT FROM DATE TO CC ADDRESSPRINTFN) (* ; "Edited 10-Jun-88 17:19 by bvm") (* ;; "Construct an answer form replying to a message from FROM on DATE with specified SUBJECT. Reply should go to the lists of names TO and CC. ADDRESSPRINTFN is a function that prints a list of names suitably for the protocol in question.") (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) SELECTPOSITION) (LINELENGTH MAX.SMALLP OUTSTREAM) (* ; "Sigh, apparently text streams have linelength") (PROGN (printout OUTSTREAM "Subject: ") (if SUBJECT then (COND ((NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3) "Re:")) (printout OUTSTREAM "Re: "))) (printout OUTSTREAM SUBJECT) else (printout OUTSTREAM "(reply to message)"))) (PROGN (printout OUTSTREAM T "In-reply-to: ") (if (NULL FROM) then (printout OUTSTREAM "your") else (printout OUTSTREAM FROM "'s")) (printout OUTSTREAM " message of " DATE T)) (PROGN (printout OUTSTREAM "To: ") (if TO then (CL:FUNCALL ADDRESSPRINTFN TO OUTSTREAM) else (* ; "No to, so ask to fill in") (printout OUTSTREAM RECIPIENTSSTR T)) (TERPRI OUTSTREAM)) (COND (CC (printout OUTSTREAM "cc: ") (CL:FUNCALL ADDRESSPRINTFN CC OUTSTREAM) (TERPRI OUTSTREAM))) (TERPRI OUTSTREAM) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) (printout OUTSTREAM MESSAGESTR T) (if LAFITE.SIGNATURE then (* ; "Pre-sign it") (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS MESSAGESTR) (QUOTE RIGHT) T) OUTSTREAM)) -) -) - - - -(* ; "FORWARD") - -(DEFINEQ - -(\LAFITE.FORWARD -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: " 1-Feb-84 15:05") (ADD.PROCESS (LIST (FUNCTION \LAFITE.FORWARD.PROC) (KWOTE WINDOW) (KWOTE MAILFOLDER) (KWOTE ITEM) (KWOTE MENU)) (QUOTE NAME) (QUOTE MESSAGEFORWARDER) (QUOTE RESTARTABLE) (QUOTE NO))) -) - -(\LAFITE.FORWARD.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 14-Oct-87 16:20 by bvm:") (PROG (FORWARDEDMSGS FORM) (* ;; "the reason to get the MSG#S first is that they may have changed by the time \SENDMESSAGE finishes and then we would have marked the wrong ones") (RESETLST (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) NIL T) (LA.RESETSHADE ITEM MENU) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (SETQ FORM (MAKEFORWARDFORM WINDOW MAILFOLDER (SETQ FORWARDEDMSGS (LAB.SELECTED.MESSAGES MAILFOLDER))))))) (COND ((AND FORM (\SENDMESSAGE FORM)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) (COND (MESSAGES (* ; "Make sure folder hasn't been closed since") (for MSG in FORWARDEDMSGS when (EQ MSG (NTHMESSAGE MESSAGES (fetch (LAFITEMSG %#) of MSG))) do (* ; "If message got expunged since we constructed the forward form, we can't do anything") (MARKMESSAGE MSG MAILFOLDER FORWARDMARK)))))))))) -) - -(MAKEFORWARDFORM -(LAMBDA (WINDOW FOLDER MESSAGELIST) (* ; "Edited 5-Jan-90 17:46 by bvm") (* ;; "Make a message form that forwards each of the messages in MESSAGELIST") (PROG ((FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :ABORT)) (TEXTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) (CURMSG (CAR MESSAGELIST)) SUBJECT SELECTPOSITION SELECTLEN) (OR (fetch (LAFITEMSG PARSED?) of CURMSG) (LAFITE.PARSE.MSG.FOR.TOC CURMSG FOLDER)) (LINELENGTH MAX.SMALLP TEXTSTREAM) (PRIN3 "Subject: " TEXTSTREAM) (COND ((OR LAFITEFORWARDSUBJECTSTR (NULL (SETQ SUBJECT (fetch (LAFITEMSG SUBJECT) of CURMSG)))) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) (SETQ SELECTLEN (NCHARS (SETQ SUBJECT (OR LAFITEFORWARDSUBJECTSTR SUBJECTSTR)))) (PRIN3 SUBJECT TEXTSTREAM)) (T (CL:FORMAT TEXTSTREAM "[~@[~A: ~]~A]" (fetch (LAFITEMSG FROM) of CURMSG) SUBJECT))) (TERPRI TEXTSTREAM) (PRIN3 "To: " TEXTSTREAM) (COND ((NOT SELECTPOSITION) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) (SETQ SELECTLEN (NCHARS RECIPIENTSSTR)))) (CL:FORMAT TEXTSTREAM "~A -cc: ~A - -~A -" RECIPIENTSSTR (FULLUSERNAME) (CAR LAFITEFORWARDSTRINGS)) (if LAFITE.SIGNATURE then (* ; "Sign it up here, after the user's inserted comments, if any") (PRIN3 LAFITE.SIGNATURE TEXTSTREAM) (TERPRI TEXTSTREAM)) (for MSGDESCRIPTOR in MESSAGELIST bind NTHTIME do (PRIN3 (COND (NTHTIME (* ; "%"Next message%"") (CADDR LAFITEFORWARDSTRINGS)) (T (* ; "%"Begin forwarded messages%"") (SETQ NTHTIME T) (CADR LAFITEFORWARDSTRINGS))) TEXTSTREAM) (TERPRI TEXTSTREAM) (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM FOLDERSTREAM MSGDESCRIPTOR \LAPARSE.DONT.FORWARD.HEADERS) (TERPRI TEXTSTREAM) (TEDIT.CARETLOOKS TEXTSTREAM LAFITEEDITORFONT)) (PRIN3 (CADDDR LAFITEFORWARDSTRINGS) TEXTSTREAM) (TERPRI TEXTSTREAM) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION SELECTLEN (QUOTE RIGHT) T) (RETURN TEXTSTREAM))) -) -) - -(RPAQQ LAFITESENDINGMENUITEMS (("Deliver" (QUOTE \SENDMSG.DELIVER) "Send the message in the edit window") ("Reply To" (QUOTE \SENDMSG.REPLYTO) "Insert a Reply-to field in this message") ("Change Mode" (QUOTE \SENDMSG.CHANGE.MODE) "Change the mode (mail protocol) used to send this message.") ("Save" (QUOTE \SENDMSG.SAVE.FORM) "Save the message in a file for later use (retrieve with middle-button SendMail)"))) - -(RPAQQ LAFITEFORMSMENUITEMS (("Saved Form" (QUOTE %##ANOTHERFORM##) "You will be asked to specify a filename for the form") ("Standard Form" (FUNCTION MAKENEWMESSAGEFORM) "A clean message form"))) - -(RPAQQ LAFITEFORMATMENUITEMS (("Send Formatted Message" (QUOTE TEDIT)) ("Send Plain Text" (QUOTE TEXT)) ("Abort" (QUOTE ABORT)))) - -(RPAQQ LAFITEFORWARDSTRINGS (">>CoveringMessage<<" " - ----- Begin Forwarded Messages ----- -" " - ----- Next Message ----- -" " - ----- End Forwarded Messages -----")) - -(ADDTOVAR \SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) - -(ADDTOVAR LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) "A form to report a Lisp bug or suggestion") ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) "A form to report a Lafite bug or suggestion")) - -(ADDTOVAR LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU) - -(RPAQ? \LAFITE.REPORT.MACHINE) - -(RPAQ? LAFITECURRENTEDITORWINDOWS) - -(RPAQ? LAFITEFORMFILES) - -(RPAQ? LAFITEFORMSMENU) - -(RPAQ? LAFITEFORMATMENU) - -(RPAQ? LAFITEEDITORFONT LAFITEDISPLAYFONT) - -(RPAQ? LAFITEFORM.EXT "Lafite-form") - -(RPAQ? LAFITEFORMDIRECTORIES NIL) - -(RPAQ? LAFITE.EDITOR.SIZE (QUOTE (470 . 300))) - -(RPAQ? LAFITE.EDITOR.LAYOUTS NIL) - -(RPAQ? LAFITEFORWARDSUBJECTSTR NIL) - -(RPAQ? LAFITESUPPORT NIL) - -(RPAQ? LISPSUPPORT NIL) - -(RPAQ? MESSAGESTR ">>Message<<") - -(RPAQ? RECIPIENTSSTR ">>Recipients<<") - -(RPAQ? SUBJECTSTR ">>Subject<<") - -(RPAQ? LAFITE.SEND.FORMATTED (QUOTE ((NSCHARS :ASK) (CHARLOOKS :ASK) (PARALOOKS :ASK) (IMAGEOBJ T)))) - - - -(* ; "Obsolete") - - -(RPAQ? LAFITEEDITORREGION NIL) - - - -(* ; "ICON stuff") - - -(RPAQQ LAFITE.MSG.ICON (#*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GH@O@@@@@@@@@@@@@@@@@@@CN@@CL@@@@@@@@@@@@@@@@@@OH@@@OH@@@@@@@@@@@@@@@@CL@@@@CN@@@@@@@@@@@@@@@@O@@@@@@GH@@@@@@@@@@@@@@CL@@@@@@AN@@@@@@@@@@@@@AO@@@@@@@@GL@@@@@@@@@@@@GL@@@@@@@@AO@@@@@@@@@@@AN@@@@@@@@@@CL@@@@@@@@@@GH@@@@@@@@@@@O@@@@@@@@@CN@@@@@@@@@@@@CL@@@@@@@@OH@@@@@@@@@@@@@OH@@@@@@CL@@@@@@@@@@@@@@CN@@@@@@O@@@@@@@@@@@@@@@@GH@@@@CL@@@@@@@@@@@@@@@@AN@@@@O@@@@@@@@@@@@@@@@@@GH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@O@@@@@@@@@@@@@@@@@@GL@@@ML@@@@@@@@@@@@@@@@ALL@@@LN@@@@@@@@@@@@@@@@CHL@@@LCH@@@@@@@@@@@@@@@N@L@@@LAL@@@@@@@@@@@@@@CL@L@@@L@G@@@@@@@@@@@@@@G@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@@CH@@@@@@@@@@@N@@@L@@@L@@AL@@@@@@@@@@AL@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@G@@@@@@@@@@@@@@G@@L@@@LAL@@@@@@@@@@@@@@CL@L@@@LCH@@@@@@@@@@@@@@@N@L@@@LN@@@@@@@@@@@@@@@@CHL@@@ML@@@@@@@@@@@@@@@@ALL@@@O@@@@@@@@@@@@@@@@@@GL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ -#*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@COOOOL@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@GOOOOOOOOOOOOO@@@@@@@@@COOOOOOOOOOOOOOL@@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOH@@@@COOOOOOOOOOOOOOOOOON@@@@OOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ (8 8 64 36))) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD SENDINGCOMMAND (COMMAND ITEM MENU MESSAGE MESSAGEPARSE) (TYPE? (AND (LISTP DATUM) (FMEMB (fetch COMMAND of DATUM) (QUOTE (%##SEND## %##SAVE## %##FORGETIT##))))) -) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES LAFITE.SEND.FORMATTED) -) - - -(FILESLOAD (SOURCE) LAFITEDECLS) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) -(PUTPROPS LAFITESEND COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1993)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3626 16457 (DOLAFITESENDINGCOMMAND 3636 . 4010) (\SENDMESSAGE.INITIATE 4012 . 4868) ( -\SENDMSG.DELIVER 4870 . 5259) (\SENDMSG.EXIT.TEDIT 5261 . 5520) (\SENDMSG.SAVE.FORM 5522 . 6714) ( -\LAFITE.HEADER.EOF 6716 . 6955) (\LAFITE.INSERT.REPLYTO 6957 . 7462) (\SENDMSG.REPLYTO 7464 . 7827) ( -\SENDMSG.CHANGE.MODE 7829 . 10098) (\SENDMSG.FIND.FIELD 10100 . 10467) (\SENDMESSAGE.PARSE 10469 . -10992) (\LAFITE.PREPARE.SEND 10994 . 12656) (\LAFITE.PREPARE.ERROR 12658 . 13381) ( -\LAFITE.CHOOSE.MSG.FORMAT 13383 . 14526) (LAFITE.MAKE.PLAIN.TEXTSTREAM 14528 . 15221) ( -\SENDMESSAGE.MENUPROMPT 15223 . 15874) (\SENDMESSAGE.PROMPT 15876 . 16272) (\SENDMESSAGEFAIL 16274 . -16455)) (16458 29698 (\SENDMESSAGE 16468 . 17379) (\SENDMESSAGE.RESTARTABLE 17381 . 20007) ( -\SENDMESSAGE.CLEANUP 20009 . 20182) (\SENDMESSAGE.MAKEWINDOW 20184 . 23172) (MAKELAFITEDELIVERMENU -23174 . 23379) (\LAFITE.CLOSEMSG? 23381 . 23981) (\LAFITE.AFTER.DELIVER 23983 . 25644) ( -\LAFITE.UNSENT.ICON 25646 . 25891) (\LAFITE.FETCH.SUBJECT 25893 . 26341) (LAFITE.SENDMESSAGE 26343 . -26859) (\SENDMESSAGE0 26861 . 28266) (LA.ASSURE.PROMPT.WINDOW 28268 . 28777) (\LAFITE.SEND.FAIL 28779 - . 29144) (\LAFITE.INVALID.RECIPIENTS 29146 . 29467) (\SENDMESSAGE.ABORT 29469 . 29696)) (29730 35510 -(\OUTBOX.CREATE 29740 . 30746) (\OUTBOX.RESET 30748 . 31052) (\OUTBOX.CLOSEFN 31054 . 31143) ( -\OUTBOX.REPAINTFN 31145 . 31487) (\OUTBOX.RESHAPEFN 31489 . 32131) (\OUTBOX.SHADEITEM 32133 . 32603) ( -\OUTBOX.BUTTONFN 32605 . 34317) (\OUTBOX.DISPLAYLINE 34319 . 34609) (\OUTBOX.ADD.ITEM 34611 . 35508)) -(35797 44286 (\LAFITE.MESSAGEFORM 35807 . 37649) (MAKELAFITESUPPORTFORM 37651 . 37780) ( -MAKELISPSUPPORTFORM 37782 . 37888) (MAKEXXXSUPPORTFORM 37890 . 40031) (MAKENEWMESSAGEFORM 40033 . -40625) (MAKELAFITEPRIVATEFORMSITEMS 40627 . 40907) (\LAFITE.UNCACHE.MESSAGEFORM 40909 . 41239) ( -\LAFITE.DELETE.MESSAGEFORM 41241 . 41578) (\LAFITE.SELECT.FORM 41580 . 41836) ( -\LAFITE.DELETE.FORM.INTERNAL 41838 . 42387) (\LAFITE.READ.FORM 42389 . 43796) (\LAFITE.FIND.TEMPLATE -43798 . 44284)) (44310 48519 (\LAFITE.ANSWER 44320 . 44588) (\LAFITE.ANSWER.PROC 44590 . 45435) ( -MAKEANSWERFORM 45437 . 46786) (LA.PRINT.COMMA.LIST 46788 . 47001) (LAFITE.FILL.IN.ANSWER.FORM 47003 . -48517)) (48544 51763 (\LAFITE.FORWARD 48554 . 48825) (\LAFITE.FORWARD.PROC 48827 . 49888) ( -MAKEFORWARDFORM 49890 . 51761))))) -STOP diff --git a/library/lafite/LAFITESEND.~2~ b/library/lafite/LAFITESEND.~2~ deleted file mode 100644 index 92f4df5a..00000000 --- a/library/lafite/LAFITESEND.~2~ +++ /dev/null @@ -1,128 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Dec-2000 14:53:30" {DSK}medley3.5>library>LAFITESEND.;6 62302 changes to%: (VARS LAFITEFORWARDSTRINGS) previous date%: "18-Jul-2000 03:10:16" {DSK}medley3.5>library>LAFITESEND.;5) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1993, 1999, 2000 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITESENDCOMS) (RPAQQ LAFITESENDCOMS ((COMS (* ; "Sending mail") (FNS DOLAFITESENDINGCOMMAND \SENDMESSAGE.INITIATE \SENDMSG.DELIVER \SENDMSG.EXIT.TEDIT \SENDMSG.SAVE.FORM \LAFITE.HEADER.EOF \LAFITE.INSERT.REPLYTO \SENDMSG.REPLYTO \SENDMSG.CHANGE.MODE \SENDMSG.FIND.FIELD \SENDMESSAGE.PARSE \LAFITE.PREPARE.SEND \LAFITE.PREPARE.ERROR \LAFITE.CHOOSE.MSG.FORMAT LAFITE.MAKE.PLAIN.TEXTSTREAM \SENDMESSAGE.MENUPROMPT \SENDMESSAGE.PROMPT \SENDMESSAGEFAIL) (FNS \SENDMESSAGE \SENDMESSAGE.RESTARTABLE \SENDMESSAGE.CLEANUP \SENDMESSAGE.MAKEWINDOW MAKELAFITEDELIVERMENU \LAFITE.CLOSEMSG? \LAFITE.AFTER.DELIVER \LAFITE.UNSENT.ICON \LAFITE.FETCH.SUBJECT LAFITE.SENDMESSAGE \SENDMESSAGE0 LA.ASSURE.PROMPT.WINDOW \LAFITE.SEND.FAIL \LAFITE.INVALID.RECIPIENTS \SENDMESSAGE.ABORT)) (COMS (* ; "Outbox hacking") (FNS \OUTBOX.CREATE \OUTBOX.RESET \OUTBOX.CLOSEFN \OUTBOX.REPAINTFN \OUTBOX.RESHAPEFN \OUTBOX.SHADEITEM \OUTBOX.BUTTONFN \OUTBOX.DISPLAYLINE \OUTBOX.ADD.ITEM) (INITVARS (LAFITEOUTBOXSIZE 2) (\LAFITE.OUTBOX)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS OUTBOXITEM) (GLOBALVARS LAFITEOUTBOXSIZE))) (COMS (* ; "Built-in message forms") (FNS \LAFITE.MESSAGEFORM MAKELAFITESUPPORTFORM MAKELISPSUPPORTFORM MAKEXXXSUPPORTFORM MAKENEWMESSAGEFORM MAKELAFITEPRIVATEFORMSITEMS \LAFITE.UNCACHE.MESSAGEFORM \LAFITE.DELETE.MESSAGEFORM \LAFITE.SELECT.FORM \LAFITE.DELETE.FORM.INTERNAL \LAFITE.READ.FORM \LAFITE.FIND.TEMPLATE)) (COMS (* ; "ANSWER") (FNS \LAFITE.ANSWER \LAFITE.ANSWER.PROC MAKEANSWERFORM LA.PRINT.COMMA.LIST LAFITE.FILL.IN.ANSWER.FORM)) (COMS (* ; "FORWARD") (FNS \LAFITE.FORWARD \LAFITE.FORWARD.PROC MAKEFORWARDFORM)) [COMS (VARS LAFITESENDINGMENUITEMS LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS) (ADDVARS (\SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) (LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) "A form to report a Lisp bug or suggestion") ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) "A form to report a Lafite bug or suggestion")) (LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU)) (INITVARS (\LAFITE.REPORT.MACHINE) (LAFITECURRENTEDITORWINDOWS) (LAFITEFORMFILES) (LAFITEFORMSMENU) (LAFITEFORMATMENU)) (INITVARS (LAFITEEDITORFONT LAFITEDISPLAYFONT) (LAFITEFORM.EXT "Lafite-form") (LAFITEFORMDIRECTORIES NIL) (LAFITE.EDITOR.SIZE '(470 . 300)) (LAFITE.EDITOR.LAYOUTS NIL) (LAFITEFORWARDSUBJECTSTR NIL) (LAFITESUPPORT NIL) (LISPSUPPORT NIL) (MESSAGESTR ">>Message<<") (RECIPIENTSSTR ">>Recipients<<") (SUBJECTSTR ">>Subject<<") (LAFITE.SEND.FORMATTED '((NSCHARS :ASK) (CHARLOOKS :ASK) (PARALOOKS :ASK) (IMAGEOBJ :ASK] (COMS (* ; "Obsolete") (INITVARS (LAFITEEDITORREGION NIL))) (COMS (* ; "ICON stuff") (VARS LAFITE.MSG.ICON)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SENDINGCOMMAND) (GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES LAFITE.SEND.FORMATTED) (FILES (SOURCE) LAFITEDECLS) (LOCALVARS . T)))) (* ; "Sending mail") (DEFINEQ (DOLAFITESENDINGCOMMAND -(LAMBDA (ITEM MENU KEY) (* bvm%: "31-Jul-84 15:03") (* ;;; "this function is invoked by buttoning the menu on top of the 'sending' window") (PROG ((WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) PROC) (AND (SETQ PROC (WINDOWPROP WINDOW (QUOTE PROCESS))) (PROCESS.APPLY PROC (FUNCTION \SENDMESSAGE.INITIATE) (LIST WINDOW MENU ITEM))))) -) (\SENDMESSAGE.INITIATE -(LAMBDA (WINDOW MENU ITEM) (* ; "Edited 31-Jan-89 16:59 by bvm") (* ;; "Called by selecting a menu command from a message composition window") (ERSETQ (RESETLST (LET ((COMMAND (EXTRACTMENUCOMMAND ITEM))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (ITEM MENU) (COND (RESETSTATE (* ; "In case of error/abort, set menu & proc back to normal") (SHADEITEM ITEM MENU WHITESHADE) (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) NIL))))) ITEM MENU)) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE) (* ; "Now disable the menu") (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION NILL)) (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) (QUOTE DON'T)) (* ; "Don't let anyone logout now!") (CL:FUNCALL COMMAND WINDOW (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)) MENU ITEM))))) -) (\SENDMSG.DELIVER -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 31-Jan-89 16:41 by bvm") (LET (PARSE) (printout (GETPROMPTWINDOW WINDOW) T "Parsing...") (OR (SETQ PARSE (\SENDMESSAGE.PARSE TEXTSTREAM WINDOW)) (ERROR!)) (\SENDMSG.EXIT.TEDIT WINDOW TEXTSTREAM (create SENDINGCOMMAND COMMAND _ (QUOTE %##SEND##) ITEM _ ITEM MENU _ MENU MESSAGE _ TEXTSTREAM MESSAGEPARSE _ PARSE)))) -) (\SENDMSG.EXIT.TEDIT -(LAMBDA (WINDOW TEXTSTREAM VALUE) (* ; "Edited 31-Jan-89 16:39 by bvm") (WINDOWADDPROP WINDOW (QUOTE CLOSEFN) (QUOTE DON'T)) (* ; "Keep TEDIT.QUIT from closing the window") (TEDIT.QUIT TEXTSTREAM VALUE) (LA.DETACH.TEDIT TEXTSTREAM)) -) (\SENDMSG.SAVE.FORM -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 15:33 by bvm") (* ;; "Shortcut to TEdit Put that saves on mail directory and remembers it as a %"Saved Form%"") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (PROMPT "Save under name: ") (FORMNAME (WINDOWPROP WINDOW (QUOTE LAFITEFORM))) PWINDOW FORMFILE) (COND (FORMNAME (SETQ FORMNAME (LA.SHORTFILENAME FORMNAME LAFITEFORM.EXT)))) (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW WINDOW PROMPT (OR FORMNAME "XXX"))) (* ; "Kludge to keep it small") (CLEARW PWINDOW) (COND ((SETQ FORMFILE (PROMPTFORFILENAME PWINDOW FORMNAME PROMPT)) (SETQ FORMNAME (LA.SHORTFILENAME (TEDIT.PUT TEXTSTREAM (LA.LONGFILENAME FORMFILE LAFITEFORM.EXT) NIL (if (EQ (TEDIT.FORMATTEDFILEP TEXTSTREAM) (QUOTE NSCHARS)) then (* ; "Force no formatting--TEdit defaultly saves formatting even if only ns chars") T)) LAFITEFORM.EXT)) (WINDOWPROP WINDOW (QUOTE LAFITEFORM) FORMNAME) (COND ((NOT (CL:MEMBER FORMNAME LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (SETQ LAFITEFORMFILES (APPEND LAFITEFORMFILES (LIST FORMNAME))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU))))) (* ;; "Exit with error to restore window state (what a kludge)") (ERROR!))) -) (\LAFITE.HEADER.EOF -(LAMBDA (TEXTSTREAM) (* ; "Edited 3-Nov-89 14:29 by bvm") (* ;; "Return the character number in TEXTSTREAM of the blank line following the header") (ADD1 (CADAR (LAFITE.PARSE.HEADER TEXTSTREAM NIL 0 NIL NIL T)))) -) (\LAFITE.INSERT.REPLYTO -(LAMBDA (TEXTSTREAM NAME HIGHLIGHT HEADEREOF) (* ; "Edited 3-Nov-89 12:57 by bvm") (* ;; "Insert a %"Reply-to: name%" field in this message. If HIGHLIGHT, leave the name pending-delete selected for potential replacement.") (TEDIT.INSERT TEXTSTREAM (CONCAT "Reply-to: " NAME LAFITEEOL) (OR HEADEREOF (SETQ HEADEREOF (\LAFITE.HEADER.EOF TEXTSTREAM)))) (if HIGHLIGHT then (TEDIT.SETSEL TEXTSTREAM (+ HEADEREOF (CONSTANT (NCHARS "Reply-to: "))) (NCHARS NAME) (QUOTE RIGHT) T))) -) (\SENDMSG.REPLYTO -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 3-Nov-89 14:03 by bvm") (* ;; "Add a Reply-to field to the message") (\LAFITE.INSERT.REPLYTO TEXTSTREAM (fetch (LAFITEMODEDATA FULLUSERNAME) of (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE)))) T) (* ;; "Exit with error to restore window state (what a kludge)") (ERROR!)) -) (\SENDMSG.CHANGE.MODE -(LAMBDA (WINDOW TEXTSTREAM MENU ITEM) (* ; "Edited 5-Jan-90 18:06 by bvm") (LET* ((OLDMODE (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE))) (OTHERMODES (for MODE in LAFITEMODELST unless (OR (EQ (fetch (LAFITEOPS LAFITEMODE) of MODE) OLDMODE) (NLISTP (CDR MODE))) collect (fetch (LAFITEOPS LAFITEMODE) of MODE))) (NEWMODE (if (NULL OTHERMODES) then (\SENDMESSAGE.PROMPT WINDOW "There are no other modes") elseif (CDR OTHERMODES) then (MENU (\LAFITE.CREATE.MENU OTHERMODES "New mode")) else (CAR OTHERMODES)))) (if NEWMODE then (LET* ((TITLE (WINDOWPROP WINDOW (QUOTE TITLE))) (OLDMODEDATA (\LAFITE.GET.USER.DATA OLDMODE)) (NEWMODEDATA (\LAFITE.GET.USER.DATA NEWMODE)) N N2) (if (NULL NEWMODEDATA) then (\SENDMESSAGE.PROMPT WINDOW (CL:FORMAT NIL "Can't authenticate user in ~A mode" NEWMODE)) else (LET ((OLDNAME (fetch (LAFITEMODEDATA FULLUSERNAME) of OLDMODEDATA)) (END (TEDIT.FIND TEXTSTREAM " - -" 1)) START N LEN NEW OLDSEL) (if END then (add END 1)) (* ; "Don't search past end of header. END now points at second cr.") (for FIELD in (QUOTE ("cc" "Reply-to")) when (AND (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM FIELD END)) (PROGN (SETQ LEN (CADR N)) (SETQ N (CAR N)) (SETQ START (STRPOS OLDNAME (SETQ OLDSEL (TEDIT.SEL.AS.STRING TEXTSTREAM (create SELECTION CH# _ N DCH _ LEN))) NIL NIL NIL NIL UPPERCASEARRAY)))) do (* ; "Change field containing old user name to new. This is much more complicated than it needs to be because TEDIT.FIND is case sensitive.") (TEDIT.DELETE TEXTSTREAM N LEN) (TEDIT.INSERT TEXTSTREAM (SETQ NEW (CONCAT (OR (SUBSTRING OLDSEL 1 (SUB1 START)) "") (fetch (LAFITEMODEDATA FULLUSERNAME) of NEWMODEDATA) (OR (SUBSTRING OLDSEL (+ START (NCHARS OLDNAME))) ""))) N) (AND END (add END (- (NCHARS NEW) LEN)))) (if (SETQ N (\SENDMSG.FIND.FIELD TEXTSTREAM "To" END)) then (* ; "Leave the To field selected for address modification") (TEDIT.SETSEL TEXTSTREAM (CAR N) (CADR N) (QUOTE RIGHT) T)) (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE) NEWMODE) (if (SETQ N (STRPOS (CONCAT "(" OLDMODE ")") TITLE)) then (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT (SUBSTRING TITLE 1 N) NEWMODE ")"))) (\SENDMESSAGE.PROMPT WINDOW "Message mode is now " NEWMODE))))) (* ;; "Exit with error so that the window is restored to previous state") (ERROR!))) -) (\SENDMSG.FIND.FIELD -(LAMBDA (TEXTSTREAM FIELD END) (* ; "Edited 5-Jan-90 17:54 by bvm") (* ;; "Find and select the header field beginning with %"FIELD:%". Return starting index.") (LET* ((STR (CONCAT " -" FIELD ": ")) (N (TEDIT.FIND TEXTSTREAM STR 1 END)) N2) (if (AND N (SETQ N2 (TEDIT.FIND TEXTSTREAM " -" (add N (NCHARS STR)) END))) then (LIST N (- N2 N)))))) (\SENDMESSAGE.PARSE -(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 10-Aug-89 17:25 by bvm") (* ;; "Parse MSG in the current mode, returning a parse structure that the corresponding sender will be happy with") (LET* ((MODE (TEXTPROP MSG (QUOTE LAFITEMODE))) (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE))) (if *LAFITE-MODE-DATA* then (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) MSG EDITORWINDOW) else (\SENDMESSAGE.PROMPT EDITORWINDOW (CL:FORMAT NIL "Can't authenticate user in ~A mode" MODE))))) -) (\LAFITE.PREPARE.SEND -(LAMBDA (MSG EDITORWINDOW PARSETABLE) (* bvm%: "13-Nov-84 12:50") (* ;; "Does generic things to MSG, a textstream about to be sent as a message: makes sure it ends in a CR, has no leading CRs, and parses it according to PARSETABLE which defaults to \LAPARSE.FULL -- returns a parse, whose first element tries to be (EOF end-of-header-position)") (PROG (MSGEOF HEADEREOF MSGFIELDS EOFINFO) (COND ((NOT (TYPENAMEP MSG (QUOTE STREAM))) (RETURN (LISPERROR "ILLEGAL ARG" MSG)))) (COND (EDITORWINDOW (* ; "Scroll so that beginning of message is visible") (TEDIT.SETSEL MSG 1 0 (QUOTE LEFT)) (TEDIT.NORMALIZECARET MSG) (first (SETFILEPTR MSG 0) until (NEQ (BIN MSG) (CHARCODE EOL)) do (* ; "hack to get rid of leading CRs") (TEDIT.DELETE MSG 1 1)) (SETFILEPTR MSG (SUB1 (SETQ MSGEOF (GETEOFPTR MSG)))) (COND ((NEQ (BIN MSG) (CHARCODE EOL)) (* ; "Make sure message ends in eol") (TEDIT.INSERT MSG LAFITEEOL (ADD1 MSGEOF) NIL T))))) (SETFILEINFO MSG (QUOTE ENDOFSTREAMOP) (FUNCTION \LAFITE.EOF)) (* ; "Avoid parsing failure if header-only message") (SETQ MSGFIELDS (LAFITE.PARSE.HEADER MSG (OR PARSETABLE \LAPARSE.FULL) 0 (SETQ MSGEOF (GETEOFPTR MSG)) NIL T)) (COND ((EQ (CAR (SETQ EOFINFO (CAR MSGFIELDS))) (QUOTE EOF)) (SETQ HEADEREOF (CADR EOFINFO)) (COND ((CADDR EOFINFO) (* ; "Error") (RETURN (\LAFITE.PREPARE.ERROR MSG EDITORWINDOW HEADEREOF)))) (COND ((= HEADEREOF MSGEOF) (* ; "Parse ended at eof, so message does not end in double CR -- add another") (SETFILEPTR MSG MSGEOF) (BOUT MSG (CHARCODE CR)))) (RPLACA (CDR EOFINFO) (SETQ HEADEREOF (ADD1 HEADEREOF))) (* ; "Add one for tedit fileptr one-based nonsense"))) (RETURN MSGFIELDS))) -) (\LAFITE.PREPARE.ERROR -(LAMBDA (MSG EDITORWINDOW HEADEREOF) (* bvm%: "13-Nov-84 12:53") (* ;;; "Called when header of MSG contained a line not conforming to spec. Most likely cause is user deleted the blank line between header and message. Print a suitable error message") (PROG (LINE) (SETFILEPTR MSG HEADEREOF) (SETQ LINE (LAFITE.READ.TO.EOL MSG)) (SETFILEPTR MSG HEADEREOF) (BOUT MSG (CHARCODE CR)) (\SENDMESSAGEFAIL EDITORWINDOW (CONCAT "Header not understood: %"" (COND ((> (NCHARS LINE) 30) (CONCAT (SUBSTRING LINE 1 30) (QUOTE ...))) (T LINE))) "%". Assumed this was not part of header, and inserted blank line before it. If this is correct, press 'Deliver' again, else edit the message appropriately."))) -) (\LAFITE.CHOOSE.MSG.FORMAT -(LAMBDA (TEXTSTREAM HEADEREOF EDITORWINDOW) (* ; "Edited 3-Feb-89 18:36 by bvm") (* ;; "Ask if user intends to retain formatting info, and if so, send formatted") (LET ((FORMATTING (TEDIT.FORMATTEDFILEP TEXTSTREAM)) TMP) (COND ((NULL FORMATTING) (* ; "It's just plain text") (QUOTE TEXT)) ((AND (TEXTSTREAMP TEXTSTREAM) (TEXTPROP TEXTSTREAM (QUOTE LAFITEFORMAT)))) ((NULL EDITORWINDOW) (* ; "Nobody to interact with") (QUOTE TEDIT)) (T (SELECTQ (COND ((NLISTP LAFITE.SEND.FORMATTED) LAFITE.SEND.FORMATTED) ((SETQ TMP (ASSOC FORMATTING LAFITE.SEND.FORMATTED)) (CADR TMP)) (T :ASK)) (T (* ; "Send formatted") (QUOTE TEDIT)) (NIL (* ; "Send unformatted") (QUOTE TEXT)) (SELECTQ (SETQ TMP (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (OR LAFITEFORMATMENU (SETQ LAFITEFORMATMENU (\LAFITE.CREATE.MENU LAFITEFORMATMENUITEMS "Retain formatting information?" T))) (CONCAT "Message " (SELECTQ FORMATTING (CHARLOOKS "has font information") (PARALOOKS "has paragraph formatting") (NSCHARS "uses extended character set") (IMAGEOBJ "contains images") "has unknown formatting") ".") (QUOTE LAFITEFORMATMENU))) (ABORT NIL) TMP)))))) -) (LAFITE.MAKE.PLAIN.TEXTSTREAM -(LAMBDA (TEXTSTREAM START) (* ; "Edited 24-Sep-87 16:48 by bvm:") (* ;; "Coerces TEXTSTREAM to a %"plain text%" stream, returning the new stream. If START is specified, only copies from that file pointer onward.") (LET ((PLAIN (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (SETFILEPTR TEXTSTREAM (OR START (SETQ START 0))) (* ;; "TEXT streams return character codes on BIN, so we have to translate to bytes on output side to handle fat chars correctly and avoid image objects") (to (- (GETEOFPTR TEXTSTREAM) START) do (\OUTCHAR PLAIN (OR (FIXP (BIN TEXTSTREAM)) (CHARCODE *)))) (* ; "Reopen to avoid core bug") (OPENSTREAM (CLOSEF PLAIN) (QUOTE INPUT)))) -) (\SENDMESSAGE.MENUPROMPT -(LAMBDA (EDITWINDOW MENU PROMPT MENUVAR) (* ; "Edited 20-Apr-89 19:37 by bvm") (* ;; "Prompt with MENU at the upper left corner of EDITWINDOW, printing PROMPT in the prompt window. If MENUVAR is specified, it is the global variable that holds this menu, which we smash to NIL while inside MENU, lest someone else try to use it") (LET ((PWINDOW (GETPROMPTWINDOW EDITWINDOW)) RESULT) (CLEARW PWINDOW) (printout PWINDOW PROMPT) (if MENUVAR then (SET MENUVAR NIL)) (SETQ RESULT (MENU MENU (LA.POSITION.FROM.REGION (WINDOWPROP PWINDOW (QUOTE REGION)) NIL T) T)) (CLEARW PWINDOW) (if MENUVAR then (SET MENUVAR MENU)) RESULT)) -) (\SENDMESSAGE.PROMPT -(LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:03 by bvm") (* ;; "Display message MESS1 & optionally MESS2 in the prompt window of EDITORWINDOW. Returns NIL always") (LET ((PWINDOW (COND (EDITORWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MESS1 MESS2)) (T PROMPTWINDOW)))) (CLEARW PWINDOW) (PRIN3 MESS1 PWINDOW) (COND (MESS2 (PRIN3 MESS2 PWINDOW))) NIL)) -) (\SENDMESSAGEFAIL -(LAMBDA (EDITORWINDOW MESS1 MESS2) (* ; "Edited 31-Jan-89 17:02 by bvm") (\SENDMESSAGE.PROMPT EDITORWINDOW MESS1 MESS2) (RETFROM (QUOTE \SENDMESSAGE.PARSE))) -) ) (DEFINEQ (\SENDMESSAGE -(LAMBDA (FORM TEDITPROPS FORMNAME) (* ; "Edited 10-Feb-89 12:22 by bvm") (* ;;; "FORM can be a string, file, or stream --- The value of \SENDMESSAGE is T only if the message was actually sent") (OR (TEXTSTREAMP FORM) (SETQ FORM (OPENTEXTSTREAM FORM NIL NIL NIL TEDITPROPS))) (TEDIT.STREAMCHANGEDP FORM T) (* ; "Clear the changed bit") (if (NOT (LISTGET TEDITPROPS (QUOTE LEAVETTY))) then (* ; "Take control of the keyboard") (TTY.PROCESS (THIS.PROCESS))) (PROG ((MODE (LISTGET TEDITPROPS (QUOTE LAFITEMODE)))) (* ; "Old way of specifying mode") (if MODE then (TEXTPROP FORM (QUOTE LAFITEMODE) MODE) elseif (TEXTPROP FORM (QUOTE LAFITEMODE)) elseif (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)) then (TEXTPROP FORM (QUOTE LAFITEMODE) MODE) else (PRINTOUT PROMPTWINDOW T "Can't send mail without a Lafite mode.") (RETURN NIL)) (RETURN (\SENDMESSAGE.RESTARTABLE FORM TEDITPROPS NIL FORMNAME)))) -) (\SENDMESSAGE.RESTARTABLE -(LAMBDA (FORM TEDITPROPS EDITORWINDOW FORMNAME) (* ; "Edited 3-Nov-89 15:06 by bvm") (bind (CURRENTMESSAGE _ FORM) (FIRSTTIME _ T) EDITORRESULT DONE SENTOK PARSE do (PROCESSPROP (THIS.PROCESS) (QUOTE BEFOREEXIT) NIL) (* ; "Allow LOGOUT until delivery is attempted. Need to do this if we loop or restart") (COND ((NULL (PROG1 EDITORWINDOW (SETQ EDITORWINDOW (\SENDMESSAGE.MAKEWINDOW CURRENTMESSAGE NIL EDITORWINDOW (TEXTPROP FORM (QUOTE LAFITEMODE)))))) (* ; "First time thru. Fix it so that we can restart if aborted") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTFORM) (LIST (FUNCTION \SENDMESSAGE.RESTARTABLE) (KWOTE FORM) (KWOTE TEDITPROPS) (KWOTE EDITORWINDOW))) (* ; "If process is reset or aborted, this is how to resurrect") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTABLE) T) (WINDOWPROP EDITORWINDOW (QUOTE LAFITEFORM) FORMNAME))) (COND (FIRSTTIME (RESETSAVE NIL (LIST (FUNCTION \SENDMESSAGE.CLEANUP) EDITORWINDOW)) (push LAFITECURRENTEDITORWINDOWS EDITORWINDOW) (SETQ FIRSTTIME))) (SETQ EDITORRESULT (TEDIT FORM EDITORWINDOW T (APPEND TEDITPROPS (LIST (QUOTE FONT) LAFITEEDITORFONT)))) (COND ((TTY.PROCESSP) (* ; "give back the keyboard") (TTY.PROCESS T))) (WINDOWDELPROP EDITORWINDOW (QUOTE CLOSEFN) (QUOTE DON'T)) (* ; "let the window close") (COND ((NOT (type? SENDINGCOMMAND EDITORRESULT)) (* ; "get out anyway since the user used the TEDIT `quit' command instead of one of the sending commands") (SETQ DONE T)) (T (* ; "the user used the lafite menu to get out rather than the TEDIT menu so we have to do something") (* ; "make sure CURRENTMESSAGE is always a string") (SETQ CURRENTMESSAGE (fetch (SENDINGCOMMAND MESSAGE) of EDITORRESULT)) (SETQ DONE (SELECTQ (AND EDITORRESULT (fetch (SENDINGCOMMAND COMMAND) of EDITORRESULT)) (%##SEND## (SETQ SENTOK (\SENDMESSAGE0 CURRENTMESSAGE EDITORWINDOW (SETQ PARSE (fetch (SENDINGCOMMAND MESSAGEPARSE) of EDITORRESULT))))) (SHOULDNT))) (SHADEITEM (fetch (SENDINGCOMMAND ITEM) of EDITORRESULT) (fetch (SENDINGCOMMAND MENU) of EDITORRESULT) WHITESHADE) (* ; "Unshade command. DOLAFITESENDINGCOMMAND shaded it to begin with"))) (COND (DONE (* ; "Message successfully dispatched") (PROCESSPROP (THIS.PROCESS) (QUOTE RESTARTABLE) NIL) (* ; "Don't try to restart if there's any sort of error now") (COND (CURRENTMESSAGE (* ; "Mark text unchanged now, so no trouble closing icon") (TEDIT.STREAMCHANGEDP CURRENTMESSAGE T))) (COND ((NULL SENTOK) (CLOSEW EDITORWINDOW)) (T (* ; "shrink the window") (\LAFITE.AFTER.DELIVER EDITORWINDOW CURRENTMESSAGE PARSE))) (RETURN SENTOK)) (T (* ; "Loop if deliver failed or \LAFITE.SAVE.FORM was aborted."))))) -) (\SENDMESSAGE.CLEANUP -(LAMBDA (EDITORWINDOW) (* ; "Edited 6-Oct-87 15:58 by bvm:") (SETQ LAFITECURRENTEDITORWINDOWS (REMOVE EDITORWINDOW LAFITECURRENTEDITORWINDOWS))) -) (\SENDMESSAGE.MAKEWINDOW -(LAMBDA (MESSAGEFORM TITLE WINDOW MODE) (* ; "Edited 3-Nov-89 16:16 by bvm") (* ;;; "Editor for Mail system Lafite -- Handles the process mechanism right") (* ;;; "Assumes that it's running in a separate process created above") (PROG ((MENU (MAKELAFITEDELIVERMENU)) EDITWINDOW LAYOUT REGION) (COND ((NOT TITLE) (SETQ TITLE "Message Editor") (if (AND MODE (LAFITE.SHOW.MODE.P)) then (SETQ TITLE (CONCAT TITLE " (" MODE ")"))))) (COND ((WINDOWP (SETQ EDITWINDOW WINDOW)) (WINDOWPROP EDITWINDOW (QUOTE TITLE) TITLE) (for W in (ATTACHEDWINDOWS EDITWINDOW) when (WINDOWPROP W (QUOTE MENUWINDOW)) do (* ; "there's already an attached window menu, make sure we have a delivery menu in it.") (LET ((OLDMENU (CAR (WINDOWPROP W (QUOTE MENU))))) (if (if (NULL OLDMENU) then (* ; "E.g., after ABORT got removed") T elseif (NOT (EQUAL (fetch (MENU ITEMS) of MENU) (fetch (MENU ITEMS) of OLDMENU))) then (DELETEMENU OLDMENU NIL W) (* ; "Get rid of different menu") T else (SETQ MENU OLDMENU) (* ; "They're the same, don't fuss") NIL) else (ADDMENU MENU W (QUOTE (0 . 0))) (* ; "Now make it fit") (MENUWRESHAPEFN W))) (RETURN) finally (* ; "No attached menu yet") (ATTACHWINDOW (SETQ W (MENUWINDOW MENU)) EDITWINDOW (QUOTE TOP)) (WINDOWPROP W (QUOTE MENUWINDOW) T))) (T (SETQ REGION (if (for old LAYOUT in LAFITE.EDITOR.LAYOUTS unless (for WINDOW in LAFITECURRENTEDITORWINDOWS thereis (EQ (WINDOWPROP WINDOW (QUOTE LAFITE.LAYOUT)) LAYOUT)) do (* ; "Use first layout not already in use") (RETURN (CAR LAYOUT))) elseif (AND (NULL LAFITECURRENTEDITORWINDOWS) (type? REGION LAFITEEDITORREGION)) then (* ; "Old way of doing this for a single window") LAFITEEDITORREGION elseif LAFITE.EDITOR.SIZE then (* ; "Get window of appropriate size") (GETBOXREGION (CAR LAFITE.EDITOR.SIZE) (CDR LAFITE.EDITOR.SIZE)) else (GETREGION))) (SETQ EDITWINDOW (CREATEMENUEDWINDOW MENU TITLE (QUOTE TOP) (create REGION using REGION HEIGHT _ (- (fetch (REGION HEIGHT) of REGION) (HEIGHTIFWINDOW (FONTPROP LAFITEEDITORFONT (QUOTE HEIGHT))))))) (WINDOWPROP (CAR (ATTACHEDWINDOWS EDITWINDOW)) (QUOTE MENUWINDOW) T) (if LAYOUT then (WINDOWPROP EDITWINDOW (QUOTE LAFITE.LAYOUT) LAYOUT) (WINDOWPROP EDITWINDOW (QUOTE ICONPOSITION) (CADR LAYOUT))))) (GETPROMPTWINDOW EDITWINDOW 1 LAFITEEDITORFONT) (COND (NIL (* ; "don't let TEDIT close the window") (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (QUOTE DON'T)))) (PROGN (WINDOWDELPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION CLOSEATTACHEDWINDOWS)) (* ; "On closing, get rid of attachments, don't just close them") (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION DETACHALLWINDOWS)) (WINDOWADDPROP EDITWINDOW (QUOTE CLOSEFN) (FUNCTION \LAFITE.CLOSEMSG?) T)) (WINDOWPROP EDITWINDOW (QUOTE ICONFN) (FUNCTION \LAFITE.UNSENT.ICON)) (WINDOWPROP EDITWINDOW (QUOTE PROCESS) (THIS.PROCESS)) (* ; "Associate this process with the edit window") (replace (MENU WHENSELECTEDFN) of MENU with (FUNCTION DOLAFITESENDINGCOMMAND)) (* ; "Enable the menu") (RETURN EDITWINDOW))) -) (MAKELAFITEDELIVERMENU -(LAMBDA NIL (* bvm%: "28-Mar-84 12:47") (create MENU ITEMS _ LAFITESENDINGMENUITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT WHENSELECTEDFN _ (FUNCTION DOLAFITESENDINGCOMMAND))) -) (\LAFITE.CLOSEMSG? -(LAMBDA (WINDOW) (* ; "Edited 3-Sep-87 17:21 by bvm:") (* ;; "This is the first CLOSEFN on a message sending window. If contents have changed, get confirmation") (LET ((TEXTSTREAM (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)))) (COND ((OR (NULL TEXTSTREAM) (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ; "TEXTSTREAM is null once TEdit's gotten thru with it.") NIL) ((MOUSECONFIRM "Message has been edited -- LEFT to flush anyway" T (GETPROMPTWINDOW WINDOW)) (TEDIT.STREAMCHANGEDP TEXTSTREAM T) (* ; "Reset bit so question doesn't get asked a second time") NIL) (T (QUOTE DON'T))))) -) (\LAFITE.AFTER.DELIVER -(LAMBDA (EDITORWINDOW TEXTSTREAM PARSE) (* ; "Edited 30-May-90 16:25 by bvm") (TEDIT.ASSURE.NO.BACKING.FILE TEXTSTREAM) (* ; "In case the backing file gets deleted") (\OUTBOX.ADD.ITEM TEXTSTREAM (OR (CAR PARSE) UNSUPPLIEDFIELDSTR)) (LET ((FORMNAME (WINDOWPROP EDITORWINDOW (QUOTE LAFITEFORM) NIL))) (if (AND FORMNAME (EQ (CAR (UNPACKFILENAME.STRING FORMNAME)) (QUOTE NAME))) then (* ;; "See if user wants to keep the form, or if it was saved just as a checkpoint. Do this only for files saved in primary directory") (LET* ((PWINDOW (GETPROMPTWINDOW EDITORWINDOW)) (MENUW (find W in (ATTACHEDWINDOWS EDITORWINDOW) suchthat (WINDOWPROP W (QUOTE MENUWINDOW)))) (MENU (create MENU ITEMS _ (QUOTE (("Delete File" T "Delete the file(s) in which this message was earlier saved.") ("Retain Saved Form" NIL "Don't delete the saved form, I want to use it again."))) WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU KEY) (LET ((W (WFROMMENU MENU))) (WINDOWPROP W (QUOTE RESULT) ITEM) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE)))) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T ITEMWIDTH _ (IQUOTIENT (WINDOWPROP PWINDOW (QUOTE WIDTH)) 2) MENUROWS _ 1)) RESULT (MSG (CONCAT "Delivery complete. Do you want to delete the saved form of this message (" FORMNAME ")?"))) (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW MSG) (TERPRI PWINDOW) (PRIN3 MSG PWINDOW) (ADDMENU MENU MENUW (QUOTE (0 . 0))) (until (SETQ RESULT (WINDOWPROP MENUW (QUOTE RESULT))) do (BLOCK 500)) (if (CADR RESULT) then (PRINTOUT PWINDOW T "Deleting file(s)... " (if (\LAFITE.DELETE.FORM.INTERNAL FORMNAME) then "done." else "failed.")))))) (DETACHALLWINDOWS EDITORWINDOW) (CLOSEW EDITORWINDOW)) -) (\LAFITE.UNSENT.ICON -(LAMBDA (WINDOW OLDICON) (* ; "Edited 24-Sep-87 16:58 by bvm:") (TITLEDICONW LAFITE.MSG.ICON (\LAFITE.FETCH.SUBJECT (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) LAFITEMSGICONFONT (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) T)) -) (\LAFITE.FETCH.SUBJECT -(LAMBDA (TEXTSTREAM) (* bvm%: " 2-Mar-86 16:27") (COND (TEXTSTREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION SETFILEINFO) TEXTSTREAM (QUOTE ENDOFSTREAMOP) (GETFILEINFO TEXTSTREAM (QUOTE ENDOFSTREAMOP)))) (SETFILEINFO TEXTSTREAM (QUOTE ENDOFSTREAMOP) (FUNCTION \LAFITE.EOF)) (LET ((STR (LAFITE.PARSE.HEADER TEXTSTREAM \LAPARSE.SUBJECTFIELD 0 NIL T))) (COND ((STRING-EQUAL STR SUBJECTSTR) UNSUPPLIEDFIELDSTR) (T STR))))))) -) (LAFITE.SENDMESSAGE -(LAMBDA (MESSAGEFORM) (* ; "Edited 12-Sep-88 14:07 by bvm") (* ;;; "this is the external interface to sending a message") (SETQ MESSAGEFORM (OPENTEXTSTREAM MESSAGEFORM)) (LET* ((MODE (TEXTPROP MESSAGEFORM (QUOTE LAFITEMODE))) (*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) PARSE) (AND *LAFITE-MODE-DATA* (SETQ PARSE (CL:FUNCALL (fetch (LAFITEMODEDATA SENDPARSER) of *LAFITE-MODE-DATA*) MESSAGEFORM)) (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) MESSAGEFORM PARSE)))) -) (\SENDMESSAGE0 -(LAMBDA (TEXTSTREAM WINDOW PARSE) (* ; "Edited 12-Sep-88 14:04 by bvm") (PROG ((PWINDOW (GETPROMPTWINDOW WINDOW)) *LAFITE-MODE-DATA* MENUW OLDMENU ABORTMENU RESULT) (for W in (ATTACHEDWINDOWS WINDOW) when (SETQ OLDMENU (CAR (WINDOWPROP W (QUOTE MENU)))) do (SETQ MENUW W) (DELETEMENU OLDMENU NIL MENUW) (* ; "Remove Deliver menu, add Abort menu") (ADDMENU (SETQ ABORTMENU (create MENU ITEMS _ (QUOTE (("Abort" NIL "Abort delivery of this message"))) WHENSELECTEDFN _ (FUNCTION \SENDMESSAGE.ABORT) MENUFONT _ LAFITEMENUFONT CENTERFLG _ T ITEMWIDTH _ (fetch ITEMWIDTH of OLDMENU))) MENUW (QUOTE (0 . 0))) (RETURN)) (if (NULL (SETQ *LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE))))) then (printout PWINDOW "Failed to authenticate user.") else (SETQ RESULT (ERSETQ (RESETLST (CL:FUNCALL (fetch (LAFITEMODEDATA SENDER) of *LAFITE-MODE-DATA*) TEXTSTREAM PARSE WINDOW MENUW)))) (COND ((NULL RESULT) (printout PWINDOW "aborted.")) ((SETQ RESULT (CAR RESULT)) (printout PWINDOW "done.")))) (RETURN (COND (RESULT (* ; "Success") (CLOSEF TEXTSTREAM) (* ; "Explicit Close here after successful delivery so that TEdit can close any files it might have open") RESULT) (T (* ; "Restore Deliver menu") (COND ((WINDOWPROP MENUW (QUOTE MENU)) (DELETEMENU ABORTMENU NIL MENUW))) (ADDMENU OLDMENU MENUW (QUOTE (0 . 0)) NIL) (WINDOWPROP MENUW (QUOTE ABORT) NIL) NIL))))) -) (LA.ASSURE.PROMPT.WINDOW -(LAMBDA (MAINWINDOW MESS1 MESS2) (* bvm%: "24-Feb-85 18:33") (* ;;; "Returns prompt window for MAINWINDOW assuring that it is big enough to print MESS1 and MESS2") (LET ((PWINDOW (GETPROMPTWINDOW MAINWINDOW)) %#LINES) (COND ((> (SETQ %#LINES (QUOTIENT (+ (STRINGWIDTH MESS1 PWINDOW) (COND (MESS2 (STRINGWIDTH MESS2 PWINDOW)) (T 0))) (WINDOWPROP PWINDOW (QUOTE WIDTH)))) 0) (* ; "Make sure prompt window is big enough") (GETPROMPTWINDOW MAINWINDOW (ADD1 %#LINES))) (T PWINDOW)))) -) (\LAFITE.SEND.FAIL -(LAMBDA (EDITORWINDOW ERRMSG) (* bvm%: "24-Feb-85 18:38") (* ;; "Print a message explaining why delivery failed") (LET ((FULLMSG (CONCAT "Delivery failed -- " ERRMSG)) PWINDOW) (COND (EDITORWINDOW (CLEARW (SETQ PWINDOW (LA.ASSURE.PROMPT.WINDOW EDITORWINDOW FULLMSG)))) (T (TERPRI (SETQ PWINDOW PROMPTWINDOW)))) (PRIN3 FULLMSG PWINDOW) NIL)) -) (\LAFITE.INVALID.RECIPIENTS -(LAMBDA (NAMES) (* bvm%: " 5-Nov-84 15:26") (* ;;; "Returns an 'invalid recipients' error string") (PROG (NAME) (SETQ NAME (for RECIPIENT in NAMES join (LIST ", " RECIPIENT))) (RPLACA NAME ": ") (COND ((CDR NAMES) (push NAME "s"))) (RETURN (CONCATLIST (CONS "Invalid recipient" NAME))))) -) (\SENDMESSAGE.ABORT -(LAMBDA (ITEM MENU KEY) (* bvm%: " 1-Jun-84 12:21") (* ; "The WHENSELECTEDFN for the Abort menu") (PROG ((W (WFROMMENU MENU))) (WINDOWPROP W (QUOTE ABORT) T) (SHADEITEM ITEM MENU LAFITEITEMBUSYSHADE))) -) ) (* ; "Outbox hacking") (DEFINEQ (\OUTBOX.CREATE -(LAMBDA NIL (* bvm%: "21-Dec-84 22:35") (PROG (FONT NLINES W FONTHEIGHT) (OR (AND LAFITESTATUSWINDOW (FIXP (SETQ NLINES LAFITEOUTBOXSIZE)) (IGREATERP NLINES 0)) (RETURN)) (SETQ FONTHEIGHT (FONTPROP (SETQ FONT LAFITEBROWSERFONT) (QUOTE HEIGHT))) (SETQ W (CREATEW (CREATEREGION 0 0 (WINDOWPROP LAFITESTATUSWINDOW (QUOTE WIDTH)) (HEIGHTIFWINDOW (ITIMES NLINES FONTHEIGHT) T)) "Delivered Messages" NIL T)) (ATTACHWINDOW W LAFITESTATUSWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (DSPFONT FONT W) (WINDOWADDPROP W (QUOTE CLOSEFN) (FUNCTION \OUTBOX.CLOSEFN)) (WINDOWPROP W (QUOTE REPAINTFN) (FUNCTION \OUTBOX.REPAINTFN)) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION \OUTBOX.BUTTONFN)) (WINDOWPROP W (QUOTE RESHAPEFN) (FUNCTION \OUTBOX.RESHAPEFN)) (WINDOWPROP W (QUOTE MINSIZE) (CONS 0 (HEIGHTIFWINDOW FONTHEIGHT T))) (RETURN (SETQ \LAFITE.OUTBOX (\OUTBOX.RESET (create OUTBOX OBWINDOW _ W OBSIZE _ NLINES OBHEIGHT _ FONTHEIGHT OBDESCENT _ (FONTPROP FONT (QUOTE DESCENT)))))))) -) (\OUTBOX.RESET -(LAMBDA (OUTBOX) (* bvm%: " 9-Nov-84 16:29") (PROG ((WINDOW (fetch OBWINDOW of OUTBOX))) (CLEARW WINDOW) (LINELENGTH MAX.SMALLP WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (replace OBORIGIN of OUTBOX with (IPLUS (DSPYPOSITION NIL WINDOW) (fetch OBHEIGHT of OUTBOX))) (RETURN OUTBOX))) -) (\OUTBOX.CLOSEFN -(LAMBDA (WINDOW) (* bvm%: " 8-Nov-84 16:02") (SETQ \LAFITE.OUTBOX))) (\OUTBOX.REPAINTFN -(LAMBDA (WINDOW REGION) (* bvm%: "13-Nov-84 10:57") (PROG ((OUTBOX \LAFITE.OUTBOX)) (OR (EQ WINDOW (fetch OBWINDOW of OUTBOX)) (RETURN)) (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) (fetch OBHEIGHT of OUTBOX)) WINDOW) (for ITEM in (fetch OBITEMS of OUTBOX) do (\OUTBOX.DISPLAYLINE OUTBOX ITEM) (TERPRI WINDOW)))) -) (\OUTBOX.RESHAPEFN -(LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* bvm%: "13-Nov-84 10:57") (COND ((EQ WINDOW (fetch OBWINDOW of \LAFITE.OUTBOX)) (PROG ((NLINES (IQUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) (fetch OBHEIGHT of \LAFITE.OUTBOX))) (OLDSIZE (fetch OBSIZE of \LAFITE.OUTBOX)) N ITEMS) (COND ((NEQ NLINES OLDSIZE) (replace OBSIZE of \LAFITE.OUTBOX with NLINES) (COND ((AND (ILESSP NLINES OLDSIZE) (IGREATERP (SETQ N (IDIFFERENCE (LENGTH (SETQ ITEMS (fetch OBITEMS of \LAFITE.OUTBOX))) NLINES)) 0)) (replace OBITEMS of \LAFITE.OUTBOX with (CDR (NTH ITEMS N))))))) (\OUTBOX.RESET \LAFITE.OUTBOX) (REDISPLAYW WINDOW))))) -) (\OUTBOX.SHADEITEM -(LAMBDA (OUTBOX ITEM N SHADE OPERATION) (* ; "Edited 3-Sep-87 17:24 by bvm:") (* ;;; "Shade the indicated ITEM in OUTBOX using texture SHADE blted with OPERATION") (PROG ((W (fetch OBWINDOW of OUTBOX)) HEIGHT) (BLTSHADE SHADE W 0 (- (fetch OBORIGIN of OUTBOX) (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) (fetch OBDESCENT of OUTBOX))) NIL HEIGHT OPERATION) (COND ((EQ OPERATION (QUOTE REPLACE)) (\OUTBOX.DISPLAYLINE OUTBOX ITEM N))))) -) (\OUTBOX.BUTTONFN -(LAMBDA (WINDOW) (* bvm%: "13-Nov-84 10:58") (* ;;; "BUTTONEVENTFN for the outbox. If a message is selected, edit it") (PROG ((SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (OUTBOX \LAFITE.OUTBOX) SELECTED SEL# NEWSEL# ITEMS HEIGHT ORIGIN DESCENT LASTX LASTY MAXITEM) (COND ((OR (NOT (SETQ ITEMS (fetch OBITEMS of OUTBOX))) (NEQ WINDOW (fetch OBWINDOW of OUTBOX))) (* ; "Nothing to select") (RETURN))) (SETQ MAXITEM (LENGTH ITEMS)) (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX)) (SETQ DESCENT (fetch OBDESCENT of OUTBOX)) (SETQ ORIGIN (fetch OBORIGIN of OUTBOX)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((OR (NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (> (SETQ NEWSEL# (ADD1 (QUOTIENT (- ORIGIN (+ LASTY DESCENT)) HEIGHT))) MAXITEM)) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)) (SETQ SELECTED (SETQ SEL# NIL)))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Let mouse up while over a selection. Do it") (COND (SELECTED (\LAFITE.PROCESS (LIST (FUNCTION \SENDMESSAGE) (KWOTE (COPYTEXTSTREAM (fetch OBITEXT of SELECTED)))) (QUOTE MESSAGESENDER) T (QUOTE NO)) (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)))) (RETURN)) ((NEQ NEWSEL# SEL#) (COND (SELECTED (\OUTBOX.SHADEITEM OUTBOX SELECTED SEL# BLACKSHADE (QUOTE INVERT)))) (\OUTBOX.SHADEITEM OUTBOX (SETQ SELECTED (CAR (NTH ITEMS (SETQ SEL# NEWSEL#)))) SEL# BLACKSHADE (QUOTE INVERT))))))) -) (\OUTBOX.DISPLAYLINE -(LAMBDA (OUTBOX ITEM N) (* bvm%: " 8-Nov-84 21:35") (PROG ((W (fetch OBWINDOW of OUTBOX))) (COND (N (MOVETO 0 (IDIFFERENCE (fetch OBORIGIN of OUTBOX) (ITIMES N (fetch OBHEIGHT of OUTBOX))) W))) (printout W (fetch OBIDATE of ITEM) %,, (fetch OBISUBJECT of ITEM)))) -) (\OUTBOX.ADD.ITEM -(LAMBDA (TEXTSTREAM SUBJECT) (* ; "Edited 3-Sep-87 18:08 by bvm:") (PROG ((OUTBOX (OR \LAFITE.OUTBOX (\OUTBOX.CREATE))) W N ITEM BOTTOM HEIGHT ITEMS) (OR OUTBOX (RETURN)) (COND ((>= (SETQ N (LENGTH (SETQ ITEMS (fetch OBITEMS of OUTBOX)))) (fetch OBSIZE of OUTBOX)) (replace OBITEMS of OUTBOX with (SETQ ITEMS (CDR ITEMS))) (BITBLT (SETQ W (fetch OBWINDOW of OUTBOX)) 0 (SETQ BOTTOM (- (fetch OBORIGIN of OUTBOX) (+ (ITIMES N (SETQ HEIGHT (fetch OBHEIGHT of OUTBOX))) (fetch OBDESCENT of OUTBOX)))) W 0 (+ BOTTOM HEIGHT) NIL (ITIMES HEIGHT (SUB1 N)) (QUOTE INPUT) (QUOTE REPLACE)) (BLTSHADE WHITESHADE W 0 BOTTOM NIL HEIGHT (QUOTE REPLACE))) (T (SETQ N (ADD1 N)))) (replace OBITEMS of OUTBOX with (NCONC1 ITEMS (SETQ ITEM (create OUTBOXITEM OBITEXT _ TEXTSTREAM OBIDATE _ (DATE (DATEFORMAT NO.DATE NO.SECONDS)) OBISUBJECT _ SUBJECT)))) (\OUTBOX.DISPLAYLINE OUTBOX ITEM N))) -) ) (RPAQ? LAFITEOUTBOXSIZE 2) (RPAQ? \LAFITE.OUTBOX ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD OUTBOXITEM (OBITEXT OBIDATE OBISUBJECT OBIWINDOW)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAFITEOUTBOXSIZE) ) ) (* ; "Built-in message forms") (DEFINEQ (\LAFITE.MESSAGEFORM -(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 23-Feb-89 12:50 by bvm") (COND ((NULL (OR \LAFITEMODE (\LAFITE.INFER.MODE))) (printout PROMPTWINDOW T "Must set Lafite Mode before sending mail")) (T (RESETLST (AND ITEM (LA.RESETSHADE ITEM MENU)) (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FORM FORMNAME FULLFORMNAME) (COND ((EQ BUTTON (QUOTE LEFT)) (SETQ FORM (MAKENEWMESSAGEFORM))) ((NOT (SETQ FORM (MENU (.LAFITEMENU. LAFITEFORMSMENU (APPEND (MAKELAFITEPRIVATEFORMSITEMS "Use the form defined in this file.") LAFITESPECIALFORMS LAFITEFORMSMENUITEMS) "Message Forms")))) (RETURN)) ((EQ FORM (QUOTE %##ANOTHERFORM##)) (* ; "user buttoned 'Another Form'") (OR (SETQ FORMNAME (PROMPTFORFILENAME)) (RETURN))) ((DEFINEDP FORM) (OR (SETQ FORM (CL:FUNCALL FORM)) (RETURN))) ((BOUNDP FORM) (SETQ FORM (OR (EVALV FORM) (MAKENEWMESSAGEFORM)))) (T (* ; "other private form") (SETQ FORMNAME FORM))) (COND ((NULL FORMNAME) (* ; "Have form already")) ((OR (SETQ FULLFORMNAME (INFILEP (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT))) (AND LAFITEFORMDIRECTORIES (SETQ FULLFORMNAME (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FORMNAME (QUOTE EXTENSION) LAFITEFORM.EXT) T LAFITEFORMDIRECTORIES)))) (* ; "read the form and return it") (COND ((NOT (CL:MEMBER (SETQ FORMNAME (LA.SHORTFILENAME FULLFORMNAME LAFITEFORM.EXT)) LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (push LAFITEFORMFILES FORMNAME) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU))) (SETQ FORM (\LAFITE.READ.FORM FULLFORMNAME))) (T (printout PROMPTWINDOW T FORMNAME " not found.") (RETURN))) (ADD.PROCESS (LIST (FUNCTION \SENDMESSAGE) (KWOTE FORM) NIL (KWOTE FORMNAME)) (QUOTE NAME) (QUOTE MESSAGESENDER) (QUOTE RESTARTABLE) (QUOTE NO)) (* ; "Finally, start authenticating if we haven't yet.") (\LAFITE.GET.USER.DATA (AND (TEXTSTREAMP FORM) (TEXTPROP FORM (QUOTE LAFITEMODE))))))))) -) (MAKELAFITESUPPORTFORM -(LAMBDA NIL (* bvm%: "12-Mar-85 00:39") (MAKEXXXSUPPORTFORM "Lafite" LAFITESUPPORT LAFITESYSTEMDATE))) (MAKELISPSUPPORTFORM -(LAMBDA NIL (* bvm%: "12-Mar-85 00:39") (MAKEXXXSUPPORTFORM "Lisp" LISPSUPPORT))) (MAKEXXXSUPPORTFORM -(LAMBDA (SYSTEMNAME ADDRESS SYSTEMDATE) (* ; "Edited 3-May-89 18:37 by bvm") (PROG ((SUBJFIELD ">>Terse summary of problem<<") (UCODEVERSION (MICROCODEVERSION)) (SCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH))) TEXTSTREAM SELECTPOSITION MODE) (COND ((LISTP ADDRESS) (* ; "Mode-dependent address. Pick the first address that's in a mode we know how to send") (SETQ ADDRESS (for PAIR in ADDRESS when (\LAFITE.GET.USER.DATA (SETQ MODE (CAR PAIR))) do (RETURN (CADR PAIR))))) (T (* ; "Just send in current mode") (SETQ MODE (fetch LAFITEMODE of \LAFITEMODE)))) (COND ((NOT ADDRESS) (printout PROMPTWINDOW T "Can't -- no address known for " SYSTEMNAME " report.") (RETURN))) (SETQ TEXTSTREAM (OPENTEXTSTREAM (CONCAT "Subject: " SYSTEMNAME ": ") NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) (SETQ SELECTPOSITION (ADD1 (GETEOFPTR TEXTSTREAM))) (PROGN (* ; "Now write the main stuff to a scratch stream. faster than bouting a byte at a time to tedit") (printout SCRATCH SUBJFIELD T) (printout SCRATCH "To: " ADDRESS T) (printout SCRATCH "cc: " (FULLUSERNAME NIL MODE) T T) (COND (SYSTEMDATE (printout SCRATCH SYSTEMNAME " System Date: " SYSTEMDATE T))) (printout SCRATCH "Lisp System Date: " MAKESYSDATE " (" (L-CASE (MKSTRING MAKESYSNAME) T) ")" T) (printout SCRATCH "Machine: " (OR \LAFITE.REPORT.MACHINE (PROGN (SETQ \LAFITE.REPORT.MACHINE (L-CASE (MACHINETYPE) T)) (COND ((EQ \PUP.READY T) (SETQ \LAFITE.REPORT.MACHINE (CONCAT \LAFITE.REPORT.MACHINE " (" (ETHERHOSTNAME NIL T) ")")))) \LAFITE.REPORT.MACHINE)) T) (printout SCRATCH "Microcode version: " .I1.8 (fetch HIBYTE of UCODEVERSION) "," .I1.8 (fetch LOBYTE of UCODEVERSION) T) (printout SCRATCH "Memory size: " .I4.8 (REALMEMORYSIZE) T) (printout SCRATCH "Frequency: >> Always, Intermittent, Once << -Impact: >> Fatal, Serious, Moderate, Annoying, Minor <<" T T) (printout SCRATCH ">>detailed problem description<<" T)) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION 0 (QUOTE RIGHT)) (TEDIT.INCLUDE TEXTSTREAM SCRATCH) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION (NCHARS SUBJFIELD) (QUOTE RIGHT) T) (TEXTPROP TEXTSTREAM (QUOTE LAFITEMODE) MODE) (RETURN TEXTSTREAM))) -) (MAKENEWMESSAGEFORM -(LAMBDA NIL (* ; "Edited 6-Jun-88 12:22 by bvm") (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) SELECTPOSITION) (printout OUTSTREAM "Subject: ") (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) (printout OUTSTREAM SUBJECTSTR T) (printout OUTSTREAM "To: " RECIPIENTSSTR T) (printout OUTSTREAM "cc: " (FULLUSERNAME) T T) (printout OUTSTREAM MESSAGESTR T) (if LAFITE.SIGNATURE then (* ; "Pre-sign it") (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS SUBJECTSTR) (QUOTE RIGHT) T) OUTSTREAM)) -) (MAKELAFITEPRIVATEFORMSITEMS -(LAMBDA (HELPSTR) (* ; "Edited 23-Feb-89 12:38 by bvm") (for FORMFILE in (SORT LAFITEFORMFILES) when FORMFILE collect (BQUOTE ((\, (if (U-CASEP FORMFILE) then (CL:STRING-CAPITALIZE FORMFILE) else FORMFILE)) (QUOTE (\, FORMFILE)) (\, HELPSTR))))) -) (\LAFITE.UNCACHE.MESSAGEFORM -(LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") (LET ((FORM (\LAFITE.SELECT.FORM "Forget about this message form"))) (COND (FORM (SETQ LAFITEFORMFILES (DREMOVE FORM LAFITEFORMFILES)) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU) (printout PROMPTWINDOW T FORM " forgotten."))))) -) (\LAFITE.DELETE.MESSAGEFORM -(LAMBDA (ITEM MENU) (* ; "Edited 8-Nov-89 12:38 by bvm") (LET ((FORM (\LAFITE.SELECT.FORM "Delete this saved message"))) (if (AND FORM (PROGN (CLRPROMPT) (MOUSECONFIRM (CL:FORMAT NIL "Click LEFT to confirm deleting saved message '~A'" FORM) T PROMPTWINDOW))) then (\LAFITE.DELETE.FORM.INTERNAL FORM)))) -) (\LAFITE.SELECT.FORM -(LAMBDA (MSG) (* ; "Edited 8-Nov-89 12:37 by bvm") (COND ((NULL LAFITEFORMFILES) (printout PROMPTWINDOW T "You have no private message forms")) (T (MENU (\LAFITE.CREATE.MENU (MAKELAFITEPRIVATEFORMSITEMS MSG) "Private Forms"))))) -) (\LAFITE.DELETE.FORM.INTERNAL -(LAMBDA (FORMNAME) (* ; "Edited 8-Nov-89 12:34 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (LONGNAME (LA.LONGFILENAME FORMNAME LAFITEFORM.EXT)) FULL) (while (SETQ FULL (FULLNAME LONGNAME (QUOTE OLDEST))) do (if (NOT (DELFILE FULL)) then (PRINTOUT PROMPTWINDOW T "Could not delete " FULL) (RETURN NIL)) finally (SETQ LAFITEFORMFILES (CL:DELETE FORMNAME LAFITEFORMFILES :TEST (QUOTE STRING-EQUAL))) (SETQ \LAFITEPROFILECHANGED T) (SETQ LAFITEFORMSMENU) (PRINTOUT PROMPTWINDOW T FORMNAME " deleted.") (RETURN T)))) -) (\LAFITE.READ.FORM [LAMBDA (FILE) (* ;  "Edited 18-Jul-2000 03:09 by rmk:") (* ;  "Edited 18-Jul-2000 03:08 by rmk:") (* ; "Edited 2-Nov-89 15:55 by bvm") (* ;;; "copies the messaage form in the FILE into a text stream") (PROG ((TEXTSTREAM (OPENTEXTSTREAM [OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT] NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) NAME CH) (SETFILEPTR TEXTSTREAM 0) (COND ([OR (EQ (SETQ CH (BIN TEXTSTREAM)) (CHARCODE %")) (AND (EQ CH (CHARCODE CR)) (EQ (BIN TEXTSTREAM) (CHARCODE %"] (* ;  "Old-style form, get rid of surrounding double quotes") (TEDIT.DELETE TEXTSTREAM 1 (ADD1 (GETFILEPTR TEXTSTREAM))) (TEDIT.DELETE TEXTSTREAM (GETEOFPTR TEXTSTREAM) 1))) [bind [OPENMARKER _ (CONSTANT (ALLOCSTRING 1 (CHARCODE ^A] J (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM OPENMARKER I)) do (* ;  "Change Laurel forms into Lafite forms") (COND ((AND (SETQ J (TEDIT.FIND TEXTSTREAM (CONSTANT (ALLOCSTRING 1 (CHARCODE ^B))) (ADD1 I) (IPLUS I 70))) (NOT (TEDIT.FIND TEXTSTREAM OPENMARKER (ADD1 I) J))) (TEDIT.DELETE TEXTSTREAM J 1) (TEDIT.INSERT TEXTSTREAM "<<" J) (TEDIT.DELETE TEXTSTREAM I 1) (TEDIT.INSERT TEXTSTREAM ">>" I) (SETQ I J)) (T (RETURN] (bind (I _ 1) while (SETQ I (TEDIT.FIND TEXTSTREAM ">>Self<<" I)) do (* ;  "Replace '>>Self<<' with user name") (OR NAME (SETQ NAME (FULLUSERNAME))) (TEDIT.DELETE TEXTSTREAM I 8) (TEDIT.INSERT TEXTSTREAM NAME I) (SETFILEPTR TEXTSTREAM I) (* ; "Patch around tedit bug...")) (\LAFITE.FIND.TEMPLATE TEXTSTREAM) (RETURN TEXTSTREAM]) (\LAFITE.FIND.TEMPLATE -(LAMBDA (TEXTSTREAM) (* bvm%: "22-Apr-84 23:59") (LET (SELECTSTART) (COND ((SETQ SELECTSTART (TEDIT.FIND TEXTSTREAM ">>*<<" 1 NIL T)) (* ; "Wait until TEDIT.FIND gets fixed") (* ; "highlight the first 'blank' to fill in") (COND ((LISTP SELECTSTART) (SETQ SELECTSTART (CAR SELECTSTART)))) (TEDIT.SETSEL TEXTSTREAM SELECTSTART (+ 2 (- (TEDIT.FIND TEXTSTREAM "<<" SELECTSTART) SELECTSTART)) (QUOTE RIGHT) T) T) (T (TEDIT.SETSEL TEXTSTREAM 1 0 (QUOTE LEFT)))))) -) ) (* ; "ANSWER") (DEFINEQ (\LAFITE.ANSWER -(LAMBDA (WINDOW FOLDERDATA ITEM MENU) (* bvm%: " 1-Feb-84 15:08") (ADD.PROCESS (LIST (FUNCTION \LAFITE.ANSWER.PROC) (KWOTE WINDOW) (KWOTE FOLDERDATA) (KWOTE ITEM) (KWOTE MENU)) (QUOTE NAME) (QUOTE MESSAGEANSWERER) (QUOTE RESTARTABLE) (QUOTE NO))) -) (\LAFITE.ANSWER.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: "29-May-84 15:59") (PROG (MSGDESCRIPTOR FORM) (SETQ FORM (RESETLST (LA.RESETSHADE ITEM MENU) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (MAKEANSWERFORM (SETQ MSGDESCRIPTOR (find MSGDESCRIPTOR selectedin MAILFOLDER suchthat T)) MAILFOLDER)))))) (COND ((AND FORM (\SENDMESSAGE FORM)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) (COND ((AND MESSAGES (EQ MSGDESCRIPTOR (NTHMESSAGE MESSAGES (fetch (LAFITEMSG %#) of MSGDESCRIPTOR)))) (* ; "If message got expunged since we constructed the answer form, we can't do anything") (MARKMESSAGE MSGDESCRIPTOR MAILFOLDER ANSWERMARK))))))))) -) (MAKEANSWERFORM -(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 10-Aug-89 17:28 by bvm") (LET* ((FIRSTMSG (if (LISTP MSGDESCRIPTORS) then (CAR MSGDESCRIPTORS) else MSGDESCRIPTORS)) (MODEBITS (fetch (LAFITEMSG MODEBITS) of FIRSTMSG)) (MODE (CL:NTH MODEBITS *LAFITE-WELL-KNOWN-MODES*))) (if (NULL MODE) then (if (OR (NEQ MODEBITS 0) (NULL (SETQ MODE (\LAFITE.GUESS.MODE FIRSTMSG)))) then (LAB.PROMPTPRINT MAILFOLDER (if (EQ MODEBITS 0) then "Message of unknown protocol." else "Warning: This message was retrieved under a protocol not currently enabled.")) (LAB.PROMPTPRINT MAILFOLDER "Will answer in " (SETQ MODE (fetch (LAFITEOPS LAFITEMODE) of \LAFITEMODE)) " mode; this may not work. "))) (* ;; "Currently we only pay attention to the first message. If we ever do otherwise, we'll want to notice whether the other messages are in the same mode") (LET ((*LAFITE-MODE-DATA* (\LAFITE.GET.USER.DATA MODE)) MSG) (* ;; "Before returning the form, tag it with a mail mode") (if (NULL *LAFITE-MODE-DATA*) then (LAB.FORMAT MAILFOLDER "Failed: can't authenticate user in ~A mode" MODE) elseif (SETQ MSG (CL:FUNCALL (fetch (LAFITEMODEDATA ANSWERER) of *LAFITE-MODE-DATA*) MSGDESCRIPTORS MAILFOLDER)) then (if (TEXTSTREAMP MSG) then (TEXTPROP MSG (QUOTE LAFITEMODE) MODE) MSG else (OPENTEXTSTREAM MSG NIL NIL NIL (BQUOTE (LAFITEMODE (\, MODE))))))))) -) (LA.PRINT.COMMA.LIST -(LAMBDA (STRINGS STREAM) (* ; "Edited 6-Jun-88 12:50 by bvm") (for STR in STRINGS bind NTHTIME when STR do (COND (NTHTIME (PRIN3 ", " STREAM)) (T (SETQ NTHTIME T))) (PRIN3 STR STREAM))) -) (LAFITE.FILL.IN.ANSWER.FORM -(LAMBDA (SUBJECT FROM DATE TO CC ADDRESSPRINTFN) (* ; "Edited 10-Jun-88 17:19 by bvm") (* ;; "Construct an answer form replying to a message from FROM on DATE with specified SUBJECT. Reply should go to the lists of names TO and CC. ADDRESSPRINTFN is a function that prints a list of names suitably for the protocol in question.") (LET ((OUTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) SELECTPOSITION) (LINELENGTH MAX.SMALLP OUTSTREAM) (* ; "Sigh, apparently text streams have linelength") (PROGN (printout OUTSTREAM "Subject: ") (if SUBJECT then (COND ((NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3) "Re:")) (printout OUTSTREAM "Re: "))) (printout OUTSTREAM SUBJECT) else (printout OUTSTREAM "(reply to message)"))) (PROGN (printout OUTSTREAM T "In-reply-to: ") (if (NULL FROM) then (printout OUTSTREAM "your") else (printout OUTSTREAM FROM "'s")) (printout OUTSTREAM " message of " DATE T)) (PROGN (printout OUTSTREAM "To: ") (if TO then (CL:FUNCALL ADDRESSPRINTFN TO OUTSTREAM) else (* ; "No to, so ask to fill in") (printout OUTSTREAM RECIPIENTSSTR T)) (TERPRI OUTSTREAM)) (COND (CC (printout OUTSTREAM "cc: ") (CL:FUNCALL ADDRESSPRINTFN CC OUTSTREAM) (TERPRI OUTSTREAM))) (TERPRI OUTSTREAM) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR OUTSTREAM))) (printout OUTSTREAM MESSAGESTR T) (if LAFITE.SIGNATURE then (* ; "Pre-sign it") (PRIN3 LAFITE.SIGNATURE OUTSTREAM)) (TEDIT.SETSEL OUTSTREAM SELECTPOSITION (NCHARS MESSAGESTR) (QUOTE RIGHT) T) OUTSTREAM)) -) ) (* ; "FORWARD") (DEFINEQ (\LAFITE.FORWARD -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* bvm%: " 1-Feb-84 15:05") (ADD.PROCESS (LIST (FUNCTION \LAFITE.FORWARD.PROC) (KWOTE WINDOW) (KWOTE MAILFOLDER) (KWOTE ITEM) (KWOTE MENU)) (QUOTE NAME) (QUOTE MESSAGEFORWARDER) (QUOTE RESTARTABLE) (QUOTE NO))) -) (\LAFITE.FORWARD.PROC -(LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 14-Oct-87 16:20 by bvm:") (PROG (FORWARDEDMSGS FORM) (* ;; "the reason to get the MSG#S first is that they may have changed by the time \SENDMESSAGE finishes and then we would have marked the wrong ones") (RESETLST (OBTAIN.MONITORLOCK (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) NIL T) (LA.RESETSHADE ITEM MENU) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (SETQ FORM (MAKEFORWARDFORM WINDOW MAILFOLDER (SETQ FORWARDEDMSGS (LAB.SELECTED.MESSAGES MAILFOLDER))))))) (COND ((AND FORM (\SENDMESSAGE FORM)) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) (PROG ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER))) (COND (MESSAGES (* ; "Make sure folder hasn't been closed since") (for MSG in FORWARDEDMSGS when (EQ MSG (NTHMESSAGE MESSAGES (fetch (LAFITEMSG %#) of MSG))) do (* ; "If message got expunged since we constructed the forward form, we can't do anything") (MARKMESSAGE MSG MAILFOLDER FORWARDMARK)))))))))) -) (MAKEFORWARDFORM -(LAMBDA (WINDOW FOLDER MESSAGELIST) (* ; "Edited 5-Jan-90 17:46 by bvm") (* ;; "Make a message form that forwards each of the messages in MESSAGELIST") (PROG ((FOLDERSTREAM (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :ABORT)) (TEXTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT))) (CURMSG (CAR MESSAGELIST)) SUBJECT SELECTPOSITION SELECTLEN) (OR (fetch (LAFITEMSG PARSED?) of CURMSG) (LAFITE.PARSE.MSG.FOR.TOC CURMSG FOLDER)) (LINELENGTH MAX.SMALLP TEXTSTREAM) (PRIN3 "Subject: " TEXTSTREAM) (COND ((OR LAFITEFORWARDSUBJECTSTR (NULL (SETQ SUBJECT (fetch (LAFITEMSG SUBJECT) of CURMSG)))) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) (SETQ SELECTLEN (NCHARS (SETQ SUBJECT (OR LAFITEFORWARDSUBJECTSTR SUBJECTSTR)))) (PRIN3 SUBJECT TEXTSTREAM)) (T (CL:FORMAT TEXTSTREAM "[~@[~A: ~]~A]" (fetch (LAFITEMSG FROM) of CURMSG) SUBJECT))) (TERPRI TEXTSTREAM) (PRIN3 "To: " TEXTSTREAM) (COND ((NOT SELECTPOSITION) (SETQ SELECTPOSITION (ADD1 (GETFILEPTR TEXTSTREAM))) (SETQ SELECTLEN (NCHARS RECIPIENTSSTR)))) (CL:FORMAT TEXTSTREAM "~A -cc: ~A - -~A -" RECIPIENTSSTR (FULLUSERNAME) (CAR LAFITEFORWARDSTRINGS)) (if LAFITE.SIGNATURE then (* ; "Sign it up here, after the user's inserted comments, if any") (PRIN3 LAFITE.SIGNATURE TEXTSTREAM) (TERPRI TEXTSTREAM)) (for MSGDESCRIPTOR in MESSAGELIST bind NTHTIME do (PRIN3 (COND (NTHTIME (* ; "%"Next message%"") (CADDR LAFITEFORWARDSTRINGS)) (T (* ; "%"Begin forwarded messages%"") (SETQ NTHTIME T) (CADR LAFITEFORWARDSTRINGS))) TEXTSTREAM) (TERPRI TEXTSTREAM) (\LAFITE.APPEND.MESSAGE.BODY TEXTSTREAM FOLDERSTREAM MSGDESCRIPTOR \LAPARSE.DONT.FORWARD.HEADERS) (TERPRI TEXTSTREAM) (TEDIT.CARETLOOKS TEXTSTREAM LAFITEEDITORFONT)) (PRIN3 (CADDDR LAFITEFORWARDSTRINGS) TEXTSTREAM) (TERPRI TEXTSTREAM) (TEDIT.SETSEL TEXTSTREAM SELECTPOSITION SELECTLEN (QUOTE RIGHT) T) (RETURN TEXTSTREAM))) -) ) (RPAQQ LAFITESENDINGMENUITEMS (("Deliver" '\SENDMSG.DELIVER "Send the message in the edit window" ) ("Reply To" '\SENDMSG.REPLYTO "Insert a Reply-to field in this message") ("Change Mode" '\SENDMSG.CHANGE.MODE "Change the mode (mail protocol) used to send this message." ) ("Save" '\SENDMSG.SAVE.FORM "Save the message in a file for later use (retrieve with middle-button SendMail)" ))) (RPAQQ LAFITEFORMSMENUITEMS (("Saved Form" '%##ANOTHERFORM## "You will be asked to specify a filename for the form") ("Standard Form" (FUNCTION MAKENEWMESSAGEFORM) "A clean message form"))) (RPAQQ LAFITEFORMATMENUITEMS (("Send Formatted Message" 'TEDIT) ("Send Plain Text" 'TEXT) ("Abort" 'ABORT))) (RPAQQ LAFITEFORWARDSTRINGS (">>CoveringMessage<<" " ----- Begin Forwarded Messages ----- " " ----- Next Message ----- " " ----- End Forwarded Messages -----")) (ADDTOVAR \SYSTEMCACHEVARS \LAFITE.REPORT.MACHINE) (ADDTOVAR LAFITESPECIALFORMS ("Lisp Report" (FUNCTION MAKELISPSUPPORTFORM) "A form to report a Lisp bug or suggestion") ("Lafite Report" (FUNCTION MAKELAFITESUPPORTFORM) "A form to report a Lafite bug or suggestion")) (ADDTOVAR LAFITEMENUVARS LAFITEFORMSMENU LAFITEFORMATMENU) (RPAQ? \LAFITE.REPORT.MACHINE ) (RPAQ? LAFITECURRENTEDITORWINDOWS ) (RPAQ? LAFITEFORMFILES ) (RPAQ? LAFITEFORMSMENU ) (RPAQ? LAFITEFORMATMENU ) (RPAQ? LAFITEEDITORFONT LAFITEDISPLAYFONT) (RPAQ? LAFITEFORM.EXT "Lafite-form") (RPAQ? LAFITEFORMDIRECTORIES NIL) (RPAQ? LAFITE.EDITOR.SIZE '(470 . 300)) (RPAQ? LAFITE.EDITOR.LAYOUTS NIL) (RPAQ? LAFITEFORWARDSUBJECTSTR NIL) (RPAQ? LAFITESUPPORT NIL) (RPAQ? LISPSUPPORT NIL) (RPAQ? MESSAGESTR ">>Message<<") (RPAQ? RECIPIENTSSTR ">>Recipients<<") (RPAQ? SUBJECTSTR ">>Subject<<") (RPAQ? LAFITE.SEND.FORMATTED '((NSCHARS :ASK) (CHARLOOKS :ASK) (PARALOOKS :ASK) (IMAGEOBJ :ASK))) (* ; "Obsolete") (RPAQ? LAFITEEDITORREGION NIL) (* ; "ICON stuff") (RPAQQ LAFITE.MSG.ICON (#*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GH@O@@@@@@@@@@@@@@@@@@@CN@@CL@@@@@@@@@@@@@@@@@@OH@@@OH@@@@@@@@@@@@@@@@CL@@@@CN@@@@@@@@@@@@@@@@O@@@@@@GH@@@@@@@@@@@@@@CL@@@@@@AN@@@@@@@@@@@@@AO@@@@@@@@GL@@@@@@@@@@@@GL@@@@@@@@AO@@@@@@@@@@@AN@@@@@@@@@@CL@@@@@@@@@@GH@@@@@@@@@@@O@@@@@@@@@CN@@@@@@@@@@@@CL@@@@@@@@OH@@@@@@@@@@@@@OH@@@@@@CL@@@@@@@@@@@@@@CN@@@@@@O@@@@@@@@@@@@@@@@GH@@@@CL@@@@@@@@@@@@@@@@AN@@@@O@@@@@@@@@@@@@@@@@@GH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@O@@@@@@@@@@@@@@@@@@GL@@@ML@@@@@@@@@@@@@@@@ALL@@@LN@@@@@@@@@@@@@@@@CHL@@@LCH@@@@@@@@@@@@@@@N@L@@@LAL@@@@@@@@@@@@@@CL@L@@@L@G@@@@@@@@@@@@@@G@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@@CH@@@@@@@@@@@N@@@L@@@L@@AL@@@@@@@@@@AL@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@@@@@@@@@@@@@@@@@@L@@@L@@N@@@@@@@@@@@@CH@@L@@@L@CL@@@@@@@@@@@@AL@@L@@@L@G@@@@@@@@@@@@@@G@@L@@@LAL@@@@@@@@@@@@@@CL@L@@@LCH@@@@@@@@@@@@@@@N@L@@@LN@@@@@@@@@@@@@@@@CHL@@@ML@@@@@@@@@@@@@@@@ALL@@@O@@@@@@@@@@@@@@@@@@GL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ #*(82 72)@@@@@@@@@GO@@@@@@@@@@@@@@@@@@@@@AOOL@@@@@@@@@@@@@@@@@@@@GOOO@@@@@@@@@@@@@@@@@@@COOOOL@@@@@@@@@@@@@@@@@@OOOOOOH@@@@@@@@@@@@@@@@COOOOOON@@@@@@@@@@@@@@@@OOOOOOOOH@@@@@@@@@@@@@@COOOOOOOON@@@@@@@@@@@@@AOOOOOOOOOOL@@@@@@@@@@@@GOOOOOOOOOOO@@@@@@@@@@@AOOOOOOOOOOOOL@@@@@@@@@@GOOOOOOOOOOOOO@@@@@@@@@COOOOOOOOOOOOOOL@@@@@@@@OOOOOOOOOOOOOOOOH@@@@@@COOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOOH@@@@COOOOOOOOOOOOOOOOOON@@@@OOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOL@@@ (8 8 64 36))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SENDINGCOMMAND (COMMAND ITEM MENU MESSAGE MESSAGEPARSE) [TYPE? (AND (LISTP DATUM) (FMEMB (fetch COMMAND of DATUM) '(%##SEND## %##SAVE## %##FORGETIT##]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LAFITE.REPORT.MACHINE LAFITECURRENTEDITORWINDOWS LAFITEEDITORFONT LAFITEEDITORREGION LAFITEFORMATMENU LAFITEFORMSMENUITEMS LAFITEFORMATMENUITEMS LAFITEFORWARDSTRINGS LAFITEFORWARDSUBJECTSTR LAFITESENDINGMENUITEMS LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT MAKESYSDATE MESSAGESTR RECIPIENTSSTR SUBJECTSTR LAFITE.MSG.ICON LAFITEFORMDIRECTORIES LAFITE.SEND.FORMATTED) ) (FILESLOAD (SOURCE) LAFITEDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS LAFITESEND COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1993 1999 2000) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (5338 18169 (DOLAFITESENDINGCOMMAND 5348 . 5722) (\SENDMESSAGE.INITIATE 5724 . 6580) ( \SENDMSG.DELIVER 6582 . 6971) (\SENDMSG.EXIT.TEDIT 6973 . 7232) (\SENDMSG.SAVE.FORM 7234 . 8426) ( \LAFITE.HEADER.EOF 8428 . 8667) (\LAFITE.INSERT.REPLYTO 8669 . 9174) (\SENDMSG.REPLYTO 9176 . 9539) ( \SENDMSG.CHANGE.MODE 9541 . 11810) (\SENDMSG.FIND.FIELD 11812 . 12179) (\SENDMESSAGE.PARSE 12181 . 12704) (\LAFITE.PREPARE.SEND 12706 . 14368) (\LAFITE.PREPARE.ERROR 14370 . 15093) ( \LAFITE.CHOOSE.MSG.FORMAT 15095 . 16238) (LAFITE.MAKE.PLAIN.TEXTSTREAM 16240 . 16933) ( \SENDMESSAGE.MENUPROMPT 16935 . 17586) (\SENDMESSAGE.PROMPT 17588 . 17984) (\SENDMESSAGEFAIL 17986 . 18167)) (18170 31410 (\SENDMESSAGE 18180 . 19091) (\SENDMESSAGE.RESTARTABLE 19093 . 21719) ( \SENDMESSAGE.CLEANUP 21721 . 21894) (\SENDMESSAGE.MAKEWINDOW 21896 . 24884) (MAKELAFITEDELIVERMENU 24886 . 25091) (\LAFITE.CLOSEMSG? 25093 . 25693) (\LAFITE.AFTER.DELIVER 25695 . 27356) ( \LAFITE.UNSENT.ICON 27358 . 27603) (\LAFITE.FETCH.SUBJECT 27605 . 28053) (LAFITE.SENDMESSAGE 28055 . 28571) (\SENDMESSAGE0 28573 . 29978) (LA.ASSURE.PROMPT.WINDOW 29980 . 30489) (\LAFITE.SEND.FAIL 30491 . 30856) (\LAFITE.INVALID.RECIPIENTS 30858 . 31179) (\SENDMESSAGE.ABORT 31181 . 31408)) (31442 37222 (\OUTBOX.CREATE 31452 . 32458) (\OUTBOX.RESET 32460 . 32764) (\OUTBOX.CLOSEFN 32766 . 32855) ( \OUTBOX.REPAINTFN 32857 . 33199) (\OUTBOX.RESHAPEFN 33201 . 33843) (\OUTBOX.SHADEITEM 33845 . 34315) ( \OUTBOX.BUTTONFN 34317 . 36029) (\OUTBOX.DISPLAYLINE 36031 . 36321) (\OUTBOX.ADD.ITEM 36323 . 37220)) (37518 47459 (\LAFITE.MESSAGEFORM 37528 . 39370) (MAKELAFITESUPPORTFORM 39372 . 39501) ( MAKELISPSUPPORTFORM 39503 . 39609) (MAKEXXXSUPPORTFORM 39611 . 41752) (MAKENEWMESSAGEFORM 41754 . 42346) (MAKELAFITEPRIVATEFORMSITEMS 42348 . 42628) (\LAFITE.UNCACHE.MESSAGEFORM 42630 . 42960) ( \LAFITE.DELETE.MESSAGEFORM 42962 . 43299) (\LAFITE.SELECT.FORM 43301 . 43557) ( \LAFITE.DELETE.FORM.INTERNAL 43559 . 44108) (\LAFITE.READ.FORM 44110 . 46969) (\LAFITE.FIND.TEMPLATE 46971 . 47457)) (47483 51692 (\LAFITE.ANSWER 47493 . 47761) (\LAFITE.ANSWER.PROC 47763 . 48608) ( MAKEANSWERFORM 48610 . 49959) (LA.PRINT.COMMA.LIST 49961 . 50174) (LAFITE.FILL.IN.ANSWER.FORM 50176 . 51690)) (51717 54936 (\LAFITE.FORWARD 51727 . 51998) (\LAFITE.FORWARD.PROC 52000 . 53061) ( MAKEFORWARDFORM 53063 . 54934))))) STOP \ No newline at end of file diff --git a/library/lafite/LAFITESORT.~1~ b/library/lafite/LAFITESORT.~1~ deleted file mode 100644 index 7dbf4a9e..00000000 --- a/library/lafite/LAFITESORT.~1~ +++ /dev/null @@ -1,90 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 7-Oct-89 14:07:49" "{pooh/n}lafite>sources>LAFITESORT;21" 11104 - - changes to%: (FNS LAFITE.SORT.MESSAGES) (VARS LAFITESORTCOMS) (FILES LAFITEDECLS) - - previous date%: " 5-May-89 15:55:45" "{pooh/n}lafite>sources>LAFITESORT;19") - - -(* " -Copyright (c) 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITESORTCOMS) - -(RPAQQ LAFITESORTCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) LAFITEDECLS)) (FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER \LAFITE.SORT.BY.DATE.INTERACTIVE \LAFITE.SORT.BY.DATE.REGION) (APPENDVARS (LAFITEEXTRAMENUITEMS ("Sort by Date" (QUOTE \LAFITE.SORT.BY.DATE.INTERACTIVE) "Sort all the messages in this folder by their Date: fields." (SUBITEMS ("Sort Entire Folder" (QUOTE \LAFITE.SORT.BY.DATE.INTERACTIVE) "Sort all the messages in this folder by their Date: fields.") ("Sort Selected Range" (QUOTE \LAFITE.SORT.BY.DATE.REGION) "Sort only the messages between the first and last selected messages."))))) (COMS (* ; "Date hax") (FNS GDATE1-6) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays) (GLOBALVARS \TimeZoneComp \DayLightSavings))) (FILES (SYSLOAD) DATEPATCH))) -(DECLARE%: EVAL@COMPILE DONTCOPY - -(FILESLOAD (SOURCE) LAFITEDECLS) -) -(DEFINEQ - -(LAFITE.ASSURE.DATE.FIELDS -(LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 5-May-89 15:46 by bvm") (* ;; "Assure that messages FIRST# thru LAST# have IDATE fields. FIRST# & LAST# default.") (for I from (OR FIRST# 1) to (OR LAST# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)) bind (STREAM _ (\LAFITE.OPEN.FOLDER FOLDER (QUOTE INPUT) :ABORT)) (MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (FAILURECNT _ 0) (MISSING _ 0) MSG ID PREV DATEFAILURE DATEFETCHED BABBLED do (if (fetch (LAFITEMSG DATEFETCHED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) then (* ; "Ok") (if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG)) then (add FAILURECNT 1)) else (if (NOT BABBLED) then (* ; "Tell user what's taking so long") (LAB.PROMPTPRINT FOLDER "Collecting dates... ") (SETQ BABBLED T)) (if (FIXP (SETQ ID (LAFITE.PARSE.HEADER STREAM \LAPARSE.DATEFIELD (fetch (LAFITEMSG START) of MSG) (fetch (LAFITEMSG END) of MSG) T))) then (replace (LAFITEMSG IDATE) of MSG with ID) (replace (LAFITEMSG DATEKNOWN?) of MSG with T) (replace (LAFITEMSG DATEFETCHED?) of MSG with T) (replace (LAFITEMSG DATE) of MSG with NIL) (* ; "So it will be regenerated in canonical form") (OR DATEFETCHED (SETQ DATEFETCHED I)) else (replace (LAFITEMSG DATEKNOWN?) of MSG with NIL) (if LAFITEDEBUGFLG then (LAB.FORMAT FOLDER " ~:[Date missing for~;Could not parse date of~] msg ~D. " ID I)) (add FAILURECNT 1) (if (NULL ID) then (add MISSING 1)) (if (AND (> I 1) (fetch (LAFITEMSG DATEFETCHED?) of (SETQ PREV (NTHMESSAGE MESSAGES (SUB1 I))))) then (* ; "Guess that message i has date just after i-1") (replace (LAFITEMSG IDATE) of MSG with (ADD1 (fetch (LAFITEMSG IDATE) of PREV))) (replace (LAFITEMSG DATEFETCHED?) of MSG with T) else (SETQ DATEFAILURE I)))) finally (if (AND DATEFETCHED (< DATEFETCHED (fetch (MAILFOLDER TOCLASTMESSAGE#) of FOLDER))) then (* ; "Assure that the toc will be rewritten at least this far back so that we save the dates.") (replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with DATEFETCHED)) (COND ((AND DATEFAILURE (NOT (for I from (ADD1 (OR FIRST# 1)) to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER) when (fetch (LAFITEMSG DATEFETCHED?) of (SETQ MSG (NTHMESSAGE MESSAGES I))) do (* ; "Got a date later on") (SETQ ID (fetch (LAFITEMSG IDATE) of MSG)) (for J from DATEFAILURE to (OR FIRST# 1) by -1 do (* ; "Store guess dates for first message(s)") (replace (LAFITEMSG IDATE) of (SETQ MSG (NTHMESSAGE MESSAGES J)) with (add ID -1)) (replace (LAFITEMSG DATEFETCHED?) of MSG with T)) (RETURN T)))) (LAB.PROMPTPRINT FOLDER "Could not parse dates of ANY messages in this file.")) ((> FAILURECNT 0) (LAB.FORMAT FOLDER (if (< MISSING FAILURECNT) then " Note: Could not parse date field of ~D of these messages." else " Note: Missing date field for ~D of these messages.") FAILURECNT))))) -) - -(LAFITE.PARSE.DATE.FIELD -(LAMBDA (STREAM) (* ; "Edited 5-May-89 12:52 by bvm") (LET* ((DATESTR (LAFITE.READ.TO.EOL STREAM)) (ID (IDATE DATESTR))) (if (AND ID (> ID (CONSTANT (IDATE "1-jan-70 1200")))) then (* ; "Plausible date. Test is for those silly senders who didn't get the date set and have messages reading %"31-dec-00 ...%"") ID else (CONCAT (OR (SUBSTRING DATESTR 1 6 DATESTR) DATESTR) "?")))) -) - -(LAFITE.PARSE.DATE.FIELD.ONLY -(LAMBDA (STREAM) (DECLARE (USEDFREE PARSERESULT)) (* ; "Edited 26-Apr-89 14:35 by bvm") (SETQ PARSERESULT (LAFITE.PARSE.DATE.FIELD STREAM))) -) - -(LAFITE.SORT.BY.DATE -(LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 26-Apr-89 15:32 by bvm") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (LAFITE.ASSURE.DATE.FIELDS FOLDER FIRST# LAST#) (LAFITE.SORT.MESSAGES FOLDER (FUNCTION LAFITEMSG.DATE.ORDER) FIRST# LAST#))) -) - -(LAFITE.SORT.MESSAGES -(LAMBDA (FOLDER COMPAREFN FIRST# LAST#) (* ; "Edited 7-Oct-89 14:03 by bvm") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (OR FIRST# (SETQ FIRST# 1)) (OR LAST# (SETQ LAST# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) (LAB.PROMPTPRINT FOLDER "Sorting... ") (LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER)) (SORTED (CL:STABLE-SORT (for I from FIRST# to LAST# collect (NTHMESSAGE MESSAGES I)) COMPAREFN))) (while (AND SORTED (EQ (fetch (LAFITEMSG %#) of (CAR SORTED)) FIRST#)) do (* ; "Skip over the initial prefix of in-order messages") (add FIRST# 1) (SETQ SORTED (CDR SORTED))) (if (NULL SORTED) then (LAB.PROMPTPRINT FOLDER "already in order") else (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with T) (if (< FIRST# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER)) then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER with FIRST#)) (UNINTERRUPTABLY (for MSG in SORTED as I from FIRST# do (replace (LAFITEMSG %#) of MSG with I) (SETA MESSAGES I MSG))) (LET ((FIRSTSEL (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LASTSEL (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER))) (if (>= LASTSEL FIRSTSEL) then (if (AND (>= FIRSTSEL FIRST#) (<= FIRSTSEL LAST#)) then (* ; "Start of selection was inside here, have to recompute its number") (replace (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER with (LAB.FIND.SELECTED.MSG FOLDER FIRST# LAST#))) (if (AND (>= LASTSEL FIRST#) (<= LASTSEL LAST#)) then (* ; "End of selection was inside here, have to recompute its number") (replace (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER with (LAB.REV.FIND.SELECTED.MSG FOLDER FIRST# LAST#))))) (LAB.DISPLAYLINES FOLDER FIRST# LAST# NIL T) (LAB.PROMPTPRINT FOLDER "done"))))) -) - -(LAFITEMSG.DATE.ORDER -(LAMBDA (X Y) (* ; "Edited 26-Apr-89 14:53 by bvm") (* ;; "True if msg X has older date than msg Y. Since date field is stored as an unboxed 32-bit integer, we open code %"<%" here to avoid boxing.") (LET ((HIDIFF (- (LOGXOR (fetch (LAFITEMSG IDATEHI) of X) 32768) (LOGXOR (fetch (LAFITEMSG IDATEHI) of Y) 32768)))) (* ;; "HIDIFF is unsigned difference of high words") (OR (< HIDIFF 0) (AND (EQ HIDIFF 0) (< (fetch (LAFITEMSG IDATELO) of X) (fetch (LAFITEMSG IDATELO) of Y)))))) -) - -(\LAFITE.SORT.BY.DATE.INTERACTIVE -(LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 3-May-89 18:38 by bvm") (if (LAB.MOUSECONFIRM FOLDER "Click LEFT to confirm sorting ~D messages by date" (if LAST# then (ADD1 (- LAST# FIRST#)) else (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER))) then (\LAFITE.PROCESS (BQUOTE ((\, (FUNCTION LAFITE.SORT.BY.DATE)) (QUOTE (\, FOLDER)) (QUOTE (\, FIRST#)) (QUOTE (\, LAST#)))) "LafiteSort"))) -) - -(\LAFITE.SORT.BY.DATE.REGION -(LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 16:23 by bvm") (LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER)) (LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER))) (if (> LAST# FIRST#) then (\LAFITE.SORT.BY.DATE.INTERACTIVE FOLDER FIRST# LAST#) else (LAB.FORMAT FOLDER "There is ~:[no~;only one~] message selected." (EQ LAST# FIRST#))))) -) -) - -(APPENDTOVAR LAFITEEXTRAMENUITEMS ("Sort by Date" (QUOTE \LAFITE.SORT.BY.DATE.INTERACTIVE) "Sort all the messages in this folder by their Date: fields." (SUBITEMS ("Sort Entire Folder" (QUOTE \LAFITE.SORT.BY.DATE.INTERACTIVE) "Sort all the messages in this folder by their Date: fields.") ("Sort Selected Range" (QUOTE \LAFITE.SORT.BY.DATE.REGION) "Sort only the messages between the first and last selected messages."))) -) - - - -(* ; "Date hax") - -(DEFINEQ - -(GDATE1-6 -(LAMBDA (D) (* ; "Edited 26-Apr-89 15:24 by bvm") (* ;; "Return a string containing the day and month given in internal date D.") (* ;; "This is an optimization by source code simplification of (SUBSTRING (GDATE IDT) 1 6)") (PROG ((CHECKDLS \DayLightSavings) (DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D) 1) (CONSTANT (IQUOTIENT (TIMES 60 60) 2)))) HR DAY4 YDAY WDAY YEAR4 TOTALDAYS DLS) (* ; "DQ is number of hours since day 0, getting us past the sign bit problem.") (* ;; "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") (SETQ HR (IREMAINDER (SETQ DQ (- (+ DQ (CONSTANT (ITIMES 24 \4YearsDays))) \TimeZoneComp)) 24)) (SETQ TOTALDAYS (IQUOTIENT DQ 24)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ; "DAY4 = number of days since last leap year day 0") (SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 (QUOTE ((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)) (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 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") (COND ((> (SETQ HR (ADD1 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 (ADD1 TOTALDAYS)) (SETQ HR 0) (SETQ CHECKDLS NIL) (GO DTLOOP))))) (RETURN (LET* ((MONTH (\DTSCAN YDAY (QUOTE ((335 . "Dec") (305 . "Nov") (274 . "Oct") (244 . "Sep") (213 . "Aug") (182 . "Jul") (152 . "Jun") (121 . "May") (91 . "Apr") (60 . "Mar") (31 . "Feb") (0 . "Jan"))))) (DAY (ADD1 (- YDAY (CAR MONTH)))) (RESULT (CONCAT " " (CDR MONTH)))) (\RPLRIGHT RESULT 2 DAY 1) RESULT)))) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \4YearsDays 1461) - - -(CONSTANTS \4YearsDays) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \TimeZoneComp \DayLightSavings) -) -) - -(FILESLOAD (SYSLOAD) DATEPATCH) -(PUTPROPS LAFITESORT COPYRIGHT ("Xerox Corporation" 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1402 8115 (LAFITE.ASSURE.DATE.FIELDS 1412 . 4187) (LAFITE.PARSE.DATE.FIELD 4189 . 4599) - (LAFITE.PARSE.DATE.FIELD.ONLY 4601 . 4777) (LAFITE.SORT.BY.DATE 4779 . 5054) (LAFITE.SORT.MESSAGES -5056 . 6788) (LAFITEMSG.DATE.ORDER 6790 . 7297) (\LAFITE.SORT.BY.DATE.INTERACTIVE 7299 . 7721) ( -\LAFITE.SORT.BY.DATE.REGION 7723 . 8113)) (8570 10791 (GDATE1-6 8580 . 10789))))) -STOP diff --git a/library/lafite/MAILSCAVENGE.LCOM.~1~ b/library/lafite/MAILSCAVENGE.LCOM.~1~ deleted file mode 100644 index 36d3a83723b8d8bc86f0f7711349cb12ab69eb92..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11903 zcmbtaYit`=b|z)7lQ^LvC$8buy3WlcaVXVN#E1Bh4TnQ=Xi}m$G)bBE#wnK~$0jYB z6i6zLkd4}HgDqNMfsKJ|7u{yj25qq@&_a^sA9?JuXt8MXuRrV}?fxvdXskAno$|Q7gDyOOOf*MV0LP=!` zS}vW+XBBZOtHu`93qy^QE;o&fVMIZT3&rc5R@bjjhyB9ioA(FjXTyqcE0xyGwR*#- zidIu7!u4i6zxdX<)q3;#dER=az?QSYo(T5aQeqkOI2HO{Y<+Z9Z5eo0NG^D*_3 zmbswKob^m%fzb5AdV?1T&U-`i{(vG@X#U1aRZ(vWm$GD38^(qhbex%)QAD-e#rng; zeRK2PurkVm2u^2OuTO`y1vO z{JPP+Zk+XiW3R^(o)eW?84VrLZM`@z+^$P%E-&m1#q_28q;MxPd68BVse(3Rv1)%- z!TO|FYa6fETk9R>1JfzOH@#HeU@Cp{9*6?Vy8bU@2Eq8qvg+*YtVhhpLoRnlUD8B8 zH9tSKoGGR<@#$<%FKDsClt_tL`68Cq)XZ{rI-%#5@>3##_Jp2}YdPF{gqF)u`-OY~ z&{&!jj+2fthckP~fxl0ls$Hk+lk}6lc$hBZ4!3tsT(!$*hOw7X)4~%HdbFUXGBZnh zCRNaLX+5?Gy?K11m?|W#Rx!u&l~myM9tI_EY2o&Q)Z7KF@JgR(Vt7(yg;z3{)ACxu z@f@XU!+Cc9jKd?jK?OEcQ#0?T-RoiQEsNp9sIHvUSaS4>KuaHcfg+nP1IzFSOIB3ncK zd64uQE*?Q+BdmoI4K;n7Z%R-1iVJrp&6Rhb zDJJElQ`L9*=C^rf?pj&s@dWyDIYlvg=gk|HXm7QWu$H{N?f9Kyr16;9AtD-wAM76Z zjcvz2@ko%IYd6^v#-+#!fecU+wQN47eryu8cmAJ(qzqNQQMy*x2*PqK3 z62++O0FICAPn%r!ii!T6DYXfU=8||<7dIZ>d97YL+0!R}v`~y>c#4v8d;5U5m{@)A z{`P^x`bqpAtnn)PiDL9V_u-{)Z;$<3ZCt)NK4>N$4}N;1G_mz(mZ}Dep4vTUZxo=W z|6iI}eDJ6Gk=+S>rr~-3omeDeRsGb%+Jo8ykXnrD;$BHHUp{<)`*TfK^b-$nZ-0JH zKcOpVar%o9T^SP7?QQ3?_C|37+8<-Me~k>)-3| zZ~y#XB!db>Nu61Zy<+_Li;-d+v?z^(=_9|XDhr96P&^x!VjQOV+=L=q7hv=n>3GU1ie}8-I$HnB`mrZeCaucRJ zqIBL_I@i8J^dUyf3v-Oh){p8Lf(a$p%`)C4_5^kjzF!jzc zF#N*3#xwUy6FmrhV%vF})S7nKEWFM461N^2&qq4st}DSh~4og zCbhLvpjYyn*5zNV)m>jAmw_H{>;A@*JgVgPiJdMc@nfY^SnJr`XP8Kqk?e9z`UcF_ zCtvsLfj{P_Zx!S3^3B`)E0^f$0U)A^S3v)^cCYr0UVY~;@%qrc?VtUwu0TE| zVUj{(*H31US9s%?IdyCLw{6;Y=qp+8VB#wj~+Tgc6o|$ zAzw(l07xoP{R9EwXFtV~_bQ3)|31%?>GN{(8hqz%bNXU}G2N?eJAPe1edmPkzH>}= zKHh(|Wenke_Y%nRaWQjtmmcZqr;8DjJ@@y`@w!{CUoV~cJzm!o z;MCnG^fS8$_2c8R!S-(Jrw+F#7#a;?DTq`H!V?VoMO-VWu_VRQdJ!#i6v){#oPJ-# zbrgRhM&pFc6GSvN(sdBoU?z`OTs4DvJ*#DAtZ*-gc%B+$yd*pUkSAjn+y?{v4v|M- zE;KTIOwS}zh!Q*jzh~r?MP$IUhbEKNIi!Ch)LL&mK|#Ta4>2W3LoCXnOA`4e@&=DT z{HVqJp;-~rvsa>53R)f=1CJ7&-#@xG3&afNFcP86{3^$mOq_F>W`KHQXC05A|bp-fp&(&p-~Z=^o8dF z7P`Xza37HjI17?tFNr~BFJTa9!8XU)2q9jCXZs)xg-3;E0W%Z?AUOIKp#UjPP8r%G zAuEZrB_tvLoLx{MSP#L_BZA?ui08AHA*ECyrDsGC8Q8w62!xO{4Fnc|aS!(+;pPkK zQdR^4fuXL5w2^rdrzGkCn6*951%}?v&H2bkXtJ2ToIwVLJ<#5LPtL677nk#}r8&qM zIyN;k2kj5jXZ7=kgSLKt;2^=I0ViZCLyP;p0sG>9q~+3>{j;HAx%mJftjJ|YkgXh^G3xI29*TVSUL7ufgmZ1><5t7&?IpOBpmZ2_Ku zNGzw*T$q8q_6^78-u=U^rpZyAB#2y2nlLtt*`SE(<5%0u4=Esz$e5siB~Ft=+mQ>fMf5X}4~5jP{I6TxqR~ zo8=8rX|y^9-idNoY@kvoDy=3;gmt4?F=i$e+W);mskWNN%%=Cn7p-Bp%FQlHhQfHG ze6!v(M7L&$n?|Qorcxs6q*TT%ue4q_#I;siRM*!U^-8&0Z#6pt&sYObMw6?Z*07n) z7hhCdr0;-my9-ycnkml7N!t5;Ldn<4jRs14sKK_43f8X~pxqizbyXtc8fv(&p!Dbo zpp>9s(oK~FQWm$2Mq?V}+yrgrAnq($*TiPrYU<1|5pZ}kHg6V8Awx_nI$e~1!C6Oa zswmfDrweko9C*2DB&f?Zlv$1HX5>||VpPiOAaGONe2qK9G?nFL6hN`ThXSTl=>gjT zEf#C7ZJ^vt#PlnvCZU`2SrT`r(k^!^H714&#)uR=JXT+W(lFNEgGQjbi$XK-v9exo zbVbc5SD}Amk=!AznlWyP28zPnny9v*y=JS6`MVG&hPN73bIcil3(~KlfK2ns39H1H zk932H1pYDx#4~tJlNjx08RO)_LM%y?h?Q1#gAup_6_y)PFHD#>06AektLO8O2hh2) z(SWj_v z(Hv0ko8|VZ1X8(g9R>lB5Da6p7zXQXyyYgDQ=806dt+@K6?+08(Tspid9&H7*4uP6 z@fKE}MSQAQCTC13A{>-p{sMuvR?mo)bqgcndbzy59sy*=<&($va=unb!@O`gzTLUc3!3Rv+WEmACp)Fu?ck6wd^0d3v> zC<3`@DmZ>Ye5FivNWQ><}%tE(L{sTP`*UWw>yJ25t0t^x{y#5)wfQWO%&2ON%zTvh(=MYD!=Tvq1a zlb7$vOE1TH`mRe}`GG3;bI8ThoNXX!GV=&Zy7{yU)%AV`;>FPu66h?>^!jfp>NJB8 zdv1f!Vb1~7{+vsu>0HTHkf+n6AwIDm`^*Y_3g=Q*t)7mWM$7MfDrZ&baoDDhIUEO% z3g<}mFd`)uu_TsadAuht-;tM|EPsDbUSyR+o<;?|eW4-!Hid>A#S$7eD@&4AWxY`Py^zNss2eQ-*n9iYdlYv=sRP3fCxO-p9-oCl za#2(rrP$RRIaq%$(-}4W@=lT*5hMd$MnfnACo)h3`p&1AzmAN1g zVIZGH`cCLt&g|2LFy#{&tq9j>Maqa`qk8-bEKeXEL2-vNRYX982fw(4xEakDE)W6@ z?-jzG*Dfw=nL-Ljs|Cb>2(^`I_;o(OuI{l{d+u+Ejf_Ff6)01&BnY0CFqz{y9FmQx zjmPgDbvhzRmX`@QS;SAG$_@by=aTTIL#ZZAY>*Z{;(X1XNLY0FgqDfZAudq|LqQG> zp_66hVz?pteuZo!B5T>P=>4NdovT-p58tVcs}Uhfv<;Um2cjIi_0JABoWa#7vJ_#@ z;~zoOAhWe7vg~6LUTsz$+JOiSM~O}x4oyASJ&#N0!EO+j?t|S~T*?o2Cvj;%*i~fX zS8zekV??0q!8`SFI#fE8#qYR-PBr&E*|e30ELuw4Gmv_G`Z?5c)N3>`xuBMW%$ElbPrQ54QNiDWG(M#Oe>%)kk!)LC9$gKSrP=;Cju(+QU)8+Q{&NOKP=b3v>FdgfMoMR3HuuZNW^?qp~ z^>Alu@#&+_9k|4d?f5RSnb%TW8kUW#pYp@_Liva3yRN0$#MO@$R_}dv>&Hu{Ki>K; z?!WrchnG@YC#ufR#+qY}#nn$={f{5i8h#0}yZ^ela0G(!Ab_|^pV`Qg2{J=`PLnF& z69^P@aL&&~BC|9Ar;6H&n$4!K2-JlKHHj?Do$93hvJYh1f7r(%+6oo}8Oa@q4CVU= z;R+-2boTU7&w(T#S$?Z#H8BStG!Cb@%ikRSJGrfVcmr0nz?J0hmn2@g)Np5p~_Ok;apmGotYQa`$M`7VA zezZrP4nJI8H!j~&SMlDw8ul06t2G_Ixpy1fjWzA2Q%l0YcR`H7T>jyK5g$u!U<%S zNZ@4&$)qW+XI?5Gi>HKK5dnm;OO!mA;TVE(Q%Yn*m$qHdhAfIdgIsx{ha7Y zm>d(<&B@-4YV+4VukxAX535VZ4)>~ZmBV9WX{VE?VM-Sp2Y-SC_g~eIJbWkf4gJW8 zUTJ(`QJ2R&OwfH0FGHkH&M*rS%aZlpcs0U}j8nK}w>Rt)mVmv4ID9UZD+(_Vx1?p3 zal;PJDmBj}P#J`KW9)gM$YIEO5wS*7g(WpB4;{P|wvq>ZnI?NVwM5_LQN2<|7UszW zf`Z{`s4R<(U(0a?GLBfN?QZ)YhMo~ z%S2kuTL)aQL&-GEh0ZwOtzaB71|+K4e7v(jJjnw^H-wi7bva$2=cJa7ClJ=4ZW>F2 zTq>JVJ!f>h2Lbxm4<4W)RM>j{>xhJg3W)))X~zP_W6H&DWFQVU>_v>EWMw|8h=Nd% zk0Ik)m-RO*Hlp%Wxr6e8g75YemC6Q+z~+lQnC`j6z{z`mKx@rFT?wg~GC4UKkJ>&? zk_iFAQ7g%ysEWUOB1gRT7$U03R=w&xT0WF?{wO*2n)BnOu~(fRE{-`rP&0_N7{k5v z-LI&O)m~~RoZfkU0q65_o8J0mm65q%dQisd)<2lNxlwlPJu`OT?ssdvCCOtE9}Z-! ztydmGgd}q5qa)dXsy+5*#*}QpA>7dBO{=uwh1D|aZRU>l@>bR=K2 zj(jXPMPx}hz@-+{G`>(m?OBaybTh`1TNu7cas&}(9boPvDzhAA@$5dI-T5W+Tf{ML zky7KHd|QVA0Qcc^#Ed6^dMkNEXjsrGu;j2_<}&sJUCRMrBiL^$G7Pwbeo8|E0ZNr( zt4&|W%2XQZHPwd`^=7?;lJgn(a+E@-JhM{nms?T%MSV$@Tf40;3TI}mqr=5tOq|VW zg~Anlb1DxXXi@8PQ~nUu<<4c*ix-(1`wJMxeqX2#vty-RBU}z;Tq9bwXBESf+2i`* zH-qSUxV;}mz9L3eF;zC)-4^!@zp&Ib+-kSek?Bon!W+c3SX#|#_%v6$q^2VzXFAKo z{tO$*UJ-6|Mc|q#nry5rjxLh|e6c+u$dR87Oc0AAacVtpET3 diff --git a/library/lafite/MAILSCAVENGE.LCOM.~2~ b/library/lafite/MAILSCAVENGE.LCOM.~2~ deleted file mode 100644 index a73235bbc64146801aea0ec8af01361d44146902..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11937 zcmbtaZ){uFbth%lNu1D-6VGr}&%I?5m(na&?~&pkC2;siKAMy$K8B>sxJkxR~};1zH2?ighivU>k}78zfo&&?GH~4aL@P`(O{<`f=D+Y{1~b81`Xp zv)?)QJ@S#V*J2YOzW46Cf6kxZIrp4%pD(GWGC6%dmC5S!nOw>c7Ye$TENStqF1(ps zNiSqG#k^Ns$ZLre?aEl=tj9;=5*Sg^lftWp=aXh_J{l3Kx)e~Bf)TIqd25}UTg{eP z7oE27iq9sCE1!RPtJ~QyYyHbN&3en+3HTQ;x0>tSYIo=Is+P$X6WUchcSZNVq|OSD zH=xWfSKBnL5?xXjc-pQxoYs7MtJ`~VNwhotMzeiGG_lMo&nqyo$ZLg!NNu-TqPWxR zZ1;tt&gVLB(R6;l-z)0XK4|lJN6m`5q$*2+fOnEVWpRFa8-y$fC9;^Z9~N(i5dQkr4~>MIx(fxwZU!$|$TB=R^waDI=TI3%FH; zUMNuem0}5aS)CQG^R6kEJAcB3zaKo)xIx#a=_mi{NxDqCeCncj!zll2OPSi52Ke35as0l(t*NA`4Pdf!9YEl)PnyPX(!kD|+dbA<@L}tjG&h zGFQ-xddcD}4|Z4-w5pz*w`iC{?;*>XN3s0UF_-ID>@&n3^TXM(Q?|PG8kK41jL+fWF-dY@&%a6d>p<0 zH~S0_>d8PMy;Vpv5D-@kBbhIe#Rh`o>{1iVsdy!4&}~S}$+2YU0LA#}3gBQwaZsi{~{#tBMPD`I~sWLs-Td=ymQ%=`n zdt?21kn|fK9zkPctc=Q8-0}O?1)g^J;vDWa*!Bj-^ubIy&BV!uhB3`Im1hU#Udll~W z=W>NqIW9YZrHY?``#?1GY%ds3!QSsj1Kc<#b zn-AXIKX%eMkKf}BUd1?9j^F1#y!7q;sefxs%Qt67&BWvJA8u4;_WsOP)o9TRhc7!D z1*jSRSNtmv{?s^iIAi!*o(Is0O)^$BE<9{JXgmO^<+vg4RlL^Ahwtuxs2g76+{4@Z zAHHmyGrVYV2g@DR*UQV7!dZUuy18eWl5w*}G@Yy8mI(IDfE0^z+Q+A)3IXgj?kW zOnq<$48L%%_1wM6%m6~4*>~S2br>%+8#DMbF3wag?oT~q%&^9O3RSq?gVbkiRfyIc z#P0eNi`qsdG^hkE>k4i*nx2o4%RrAW8o}1nJgO25h=V>R31X!SSnJH)=a@*Ak?e9t z`UcE4B;N=cp+DxQFPD?=@XZ(bS1vIyLO?_vuYmr2*I$?8jk=Qucbc^1PDmy1y936# ziq|o_fV^I60T0H^{ffA^7cx#A{3GG3^~Aj)vvr{OkLqv*w+D?c44MajiPtCY?f>L= z4KL(V5f&*VcH{gvm^#+T-YezgouDE3!J&bNcS!z_HVIqG+VuycVFSFnfN7zqyAmNh zfzzGDHy$3$@(7ss-`j+ilN;r@#I<8KAW6s`#`$l`F-d;jyO6C!V7KTn(>i{ievHT| zvdasE3;9CY1wc}Z8|MfJKlw41yjM%@|Mz8{%vh3>H{d&OTho_QjOjsR-}URp#XIK= z-<>nE^V#96J#!5IhgX4qpS2P2jCVe1p^E_`9Tzj_bm_5yaj_h;*z%&_f(F|o?OdkGYKT*uLuPq z9aA=nK_Ctk$JBf58B$42vQ&16D55Z6o;b>GOi}}|erA#Sf-k0<(_C#n9N>#l-*_2~CzT)^fubP zwzLR2L&p}mi_rc!eRjWKH0s-MIZY134th}A*;pV?u^xZiJcx?;Lyvn-Gf)GrW+}KLUv{e zMs5L0NTk-XSuV`LUWbO`aPPtKR?Fn5P7+2gCruce#X?xb4RTx|SeJDNH5h9p%JCHi z*1@e2fNxxHM{Fq|BA6LTC9c+70TM4IkEj6|SrGtc#wW?9Mvfd6vEjN=)lt2H7YvE` zS}KKX74C`37F4PdhVkM-t3Uy#V5tXG5ag_l5Tac&Rw#{?g$y<9e2a~2 zND`z45y9bmJ-$+-*%MuJtJCd^Tg`U8b4#G1jZ59^S8EMa60dhVH$}7G6YJg1t)AKS zd&ITQwzyf{5w%vQXX2fx_Qg(TyDMs)_FHDVX|`*of7VO;zbd@-PTTbFsxQ8154%-u z_fZ-Y=G)bq&9*7}4O84Sd%Y@^3{h*O`ek*!^Oh;Dcegs{LlC-4l4m8hA3> zT;{Zg`FCG@(d!|7hlI~px|Y{1an8=t-X9R&Vxx+ZX$Hf)sI_AKh6&p3@l<3bGOnYr z`wA+NN(iL{FDBj9NFY^l%WSpgK@JMM_8{&oI@iT+(r)VcnFu&M8e6PYA&na(Lrg1r zeUwnaSx@Y0sMBJn3v;&uc)4k&sLS;#6_$5nuZwlFR^0}HyV~xX+!?0nU0Xw47aM#e zWJ#4CupQ81iO$vzRf|E)u&`=zx4V=larbK7YQNTCVz^R_NI~JT#uk)@vCbYe0##g; zvw@HG?PjYl8fLW){S%Ai4r$e#c}ujwW4|Hl9cT|VYs}w=I5E7_s#{|&0bG!N1M;AG z<%D(OD?qxzL;`;~6XF@Yrb)QkY%eUtszixc@6>k~f$LCVwI%h!gsCCO3G>-KpNBkv z&h?!>WSLyDiQQd#{bsY*1Jl;pzTKCaZ3`QAlhj&u2MSx7+f7~)yKh#vwyIqd@U@r* zHg=PDhQT@;Z?#S4)Frdh-`?5=A_;&*GXgg6XWN~6 zvrFau&tvrk#HU`{SquN~ulA+;9WYHtM1#_!at(hqG z--MOJgaCAD6}OtePH)Uo$N(cCZPJh&>!x7z>isml|dlYQlfJGbD4pv)!&&yG@u8 zdn0I?5D2=G9dfV2_M83f?#Nq7Q>zNXGHlf{c|wB)(cR=LU?qUG$ZI>KE};m1^g28Y zXzLG05y&l5@nT;CI_7#LU*I4>7SGbV1rKK1L2F0c>Nfju$5I54EH6!NU2X>Cx3OD- ziv(>B*k@qjiGuLuI(>5q;YJPaU>mNb z+Umj~?MSb(Zi0ldL9jk{h_+jog2KKn7n_ALJVGUH40%*>s9+0;AO$m_6E$RrP@E+^ zw4;##I2`D~!PR>s78QfBjXfhILj} z=D#T~Uz3+Xf%Ei3kG%2&Rqhv&i)T68K+8mrT>SlA|C`r%7XcVm}U875EI!rR-Wg9W_ms-}zL|uF&JK&6skz zj-M9piRxiYN-SneEW`5nro4PjUIw!K{SA4MRStO?6;_8rL;7tA4Lgc0G;CJ3B<;#V z0Fk#XQY5vH5E{ZD#D_9@qbkN&p5R0Zjw^jCB-n z7YKpI_X^=F>aVWpxl#s4t0lyM2(`WQ@ar-jJ7TZS+}{=(8G}|RQKn)`5In77GS??? zNH(Rlp1gP3?TV#YUKZeF5kHM8I|MYIOTwFurJ69YQCj$z^EGE8Vbc{5dM-(axI`Tc z1vxl`PL@?j;D+e?6|#+(tYs(S_fMa8Z(d73{Ay!biwRkxZFyul5armte|Guc4Bm(% zI}*-3{xLL-GFzJ>+dgLD)fVKT9f;6zl<3Cc(AS4wX*i@jLCJQ_V-7Y&uFqHZ7}9q$Mkq2sb$ihC#jeZr8}!aX+5#x z9}IYd;WJl4WY+!*D8nj#*xWCO`D*t@Z=N)P^UNbBn6B*;?kSfE*rqp6 zs~=g;JUp0NdG_=tj$LKO4gy!%%o`al4a>&OAM(TWa`n5}yPnm?%p317Z{GX#-uG88 zez5mn+<)`^_pWC4&eh#NooY|HRyKe5`hR@8(F#h4-Tl{<!hf&k(T`u0YaOpqDk z8=FiCpFp6PgL8f^5?Q4II91eEw0u5$O`tA3s!8Nw?o=lomVF@8;lm>wqN89jl9Akz z$WXp@9Ih}XPiHTlR*t3l$nwh#yNNmYPU~cbyZp_`zmwa_dmFH#W%h&Y5v}egxO@MCT|oX$NgZaH$>X~g(x>D7 zL^y%W5(&I4Az3sfjoc?o$l@s>_lgk0*i}j%tZ)p$IC2XrUm&a#M;yCdEE_3b&P@gq z9R^^t!tH+w-s<#Mo-99G$5Gfh3lguF3AJm&?o*C4+;mq`)zIo=vpuTZt zhJMZsBuvf-`{w*$qu&0t59@p;`Q7^JnUjOMT;=4{RMze0X_(TL*6|9wz8Mh?gPK4=yna63deH!E`;wjf_*cWuF=i2wT7^Ar7BQ70N;d z;#T$C8gAI(*`;QG3Y9^)H^!a{MUF#OMZ_AxlSM`!15agjADS-xH;CmDW68y7WFQVUtRhD8=4C$W z6(!+CK8B2ITh`y~*oewg)gHvxe9MIV^QCC80=AE6L zj7J?GC&`2W;i#QtP*lZVJ&_~cdIAwuY_C~&pRS%ryT6y7dei;E>eTD*_g1Fd-_df2 zwHU*L?A?!PjMYKrAeudRei`TUa+}`!WsQ-!YfS$Cy}40#96UF5?C#eayd}wF zkpK>4?5$TGLPR8T>7ygrfT}(AX2z6kz#-h&=1pH04bMCvacC9nk?2v9v?_NfrC=MR zfOH~Xw2ypjH$`MgIKZWrv@E_*LhV^g<_s&wl3N(QNpgh|W*uYhVj8m?XYm|9pFj8| z>s!PrZjn;so_yPc008&#bi|4$fOHPJklaZPB| znN^I-#u?X-zZpf>6W$=HC$d^W$CtYL zRV^DMIn!At_Gj2g{+jTiD+1SCsVIDNoSn>B0e1u@?nB_0;4gtab{2mmK(%uRA4eP9 z+0W^lV{KZF*UuVS5{o~Y7LP?;fhX~4$)vo=Wwlie#LzX1D?LtVRLT>+3|8vHaS`nc ylafite>sources>mailscavenge;19" 21195 - - changes to%: (VARS MAILSCAVENGECOMS) (FNS LAFITE.SCAVENGE LAFITE.SCAVANGE) - - previous date%: " 3-May-89 13:17:29" "{pooh/n}lafite>sources>mailscavenge;17") - - -(* " -Copyright (c) 1985, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT MAILSCAVENGECOMS) - -(RPAQQ MAILSCAVENGECOMS ((FNS LAFITE.SCAVENGE \MAILSCAVENGE.INTERNAL \MAILSCAVENGE.OPEN.SCRATCH \MAILSCAVENGE.LENGTHWIDTH \MAILSCAVENGE.LFCOPYBYTES \MAILSCAVENGE.READSTAMP \MAILSCAVENGE.DUPLICATE? \MAILSCAVENGE.FORMAT \MAILSCAVENGE.MAKEWINDOW \MAILSCAVENGE.ASKUSER \MAILSCAVENGE.FIX.LENGTHS \MAILSCAVENGE.CONFIRM) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (*START*LENGTH 8)) (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \MAILSCAVENGE.FORMAT))))) -(DEFINEQ - -(LAFITE.SCAVENGE -(LAMBDA (FOLDERNAME ERRORMSGSTREAM FORGET?) (* ; "Edited 18-Apr-89 18:19 by bvm") (* ;; "User entry to the scavenger. If FORGET?, we won't add folder to the list of known folders.") (LET ((FOLDER (LAFITE.OBTAIN.FOLDER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) (QUOTE INPUT) T (AND FORGET? :FORGET)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (\MAILSCAVENGE.INTERNAL FOLDER ERRORMSGSTREAM)))) -) - -(\MAILSCAVENGE.INTERNAL -(LAMBDA (*FOLDER* *ERRORMSGSTREAM* GOODPTR MSGNO) (* ; "Edited 3-May-89 13:05 by bvm") (* ;; "Scavenge FOLDER, which can be a mail folder, mail file name, or open stream on a mail file. Commentary goes to *ERRORMSGSTREAM*, which for folders defaults to its browser window. If GOODPTR is supplied, it is a file pointer that we assert points to the *START* corresponding to msg # MSGNO, and we guarantee we will not touch anything earlier in the file.") (LET (SCRATCHSTREAM FOLDERSTRM) (CL:UNWIND-PROTECT (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (*PRINT-BASE* 10) (BADCOUNT 0) (*START* "*start* -") (*EOL* (CHARCODE CR)) (COPYFN (FUNCTION COPYBYTES)) TRYPTR LFP PWINDOW XPOS DUPSCRATCH FOLDERNAME EOFPTR BODYSTART BADHEADER NOMOREP STAMPLENGTH MSGLENGTH ENDPTR FIELDWIDTH LENGTHFIXUPS TRUNCATEPTR TSTREAM SUCCESS CH) (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM* *EOL*)) (* ; "Used by \mailscavenge.askuser") (if (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) then (* ; "It's a mail folder, so play by the rules") (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE INPUT) :OK)) (SETQ PWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of *FOLDER*)) elseif (TYPENAMEP *FOLDER* (QUOTE STREAM)) then (SETQ FOLDERSTRM *FOLDER*) else (SETQ FOLDERSTRM (\LAFITE.OPENSTREAM *FOLDER* (QUOTE INPUT) (QUOTE OLD) (FUNCTION \LAFITE.EOF) NIL (QUOTE LAFITE)))) (SETQ FOLDERNAME (FULLNAME FOLDERSTRM)) (SETFILEINFO FOLDERSTRM (QUOTE BUFFERS) 30) (SETQ EOFPTR (GETEOFPTR FOLDERSTRM)) (SETFILEPTR FOLDERSTRM 0) (if PWINDOW then (LAB.PROMPTPRINT *FOLDER* " Scavenging... ") (SETQ XPOS (DSPXPOSITION NIL PWINDOW))) (if (NOT *ERRORMSGSTREAM*) then (SETQ *ERRORMSGSTREAM* (if (AND (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) (SETQ TSTREAM (\MAILSCAVENGE.MAKEWINDOW *FOLDER*))) then (* ; "We waited til here to make the window in case printing %"Scavenging... %" up there grew the window.") (TEXTSTREAM TSTREAM) else (GETSTREAM NIL (QUOTE OUTPUT))))) (\MAILSCAVENGE.FORMAT "Scavenging ~A..." FOLDERNAME) (if GOODPTR then (* ; "Somebody has already gotten us started") (GO LP) else (SETQ GOODPTR 0) (SETQ MSGNO 1) (if (LA.READSTAMP FOLDERSTRM) then (* ; "Good start") (GO PARSEMSG) elseif (PROGN (SETFILEPTR FOLDERSTRM (SUB1 *START*LENGTH)) (AND (EQ (BIN FOLDERSTRM) (CHARCODE LF)) (FILEPOS "*start*" FOLDERSTRM 0 7))) then (* ; "LF woes") (if (\MAILSCAVENGE.ASKUSER "File was apparently written with end of line convention LF. Convert to CR (Note: TEdit formatting may be corrupted by this action, or could already have been corrupted by copying the file into LF format)? ") then (SETQ *START* "*start*") (SETQ COPYFN (FUNCTION \MAILSCAVENGE.LFCOPYBYTES)) (SETQ *EOL* (CHARCODE LF)) (SETQ LFP T) (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (SETFILEINFO FOLDERSTRM (QUOTE EOL) (QUOTE LF))) elseif (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "Alleged mail folder ~A doesn't begin with a Lafite header -- proceed anyway? " FOLDERNAME)) then (SETQ BODYSTART 0) (GO FINDSTART) else (RETURN NIL))) LP (* ;; "GOODPTR is believed to point at *start*") (SETFILEPTR FOLDERSTRM GOODPTR) (if (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)) then (* ; "This shouldn't happen") (CL:ERROR "Scavenger is confused at message ~D, byte ~D" MSGNO GOODPTR)) PARSEMSG (if PWINDOW then (* ; "Tell which message we're on") (DSPXPOSITION XPOS PWINDOW) (PRIN3 MSGNO PWINDOW)) (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (if (NOT (AND (SETQ MSGLENGTH (LA.READCOUNT FOLDERSTRM)) (> MSGLENGTH 0))) then (* ; "Malformed header--not even the length exists. Will need to build a new header. Take all the stuff from BODYSTART as potential message") (SETQ BADHEADER T) (GO FINDSTART)) (SETQ BADHEADER (NOT (AND (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (SETQ STAMPLENGTH (LA.READCOUNT FOLDERSTRM))) (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (* ; "Read 3 status bytes") (OR (EQ (SETQ CH (BIN FOLDERSTRM)) *EOL*) (AND LFP (EQ CH (CHARCODE CR))))) (<= (- (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) GOODPTR) STAMPLENGTH)))) (* ;; "We have a plausible length. BADHEADER true means the rest of header does not parse because (a) no header length, (b) no CR after the the 3 mark bytes, or (c) header length is too short. Wait to see whether the length appears correct before deciding whether to rebuild the header or just smash it.") (* ; "Take all the stuff from BODYSTART as potential message") (if (OR (<= (SETQ ENDPTR (+ GOODPTR MSGLENGTH)) (GETFILEPTR FOLDERSTRM)) (> ENDPTR EOFPTR)) then (* ; "Length too short or points past eof.") (GO FINDSTART) elseif (AND (< ENDPTR EOFPTR) (PROGN (SETFILEPTR FOLDERSTRM ENDPTR) (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)))) then (* ; "Length doesn't point at next *start*, have to search for a boundary") (SETFILEPTR FOLDERSTRM ENDPTR) (if (AND (EQ (BIN FOLDERSTRM) 0) (to (- EOFPTR ENDPTR 1) always (EQ (BIN FOLDERSTRM) 0))) then (* ; "File is well-formed except for ending in a bunch of nulls. This seems to happen every once in a fhile when a file server spazzes. Throw them away.") (\MAILSCAVENGE.FORMAT "~%%Starting at byte ~D (after message #~D):~%% File ends in ~D null bytes. Will discard." ENDPTR MSGNO (- EOFPTR ENDPTR)) (if SCRATCHSTREAM then (* ; "Copy last message verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR) else (* ; "Note truncation here") (SETQ TRUNCATEPTR ENDPTR)) (add BADCOUNT 1) (GO DONE)) (GO FINDSTART) elseif BADHEADER then (* ; "Length ok, but header was malformed. It is likely to be safe to just overwrite the header") (add BADCOUNT 1) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ok, but header garbled." MSGNO GOODPTR) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR)) (if SCRATCHSTREAM then (* ; "Have to copy") (SETQ BODYSTART (+ GOODPTR FIELDWIDTH LAFITEBASICSTAMPLENGTH)) (SETQ MSGLENGTH (- ENDPTR BODYSTART)) (GO COPYMSG) else (* ; "Remember fixup") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH T)) (GO NEXT)) else (* ; "Well-formed message") (if (AND (< (- BODYSTART GOODPTR) STAMPLENGTH) (EQ (PROGN (SETFILEPTR FOLDERSTRM BODYSTART) (BIN FOLDERSTRM)) (CHARCODE *))) then (* ; "May be a funny one") (LET ((INFO (CL:READ-LINE FOLDERSTRM)) ISDUP) (if (AND (STRPOS "duplicate*" INFO 1 NIL T) (FIXP (SETQ INFO (SUBATOM INFO 11)))) then (* ; "This message claims to be a duplicate of the one at INFO") (SETQ ISDUP (\MAILSCAVENGE.DUPLICATE? FOLDERSTRM INFO GOODPTR STAMPLENGTH MSGLENGTH (OR DUPSCRATCH (SETQ DUPSCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH)))))) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D is marked as a duplicate of the one at byte~D from an aborted Expunge~A." MSGNO GOODPTR INFO (if (NOT ISDUP) then "; however, the original is not there" elseif SCRATCHSTREAM then " (not copied)" else "")) (if ISDUP then (* ; "Nothing to do.") (GO NEXT) elseif SCRATCHSTREAM then (SETQ BADHEADER T) (* ; "so that message gets undeleted") (GO COPYGOOD) else (* ; "Want to rewrite the flags") (push LENGTHFIXUPS (LIST GOODPTR NIL NIL T)) (GO NEXT))))) (if SCRATCHSTREAM then (* ; "Copy verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR)) (GO NEXT)) FINDSTART (* ;; "At this point, we have a malformed message starting at GOODPTR. Look for its end. If the header is also malformed, BADHEADER is true. BODYSTART points at what could be the start of text..") (SETQ TRYPTR BODYSTART) FINDSTARTLP (SETQ ENDPTR (FFILEPOS *START* FOLDERSTRM TRYPTR)) (if (NULL ENDPTR) then (* ; "Can't find next message. Maybe this is the last one") (if (AND (EQ MSGNO 1) BADHEADER) then (* ; "Never saw a single *start*") (if (NULL (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "There are no message boundaries in this file. Do you want to turn the file into a single message of length ~D?" (- EOFPTR GOODPTR)))) then (RETURN NIL))) (SETQ ENDPTR EOFPTR) elseif (AND LFP (PROGN (* ; "Have to check that an eol follows, since we're not sure which kind.") (SETFILEPTR FOLDERSTRM (+ ENDPTR (SUB1 *START*LENGTH))) (SELCHARQ (BIN FOLDERSTRM) ((CR LF) NIL) T))) then (SETQ TRYPTR (+ ENDPTR (- *START*LENGTH 2))) (GO FINDSTARTLP)) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ~:[missing~%% (~;incorrect~%% (file says ~:*~D, ~]apparent length is ~D)" MSGNO GOODPTR MSGLENGTH (if BADHEADER then (* ; "Estimate based on standard header size. We'll be exact later") (+ LAFITESTAMPLENGTH (SETQ MSGLENGTH (- ENDPTR BODYSTART))) else (SETQ MSGLENGTH (- ENDPTR GOODPTR)))) (add BADCOUNT 1) (if BADHEADER then (\MAILSCAVENGE.FORMAT "~%% Need to rebuild internal header. Message body may be malformed.") (GO COPYMSG)) (* ; "Header ok, just the length was wrong") (if (NULL SCRATCHSTREAM) then (* ; "Should suffice just to change length in place") (if (<= (NCHARS MSGLENGTH) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR))) then (* ; "Good, the correct length fits in the available space. Save for confirmation later") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH)) (GO NEXT)) (* ;; "Arrrgh, the length is too big. Fall thru to copy message to scratch file.") (\MAILSCAVENGE.FORMAT "~%%New length does not fit into old header, will have to rebuild.")) COPYGOOD (* ;; "Bring MSGLENGTH down to just the body length so we compute the new header correctly") (SETQ MSGLENGTH (- MSGLENGTH STAMPLENGTH)) COPYMSG (* ;; "At this point, we want to write the current message on scratch file. MSGLENGTH is the length of the body, sans header, starting at BODYSTART. If BADHEADER is true, we rebuild whole header. Otherwise, message is believed well-formed, so we can copy flag bytes from old message.") (if (NULL SCRATCHSTREAM) then (* ; "Have to set up scratch file") (\MAILSCAVENGE.FORMAT "~%%Opening scratch file to handle rebuilt header.") (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (if (> GOODPTR 0) then (\MAILSCAVENGE.FORMAT "~%%Copying ~D previous message~:P to scratch file..." (SUB1 MSGNO)) (COPYBYTES FOLDERSTRM SCRATCHSTREAM 0 GOODPTR) (\MAILSCAVENGE.FORMAT "done."))) (LA.PRINTHEADER SCRATCHSTREAM MSGLENGTH) (if BADHEADER then (* ; "Have to create afresh, so use primordial flags") (PRIN3 "UU -" SCRATCHSTREAM) else (* ; "Original header was ok, except for length info, so copy flags and mark byte from it.") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM (- BODYSTART 4) BODYSTART) (SETQ BODYSTART (+ GOODPTR STAMPLENGTH))) (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM BODYSTART ENDPTR) NEXT (COND ((< (SETQ GOODPTR ENDPTR) EOFPTR) (* ; "Go process some more") (add MSGNO 1) (GO LP))) DONE (* ;; "All finished--shall we confirm it?") (if SCRATCHSTREAM then (* ; "Close this now (could be slow) before saying done.") (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM))) (if PWINDOW then (DSPXPOSITION XPOS PWINDOW) (PRIN1 "done. " PWINDOW)) (SETQ SUCCESS (if SCRATCHSTREAM then (* ; "We had to use a scratch file.") (if LENGTHFIXUPS then (* ; "Had some length fixups before we got to a really bad spot, so go back and do them now") (SETQ SCRATCHSTREAM (OPENSTREAM SCRATCHSTREAM (QUOTE BOTH) (QUOTE OLD) (QUOTE ((TYPE LAFITE))))) (CL:UNWIND-PROTECT (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS SCRATCHSTREAM) (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM)))) (if (AND (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Replace damaged mail file with scavenged file? ") (PROGN (if *FOLDER* then (\LAFITE.CLOSE.FOLDER *FOLDER* T) else (CLOSEF FOLDERSTRM)) (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHSTREAM FOLDERNAME) (if RESULT then T else (\MAILSCAVENGE.FORMAT "~%%RenameFile failed~@[ because ~A~]." CONDITION) NIL)))) then T else (* ; "File not renamed, either because of error or user choice. Tell where the scavenged file is.") (\MAILSCAVENGE.FORMAT "~%%Scavenged file stored as ~A." SCRATCHSTREAM MSGNO) NIL) elseif (AND (NULL LENGTHFIXUPS) (NULL TRUNCATEPTR)) then (\MAILSCAVENGE.FORMAT "~%%~A is a well-formed message file of ~D messages." FOLDERNAME MSGNO) NIL elseif (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Shall I correct these messages in the file? ") then (* ; "Do fixups in place") (if *FOLDER* then (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE BOTH))) elseif (NOT (OPENP FOLDERSTRM (QUOTE OUTPUT))) then (SETQ FOLDERSTRM (OPENSTREAM (CLOSEF FOLDERSTRM) (QUOTE BOTH) NIL (QUOTE ((TYPE LAFITE)))))) (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS FOLDERSTRM) (if TRUNCATEPTR then (* ; "Truncate file to drop nulls off end") (SETFILEINFO FOLDERSTRM (QUOTE LENGTH) TRUNCATEPTR)) (* ; "Return success") T)) (if SUCCESS then (\MAILSCAVENGE.FORMAT "done.~2%%You may want to examine the messages listed above for duplications or concatenated messages.~%%")) (if TSTREAM then (DETACHWINDOW TSTREAM) (\MAILSCAVENGE.FORMAT " -(This report window is now detached from its browser. - You may close it at your convenience.)")) (RETURN (AND SUCCESS FOLDERNAME))) (* ;; "Cleanup time") (if (type? MAILFOLDER *FOLDER*) then (\LAFITE.CLOSE.FOLDER *FOLDER* T) elseif (AND (STREAMP FOLDERSTRM) (OPENP FOLDERSTRM)) then (CLOSEF FOLDERSTRM)) (if (STREAMP SCRATCHSTREAM) then (* ; "Must have aborted.") (DELFILE (CLOSEF SCRATCHSTREAM)))))) -) - -(\MAILSCAVENGE.OPEN.SCRATCH -(LAMBDA (FOLDERNAME) (* ; "Edited 3-May-89 13:03 by bvm") (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERNAME (QUOTE EXTENSION)) "-scavenged") (QUOTE BODY) FOLDERNAME) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE LAFITE) (SEQUENTIAL T))))) -) - -(\MAILSCAVENGE.LENGTHWIDTH -(LAMBDA (FOLDERSTRM STARTPTR) (* ; "Edited 3-May-89 12:42 by bvm") (* ;; "Return the actual width of the %"message length%" field in this message") (LET ((LENSTART (+ STARTPTR *START*LENGTH))) (SETFILEPTR FOLDERSTRM LENSTART) (LA.READCOUNT FOLDERSTRM T) (- (GETFILEPTR FOLDERSTRM) LENSTART 1))) -) - -(\MAILSCAVENGE.LFCOPYBYTES -(LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 3-May-89 13:07 by bvm") (* ;; "A COPYBYTES that turns LF into CR as it goes.") (SETFILEPTR SRCFIL START) (to (- END START) bind CH do (\BOUT DSTFIL (if (EQ (SETQ CH (BIN SRCFIL)) (CHARCODE LF)) then (CHARCODE CR) else CH)))) -) - -(\MAILSCAVENGE.READSTAMP -(LAMBDA (STREAM) (* ; "Edited 3-May-89 12:20 by bvm") (* ;; "Like LA.READSTAMP, but also succeeds if the stamp ends in LF when we're processing a LF file.") (AND (EQ (BIN STREAM) (CHARCODE *)) (EQ (BIN STREAM) (CHARCODE s)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE a)) (EQ (BIN STREAM) (CHARCODE r)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE *)) (SELCHARQ (BIN STREAM) (CR T) (LF (EQ *EOL* (CHARCODE LF))) NIL))) -) - -(\MAILSCAVENGE.DUPLICATE? -(LAMBDA (FOLDERSTRM OLDPTR GOODPTR STAMPLENGTH MSGLENGTH SCRATCH) (* ; "Edited 2-May-89 12:06 by bvm") (* ;; "True if the message at pointer OLDPTR is a duplicate of the one starting at GOODPTR with lengths STAMPLENGTH & MSGLENGTH.") (SETFILEPTR FOLDERSTRM OLDPTR) (LET (OLDLENGTH OLDSTAMP) (AND (LA.READSTAMP FOLDERSTRM) (SETQ OLDLENGTH (LA.READCOUNT FOLDERSTRM)) (SETQ OLDSTAMP (LA.READCOUNT FOLDERSTRM)) (\LAFITE.CHECK.DUPLICATE FOLDERSTRM SCRATCH GOODPTR STAMPLENGTH MSGLENGTH OLDPTR OLDSTAMP OLDLENGTH)))) -) - -(\MAILSCAVENGE.FORMAT -(CL:LAMBDA (&REST ARGS) (* ; "Edited 21-Apr-89 15:25 by bvm") (if (TEXTSTREAMP *ERRORMSGSTREAM*) then (* ;; "It is MUCH faster to cons the string and hand it to tedit than to print a character at a time. One difference: unless we set the %"dontscroll%" flag, the window will scroll when we run off the bottom. This is probably desirable, as it means we look like we're doing something.") (TEDIT.INSERT *ERRORMSGSTREAM* (CL:APPLY (FUNCTION CL:FORMAT) NIL ARGS) (ADD1 (GETEOFPTR *ERRORMSGSTREAM*))) else (CL:APPLY (FUNCTION CL:FORMAT) *ERRORMSGSTREAM* ARGS))) -) - -(\MAILSCAVENGE.MAKEWINDOW -(LAMBDA (FOLDER) (* ; "Edited 21-Apr-89 15:34 by bvm") (* ;; "Return a tedit window to use for Scavenger report, or NIL if FOLDER doesn't have a browser") (LET ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if BROWSERWINDOW then (LET* ((FONT (DSPFONT NIL (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (ERRHEIGHT (HEIGHTIFWINDOW (TIMES 10 (FONTPROP FONT (QUOTE HEIGHT))) T)) (ERRW (CREATEW (CREATEREGION 0 0 10 ERRHEIGHT) (CONCAT "Mail Scavenger Report for " (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER)) T))) (ATTACHWINDOW ERRW BROWSERWINDOW (if (< (fetch (REGION BOTTOM) of (WINDOWPROP BROWSERWINDOW (QUOTE REGION))) ERRHEIGHT) then (* ; "Won't fit below") (QUOTE TOP) else (QUOTE BOTTOM)) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (OPENTEXTSTREAM "" ERRW NIL NIL (BQUOTE (FONT (\, FONT) PROMPTWINDOW DON'T))) ERRW)))) -) - -(\MAILSCAVENGE.ASKUSER -(LAMBDA (PROMPT) (DECLARE (CL:SPECIAL *FOLDER*)) (* ; "Edited 2-May-89 11:42 by bvm") (LET (BROWSERWINDOW) (if (AND *FOLDER* (SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of *FOLDER*))) then (* ; "Use the browser for interaction") (CLEARW BROWSERWINDOW) (FLASHWINDOW BROWSERWINDOW) (if (> (STRINGWIDTH PROMPT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE WIDTH))) then (* ; "Sigh, too wide to centerprint. I wish we had better text layout...") (RELMOVETO 0 (- (IQUOTIENT (WINDOWPROP BROWSERWINDOW (QUOTE HEIGHT)) 2)) BROWSERWINDOW) (PRIN3 PROMPT BROWSERWINDOW) else (* ; "Nicely center the prompt") (CENTERPRINTINREGION PROMPT NIL BROWSERWINDOW)) (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of *FOLDER*)) (MENUWREG (WINDOWPROP MENUW (QUOTE REGION))) (MENUWIDTH (fetch (REGION WIDTH) of MENUWREG)) (ITEMS (QUOTE (("Proceed" T "Continue the scavenge as asked") ("Abort" NIL "Abort the mail scavenge operation")))) (MENU (create MENU ITEMS _ ITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT MENUROWS _ 1 ITEMWIDTH _ (MAX (STRINGWIDTH (CAAR ITEMS) LAFITEMENUFONT) (IQUOTIENT MENUWIDTH 4)) MENUOUTLINESIZE _ 0 MENUBORDERSIZE _ 0))) (* ; "Position the menu in the middle of the browser's menu window") (PROG1 (MENU MENU (LA.POSITION.FROM.REGION MENUWREG (IQUOTIENT (- MENUWIDTH (fetch (MENU IMAGEWIDTH) of MENU)) 2) (WINDOWPROP MENUW (QUOTE BORDER))) T) (CLEARW BROWSERWINDOW))) else (EQ (ASKUSER NIL NIL PROMPT) (QUOTE Y))))) -) - -(\MAILSCAVENGE.FIX.LENGTHS -(LAMBDA (FIXUPS STREAM) (* ; "Edited 3-May-89 12:42 by bvm") (* ;; "Perform length fixups. FIXUPS has entries of the form (startptr length fieldwidth fixheader)") (for ENTRY in FIXUPS do (DESTRUCTURING-BIND (START LENGTH FIELDWIDTH FIXHEADER) ENTRY (SETFILEPTR STREAM (+ START *START*LENGTH)) (if LENGTH then (LA.PRINTCOUNT LENGTH STREAM (BQUOTE (FIX (\, FIELDWIDTH) 10 T))) else (LA.READCOUNT STREAM)) (if FIXHEADER then (* ; "Write the rest of the header, too") (if LENGTH then (LA.PRINTCOUNT (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH) STREAM) else (LA.READCOUNT STREAM)) (PRIN3 "UU -" STREAM)))))) - -(\MAILSCAVENGE.CONFIRM -(LAMBDA (BADNO TOTALNO PROMPT) (* ; "Edited 21-Apr-89 15:27 by bvm") (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM*)) (* ;; "Called at end of scavenge to report results. Return T/NIL response to PROMPT") (LET ((FORMATSTRING "~2%%Finished, found ~D bad messages out of ~D total messages.~%%")) (\MAILSCAVENGE.FORMAT FORMATSTRING BADNO TOTALNO) (if (\MAILSCAVENGE.ASKUSER PROMPT) then (if *FOLDER* then (* ; "Make sure to delete any toc that might be hanging around") (DELFILE (TOCFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of *FOLDER*)))) (\MAILSCAVENGE.FORMAT "Working... ") (* ; "Show some response") T))) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ *START*LENGTH 8) - - -(CONSTANTS (*START*LENGTH 8)) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA) - -(ADDTOVAR NLAML) - -(ADDTOVAR LAMA \MAILSCAVENGE.FORMAT) -) -(PUTPROPS MAILSCAVENGE COPYRIGHT ("Xerox Corporation" 1985 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1004 20710 (LAFITE.SCAVENGE 1014 . 1446) (\MAILSCAVENGE.INTERNAL 1448 . 14521) ( -\MAILSCAVENGE.OPEN.SCRATCH 14523 . 14854) (\MAILSCAVENGE.LENGTHWIDTH 14856 . 15184) ( -\MAILSCAVENGE.LFCOPYBYTES 15186 . 15491) (\MAILSCAVENGE.READSTAMP 15493 . 15970) ( -\MAILSCAVENGE.DUPLICATE? 15972 . 16515) (\MAILSCAVENGE.FORMAT 16517 . 17104) (\MAILSCAVENGE.MAKEWINDOW - 17106 . 17971) (\MAILSCAVENGE.ASKUSER 17973 . 19439) (\MAILSCAVENGE.FIX.LENGTHS 19441 . 20069) ( -\MAILSCAVENGE.CONFIRM 20071 . 20708))))) -STOP diff --git a/library/lafite/MAILSCAVENGE.~2~ b/library/lafite/MAILSCAVENGE.~2~ deleted file mode 100644 index 95de1b1f..00000000 --- a/library/lafite/MAILSCAVENGE.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Jun-90 18:25:37" {DSK}local>lde>lispcore>internal>library>MAILSCAVENGE.;2 21651 changes to%: (VARS MAILSCAVENGECOMS) previous date%: " 7-Nov-89 19:34:02" {DSK}local>lde>lispcore>internal>library>MAILSCAVENGE.;1) (* ; " Copyright (c) 1985, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MAILSCAVENGECOMS) (RPAQQ MAILSCAVENGECOMS [(FNS LAFITE.SCAVENGE \MAILSCAVENGE.INTERNAL \MAILSCAVENGE.OPEN.SCRATCH \MAILSCAVENGE.LENGTHWIDTH \MAILSCAVENGE.LFCOPYBYTES \MAILSCAVENGE.READSTAMP \MAILSCAVENGE.DUPLICATE? \MAILSCAVENGE.FORMAT \MAILSCAVENGE.MAKEWINDOW \MAILSCAVENGE.ASKUSER \MAILSCAVENGE.FIX.LENGTHS \MAILSCAVENGE.CONFIRM) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (*START*LENGTH 8)) (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \MAILSCAVENGE.FORMAT ]) (DEFINEQ (LAFITE.SCAVENGE (LAMBDA (FOLDERNAME ERRORMSGSTREAM FORGET?) (* ; "Edited 18-Apr-89 18:19 by bvm") (* ;; "User entry to the scavenger. If FORGET?, we won't add folder to the list of known folders.") (LET ((FOLDER (LAFITE.OBTAIN.FOLDER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) (QUOTE INPUT) T (AND FORGET? :FORGET)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (\MAILSCAVENGE.INTERNAL FOLDER ERRORMSGSTREAM)))) ) (\MAILSCAVENGE.INTERNAL (LAMBDA (*FOLDER* *ERRORMSGSTREAM* GOODPTR MSGNO) (* ; "Edited 3-May-89 13:05 by bvm") (* ;; "Scavenge FOLDER, which can be a mail folder, mail file name, or open stream on a mail file. Commentary goes to *ERRORMSGSTREAM*, which for folders defaults to its browser window. If GOODPTR is supplied, it is a file pointer that we assert points to the *START* corresponding to msg # MSGNO, and we guarantee we will not touch anything earlier in the file.") (LET (SCRATCHSTREAM FOLDERSTRM) (CL:UNWIND-PROTECT (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (*PRINT-BASE* 10) (BADCOUNT 0) (*START* "*start* ") (*EOL* (CHARCODE CR)) (COPYFN (FUNCTION COPYBYTES)) TRYPTR LFP PWINDOW XPOS DUPSCRATCH FOLDERNAME EOFPTR BODYSTART BADHEADER NOMOREP STAMPLENGTH MSGLENGTH ENDPTR FIELDWIDTH LENGTHFIXUPS TRUNCATEPTR TSTREAM SUCCESS CH) (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM* *EOL*)) (* ; "Used by \mailscavenge.askuser") (if (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) then (* ; "It's a mail folder, so play by the rules") (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE INPUT) :OK)) (SETQ PWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of *FOLDER*)) elseif (TYPENAMEP *FOLDER* (QUOTE STREAM)) then (SETQ FOLDERSTRM *FOLDER*) else (SETQ FOLDERSTRM (\LAFITE.OPENSTREAM *FOLDER* (QUOTE INPUT) (QUOTE OLD) (FUNCTION \LAFITE.EOF) NIL (QUOTE LAFITE)))) (SETQ FOLDERNAME (FULLNAME FOLDERSTRM)) (SETFILEINFO FOLDERSTRM (QUOTE BUFFERS) 30) (SETQ EOFPTR (GETEOFPTR FOLDERSTRM)) (SETFILEPTR FOLDERSTRM 0) (if PWINDOW then (LAB.PROMPTPRINT *FOLDER* " Scavenging... ") (SETQ XPOS (DSPXPOSITION NIL PWINDOW))) (if (NOT *ERRORMSGSTREAM*) then (SETQ *ERRORMSGSTREAM* (if (AND (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) (SETQ TSTREAM (\MAILSCAVENGE.MAKEWINDOW *FOLDER*))) then (* ; "We waited til here to make the window in case printing %"Scavenging... %" up there grew the window.") (TEXTSTREAM TSTREAM) else (GETSTREAM NIL (QUOTE OUTPUT))))) (\MAILSCAVENGE.FORMAT "Scavenging ~A..." FOLDERNAME) (if GOODPTR then (* ; "Somebody has already gotten us started") (GO LP) else (SETQ GOODPTR 0) (SETQ MSGNO 1) (if (LA.READSTAMP FOLDERSTRM) then (* ; "Good start") (GO PARSEMSG) elseif (PROGN (SETFILEPTR FOLDERSTRM (SUB1 *START*LENGTH)) (AND (EQ (BIN FOLDERSTRM) (CHARCODE LF)) (FILEPOS "*start*" FOLDERSTRM 0 7))) then (* ; "LF woes") (if (\MAILSCAVENGE.ASKUSER "File was apparently written with end of line convention LF. Convert to CR (Note: TEdit formatting may be corrupted by this action, or could already have been corrupted by copying the file into LF format)? ") then (SETQ *START* "*start*") (SETQ COPYFN (FUNCTION \MAILSCAVENGE.LFCOPYBYTES)) (SETQ *EOL* (CHARCODE LF)) (SETQ LFP T) (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (SETFILEINFO FOLDERSTRM (QUOTE EOL) (QUOTE LF))) elseif (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "Alleged mail folder ~A doesn't begin with a Lafite header -- proceed anyway? " FOLDERNAME)) then (SETQ BODYSTART 0) (GO FINDSTART) else (RETURN NIL))) LP (* ;; "GOODPTR is believed to point at *start*") (SETFILEPTR FOLDERSTRM GOODPTR) (if (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)) then (* ; "This shouldn't happen") (CL:ERROR "Scavenger is confused at message ~D, byte ~D" MSGNO GOODPTR)) PARSEMSG (if PWINDOW then (* ; "Tell which message we're on") (DSPXPOSITION XPOS PWINDOW) (PRIN3 MSGNO PWINDOW)) (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (if (NOT (AND (SETQ MSGLENGTH (LA.READCOUNT FOLDERSTRM)) (> MSGLENGTH 0))) then (* ; "Malformed header--not even the length exists. Will need to build a new header. Take all the stuff from BODYSTART as potential message") (SETQ BADHEADER T) (GO FINDSTART)) (SETQ BADHEADER (NOT (AND (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (SETQ STAMPLENGTH (LA.READCOUNT FOLDERSTRM))) (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (* ; "Read 3 status bytes") (OR (EQ (SETQ CH (BIN FOLDERSTRM)) *EOL*) (AND LFP (EQ CH (CHARCODE CR))))) (<= (- (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) GOODPTR) STAMPLENGTH)))) (* ;; "We have a plausible length. BADHEADER true means the rest of header does not parse because (a) no header length, (b) no CR after the the 3 mark bytes, or (c) header length is too short. Wait to see whether the length appears correct before deciding whether to rebuild the header or just smash it.") (* ; "Take all the stuff from BODYSTART as potential message") (if (OR (<= (SETQ ENDPTR (+ GOODPTR MSGLENGTH)) (GETFILEPTR FOLDERSTRM)) (> ENDPTR EOFPTR)) then (* ; "Length too short or points past eof.") (GO FINDSTART) elseif (AND (< ENDPTR EOFPTR) (PROGN (SETFILEPTR FOLDERSTRM ENDPTR) (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)))) then (* ; "Length doesn't point at next *start*, have to search for a boundary") (SETFILEPTR FOLDERSTRM ENDPTR) (if (AND (EQ (BIN FOLDERSTRM) 0) (to (- EOFPTR ENDPTR 1) always (EQ (BIN FOLDERSTRM) 0))) then (* ; "File is well-formed except for ending in a bunch of nulls. This seems to happen every once in a fhile when a file server spazzes. Throw them away.") (\MAILSCAVENGE.FORMAT "~%%Starting at byte ~D (after message #~D):~%% File ends in ~D null bytes. Will discard." ENDPTR MSGNO (- EOFPTR ENDPTR)) (if SCRATCHSTREAM then (* ; "Copy last message verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR) else (* ; "Note truncation here") (SETQ TRUNCATEPTR ENDPTR)) (add BADCOUNT 1) (GO DONE)) (GO FINDSTART) elseif BADHEADER then (* ; "Length ok, but header was malformed. It is likely to be safe to just overwrite the header") (add BADCOUNT 1) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ok, but header garbled." MSGNO GOODPTR) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR)) (if SCRATCHSTREAM then (* ; "Have to copy") (SETQ BODYSTART (+ GOODPTR FIELDWIDTH LAFITEBASICSTAMPLENGTH)) (SETQ MSGLENGTH (- ENDPTR BODYSTART)) (GO COPYMSG) else (* ; "Remember fixup") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH T)) (GO NEXT)) else (* ; "Well-formed message") (if (AND (< (- BODYSTART GOODPTR) STAMPLENGTH) (EQ (PROGN (SETFILEPTR FOLDERSTRM BODYSTART) (BIN FOLDERSTRM)) (CHARCODE *))) then (* ; "May be a funny one") (LET ((INFO (CL:READ-LINE FOLDERSTRM)) ISDUP) (if (AND (STRPOS "duplicate*" INFO 1 NIL T) (FIXP (SETQ INFO (SUBATOM INFO 11)))) then (* ; "This message claims to be a duplicate of the one at INFO") (SETQ ISDUP (\MAILSCAVENGE.DUPLICATE? FOLDERSTRM INFO GOODPTR STAMPLENGTH MSGLENGTH (OR DUPSCRATCH (SETQ DUPSCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH)))))) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D is marked as a duplicate of the one at byte~D from an aborted Expunge~A." MSGNO GOODPTR INFO (if (NOT ISDUP) then "; however, the original is not there" elseif SCRATCHSTREAM then " (not copied)" else "")) (if ISDUP then (* ; "Nothing to do.") (GO NEXT) elseif SCRATCHSTREAM then (SETQ BADHEADER T) (* ; "so that message gets undeleted") (GO COPYGOOD) else (* ; "Want to rewrite the flags") (push LENGTHFIXUPS (LIST GOODPTR NIL NIL T)) (GO NEXT))))) (if SCRATCHSTREAM then (* ; "Copy verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR)) (GO NEXT)) FINDSTART (* ;; "At this point, we have a malformed message starting at GOODPTR. Look for its end. If the header is also malformed, BADHEADER is true. BODYSTART points at what could be the start of text..") (SETQ TRYPTR BODYSTART) FINDSTARTLP (SETQ ENDPTR (FFILEPOS *START* FOLDERSTRM TRYPTR)) (if (NULL ENDPTR) then (* ; "Can't find next message. Maybe this is the last one") (if (AND (EQ MSGNO 1) BADHEADER) then (* ; "Never saw a single *start*") (if (NULL (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "There are no message boundaries in this file. Do you want to turn the file into a single message of length ~D?" (- EOFPTR GOODPTR)))) then (RETURN NIL))) (SETQ ENDPTR EOFPTR) elseif (AND LFP (PROGN (* ; "Have to check that an eol follows, since we're not sure which kind.") (SETFILEPTR FOLDERSTRM (+ ENDPTR (SUB1 *START*LENGTH))) (SELCHARQ (BIN FOLDERSTRM) ((CR LF) NIL) T))) then (SETQ TRYPTR (+ ENDPTR (- *START*LENGTH 2))) (GO FINDSTARTLP)) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ~:[missing~%% (~;incorrect~%% (file says ~:*~D, ~]apparent length is ~D)" MSGNO GOODPTR MSGLENGTH (if BADHEADER then (* ; "Estimate based on standard header size. We'll be exact later") (+ LAFITESTAMPLENGTH (SETQ MSGLENGTH (- ENDPTR BODYSTART))) else (SETQ MSGLENGTH (- ENDPTR GOODPTR)))) (add BADCOUNT 1) (if BADHEADER then (\MAILSCAVENGE.FORMAT "~%% Need to rebuild internal header. Message body may be malformed.") (GO COPYMSG)) (* ; "Header ok, just the length was wrong") (if (NULL SCRATCHSTREAM) then (* ; "Should suffice just to change length in place") (if (<= (NCHARS MSGLENGTH) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR))) then (* ; "Good, the correct length fits in the available space. Save for confirmation later") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH)) (GO NEXT)) (* ;; "Arrrgh, the length is too big. Fall thru to copy message to scratch file.") (\MAILSCAVENGE.FORMAT "~%%New length does not fit into old header, will have to rebuild.")) COPYGOOD (* ;; "Bring MSGLENGTH down to just the body length so we compute the new header correctly") (SETQ MSGLENGTH (- MSGLENGTH STAMPLENGTH)) COPYMSG (* ;; "At this point, we want to write the current message on scratch file. MSGLENGTH is the length of the body, sans header, starting at BODYSTART. If BADHEADER is true, we rebuild whole header. Otherwise, message is believed well-formed, so we can copy flag bytes from old message.") (if (NULL SCRATCHSTREAM) then (* ; "Have to set up scratch file") (\MAILSCAVENGE.FORMAT "~%%Opening scratch file to handle rebuilt header.") (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (if (> GOODPTR 0) then (\MAILSCAVENGE.FORMAT "~%%Copying ~D previous message~:P to scratch file..." (SUB1 MSGNO)) (COPYBYTES FOLDERSTRM SCRATCHSTREAM 0 GOODPTR) (\MAILSCAVENGE.FORMAT "done."))) (LA.PRINTHEADER SCRATCHSTREAM MSGLENGTH) (if BADHEADER then (* ; "Have to create afresh, so use primordial flags") (PRIN3 "UU " SCRATCHSTREAM) else (* ; "Original header was ok, except for length info, so copy flags and mark byte from it.") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM (- BODYSTART 4) BODYSTART) (SETQ BODYSTART (+ GOODPTR STAMPLENGTH))) (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM BODYSTART ENDPTR) NEXT (COND ((< (SETQ GOODPTR ENDPTR) EOFPTR) (* ; "Go process some more") (add MSGNO 1) (GO LP))) DONE (* ;; "All finished--shall we confirm it?") (if SCRATCHSTREAM then (* ; "Close this now (could be slow) before saying done.") (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM))) (if PWINDOW then (DSPXPOSITION XPOS PWINDOW) (PRIN1 "done. " PWINDOW)) (SETQ SUCCESS (if SCRATCHSTREAM then (* ; "We had to use a scratch file.") (if LENGTHFIXUPS then (* ; "Had some length fixups before we got to a really bad spot, so go back and do them now") (SETQ SCRATCHSTREAM (OPENSTREAM SCRATCHSTREAM (QUOTE BOTH) (QUOTE OLD) (QUOTE ((TYPE LAFITE))))) (CL:UNWIND-PROTECT (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS SCRATCHSTREAM) (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM)))) (if (AND (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Replace damaged mail file with scavenged file? ") (PROGN (if *FOLDER* then (\LAFITE.CLOSE.FOLDER *FOLDER* T) else (CLOSEF FOLDERSTRM)) (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHSTREAM FOLDERNAME) (if RESULT then T else (\MAILSCAVENGE.FORMAT "~%%RenameFile failed~@[ because ~A~]." CONDITION) NIL)))) then T else (* ; "File not renamed, either because of error or user choice. Tell where the scavenged file is.") (\MAILSCAVENGE.FORMAT "~%%Scavenged file stored as ~A." SCRATCHSTREAM MSGNO) NIL) elseif (AND (NULL LENGTHFIXUPS) (NULL TRUNCATEPTR)) then (\MAILSCAVENGE.FORMAT "~%%~A is a well-formed message file of ~D messages." FOLDERNAME MSGNO) NIL elseif (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Shall I correct these messages in the file? ") then (* ; "Do fixups in place") (if *FOLDER* then (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE BOTH))) elseif (NOT (OPENP FOLDERSTRM (QUOTE OUTPUT))) then (SETQ FOLDERSTRM (OPENSTREAM (CLOSEF FOLDERSTRM) (QUOTE BOTH) NIL (QUOTE ((TYPE LAFITE)))))) (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS FOLDERSTRM) (if TRUNCATEPTR then (* ; "Truncate file to drop nulls off end") (SETFILEINFO FOLDERSTRM (QUOTE LENGTH) TRUNCATEPTR)) (* ; "Return success") T)) (if SUCCESS then (\MAILSCAVENGE.FORMAT "done.~2%%You may want to examine the messages listed above for duplications or concatenated messages.~%%")) (if TSTREAM then (DETACHWINDOW TSTREAM) (\MAILSCAVENGE.FORMAT " (This report window is now detached from its browser. You may close it at your convenience.)")) (RETURN (AND SUCCESS FOLDERNAME))) (* ;; "Cleanup time") (if (type? MAILFOLDER *FOLDER*) then (\LAFITE.CLOSE.FOLDER *FOLDER* T) elseif (AND (STREAMP FOLDERSTRM) (OPENP FOLDERSTRM)) then (CLOSEF FOLDERSTRM)) (if (STREAMP SCRATCHSTREAM) then (* ; "Must have aborted.") (DELFILE (CLOSEF SCRATCHSTREAM)))))) ) (\MAILSCAVENGE.OPEN.SCRATCH (LAMBDA (FOLDERNAME) (* ; "Edited 3-May-89 13:03 by bvm") (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERNAME (QUOTE EXTENSION)) "-scavenged") (QUOTE BODY) FOLDERNAME) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE LAFITE) (SEQUENTIAL T))))) ) (\MAILSCAVENGE.LENGTHWIDTH (LAMBDA (FOLDERSTRM STARTPTR) (* ; "Edited 3-May-89 12:42 by bvm") (* ;; "Return the actual width of the %"message length%" field in this message") (LET ((LENSTART (+ STARTPTR *START*LENGTH))) (SETFILEPTR FOLDERSTRM LENSTART) (LA.READCOUNT FOLDERSTRM T) (- (GETFILEPTR FOLDERSTRM) LENSTART 1))) ) (\MAILSCAVENGE.LFCOPYBYTES (LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 3-May-89 13:07 by bvm") (* ;; "A COPYBYTES that turns LF into CR as it goes.") (SETFILEPTR SRCFIL START) (to (- END START) bind CH do (\BOUT DSTFIL (if (EQ (SETQ CH (BIN SRCFIL)) (CHARCODE LF)) then (CHARCODE CR) else CH)))) ) (\MAILSCAVENGE.READSTAMP (LAMBDA (STREAM) (* ; "Edited 3-May-89 12:20 by bvm") (* ;; "Like LA.READSTAMP, but also succeeds if the stamp ends in LF when we're processing a LF file.") (AND (EQ (BIN STREAM) (CHARCODE *)) (EQ (BIN STREAM) (CHARCODE s)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE a)) (EQ (BIN STREAM) (CHARCODE r)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE *)) (SELCHARQ (BIN STREAM) (CR T) (LF (EQ *EOL* (CHARCODE LF))) NIL))) ) (\MAILSCAVENGE.DUPLICATE? (LAMBDA (FOLDERSTRM OLDPTR GOODPTR STAMPLENGTH MSGLENGTH SCRATCH) (* ; "Edited 2-May-89 12:06 by bvm") (* ;; "True if the message at pointer OLDPTR is a duplicate of the one starting at GOODPTR with lengths STAMPLENGTH & MSGLENGTH.") (SETFILEPTR FOLDERSTRM OLDPTR) (LET (OLDLENGTH OLDSTAMP) (AND (LA.READSTAMP FOLDERSTRM) (SETQ OLDLENGTH (LA.READCOUNT FOLDERSTRM)) (SETQ OLDSTAMP (LA.READCOUNT FOLDERSTRM)) (\LAFITE.CHECK.DUPLICATE FOLDERSTRM SCRATCH GOODPTR STAMPLENGTH MSGLENGTH OLDPTR OLDSTAMP OLDLENGTH)))) ) (\MAILSCAVENGE.FORMAT (CL:LAMBDA (&REST ARGS) (* ; "Edited 21-Apr-89 15:25 by bvm") (if (TEXTSTREAMP *ERRORMSGSTREAM*) then (* ;; "It is MUCH faster to cons the string and hand it to tedit than to print a character at a time. One difference: unless we set the %"dontscroll%" flag, the window will scroll when we run off the bottom. This is probably desirable, as it means we look like we're doing something.") (TEDIT.INSERT *ERRORMSGSTREAM* (CL:APPLY (FUNCTION CL:FORMAT) NIL ARGS) (ADD1 (GETEOFPTR *ERRORMSGSTREAM*))) else (CL:APPLY (FUNCTION CL:FORMAT) *ERRORMSGSTREAM* ARGS))) ) (\MAILSCAVENGE.MAKEWINDOW (LAMBDA (FOLDER) (* ; "Edited 21-Apr-89 15:34 by bvm") (* ;; "Return a tedit window to use for Scavenger report, or NIL if FOLDER doesn't have a browser") (LET ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if BROWSERWINDOW then (LET* ((FONT (DSPFONT NIL (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (ERRHEIGHT (HEIGHTIFWINDOW (TIMES 10 (FONTPROP FONT (QUOTE HEIGHT))) T)) (ERRW (CREATEW (CREATEREGION 0 0 10 ERRHEIGHT) (CONCAT "Mail Scavenger Report for " (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER)) T))) (ATTACHWINDOW ERRW BROWSERWINDOW (if (< (fetch (REGION BOTTOM) of (WINDOWPROP BROWSERWINDOW (QUOTE REGION))) ERRHEIGHT) then (* ; "Won't fit below") (QUOTE TOP) else (QUOTE BOTTOM)) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (OPENTEXTSTREAM "" ERRW NIL NIL (BQUOTE (FONT (\, FONT) PROMPTWINDOW DON'T))) ERRW)))) ) (\MAILSCAVENGE.ASKUSER (LAMBDA (PROMPT) (DECLARE (CL:SPECIAL *FOLDER*)) (* ; "Edited 2-May-89 11:42 by bvm") (LET (BROWSERWINDOW) (if (AND *FOLDER* (SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of *FOLDER*))) then (* ; "Use the browser for interaction") (CLEARW BROWSERWINDOW) (FLASHWINDOW BROWSERWINDOW) (if (> (STRINGWIDTH PROMPT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE WIDTH))) then (* ; "Sigh, too wide to centerprint. I wish we had better text layout...") (RELMOVETO 0 (- (IQUOTIENT (WINDOWPROP BROWSERWINDOW (QUOTE HEIGHT)) 2)) BROWSERWINDOW) (PRIN3 PROMPT BROWSERWINDOW) else (* ; "Nicely center the prompt") (CENTERPRINTINREGION PROMPT NIL BROWSERWINDOW)) (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of *FOLDER*)) (MENUWREG (WINDOWPROP MENUW (QUOTE REGION))) (MENUWIDTH (fetch (REGION WIDTH) of MENUWREG)) (ITEMS (QUOTE (("Proceed" T "Continue the scavenge as asked") ("Abort" NIL "Abort the mail scavenge operation")))) (MENU (create MENU ITEMS _ ITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT MENUROWS _ 1 ITEMWIDTH _ (MAX (STRINGWIDTH (CAAR ITEMS) LAFITEMENUFONT) (IQUOTIENT MENUWIDTH 4)) MENUOUTLINESIZE _ 0 MENUBORDERSIZE _ 0))) (* ; "Position the menu in the middle of the browser's menu window") (PROG1 (MENU MENU (LA.POSITION.FROM.REGION MENUWREG (IQUOTIENT (- MENUWIDTH (fetch (MENU IMAGEWIDTH) of MENU)) 2) (WINDOWPROP MENUW (QUOTE BORDER))) T) (CLEARW BROWSERWINDOW))) else (EQ (ASKUSER NIL NIL PROMPT) (QUOTE Y))))) ) (\MAILSCAVENGE.FIX.LENGTHS (LAMBDA (FIXUPS STREAM) (* ; "Edited 3-May-89 12:42 by bvm") (* ;; "Perform length fixups. FIXUPS has entries of the form (startptr length fieldwidth fixheader)") (for ENTRY in FIXUPS do (DESTRUCTURING-BIND (START LENGTH FIELDWIDTH FIXHEADER) ENTRY (SETFILEPTR STREAM (+ START *START*LENGTH)) (if LENGTH then (LA.PRINTCOUNT LENGTH STREAM (BQUOTE (FIX (\, FIELDWIDTH) 10 T))) else (LA.READCOUNT STREAM)) (if FIXHEADER then (* ; "Write the rest of the header, too") (if LENGTH then (LA.PRINTCOUNT (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH) STREAM) else (LA.READCOUNT STREAM)) (PRIN3 "UU " STREAM)))))) (\MAILSCAVENGE.CONFIRM (LAMBDA (BADNO TOTALNO PROMPT) (* ; "Edited 21-Apr-89 15:27 by bvm") (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM*)) (* ;; "Called at end of scavenge to report results. Return T/NIL response to PROMPT") (LET ((FORMATSTRING "~2%%Finished, found ~D bad messages out of ~D total messages.~%%")) (\MAILSCAVENGE.FORMAT FORMATSTRING BADNO TOTALNO) (if (\MAILSCAVENGE.ASKUSER PROMPT) then (if *FOLDER* then (* ; "Make sure to delete any toc that might be hanging around") (DELFILE (TOCFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of *FOLDER*)))) (\MAILSCAVENGE.FORMAT "Working... ") (* ; "Show some response") T))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ *START*LENGTH 8) (CONSTANTS (*START*LENGTH 8)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \MAILSCAVENGE.FORMAT) ) (PUTPROPS MAILSCAVENGE COPYRIGHT ("Venue & Xerox Corporation" 1985 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1429 21135 (LAFITE.SCAVENGE 1439 . 1871) (\MAILSCAVENGE.INTERNAL 1873 . 14946) ( \MAILSCAVENGE.OPEN.SCRATCH 14948 . 15279) (\MAILSCAVENGE.LENGTHWIDTH 15281 . 15609) ( \MAILSCAVENGE.LFCOPYBYTES 15611 . 15916) (\MAILSCAVENGE.READSTAMP 15918 . 16395) ( \MAILSCAVENGE.DUPLICATE? 16397 . 16940) (\MAILSCAVENGE.FORMAT 16942 . 17529) (\MAILSCAVENGE.MAKEWINDOW 17531 . 18396) (\MAILSCAVENGE.ASKUSER 18398 . 19864) (\MAILSCAVENGE.FIX.LENGTHS 19866 . 20494) ( \MAILSCAVENGE.CONFIRM 20496 . 21133))))) STOP \ No newline at end of file diff --git a/library/lafite/NEWNSMAIL.~1~ b/library/lafite/NEWNSMAIL.~1~ deleted file mode 100644 index c2d72274..00000000 --- a/library/lafite/NEWNSMAIL.~1~ +++ /dev/null @@ -1,409 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 6-Aug-93 17:20:37" {DSK}lafite>sources>NEWNSMAIL.;45 83395 - - changes to%: (VARS NEWNSMAILCOMS) (FNS \NSMAIL.NEW.SEND.PARSE \NSMAIL.NEW.CHECK \NSMAIL.NEW.AUTHENTICATE \NSMAIL.NEW.SEND) - (ALISTS (LAFITEMODELST NS)) - - previous date%: "11-Nov-92 17:15:26" {DSK}lafite>sources>NEWNSMAIL.;43) - - -(* ; " -Copyright (c) 1989, 1990, 1992, 1993 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT NEWNSMAILCOMS) - -(RPAQQ NEWNSMAILCOMS ((COURIERPROGRAMS NEW.MAILTRANSPORT NEW.INBASKET) (COMS (* ; "Courier type EnvelopeItem") (FNS \NS.NEW.READ.ENVELOPE.ITEM \NS.NEW.WRITE.ENVELOPE.ITEM) (VARS \NSMAIL.NEW.ENVELOPE.ITEM.TYPES) (PROP COURIERDEF NEW.ENVELOPE.ITEM)) (COMS (* ; "Courier type HeadingAttribute") (FNS \NS.READ.HEADING.ATTRIBUTE \NS.WRITE.HEADING.ATTRIBUTE) (VARS \NSMAIL.HEADING.ATTRIBUTES) (PROP COURIERDEF HEADING.ATTRIBUTE)) (COMS (* ; "Courier type RName") (FNS \NSMAIL.READ.RNAME \NSMAIL.WRITE.RNAME \NSMAIL.RNAME.LENGTH) (PROP COURIERDEF NEW.RNAME) (FNS RNAME.TO.STRING X400.NAME.TO.STRING EQUAL.RNAMES)) (COMS (* ; "Posting") (FNS \NSMAIL.NEW.SEND.PARSE \NSMAIL.CHECK.ENUMERATION \NSMAIL.NEW.SEND \NSMAIL.NEW.INVALID.RECIPIENTS \NSMAIL.BUILD.HEADING \NSMAIL.POST.BODY.PART \NSMAIL.NEW.PREPARE.ATTACHMENT \NSMAIL.CHECK.ABORT \NSMAIL.NEW.FINDSERVER \NSMAIL.NEW.CHECKSERVER) (VARS NSMAIL.PARSEFIELDS (\LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS))) (INITVARS (*NEWNSMAIL-POST-AS-TEXTFILE* :TEST) (*NEWNSMAIL-REPORT-TYPE* (QUOTE NON.DELIVERY.ONLY)) (*NSMAIL-ALLOW-DL-RECIPIENTS* T) (*NSMAIL-RETURN-CONTENTS* T) (*NSMAIL-MIN-WILLINGNESS* 9) (*NSMAIL-TRACE-SERVERS*) (*NSMAIL-GENERATE-MESSAGE-ID*) (*NSMAIL-DISPLAY-TRANSPORT-ID*) (*NSMAIL-DISPLAY-POSTMARK*) (*NSMAIL-DISPLAY-ERRORS-TO*) (*NSMAIL-CACHE-TIMEOUT* (TIMES 1000 60 60)) (\NSMAIL.MIN.VP.TYPE 4300) (\NSMAIL.MAX.VP.TYPE 5200) (\NSMAIL.NEW.SERVER.CACHE)) (VARS (*NSMAIL-OP-VECTOR* (QUOTE (NEWNS.POLLNEWMAIL NEWNS.OPENMAILBOX NEWNS.NEXTMESSAGE NEWNS.RETRIEVEMESSAGE NEWNS.CLOSEMAILBOX)))) (GLOBALVARS \NSMAIL.NEW.SERVER.CACHE \NSMAIL.MIN.VP.TYPE \NSMAIL.MAX.VP.TYPE) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *NEWNSMAIL-POST-AS-TEXTFILE* *NEWNSMAIL-REPORT-TYPE* *NSMAIL-ALLOW-DL-RECIPIENTS* *NSMAIL-RETURN-CONTENTS* *NSMAIL-MIN-WILLINGNESS* *NSMAIL-TRACE-SERVERS* *NSMAIL-GENERATE-MESSAGE-ID* *NSMAIL-DISPLAY-TRANSPORT-ID* *NSMAIL-DISPLAY-POSTMARK* *NSMAIL-DISPLAY-ERRORS-TO* *NSMAIL-CACHE-TIMEOUT*))))) (COMS (* ; "Retrieving") (FNS \NSMAIL.NEW.AUTHENTICATE NEWNS.POLLNEWMAIL NEWNS.OPENMAILBOX \NSMAIL.NEW.CHECK NEWNS.NEXTMESSAGE NEWNS.RETRIEVEMESSAGE \NSMAIL.READ.BODY.PARTS \NSMAIL.COPY.IA5 \NSMAIL.COPY.NSTEXTFILE \NSMAIL.READ.HEADING \NSMAIL.PARSE.ANNOTATION \NSMAIL.EMIT.ANNOTATION LA.TRIM.WHITESPACE \NSMAIL.READ.FORWARDING \NSMAIL.NEW.PRINT.HEADING \NSMAIL.NEW.PRINT.NAMES \NSMAIL.EMIT.FORWARDING \NSMAIL.GDATE \NSMAIL.TRANSLATE.IP.MESSAGEID \NSMAIL.MAYBE.QUOTE NULL.NSNAME \NSMAIL.HANDLE.DELIVERY.REPORT \NSMAIL.RECIPIENT.NAME NEW.INBASKET.CALL NEWNS.CLOSEMAILBOX \NSMAIL.NEW.LOGOFF) (VARS \NSMAIL.GOOD.BODY.PARTS \NSMAIL.DISCARDABLE.BODY.PARTS) (GLOBALVARS \NSMAIL.GOOD.BODY.PARTS \NSMAIL.DISCARDABLE.BODY.PARTS) (ALISTS (LAFITEMODELST NS)) (FILES NSMAIL)) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (RECORDS FORWARD) (MACROS \NSMAIL.BODY.PART.TYPE) (GLOBALVARS \NSMAIL.BODY.PART.TYPES \NSMAIL.HEADING.ATTRIBUTES) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *RETRIEVAL-ERROR*)))) (FILES (SOURCE) LAFITEDECLS) (FILES (LOADCOMP) NSMAIL) (CONSTANTS * \NSMAIL.CONTENTS.TYPES) (* ; "This one we need at run time also") DOCOPY (VARS \NSMAIL.BODY.PART.TYPES)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NEW.INBASKET.CALL))))) - -(COURIERPROGRAM NEW.MAILTRANSPORT (17 5) - TYPES - ((CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER)) (SESSION (RECORD (TOKEN (ARRAY 2 UNSPECIFIED)) (VERIFIER VERIFIER))) (ENVELOPE.ITEM.TYPE LONGCARDINAL) (ENVELOPE (SEQUENCE NEW.ENVELOPE.ITEM)) (INVALID.NAME (RECORD (ID CARDINAL) (REASON INVALID.REASON))) (INVALID.NAME.LIST (SEQUENCE INVALID.NAME)) (INVALID.REASON (ENUMERATION (NoSuchRecipient 0) (NoMailboxForRecipient 1) (IllegalName 2) (NoDlsAllowed 3) (ReportNotAllowed 4))) (NAME NSNAME) (RNAME NEW.RNAME (* ; "(choice (xns 0 name) (gateway 1 gateway.name))")) (RNAME.LIST (SEQUENCE RNAME)) (GATEWAY.NAME (RECORD (COUNTRY STRING) (ADMIN.DOMAIN STRING) (PRIVATE.DOMAIN STRING) (ORGANIZATION STRING) (ORGANIZATIONAL.UNITS (SEQUENCE STRING)) (PERSONAL (CHOICE (WHOLE 0 STRING) (BROKEN 1 BROKEN.NAME))) (GATEWAY.SPECIFIC.INFORMATION (SEQUENCE X400.ATTRIBUTE)))) (BROKEN.NAME (RECORD (GIVEN STRING) (INITIALS STRING) (FAMILY STRING) (GENERATION STRING))) (X400.ATTRIBUTE (RECORD (TYPE STRING) (VALUE STRING))) (REPORT.TYPE (ENUMERATION (NONE 0) (NON.DELIVERY.ONLY 1) (ALL 2))) (RECIPIENT (RECORD (NAME RNAME) (RECIPIENT.ID CARDINAL) (REPORT REPORT.TYPE))) (RECIPIENT.LIST (SEQUENCE RECIPIENT)) (WILLINGNESS (SEQUENCE WILLINGNESS.METRIC)) (WILLINGNESS.METRIC CARDINAL) (BODY.PART.TYPE LONGCARDINAL) (CONTENTS.TYPE LONGCARDINAL) (MESSAGEID (ARRAY 5 UNSPECIFIED)) (POSTING.DATA (RECORD (RECIPIENTS RECIPIENT.LIST) (CONTENTS.TYPE CONTENTS.TYPE) (CONTENTS.SIZE LONGCARDINAL) (BODY.PART.TYPES.SEQUENCE (SEQUENCE BODY.PART.TYPE)))) (POSTMARK (RECORD (POSTED.AT RNAME) (TIME TIME))) (TOC (SEQUENCE TOC.ITEM)) (TOC.ITEM (RECORD (TYPE BODY.PART.TYPE) (SIZE LONGCARDINAL))) (REPORT (RECORD (ORIGINAL.ENVELOPE ENVELOPE) (FATE (CHOICE (DELIVERED 0 (ENUMERATION (CONTENTS.TRUNCATED 0) (NO.PROBLEM 1))) (NOT.DELIVERED 1 (RECORD (REASON NON.DELIVERY.REASON) (POSTMARK POSTMARK))))) (REPORT.TYPE (CHOICE (DLMEMBER 0 DLREPORT) (OTHER 1 OTHER.REPORT))))) (DLREPORT (RECORD (DLNAME RNAME) (INVALID.RECIPIENTS (SEQUENCE NON.DELIVERED.RECIPIENT)))) (OTHER.REPORT (RECORD (SUCCEEDED (SEQUENCE DELIVERED.RECIPIENT)) (FAILED (SEQUENCE NON.DELIVERED.RECIPIENT)))) (DELIVERED.RECIPIENT (RECORD (RECIPIENT RECIPIENT) (WHEN TIME))) (NON.DELIVERED.RECIPIENT (RECORD (RECIPIENT RECIPIENT) (REASON NON.DELIVERY.REASON))) (NON.DELIVERY.REASON (ENUMERATION (NoSuchRecipient 0) (NoMailboxForRecipient 1) (IllegalName 2) (Timeout 3) (ReportNotAllowed 4) (MessageTooLong 5) (AmbiguousRName 6) (IllegalCharacters 7) (UnsupportedBodyParts 8) (UnsupportedContentsType 9) (TransientProblem 10) (ContentSyntaxError 11) (TooManyRecipients 12) (ProtocolViolation 13) (X400PragmaticConstraintViolation 14) (x400NoBilateralAgreement 15) (AccessRightsInsufficientForDL 16) (Other 17))) (TRANSPORT.OPTIONS (RECORD (RETURN.OF.CONTENTS BOOLEAN) (ALTERNATE.RECIPIENT.ALLOWED BOOLEAN))) (PRIORITY (ENUMERATION (NonUrgent 0) (Normal 1) (Urgent 2))) (CONVERTED.ITEM (ENUMERATION (IA5TextToTeletex 0) (TeletexToTelex 1) (TeletexToIA5Text 2) (TelexToTeletex 3))) (IP.MESSAGEID (RECORD (ORIGINATOR RNAME) (UNIQUESTRING STRING))) (AUTHENTICATION.LEVEL (ENUMERATION (Strong 0) (Simple 1) (Foreign 2))) (FORWARDED.MESSAGE.INFO (RECORD (ENVELOPE ENVELOPE) (HEADING (SEQUENCE HEADING.ATTRIBUTE)) (ASSOCIATED.BODY.PARTS (SEQUENCE BODY.PART.INDEX)) (INDEX.OF.PARENT.HEADING (CHOICE (NULL 0 (RECORD)) (NESTED 1 CARDINAL))))) (BODY.PART.INDEX CARDINAL) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2) (MediumFull 3))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0))) (OTHER.PROBLEM (ENUMERATION (Can'tExpedite 0) (MalformedMessage 1) (IncorrectContentsSize 2) (LAST 65535))) (SESSION.PROBLEM (ENUMERATION (InvalidHandle 0) (WrongState 1)))) - PROCEDURES - ((SERVER.POLL 0 NIL RETURNS (WILLINGNESS (CLEARINGHOUSE . NETWORK.ADDRESS.LIST) NAME)) (BEGIN.POST 1 (POSTING.DATA BOOLEAN BOOLEAN (SEQUENCE NEW.ENVELOPE.ITEM) CREDENTIALS VERIFIER) RETURNS (SESSION INVALID.NAME.LIST) REPORTS (AUTHENTICATION.ERROR INVALID.RECIPIENTS SERVICE.ERROR OTHER.ERROR)) (MAILPOLL 7 (NAME CREDENTIALS VERIFIER) RETURNS (BOOLEAN) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR)) (POST.ONE.BODY.PART 8 (SESSION BODY.PART.TYPE BULK.DATA.SOURCE) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR SESSION.ERROR TRANSFER.ERROR)) (END.POST 9 (SESSION BOOLEAN) RETURNS (MESSAGEID) REPORTS (AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR SESSION.ERROR TRANSFER.ERROR))) - ERRORS - ((ACCESS.ERROR 0 (ACCESS.PROBLEM)) (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) (INVALID.RECIPIENTS 3 (INVALID.NAME.LIST)) (SERVICE.ERROR 4 (SERVICE.PROBLEM)) (TRANSFER.ERROR 5 (TRANSFER.PROBLEM)) (OTHER.ERROR 6 (OTHER.PROBLEM)) (SESSION.ERROR 7 (SESSION.PROBLEM))) -) - -(COURIERPROGRAM NEW.INBASKET (18 2) - INHERITS - (NEW.MAILTRANSPORT) - TYPES - ((CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER)) (NAME NSNAME) (INDEX LONGCARDINAL) (RANGE (RECORD (LOW INDEX) (HIGH INDEX))) (MESSAGE.STATUS (RECORD (USER.DEFINED.STATUS CARDINAL) (EXISTENCE.OF.MESSAGE (ENUMERATION (NEW 0) (KNOWN 1))))) (BODY.PART.SEQUENCE (SEQUENCE BODY.PART.INDEX)) (BODY.PART.STATUS (SEQUENCE BOOLEAN)) (BODY.PART.STATUS.CHANGE (RECORD (BODY.PART.INDEX BODY.PART.INDEX) (DELETABLE (ENUMERATION (TRUE 0) (NOCHANGE 1))))) (BODY.PART.STATUS.CHANGE.SEQUENCE (SEQUENCE BODY.PART.STATUS.CHANGE)) (STATUS (RECORD (MESSAGE.STATUS MESSAGE.STATUS) (BODY.PART.STATUS BODY.PART.STATUS))) (SESSION (RECORD (TOKEN (ARRAY 2 UNSPECIFIED)) (VERIFIER VERIFIER))) (ANCHOR (ARRAY 5 UNSPECIFIED)) (STATE (RECORD (NEW CARDINAL) (TOTAL CARDINAL))) (WHICH.MESSAGE (ENUMERATION (THIS 0) (NEXT 1))) (ACCESS.PROBLEM (ENUMERATION (AccessRightsInsufficient 0) (AccessRightsIndeterminate 1) (NoSuchInbasket 2) (InbasketIndeterminate 3) (WrongService 4))) (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM)) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0))) (SESSION.PROBLEM (ENUMERATION (TokenInvalid 0))) (OTHER.PROBLEM (ENUMERATION (USE.COURIER 0) (MalformedMessage 1) (InvalidOperation 2) (LAST 65535))) (INDEX.PROBLEM (ENUMERATION (InvalidIndex 0) (InvalidBodyPartIndex 1)))) - PROCEDURES - ((LOGON 5 (NAME CREDENTIALS VERIFIER) RETURNS (SESSION STATE ANCHOR) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR INBASKET.IN.USE SERVICE.ERROR OTHER.ERROR)) (LOGOFF 4 (SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SESSION.ERROR OTHER.ERROR)) (MAILPOLL 7 (NAME CREDENTIALS VERIFIER) RETURNS (STATE) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR)) (MAILCHECK 6 (SESSION) RETURNS (STATE) REPORTS (AUTHENTICATION.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (RETRIEVE.ENVELOPES 2 (INDEX WHICH.MESSAGE SESSION) RETURNS (ENVELOPE STATUS INDEX)) (RETRIEVE.BODY.PARTS 8 (INDEX BODY.PART.SEQUENCE BULK.DATA.SINK SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR INDEX.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR TRANSFER.ERROR)) (CHANGE.MESSAGE.STATUS 0 (RANGE BOOLEAN CARDINAL SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR INDEX.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (CHANGE.BODY.PARTS.STATUS 3 (INDEX BODY.PART.STATUS.CHANGE.SEQUENCE SESSION) RETURNS (BOOLEAN) REPORTS (AUTHENTICATION.ERROR INDEX.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (DELETE 1 (RANGE SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (GET.SIZE 10 (NAME CREDENTIALS VERIFIER) RETURNS (LONGCARDINAL) REPORTS (AUTHENTICATION.ERROR ACCESS.ERROR SERVICE.ERROR OTHER.ERROR))) - ERRORS - ((ACCESS.ERROR 0 (ACCESS.PROBLEM)) (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) (SESSION.ERROR 5 (SESSION.PROBLEM)) (SERVICE.ERROR 6 (SERVICE.PROBLEM)) (TRANSFER.ERROR 7 (TRANSFER.PROBLEM)) (OTHER.ERROR 8 (OTHER.PROBLEM)) (INDEX.ERROR 9 (INDEX.PROBLEM)) (INBASKET.IN.USE 10 (NAME))) -) - - - -(* ; "Courier type EnvelopeItem") - -(DEFINEQ - -(\NS.NEW.READ.ENVELOPE.ITEM -(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:53 by bvm") (* ;; "Reads a mailing envelope attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE); if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (LET* ((TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (VALUETYPE (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.NEW.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CADR TRIPLE)) (SETQ TYPE (QUOTE (\, (CAR TRIPLE)))) (QUOTE (\, (CADDR TRIPLE)))))))))))) (LIST TYPE (if VALUETYPE then (\WIN STREAM) (* ; "Skip sequence count") (COURIER.READ STREAM PROGRAM VALUETYPE) else (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED)))))) -) - -(\NS.NEW.WRITE.ENVELOPE.ITEM -(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:53 by bvm") (* ;;; "Writes a filing attribute value pair to STREAM. ITEM is a list of two elements (TYPE VALUE)") (LET ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COURIER.WRITE STREAM (OR (FIXP TYPE) (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.NEW.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CAR TRIPLE)) (SETQ VALUETYPE (QUOTE (\, (CADDR TRIPLE)))) (QUOTE (\, (CADR TRIPLE))))))) (T (ERROR "Unknown Envelope Item Type" TYPE)))))) NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED)))))) -) -) - -(RPAQQ \NSMAIL.NEW.ENVELOPE.ITEM.TYPES ((Postmark 0 POSTMARK) (Message-ID 1 MESSAGEID) (ContentsType 2 CONTENTS.TYPE) (TOC 3 TOC) (CONTENTS.SIZE 4 LONGCARDINAL) (Originator 5 RNAME) (REPORT 6 REPORT) (RETURN.TO.NAME 7 RNAME) (Previous-Recipients 8 RECIPIENT.LIST) (GatewayPostmark 9 POSTMARK) (AddressChangeNotice 10 RNAME) (TRANSPORT.OPTIONS 11 TRANSPORT.OPTIONS) (X400SpecificReportInformation 12 (SEQUENCE (SEQUENCE UNSPECIFIED))) (OtherRecipients 13 RECIPIENT.LIST) (Priority 14 PRIORITY) (Converted 15 (SEQUENCE CONVERTED.ITEM)) (AuthenticationLevelOfSender 16 AUTHENTICATION.LEVEL))) - -(PUTPROPS NEW.ENVELOPE.ITEM COURIERDEF (\NS.NEW.READ.ENVELOPE.ITEM \NS.NEW.WRITE.ENVELOPE.ITEM)) - - - -(* ; "Courier type HeadingAttribute") - -(DEFINEQ - -(\NS.READ.HEADING.ATTRIBUTE -(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 25-Jan-90 16:59 by bvm") (* ;; "Reads a mail heading attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE); if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (bind (TYPE _ (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) for X in \NSMAIL.HEADING.ATTRIBUTES when (EQ (CADR X) TYPE) do (RETURN (LIST* (CAR X) (LET* ((RANDP (RANDACCESSP STREAM)) (END (+ (UNFOLD (\WIN STREAM) BYTESPERWORD) (if RANDP then (GETFILEPTR STREAM) else 0))) HERE) (CONS (COURIER.READ STREAM (OR PROGRAM (QUOTE NEW.MAILTRANSPORT)) (CADDR X)) (if (AND RANDP (NOT (EQL (SETQ HERE (GETFILEPTR STREAM)) END))) then (if (> HERE END) then (HELP "Heading attribute overran by " (- HERE END)) else (to (- END HERE) collect (BIN STREAM)))))))) finally (* ; "TYPE not recognized") (RETURN (LIST TYPE (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED)))))) -) - -(\NS.WRITE.HEADING.ATTRIBUTE -(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 18:17 by bvm") (* ;;; "Writes a mail heading attribute value pair to STREAM. ITEM is a list of two elements (TYPE VALUE)") (PROG ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COND ((NOT (FIXP TYPE)) (for X in \NSMAIL.HEADING.ATTRIBUTES when (EQ (CAR X) TYPE) do (SETQ TYPE (CADR X)) (SETQ VALUETYPE (CADDR X)) (RETURN) finally (ERROR "Unknown Heading Attribute Type" TYPE)))) (COURIER.WRITE STREAM TYPE NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED)))))) -) -) - -(RPAQQ \NSMAIL.HEADING.ATTRIBUTES ((Message-ID 1 IP.MESSAGEID) (Sender 2 RNAME) (From 3 RNAME.LIST) (To 4 RNAME.LIST) (cc 5 RNAME.LIST) (bcc 6 RNAME.LIST) (In-Reply-to 7 IP.MESSAGEID) (Obsoletes 8 (SEQUENCE IP.MESSAGEID)) (References 9 (SEQUENCE IP.MESSAGEID)) (Subject 10 STRING) (Expiration-Date 11 TIME) (Reply-By 12 TIME) (Reply-to 13 RNAME.LIST) (Importance 14 (ENUMERATION (Low 0) (Normal 1) (High 2))) (Sensitivity 15 (ENUMERATION (Personal 0) (Private 1) (CompanyConfidential 2))) (Auto-Forwarded 16 BOOLEAN) (Immutable 17 (RECORD)) (Reply-Requested-of 18 RNAME.LIST) (TextAnnotation 19 STRING) (ForwardedHeadings 20 (SEQUENCE FORWARDED.MESSAGE.INFO)) (newTextAnnotation 199 STRING) (BodyOffset 198 LONGCARDINAL) (LispFormatting 4911 STRING))) - -(PUTPROPS HEADING.ATTRIBUTE COURIERDEF (\NS.READ.HEADING.ATTRIBUTE \NS.WRITE.HEADING.ATTRIBUTE)) - - - -(* ; "Courier type RName") - -(DEFINEQ - -(\NSMAIL.READ.RNAME -(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 29-Nov-89 12:53 by bvm") (* ;; "Special code to read newmailtransport.rname, whose definition is (choice (xns 0 name) (gateway 1 gateway.name)). The xns name we return as an NSNAME object, all other types as if they had been read as the definition reads.") (LET ((CHOICE (\WIN STREAM))) (CASE CHOICE (0 (COURIER.READ.NSNAME STREAM PROGRAM (QUOTE NSNAME))) (1 (LIST (QUOTE GATEWAY) (COURIER.READ STREAM PROGRAM (QUOTE GATEWAY.NAME)))) (T (ERROR "Not a recognized type of RNAME" CHOICE))))) -) - -(\NSMAIL.WRITE.RNAME -(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 29-Nov-89 12:52 by bvm") (* ;; "Special code to write newmailtransport.rname. ITEM can be an NSNAME or a list (GATEWAY gatewayname).") (if (TYPEP ITEM (QUOTE NSNAME)) then (\WOUT STREAM 0) (COURIER.WRITE.NSNAME STREAM ITEM PROGRAM (QUOTE NSNAME)) elseif (EQ (CAR (LISTP ITEM)) (QUOTE GATEWAY)) then (\WOUT STREAM 1) (COURIER.WRITE STREAM (CADR ITEM) PROGRAM (QUOTE GATEWAY.NAME)) else (ERROR "ARG not RNAME" ITEM))) -) - -(\NSMAIL.RNAME.LENGTH -(LAMBDA (ITEM PROGRAM TYPE) (* ; "Edited 29-Nov-89 21:22 by bvm") (+ 1 (if (TYPEP ITEM (QUOTE NSNAME)) then (COURIER.NSNAME.LENGTH ITEM PROGRAM (QUOTE NSNAME)) elseif (EQ (CAR (LISTP ITEM)) (QUOTE GATEWAY)) then (COURIER.REP.LENGTH (CADR ITEM) PROGRAM (QUOTE GATEWAY.NAME)) else (ERROR "ARG not RNAME" ITEM)))) -) -) - -(PUTPROPS NEW.RNAME COURIERDEF (\NSMAIL.READ.RNAME \NSMAIL.WRITE.RNAME \NSMAIL.RNAME.LENGTH)) -(DEFINEQ - -(RNAME.TO.STRING -(LAMBDA (NAME FULLFLG) (* ; "Edited 4-Apr-90 17:26 by bvm") (CL:ETYPECASE NAME (NSNAME (NSNAME.TO.STRING NAME FULLFLG)) (LIST (X400.NAME.TO.STRING NAME)))) -) - -(X400.NAME.TO.STRING -(LAMBDA (NAME) (* ; "Edited 4-Apr-90 17:27 by bvm") (LET ((SLASH "/") TMP) (if (NEQ (CAR NAME) (QUOTE GATEWAY)) then (ERROR "ARG NOT X400 NAME" NAME) else (SETQ NAME (CADR NAME))) (CONCATLIST (BQUOTE ((\, SLASH) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) COUNTRY of NAME)) (LIST "C=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) ADMIN.DOMAIN of NAME)) (LIST "ADMD=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) PRIVATE.DOMAIN of NAME)) (LIST "PRMD=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) ORGANIZATION of NAME)) (LIST "O=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) ORGANIZATIONAL.UNITS of NAME)) (for UNIT in TMP join (LIST "OU=" UNIT SLASH)))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) PERSONAL of NAME)) (CASE (CAR TMP) (WHOLE (LIST "PN=" (CADR TMP) SLASH)) (BROKEN (LET ((BROKEN (CADR TMP))) (BQUOTE ((\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) GIVEN of BROKEN)) (LIST "G=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) INITIALS of BROKEN)) (LIST "I=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) FAMILY of BROKEN)) (LIST "S=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) GENERATION of BROKEN)) (LIST "GQ=" TMP SLASH)))))))))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) GATEWAY.SPECIFIC.INFORMATION of NAME)) (for PAIR in TMP join (LIST (CAR PAIR) "=" (CADR PAIR) SLASH))))))))) -) - -(EQUAL.RNAMES -(LAMBDA (NAME1 NAME2) (* ; "Edited 4-Apr-90 17:21 by bvm") (if (type? NSNAME NAME1) then (AND (type? NSNAME NAME2) (EQUAL.CH.NAMES NAME1 NAME2)) else (EQUAL NAME1 NAME2))) -) -) - - - -(* ; "Posting") - -(DEFINEQ - -(\NSMAIL.NEW.SEND.PARSE -(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 6-Aug-93 16:40 by bvm") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) RECIPIENTS MSGFIELDS FORMATTEDP HEADEREOF INTERESTINGFIELDS SUBJECT ATTACHMENT) (OR (SETQ MSGFIELDS (\LAFITE.PREPARE.SEND MSG EDITORWINDOW \LAPARSE.NSMAIL)) (RETURN)) (COND ((EQ (CAAR MSGFIELDS) (QUOTE EOF)) (SETQ HEADEREOF (CADR (pop MSGFIELDS))))) (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) ((To cc From Reply-to) (push INTERESTINGFIELDS (RPLACD PAIR (\NSMAIL.PARSE (CDR PAIR) SENDER EDITORWINDOW))) (SELECTQ (CAR PAIR) ((To cc) (LET ((EXPANDED (for NAME in (CDR PAIR) join (if (CL:STRING= (fetch NSDOMAIN of NAME) ";") then (* ; "DL syntax") (\NSMAIL.EXPAND.DL (fetch NSOBJECT of NAME) SENDER EDITORWINDOW) else (LIST NAME))))) (SETQ RECIPIENTS (COND (RECIPIENTS (NS.REMOVEDUPLICATES (APPEND EXPANDED RECIPIENTS))) (T EXPANDED))))) (PROGN (* ; "Might want to check validity of From and Reply-to") NIL))) ((Subject In-Reply-to) (LET ((STR (COND ((CDDR PAIR) (* ; "Make one string") (CONCATLIST (CDR PAIR))) (T (CADR PAIR))))) (COND ((EQ (CAR PAIR) (QUOTE Subject)) (SETQ SUBJECT STR)) (T (* ; "format is different in new protocol") (SETQ STR (COURIER.CREATE (NEW.MAILTRANSPORT . IP.MESSAGEID) ORIGINATOR _ (create NSNAME NSOBJECT _ "" NSDOMAIN _ "" NSORGANIZATION _ "") UNIQUESTRING _ STR)))) (RPLACD PAIR STR) (push INTERESTINGFIELDS PAIR))) (Date (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) (Sender (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) (Format (SETQ FORMATTEDP (SELECTQ (CADR PAIR) (TEDIT T) NIL))) ((REFERENCE ATTACHMENT) (if ATTACHMENT then (\SENDMESSAGEFAIL EDITORWINDOW "Can only send a single attachment")) (SETQ ATTACHMENT T) (push INTERESTINGFIELDS PAIR)) ((Importance Sensitivity Immutable) (if (AND (> (NCHARS (CADR PAIR)) 0) (SETQ PAIR (\NSMAIL.CHECK.ENUMERATION PAIR EDITORWINDOW))) then (push INTERESTINGFIELDS PAIR))) NIL)) (COND ((NULL RECIPIENTS) (\SENDMESSAGEFAIL EDITORWINDOW "No recipients!"))) (OR FORMATTEDP (SELECTQ (\LAFITE.CHOOSE.MSG.FORMAT MSG NIL EDITORWINDOW) (TEDIT (SETQ FORMATTEDP T)) (NIL (* ; "Aborted") (RETURN)) NIL)) (RETURN (create NSMAILPARSE NSPSUBJECT _ SUBJECT NSPRECIPIENTS _ RECIPIENTS NSPSTART _ HEADEREOF NSPFIELDS _ INTERESTINGFIELDS NSPFORMATTED _ FORMATTEDP)))) -) - -(\NSMAIL.CHECK.ENUMERATION -(LAMBDA (PAIR EDITORWINDOW) (* ; "Edited 24-Jan-90 16:35 by bvm") (LET* ((FIELD (CAR PAIR)) (VALUE (CADR PAIR)) (EXPECTED (CADDR (ASSOC FIELD \NSMAIL.HEADING.ATTRIBUTES))) FOUND) (if (EQ (CAR (LISTP EXPECTED)) (QUOTE ENUMERATION)) then (SETQ EXPECTED (CDR EXPECTED)) (if (SETQ FOUND (CL:ASSOC VALUE EXPECTED :TEST (QUOTE STRING-EQUAL))) then (CONS FIELD (CAR FOUND)) else (\SENDMESSAGEFAIL EDITORWINDOW (CL:FORMAT NIL "Field '~A' not understood--expected one of ~A" FIELD (CONCATLIST (CDR (for V in EXPECTED join (LIST ", " (CAR V)))))))) elseif (OR (STRING-EQUAL VALUE "True") (STRING-EQUAL VALUE "Yes") (STRING-EQUAL VALUE T)) then (* ; "Good. Value is actually irrelevant") PAIR elseif (OR (STRING-EQUAL VALUE "False") (STRING-EQUAL VALUE "No")) then (* ; "Good, omit attribute") NIL else (\SENDMESSAGEFAIL EDITORWINDOW "Field 'Immutable' not understood--expected True or False")))) -) - -(\NSMAIL.NEW.SEND -(LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* ; "Edited 6-Aug-93 15:20 by bvm") (* ;;; "MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients") (RESETLST (PROG* ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW))) (RECIPIENTS (fetch NSPRECIPIENTS of PARSE)) (START (OR (fetch NSPSTART of PARSE) (GETEOFPTR MSG))) (MSGFIELDS (fetch NSPFIELDS of PARSE)) (CREDENTIALS (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*)) (ALLOW.DL.RECIPIENTS (OR *NSMAIL-ALLOW-DL-RECIPIENTS* (ASSOC (QUOTE Reply-to) MSGFIELDS))) USENSTEXTFILE FORMATSTREAM REFERENCE ATTACHMENT ATTACHMENT-TYPE ATTACHMENT-STREAM ATTACHED-ATTRIBUTES BODYLENGTH COURIERSTREAM MAILDROP RESULTS HEADING SESSION ESTIMATED-SIZE PART-TYPES) (* ;; "Some day maybe try using the ALLOW.DL.RECIPIENTS feature. Unfortunately, there are too many users in XNS who look like groups to the mail system for this to be very interesting.") (COND (PWINDOW (* ; "Make sure prompt window will expand as needed. Probably generic sendmessage should do this") (RESETSAVE (TTYDISPLAYSTREAM PWINDOW)) (RESETSAVE (LINELENGTH T)))) (COND ((AND (fetch NSPFORMATTED of PARSE) (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message is formatted, so get info. Have to exclude header, since it is not sent.") (SETQ MSG (COPYTEXTSTREAM MSG)) (TEDIT.DELETE MSG 1 START) (SETQ FORMATSTREAM (COERCETEXTOBJ MSG (QUOTE SPLIT))) (* ; "Get (body . formatting)") (CLOSEF MSG) (* ; "We're thru with this new textstream, let it clean up after itself.") (SETQ MSG (OPENSTREAM (CAR FORMATSTREAM) (QUOTE INPUT))) (SETQ FORMATSTREAM (OPENSTREAM (CDR FORMATSTREAM) (QUOTE INPUT))) (SETQ START 0)) ((AND (TEXTSTREAMP MSG) (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message has formatting, but caller asked to send it as plain text. Carefully coerce it, since TEDIT ns chars and image objects don't pass thru COPYBYTES very well") (SETQ MSG (LAFITE.MAKE.PLAIN.TEXTSTREAM MSG START)) (SETQ START 0))) (SETQ BODYLENGTH (- (GETEOFPTR MSG) START)) (if FORMATSTREAM then (* ; "Formatted messages can only go as text files for now, or else old clients can't receive them") (SETQ USENSTEXTFILE T) else (CASE *NEWNSMAIL-POST-AS-TEXTFILE* ((NIL) (* ; "Always send as note")) ((:TEST) (* ; "Send as note only if short enough (the default)") (if (> BODYLENGTH *NSMAIL-MAX-NOTE-LENGTH*) then (SETQ USENSTEXTFILE T))) (T (SETQ USENSTEXTFILE T)))) (SETQ REFERENCE (ASSOC (QUOTE REFERENCE) MSGFIELDS)) (SETQ ATTACHMENT (ASSOC (QUOTE ATTACHMENT) MSGFIELDS)) (if (OR REFERENCE ATTACHMENT) then (if ATTACHMENT then (* ; "We're going to send a whole file along with the message") (SETQ MSGFIELDS (DREMOVE ATTACHMENT MSGFIELDS)) (SETQ ATTACHMENT (\NSMAIL.NEW.PREPARE.ATTACHMENT (CADR ATTACHMENT) EDITORWINDOW)) (SETQ ATTACHMENT-STREAM (CAR ATTACHMENT)) (SETQ ATTACHED-ATTRIBUTES (CDDR ATTACHMENT)) (SETQ ATTACHMENT-TYPE (CADR ATTACHMENT)) (SETQ ATTACHMENT-TYPE (CASE (\TYPE.FROM.FILETYPE ATTACHMENT-TYPE) (INTERPRESS (if NIL then (* ; "This way doesn't go thru the backward incompatibility module correctly.") (\NSMAIL.BODY.PART.TYPE INTERPRESS) else (\NSMAIL.BODY.PART.TYPE VPDOCUMENT))) (DIRECTORY (\NSMAIL.BODY.PART.TYPE VPFOLDER)) (TEXT (\NSMAIL.BODY.PART.TYPE NSTEXTFILE)) (T (if (AND (>= ATTACHMENT-TYPE \NSMAIL.MIN.VP.TYPE) (<= ATTACHMENT-TYPE \NSMAIL.MAX.VP.TYPE)) then (* ; "I assume everything in this range is a vpdocument") (\NSMAIL.BODY.PART.TYPE VPDOCUMENT) else (\NSMAIL.BODY.PART.TYPE OTHERNSFILE))))) elseif REFERENCE then (* ; "Just a Vp reference. This is a null file with a special attribute giving the file name, etc") (SETQ MSGFIELDS (DREMOVE REFERENCE MSGFIELDS)) (SETQ ATTACHED-ATTRIBUTES (LIST (CONSTANT (CONS (QUOTE BodyType) \NSMAIL.REFERENCE.BODYTYPE)) (RPLACD REFERENCE (\NSMAIL.PARSE.REFERENCE (CADR REFERENCE) EDITORWINDOW)))) (SETQ ATTACHMENT-TYPE (\NSMAIL.BODY.PART.TYPE VPDOCUMENT))) (SETQ PART-TYPES (LIST ATTACHMENT-TYPE))) (if USENSTEXTFILE then (push PART-TYPES (\NSMAIL.BODY.PART.TYPE NSTEXTFILE)) elseif (> BODYLENGTH 0) then (push PART-TYPES (\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE))) (SETQ HEADING (\NSMAIL.BUILD.HEADING MSGFIELDS (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (SETQ RECIPIENTS (for R in RECIPIENTS as I from 1 collect (COURIER.CREATE (NEW.MAILTRANSPORT . RECIPIENT) NAME _ R RECIPIENT.ID _ I REPORT _ (OR *NEWNSMAIL-REPORT-TYPE* (QUOTE NON.DELIVERY.ONLY))))) (COND (PWINDOW (CLEARW PWINDOW) (LET ((TYPE (if REFERENCE then (\TYPE.FROM.FILETYPE (CADR (ASSOC (QUOTE TYPE) (CDR REFERENCE)))) elseif ATTACHMENT-TYPE then (for PAIR in \NSMAIL.BODY.PART.TYPES when (EQL ATTACHMENT-TYPE (CADR PAIR)) do (RETURN (CAR PAIR)))))) (CL:FORMAT PWINDOW "Delivering ~:[~;formatted ~]~@[with ~A ~]~@[~A ~]to ~D recipient~:P" FORMATSTREAM (AND TYPE (CL:STRING-CAPITALIZE (MKSTRING TYPE))) (COND (REFERENCE "reference") (ATTACHMENT "attachment")) (LENGTH RECIPIENTS))))) (SETQ ESTIMATED-SIZE (PROGN (* ;; "@##!@ protocol demands that you tell the size of the message almost exactly. Specifically, size estimate must not be too large (!), and not be more than 5000 bytes too small. That almost means you have to buffer the whole message before you start. We are lazy here and hope that serialization overhead and file server size estimates don't screw us up.") (+ (GETEOFPTR HEADING) BODYLENGTH (if FORMATSTREAM then (* ; "This plus a few more bytes of serialized file encoding") (GETEOFPTR FORMATSTREAM) else 0) (if ATTACHMENT-STREAM then (* ; "This is an underestimate in the case of a non-ns file, but that's the safe direction, and it's only by the small length of the attributes") (GETEOFPTR ATTACHMENT-STREAM) else 0)))) (COND ((NULL (SETQ MAILDROP (\NSMAIL.NEW.FINDSERVER ESTIMATED-SIZE))) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't find a mail drop")))) (to 3 until (SETQ COURIERSTREAM (COURIER.OPEN MAILDROP NIL T (QUOTE NSMAILER))) do (* ; "loop 3 times trying to start this send") (DISMISS 1000)) (COND ((NULL COURIERSTREAM) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop")))) (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) COURIERSTREAM)) (AND PWINDOW (printout PWINDOW (QUOTE ...))) (SETQ RESULTS (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE BEGIN.POST) (COURIER.CREATE (NEW.MAILTRANSPORT . POSTING.DATA) RECIPIENTS _ RECIPIENTS CONTENTS.TYPE _ \CT.STANDARD.MESSAGE CONTENTS.SIZE _ ESTIMATED-SIZE BODY.PART.TYPES.SEQUENCE _ (CONS (\NSMAIL.BODY.PART.TYPE HEADING) PART-TYPES)) NIL ALLOW.DL.RECIPIENTS (AND *NSMAIL-RETURN-CONTENTS* (QUOTE ((TRANSPORT.OPTIONS (T T))))) (CAR CREDENTIALS) (CDR CREDENTIALS) (QUOTE RETURNERRORS))) (COND ((EQ (CAR (LISTP RESULTS)) (QUOTE ERROR)) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (SELECTQ (CADR RESULTS) (INVALID.RECIPIENTS (\NSMAIL.NEW.INVALID.RECIPIENTS (CADDR RESULTS) RECIPIENTS)) (MKSTRING (CDR RESULTS))))))) (* ;; "RESULTS = (session invalid-recipients)") (SETQ SESSION (CAR RESULTS)) (if (SETQ RESULTS (CADR RESULTS)) then (* ; "Some were invalid. I think we don't get any here because we didn't say to post anyway.") (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (\NSMAIL.NEW.INVALID.RECIPIENTS RESULTS RECIPIENTS)))) (* ;; "Now post body parts") (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION) (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION (\NSMAIL.BODY.PART.TYPE HEADING) HEADING 0 EDITORWINDOW) (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION) (if USENSTEXTFILE then (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION (\NSMAIL.BODY.PART.TYPE NSTEXTFILE) MSG START EDITORWINDOW (BQUOTE ((BodyType (\,@ \NSMAIL.TEXT.BODYTYPE)) (\,@ (AND FORMATSTREAM (BQUOTE ((LispFormatting (\,@ FORMATSTREAM))))))))) elseif (> BODYLENGTH 0) then (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION (\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE) MSG START EDITORWINDOW)) (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION) (if ATTACHMENT-TYPE then (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION ATTACHMENT-TYPE ATTACHMENT-STREAM NIL EDITORWINDOW ATTACHED-ATTRIBUTES) (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION)) (if ABORTWINDOW then (* ; "Too late to abort now") (DELETEMENU (CAR (WINDOWPROP ABORTWINDOW (QUOTE MENU))) NIL ABORTWINDOW)) (SETQ RESULTS (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE END.POST) SESSION NIL (QUOTE RETURNERRORS))) (if (EQ (CAR (LISTP RESULTS)) (QUOTE ERROR)) then (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (MKSTRING (CDR RESULTS))))) (AND NSMAILDEBUGFLG (printout PROMPTWINDOW T "EndPost results: " RESULTS)) (RETURN (LENGTH RECIPIENTS))))) -) - -(\NSMAIL.NEW.INVALID.RECIPIENTS -(LAMBDA (INVALID.NAME.LIST RECIPIENTS) (* ; "Edited 19-Dec-89 13:00 by bvm") (* ;; "INVALID.NAME.LIST = Sequence (id reason). id is 1-based.") (if (CDR INVALID.NAME.LIST) then (CONCAT "Invalid recipients: " (SUBSTRING (for PAIR in INVALID.NAME.LIST collect (LIST (COURIER.FETCH (NEW.MAILTRANSPORT . RECIPIENT) NAME of (CAR (NTH RECIPIENTS (CAR PAIR)))) (CADR PAIR))) 2 -2)) else (DESTRUCTURING-BIND (ID REASON) (CAR INVALID.NAME.LIST) (CONCAT (COURIER.FETCH (NEW.MAILTRANSPORT . RECIPIENT) NAME of (CAR (NTH RECIPIENTS ID))) " -- " REASON)))) -) - -(\NSMAIL.BUILD.HEADING -(LAMBDA (MSGFIELDS SENDER) (* ; "Edited 11-Jul-90 18:03 by bvm") (* ;; "Build a heading body part, which is a sequence of attribute. Return a stream") (LET ((S (OPENSTREAM "{nodircore}" (QUOTE BOTH))) (COUNT 2)) (SETFILEPTR S 2) (* ; "Save space for the sequence count") (COND ((ASSOC (QUOTE From) MSGFIELDS) (* ; "Identify actual sender (single name here)") (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE Sender) SENDER) (QUOTE NEW.MAILTRANSPORT))) (T (* ; "Identify sender as the sole %"From%" name") (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE From) (LIST SENDER)) (QUOTE NEW.MAILTRANSPORT)))) (for PAIR in MSGFIELDS do (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (CAR PAIR) (CDR PAIR)) (QUOTE NEW.MAILTRANSPORT)) (add COUNT 1)) (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE TextAnnotation) (CONCAT "Date: " (DATE (DATEFORMAT TIME.ZONE SPACES DAY.OF.WEEK)) LAFITEEOL)) (QUOTE NEW.MAILTRANSPORT)) (* ; "Send the Date with time zone, as Cedar does") (if *NSMAIL-GENERATE-MESSAGE-ID* then (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE Message-ID) (COURIER.CREATE (NEW.MAILTRANSPORT . IP.MESSAGEID) ORIGINATOR _ (fetch UNPACKEDUSERNAME of *LAFITE-MODE-DATA*) UNIQUESTRING _ (DATE (DATEFORMAT TIME.ZONE)))) (QUOTE NEW.MAILTRANSPORT)) (add COUNT 1)) (SETFILEPTR S 0) (\WOUT S COUNT) S)) -) - -(\NSMAIL.POST.BODY.PART -(LAMBDA (COURIERSTREAM SESSION TYPE PARTSTREAM START EDITORWINDOW ATTRIBUTES) (* ; "Edited 8-Mar-90 12:14 by bvm") (LET ((RESULTS (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE POST.ONE.BODY.PART) SESSION TYPE (FUNCTION (LAMBDA (BULKSTREAM) (if ATTRIBUTES then (* ; "Create a serialized file on the fly") (COURIER.WRITE BULKSTREAM \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "version. Next comes Sequence Attribute") (\WOUT BULKSTREAM (LENGTH ATTRIBUTES)) (for PAIR in ATTRIBUTES do (if (EQ (CAR PAIR) (QUOTE LispFormatting)) then (* ; "Do this special so we don't have to cons an enormous string") (\NSMAIL.SEND.STREAM.AS.STRING (CDR PAIR) BULKSTREAM 0 (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)) else (\NSMAIL.WRITE.ATTRIBUTE BULKSTREAM (CAR PAIR) (CDR PAIR)))) (* ;; "Next comes StreamOfUnspecified, then lastByteIsSignificant") (if PARTSTREAM then (COURIER.WRITE BULKSTREAM (COURIER.WRITE.STREAM.UNSPECIFIED BULKSTREAM PARTSTREAM (OR START 0) -1) NIL (QUOTE BOOLEAN)) else (* ; "no content") (\WOUT BULKSTREAM 1) (* ; "Last segment") (\WOUT BULKSTREAM 0) (* ; "Empty sequence") (\WOUT BULKSTREAM 1) (* ; "Last Byte is Significant = Byte Length is Even.")) (\WOUT BULKSTREAM 0) (* ; "no children") else (* ; "PARTSTREAM is already in proper format, just send it") (if START then (SETFILEPTR PARTSTREAM START)) (COPYBYTES PARTSTREAM BULKSTREAM)) (* ; "return NIL so caller can see return value") NIL)) (QUOTE RETURNERRORS)))) (if (EQ (CAR RESULTS) (QUOTE ERROR)) then (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE END.POST) SESSION T (QUOTE RETURNERRORS)) (* ; "Abort the post") (\LAFITE.SEND.FAIL EDITORWINDOW (CL:FORMAT NIL "Failed to post ~A because: ~A" (CAR (find TYP in \NSMAIL.BODY.PART.TYPES suchthat (EQ (CADR TYP) TYPE))) (CDR RESULTS))) (ERROR!)))) -) - -(\NSMAIL.NEW.PREPARE.ATTACHMENT -(LAMBDA (FILE EDITORWINDOW) (* ; "Edited 11-Nov-92 17:07 by bvm") (* ;; "Returns (stream type . attributes)") (LET* ((HOST (UNPACKFILENAME.STRING FILE (QUOTE HOST))) (SERIALIZED (STRPOS ":" HOST)) BODYTYPE) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (if SERIALIZED then (\NSFILING.GETFILE (\GETDEVICEFROMHOSTNAME (MKATOM (U-CASE HOST))) FILE (QUOTE SERIALIZE) (QUOTE OLD) NIL NIL T) else (OPENSTREAM FILE (QUOTE INPUT)))) (if (NULL STREAM) then (\LAFITE.SEND.FAIL EDITORWINDOW (OR CONDITION "Attachment not found.")) (ERROR!)) (if SERIALIZED then (* ;; "Have to copy to core in order to get the length remotely correct. Stupid protocol") (LET ((COREFILE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (COPYBYTES STREAM COREFILE) (PROG1 (LIST (OPENSTREAM (CLOSEF COREFILE) (QUOTE INPUT)) (GETFILEINFO STREAM (QUOTE FILETYPE))) (CLOSEF STREAM))) else (* ; "Not on an NS server, let's investigate the type") (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STREAM)) (CASE (SETQ BODYTYPE (\FILETYPE.FROM.TYPE (GETFILEINFO STREAM (QUOTE TYPE)))) ((NIL 0) (* ; "Under specified") (if (SETQ BODYTYPE (\NSMAIL.GUESS.FILE.TYPE (FULLNAME STREAM))) then (SETQ BODYTYPE (\FILETYPE.FROM.TYPE BODYTYPE)) elseif (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (\LAFITE.CREATE.MENU (QUOTE (("Send as BINARY attachment" T) ("Abort" NIL))) "Send attachment?") "Warning: Type of attached file is unknown; most mail clients can't do anything interesting with this.") then (SETQ BODYTYPE 0) else (ERROR!)))) (LIST* STREAM BODYTYPE (BQUOTE ((BodyType (\,@ BODYTYPE)) (MODIFIED.ON (\,@ (GETFILEINFO STREAM (QUOTE ICREATIONDATE))))))))))) -) - -(\NSMAIL.CHECK.ABORT -(LAMBDA (ABORTWINDOW COURIERSTREAM SESSION) (* ; "Edited 28-Nov-89 15:06 by bvm") (* ;; "Abort a post if user has pressed Abort") (COND ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT))) (* ; "Abort the post") (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE END.POST) SESSION T (QUOTE RETURNERRORS)) (ERROR!)))) -) - -(\NSMAIL.NEW.FINDSERVER -(LAMBDA (ESTIMATED-SIZE) (* ; "Edited 25-Jun-90 16:02 by bvm") (PROG (INFO) (if (AND (CDR \NSMAIL.NEW.SERVER.CACHE) (NOT (TIMEREXPIRED? (CAR \NSMAIL.NEW.SERVER.CACHE)))) then (if (SETQ INFO (find ADDR in (CDR \NSMAIL.NEW.SERVER.CACHE) suchthat (\NSMAIL.NEW.CHECKSERVER (COURIER.EXPEDITED.CALL ADDR \NSMAIL.SOCKET (QUOTE NEW.MAILTRANSPORT) (QUOTE SERVER.POLL) (QUOTE RETURNERRORS)) ESTIMATED-SIZE))) then (RETURN INFO)) else (* ;; "Cache nonexistent or timed out, so refigure from scratch. We like to time out the cache periodically so that we don't permanently latch on to some distant server when local ones are flaky.") (SETQ \NSMAIL.NEW.SERVER.CACHE (LIST (SETUPTIMER *NSMAIL-CACHE-TIMEOUT* (CAR \NSMAIL.NEW.SERVER.CACHE))))) (* ;; "Ask around for a server") (COND ((SETQ INFO (COURIER.BROADCAST.CALL \NSMAIL.SOCKET (QUOTE NEW.MAILTRANSPORT) (QUOTE SERVER.POLL) NIL (FUNCTION (LAMBDA (RESULT) (\NSMAIL.NEW.CHECKSERVER RESULT ESTIMATED-SIZE))) NSMAIL.NET.HINT)) (push (CDR \NSMAIL.NEW.SERVER.CACHE) INFO))) (RETURN INFO))) -) - -(\NSMAIL.NEW.CHECKSERVER -(LAMBDA (POLLRESULT ESTIMATED-SIZE) (* ; "Edited 4-Jun-92 11:31 by bvm") (* ;; "Checks that the result of a SERVER.POLL is useful for sending a message of size ESTIMATED-SIZE. Returns the server's address") (* ;; "POLLRESULT = (willingness network.address.list name)") (LET ((WILLINGNESS (CAR POLLRESULT)) (SIZE (OR ESTIMATED-SIZE 4000))) (* ; "The i'th element of willingness defines the server's willingness to accept messages up to size 8^i.") (if (AND (LISTP WILLINGNESS) (for W in WILLINGNESS as (I _ 8) by (LLSH I 3) while (> I SIZE) always (>= W *NSMAIL-MIN-WILLINGNESS*))) then (PROG ((BESTADDRESS (CAR (SORT.NSADDRESSES.BY.DISTANCE (CADR POLLRESULT))))) (SELECTQ *NSMAIL-TRACE-SERVERS* (NIL NIL) (:ASK (if (NOT (EQ (QUOTE Y) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (ASKUSER 30 (QUOTE Y) (LIST "Use posting server" (CADDR POLLRESULT) (LIST BESTADDRESS)) NIL T)))) then (RETURN NIL))) (PRINTOUT PROMPTWINDOW T "Using posting server " (CADDR POLLRESULT) " = " BESTADDRESS)) (RETURN BESTADDRESS))))) -) -) - -(RPAQQ NSMAIL.PARSEFIELDS (("DATE:" LAFITE.READ.LINE.FOR.TOC Date) ("SUBJECT:" LAFITE.READ.LINE.FOR.TOC Subject) ("SENDER:" LAFITE.READ.NAME.FIELD Sender) ("FROM:" LAFITE.READ.NAME.FIELD From) ("REPLY-TO:" LAFITE.READ.NAME.FIELD Reply-to) ("IN-REPLY-TO:" LAFITE.READ.LINE.FOR.TOC In-Reply-to) ("TO:" LAFITE.READ.NAME.FIELD To) ("CC:" LAFITE.READ.NAME.FIELD cc) ("FORMAT:" LAFITE.READ.FORMAT) ("ATTACHED-REFERENCE:" LAFITE.READ.LINE.FOR.TOC REFERENCE) ("ATTACHED-FILE:" LAFITE.READ.LINE.FOR.TOC ATTACHMENT) ("Importance:" LAFITE.READ.LINE.FOR.TOC Importance) ("Sensitivity:" LAFITE.READ.LINE.FOR.TOC Sensitivity) ("Immutable:" LAFITE.READ.LINE.FOR.TOC Immutable))) - -(RPAQ \LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS)) - -(RPAQ? *NEWNSMAIL-POST-AS-TEXTFILE* :TEST) - -(RPAQ? *NEWNSMAIL-REPORT-TYPE* (QUOTE NON.DELIVERY.ONLY)) - -(RPAQ? *NSMAIL-ALLOW-DL-RECIPIENTS* T) - -(RPAQ? *NSMAIL-RETURN-CONTENTS* T) - -(RPAQ? *NSMAIL-MIN-WILLINGNESS* 9) - -(RPAQ? *NSMAIL-TRACE-SERVERS*) - -(RPAQ? *NSMAIL-GENERATE-MESSAGE-ID*) - -(RPAQ? *NSMAIL-DISPLAY-TRANSPORT-ID*) - -(RPAQ? *NSMAIL-DISPLAY-POSTMARK*) - -(RPAQ? *NSMAIL-DISPLAY-ERRORS-TO*) - -(RPAQ? *NSMAIL-CACHE-TIMEOUT* (TIMES 1000 60 60)) - -(RPAQ? \NSMAIL.MIN.VP.TYPE 4300) - -(RPAQ? \NSMAIL.MAX.VP.TYPE 5200) - -(RPAQ? \NSMAIL.NEW.SERVER.CACHE) - -(RPAQQ *NSMAIL-OP-VECTOR* (NEWNS.POLLNEWMAIL NEWNS.OPENMAILBOX NEWNS.NEXTMESSAGE NEWNS.RETRIEVEMESSAGE NEWNS.CLOSEMAILBOX)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \NSMAIL.NEW.SERVER.CACHE \NSMAIL.MIN.VP.TYPE \NSMAIL.MAX.VP.TYPE) -) - -(CL:PROCLAIM (QUOTE (CL:SPECIAL *NEWNSMAIL-POST-AS-TEXTFILE* *NEWNSMAIL-REPORT-TYPE* *NSMAIL-ALLOW-DL-RECIPIENTS* *NSMAIL-RETURN-CONTENTS* *NSMAIL-MIN-WILLINGNESS* *NSMAIL-TRACE-SERVERS* *NSMAIL-GENERATE-MESSAGE-ID* *NSMAIL-DISPLAY-TRANSPORT-ID* *NSMAIL-DISPLAY-POSTMARK* *NSMAIL-DISPLAY-ERRORS-TO* *NSMAIL-CACHE-TIMEOUT*))) - - - -(* ; "Retrieving") - -(DEFINEQ - -(\NSMAIL.NEW.AUTHENTICATE -(LAMBDA NIL (* ; "Edited 6-Aug-93 15:08 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) NSUSERNAME FULLNAME MSERVERS AUTHENTICATED? CREDENTIALS MSG) (SETQ NSUSERNAME (PARSE.NSNAME (CAR INFO))) (COND ((NEQ (SETQ AUTHENTICATED? (COND ((NULL (SETQ FULLNAME (CH.LOOKUP.OBJECT NSUSERNAME))) (QUOTE NONE)) (T (NS.AUTHENTICATE (SETQ CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS (CONS FULLNAME (CDR INFO)))))))) T) (printout PROMPTWINDOW T "Cannot authenticate user " (RNAME.TO.STRING (OR FULLNAME NSUSERNAME) T) " because: " (SELECTQ (SETQ \LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?) (CredentialsInvalid "Login incorrect") (KeysUnavailable (CONCAT "Authentication server unavailable for domain " (fetch NSDOMAIN of FULLNAME))) (NONE "No such user") AUTHENTICATED?) ".") NIL) (T (create LAFITEMODEDATA FULLUSERNAME _ (RNAME.TO.STRING FULLNAME T) UNPACKEDUSERNAME _ FULLNAME CREDENTIALS _ CREDENTIALS SHORTUSERNAME _ (CONCAT (fetch NSOBJECT of FULLNAME) (QUOTE %:) (COND ((NOT (STRING-EQUAL (fetch NSDOMAIN of FULLNAME) CH.DEFAULT.DOMAIN)) (fetch NSDOMAIN of FULLNAME)) (T ""))) MAILSERVERS _ (\NSMAIL.MAKE.MAILSERVERS (NS.FINDMAILBOXES FULLNAME) FULLNAME CREDENTIALS)))))) -) - -(NEWNS.POLLNEWMAIL -(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* ; "Edited 18-Dec-89 18:59 by bvm") (LET ((RESULT (\NSMAIL.NEW.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER))) (COND ((OR (NOT RESULT) (EQ (CAR RESULT) (QUOTE ERROR))) (* ; "Server down") (QUOTE ?)) ((NEQ RESULT 0) RESULT)))) -) - -(NEWNS.OPENMAILBOX -(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* ; "Edited 18-Dec-89 18:59 by bvm") (LET ((STREAM (\NSMAIL.COURIER.OPEN ADDRESS)) NSMAILSTATE N) (COND ((NULL STREAM) NIL) ((OR (NULL (SETQ N (\NSMAIL.NEW.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM T))) (EQ (CAR N) (QUOTE ERROR))) (CLOSEF STREAM) (* ; "Return error msg") (CONS NIL (CDR N))) ((EQ (PROGN (SETQ NSMAILSTATE (fetch MAILSTATE of MAILSERVER)) N) 0) (\NSMAIL.NEW.LOGOFF NSMAILSTATE STREAM) (QUOTE EMPTY)) (T (* ; "Return (MAILBOX . properties)") (CONS (create NSMAILBOX NSMAILSTREAM _ STREAM NSMAILLASTINDEX _ 0 NSMAILSTATE _ NSMAILSTATE) (LIST (QUOTE %#OFMESSAGES) N)))))) -) - -(\NSMAIL.NEW.CHECK -(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM RETURNERRORS) (* ; "Edited 6-Aug-93 16:41 by bvm") (* ;;; "Performs a mail check for user REGISTEREDNAME at ADDRESS, returning INBASKETSTATE if successful, NIL if not. Updates the MAILSTATE of MAILSERVER as appropriate to reflect current SESSION and STATEFIRSTNEW (first new message)") (RESETLST (PROG ((JUSTCHECKING (NULL STREAM)) (STATE (fetch (MAILSERVER MAILSTATE) of MAILSERVER)) SESSION POLLRESULT TIMER) (SETQ SESSION (fetch STATESESSION of STATE)) RETRY (COND ((NULL SESSION) (if JUSTCHECKING then (* ; "Just polling, don't need session") (SETQ POLLRESULT (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE NEW.INBASKET) (QUOTE MAILPOLL) (fetch STATENAME of STATE) (CAR CREDENTIALS) (CDR CREDENTIALS) (QUOTE RETURNERRORS))) (GO GOTRESULT)) (COND ((NULL STREAM) (* ; "Need a real Courier stream for some reason here") (COND ((SETQ STREAM (COURIER.OPEN ADDRESS NIL T (QUOTE NSMAIL))) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM))) (T (RETURN NIL))))) (COND ((EQ (CAR (SETQ SESSION (COURIER.CALL STREAM (QUOTE NEW.INBASKET) (QUOTE LOGON) (fetch STATENAME of STATE) (CAR CREDENTIALS) (CDR CREDENTIALS) (QUOTE RETURNERRORS)))) (QUOTE ERROR)) (GO ERROR))) (* ; "result = (session state anchor)") (SETQ POLLRESULT (CADR SESSION)) (replace STATESESSION of STATE with (SETQ SESSION (CAR SESSION)))) (T (SETQ POLLRESULT (COND ((NULL STREAM) (* ; "Just checking") (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE NEW.INBASKET) (QUOTE MAILCHECK) SESSION (QUOTE RETURNERRORS))) (T (COURIER.CALL STREAM (QUOTE NEW.INBASKET) (QUOTE MAILCHECK) SESSION (QUOTE RETURNERRORS))))))) GOTRESULT (COND ((NULL POLLRESULT) (* ; "Failed somehow") (RETURN NIL)) ((EQ (CAR (LISTP POLLRESULT)) (QUOTE ERROR)) (COND ((EQ (CADR POLLRESULT) (QUOTE SESSION.ERROR)) (* ; "Session timed out, start a new one") (replace STATESESSION of STATE with (SETQ SESSION NIL)) (replace STATEFIRSTNEW of STATE with NIL) (replace STATEOLDLAST of STATE with NIL) (GO RETRY)) (T (SETQ SESSION POLLRESULT) (GO ERROR))))) (replace STATELASTERROR of STATE with NIL) (replace (MAILSERVER CONTINUANCE) of MAILSERVER with NIL) (RETURN (COURIER.FETCH (NEW.INBASKET . STATE) TOTAL of POLLRESULT)) ERROR (if (AND (NOT (EQUAL (CDR SESSION) (QUOTE (CONNECTION.PROBLEM NoResponse)))) (NOT (EQUAL (CDR SESSION) (fetch STATELASTERROR of STATE)))) then (* ;; "Don't bother mentioning the error if it's just a timeout, since mailwatch will handle our NIL response fine. Also don't repeatedly print the same error message.") (replace STATELASTERROR of STATE with (CDR SESSION)) (LET ((ERRMSG (CASE (CADR SESSION) ((REJECT) (* ; "3rd element = reject reason") (LET* ((REASON (CADDR SESSION)) (TYPE (CAR REASON))) (if (AND (EQ TYPE (QUOTE WrongVersionOfService)) (<= (CAADR REASON) 1) (< (CADADR REASON) 2)) then (* ; "Server supports old inbasket, but not new") (PRINTOUT PROMPTWINDOW T T "****Note: " (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) " does not support new mail protocols." T) (if (NOT RETURNERRORS) then (RETURN NIL))) TYPE)) ((SERVICE.ERROR ACCESS.ERROR) (* ; "the specific reason is just as informative, and more readable than the whole error.") (CADDR SESSION)) (T (COND (NSWIZARDFLG (HELP SESSION))) (SUBSTRING (CDR SESSION) 2 -2))))) (if RETURNERRORS then (RETURN (CONS (QUOTE ERROR) ERRMSG)) elseif (AND (EQ ERRMSG (QUOTE NoSuchInbasket)) (\NSMAIL.FIX.MAILBOX.LOCATIONS)) then (* ;; "We get this when the server no longer holds this inbox. At this point we have fixed mail servers in NS mode, but there's no good way for us to report the news, so go ahead and return NIL, but set %"continuance%" so that poll will happen again immediately") (replace (MAILSERVER CONTINUANCE) of MAILSERVER with 0) else (LET ((*PRINT-CASE* :UPCASE)) (* ; "Lousy atomic error names...") (CL:FORMAT PROMPTWINDOW "~%%From mail server ~A: ~A" (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) (CASE ERRMSG (NoSuchService "Mail service not running") (T ERRMSG))))))) (RETURN NIL)))) -) - -(NEWNS.NEXTMESSAGE -(LAMBDA (MAILBOX) (* ; "Edited 13-Dec-89 17:27 by bvm") (LET ((NEXT (NEW.INBASKET.CALL MAILBOX (QUOTE RETRIEVE.ENVELOPES) (fetch NSMAILLASTINDEX of MAILBOX) (QUOTE NEXT) (fetch NSMAILSESSION of MAILBOX)))) (* ;; "NEXT = (envelope status index)") (DESTRUCTURING-BIND (ENVELOPE STATUS INDEX) NEXT (if (EQ INDEX 0) then (* ; "No more messages") NIL else (replace NSMAILLASTINDEX of MAILBOX with INDEX) (replace NSMAILENVTAIL of MAILBOX with ENVELOPE) (* ; "Success") T)))) -) - -(NEWNS.RETRIEVEMESSAGE -(LAMBDA (MAILBOX MSGOUTFILE) (* ; "Edited 16-Jan-90 15:43 by bvm") (DECLARE (SPECVARS *ATTACHMENTS* *DISCARDED-PARTS* *ENVELOPE* *FORMAT-STREAM* *HAVE-ATTACHMENTS* *HEADER-EOF* *MSGSTREAM* *RETRIEVAL-ERROR* *TABLE-OF-CONTENTS*)) (* ; "For the bulk data fn") (PROG* ((*RETRIEVAL-ERROR* NIL) (INDEX (fetch NSMAILLASTINDEX of MAILBOX)) (*ENVELOPE* (fetch NSMAILENVTAIL of MAILBOX)) (*TABLE-OF-CONTENTS* (CADR (ASSOC (QUOTE TOC) *ENVELOPE*))) (*MSGSTREAM* MSGOUTFILE) (HERE 0) *DISCARDED-PARTS* *HAVE-ATTACHMENTS* *ATTACHMENTS* *FORMAT-STREAM* *HEADER-EOF* PARTS-TO-RETRIEVE RESULT REPORT) (for PAIR in *TABLE-OF-CONTENTS* bind OTHER do (if (FMEMB (CAR PAIR) \NSMAIL.GOOD.BODY.PARTS) then (* ; "we read this fine") elseif (SETQ OTHER (ASSOC (CAR PAIR) \NSMAIL.DISCARDABLE.BODY.PARTS)) then (push *DISCARDED-PARTS* OTHER) else (* ; "Will need to arrange for an attachment") (SETQ *HAVE-ATTACHMENTS* T))) (if (NOT *HAVE-ATTACHMENTS*) then (* ; "Write directly to MSGOUTFILE. Note where we are in case we have to retry") (SETQ HERE (GETFILEPTR *MSGSTREAM*))) (if *DISCARDED-PARTS* then (* ; "Ordinarily we retrieve everything (PARTS-TO-RETRIEVE = NIL), but if there were parts we like to ignore, we can skip these.") (SETQ PARTS-TO-RETRIEVE (for PAIR in *TABLE-OF-CONTENTS* as INDEX from 0 collect INDEX unless (ASSOC (CAR PAIR) *DISCARDED-PARTS*)))) RETRY (if *HAVE-ATTACHMENTS* then (SETQ *MSGSTREAM* (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (if (SETQ REPORT (CADR (ASSOC (QUOTE REPORT) *ENVELOPE*))) then (* ; "This is a delivery report. What a crufty way to represent it") (SETQ *ENVELOPE* (\NSMAIL.HANDLE.DELIVERY.REPORT *MSGSTREAM* REPORT *ENVELOPE*)) (if (NULL *TABLE-OF-CONTENTS*) then (* ; "No body, e.g., a bad dl member report") (GO FINISH) else (* ; "Some message parts will follow the report") (PRINTOUT *MSGSTREAM* T "- - - - - - - - -" T))) (if (NEQ (CAAR *TABLE-OF-CONTENTS*) (\NSMAIL.BODY.PART.TYPE HEADING)) then (HELP "First body part is not heading" *TABLE-OF-CONTENTS*)) (SETQ RESULT (COURIER.CALL (fetch NSMAILSTREAM of MAILBOX) (QUOTE NEW.INBASKET) (QUOTE RETRIEVE.BODY.PARTS) INDEX PARTS-TO-RETRIEVE (FUNCTION \NSMAIL.READ.BODY.PARTS) (fetch NSMAILSESSION of MAILBOX) (QUOTE RETURNERRORS))) (if (EQ (CAR (LISTP RESULT)) (QUOTE ERROR)) then (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX (QUOTE NEW.INBASKET) (QUOTE RETRIEVE.BODY.PARTS)) (if *HAVE-ATTACHMENTS* then (SETQ *ATTACHMENTS* NIL) else (SETFILEPTR MSGOUTFILE HERE)) (SETQ *RETRIEVAL-ERROR* NIL) (GO RETRY)) (COND (*RETRIEVAL-ERROR* (printout *MSGSTREAM* T *RETRIEVAL-ERROR* T))) (if *FORMAT-STREAM* then (* ; "This is a TEdit formatted message") (LA.ADJUST.FORMATTING *FORMAT-STREAM* *MSGSTREAM* (- *HEADER-EOF* HERE))) (if *HAVE-ATTACHMENTS* then (SETQ *MSGSTREAM* (OPENTEXTSTREAM *MSGSTREAM* NIL NIL NIL (LIST (QUOTE FONT) LAFITEDISPLAYFONT))) (LET ((ATTACHPOINT (TEDIT.FIND *MSGSTREAM* " - -Attachment: " 1))) (SETQ ATTACHPOINT (if ATTACHPOINT then (* ; "Insert object at end of this line") (+ ATTACHPOINT 14) else (* ; "Shouldn't happen") (+ (TEDIT.FIND *MSGSTREAM* " - -" 1) 2))) (for AT in *ATTACHMENTS* do (LET (TYPE) (SETFILEPTR AT 4) (* ; "Skip the version number (LONGCARDINAL). Next comes SEQUENCE Filing.Attribute") (* ; "unknown") (to (\WIN AT) bind X ATTR do (if (EQ (SETQ ATTR (COURIER.READ AT NIL (QUOTE LONGCARDINAL))) (\NSMAIL.ATTRIBUTE.TYPE BodyType)) then (\WIN AT) (SETQ TYPE (\TYPE.FROM.FILETYPE (COURIER.READ AT NIL (QUOTE LONGCARDINAL)))) else (COURIER.SKIP.SEQUENCE AT NIL (QUOTE UNSPECIFIED)))) (TEDIT.INSERT.OBJECT (\MAILOBJ.CREATE AT TYPE (GETFILEPTR AT)) *MSGSTREAM* ATTACHPOINT)))) (* ;; "Would like the following to be (COERCETEXTOBJ OUTSTREAM 'FILE MSGOUTFILE) but Tedit has a bug") (COPYBYTES (OPENSTREAM (COERCETEXTOBJ *MSGSTREAM* (QUOTE FILE)) (QUOTE INPUT)) MSGOUTFILE)) FINISH (push (fetch NSMAILENVELOPES of MAILBOX) INDEX))) -) - -(\NSMAIL.READ.BODY.PARTS -(LAMBDA (BULKSTREAM) (* ; "Edited 14-Aug-90 16:13 by bvm") (DECLARE (SPECVARS *ATTACHMENTS* *DISCARDED-PARTS* *ENVELOPE* *FORMAT-STREAM* *HAVE-ATTACHMENTS* *HEADER-EOF* *MSGSTREAM* *TABLE-OF-CONTENTS* *BODY-OFFSET*)) (* ;; "Bulk data handler for RetrieveBodyParts call. We see the body parts, one directly after the other, per toc.") (* ;; "I hope the heading part is first") (for PAIR in *TABLE-OF-CONTENTS* as INDEX from 0 bind (START _ (GETFILEPTR BULKSTREAM)) (*BODY-OFFSET* _ 0) END HAVETEXT DISCARDING HEADERFIELDS FORWARDINFO FINFO FORWARDSTREAM PART-TYPE PART-LENGTH unless (ASSOC (SETQ PART-TYPE (CAR PAIR)) *DISCARDED-PARTS*) do (* ;; "Assertion: START = (getfileptr bulkstream)") (SETQ PART-LENGTH (CADR PAIR)) (if DISCARDING then (* ; "We already ate some of this, have to skip the rest") (if (> (SETQ DISCARDING (- DISCARDING PART-LENGTH)) 0) then (* ; "We've eaten the entire part, keep discarding") else (* ; "We've eaten all but -DISCARDING bytes") (SETFILEPTR BULKSTREAM (SETQ START (- START DISCARDING))) (SETQ DISCARDING NIL)) else (SETQ END (+ START PART-LENGTH)) (SETQ FINFO (find F in FORWARDINFO suchthat (* ; "See if this is a forwarded part") (FMEMB INDEX (fetch (FORWARD PARTS) of F)))) (SELECTC PART-TYPE ((\NSMAIL.BODY.PART.TYPE HEADING) (* ; "The heading = Sequence of Heading Attribute") (CL:MULTIPLE-VALUE-SETQ (HEADERFIELDS *FORMAT-STREAM* FORWARDINFO) (\NSMAIL.READ.HEADING BULKSTREAM END)) (\NSMAIL.NEW.PRINT.HEADING *MSGSTREAM* HEADERFIELDS *ENVELOPE*) (* ; "Print your basic heading. May set *BODY-OFFSET*") (if *DISCARDED-PARTS* then (* ; "Add another header field to show what we dropped.") (MAPRINT (CL:REMOVE-DUPLICATES (MAPCAR *DISCARDED-PARTS* (FUNCTION CADR)) :TEST (QUOTE STRING-EQUAL)) *MSGSTREAM* "Discarded-Parts: " NIL ", ") (TERPRI *MSGSTREAM*)) (if *HAVE-ATTACHMENTS* then (* ; "We'll insert image object(s) here later") (PRINTOUT *MSGSTREAM* " -Attachment: " T)) (TERPRI *MSGSTREAM*) (* ; "End header with blank line") (SETQ *HEADER-EOF* (GETFILEPTR *MSGSTREAM*)) (if FORWARDINFO then (* ; "We'll need to buffer the forwarded body parts in order to print them properly") (SETQ FORWARDSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) ((LIST (\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE) (\NSMAIL.BODY.PART.TYPE NSTEXTFILE) (\NSMAIL.BODY.PART.TYPE IA5.NOTE)) (* ; "This is text") (LET ((OUTSTREAM *MSGSTREAM*) (OFFSET *BODY-OFFSET*) FORWARDSTART) (if FINFO then (* ; "We'll buffer this text part") (SETQ FORWARDSTART (GETFILEPTR (SETQ OUTSTREAM FORWARDSTREAM))) (SETQ OFFSET 0) else (* ; "Normal case") (if HAVETEXT then (* ; "yet another text part") (PRIN3 " -- - - - - - - - -" *MSGSTREAM*) else (SETQ HAVETEXT T))) (SELECTC PART-TYPE ((\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE) (* ; "Xerox character set--just copy.") (SETFILEPTR BULKSTREAM (+ START OFFSET)) (COPYBYTES BULKSTREAM OUTSTREAM (- PART-LENGTH OFFSET))) ((\NSMAIL.BODY.PART.TYPE IA5.NOTE) (* ; "ia5 takes a little bit of conversion. Note that the skip case never happens here") (\NSMAIL.COPY.IA5 BULKSTREAM OUTSTREAM PART-LENGTH)) ((\NSMAIL.BODY.PART.TYPE NSTEXTFILE) (* ; "nstextfile--decode serialized file") (\NSMAIL.COPY.NSTEXTFILE BULKSTREAM OUTSTREAM END OFFSET)) NIL) (if FINFO then (* ; "Record where the text went") (push (fetch (FORWARD MAP) of FINFO) (LIST INDEX FORWARDSTART (- (GETFILEPTR FORWARDSTREAM) FORWARDSTART))) else (* ; "We've finished whatever skipping we were going to do.") (SETQ *BODY-OFFSET* 0)))) (LET ((BODY (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (* ;; "Parts we don't handle become opaque attachments") (if (OR (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE VPFOLDER)) (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE VPDOCUMENT)) (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE OTHERNSFILE))) then (* ; "It's already serialized") (COPYBYTES BULKSTREAM BODY PART-LENGTH) else (* ; "for now, make a serialized file") (COURIER.WRITE BODY \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "version") (\WOUT BODY 1) (* ; "Length of attribute sequence") (\NSMAIL.WRITE.ATTRIBUTE BODY (QUOTE BodyType) (if (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE INTERPRESS)) then (CONSTANT (\FILETYPE.FROM.TYPE (QUOTE INTERPRESS))) else (+ PART-TYPE 100000000))) (COURIER.WRITE BODY (COURIER.WRITE.STREAM.UNSPECIFIED BODY BULKSTREAM START END) NIL (QUOTE BOOLEAN)) (* ; "StreamOfUnspecified followed by lastByteIsSignificant") (\WOUT BODY 0) (* ; "no children")) (push *ATTACHMENTS* BODY) (if FINFO then (* ; "So we can refer to this later as attachment #n") (push (fetch (FORWARD MAP) of FINFO) (LIST INDEX (LENGTH *ATTACHMENTS*)))))) (if (NOT (EQL END (SETQ START (GETFILEPTR BULKSTREAM)))) then (HELP (CL:FORMAT NIL "Body part ~A wrong length: parsed as ~D, should have been ~D" PART-TYPE (+ PART-LENGTH (- START END)) PART-LENGTH) (CL:FORMAT NIL "Type 'RETURN' to " (if (> START END) then "flush rest of message" else "flush unread portion"))) (if (> START END) then (SETQ DISCARDING (- START END)) else (SETFILEPTR BULKSTREAM (SETQ START END))))) finally (if FORWARDINFO then (* ;; "At this point we have written all the original parts. Now walk thru the Forwarding info and write those messages") (LET ((*NSMAIL-DISPLAY-TRANSPORT-ID* NIL) (*NSMAIL-DISPLAY-POSTMARK* NIL)) (* ; "Those fields are boring in forwarded mail") (\NSMAIL.EMIT.FORWARDING FORWARDINFO FORWARDSTREAM *MSGSTREAM* NIL))) (* ;; "Return NIL to let Courier result show thru") (RETURN NIL))) -) - -(\NSMAIL.COPY.IA5 -(LAMBDA (INSTREAM OUTSTREAM NBYTES) (* ; "Edited 22-Dec-89 18:06 by bvm") (* ;; "Convert NBYTES of ia5 text on INSTREAM to Xerox charset on OUTSTREAM") (while (>= (SETQ NBYTES (SUB1 NBYTES)) 0) bind CH do (SELCHARQ (SETQ CH (\BIN INSTREAM)) (CR (* ; "CR followed by some number of lfs indicates line breaks") (bind GOT1 while (AND (>= (SETQ NBYTES (SUB1 NBYTES)) 0) (EQ (SETQ CH (\BIN INSTREAM)) (CHARCODE LF))) do (* ; "One eol for each lf") (\BOUT OUTSTREAM (CHARCODE CR)) (SETQ GOT1 T) finally (if (NOT GOT1) then (* ; "Naked CR? Well, go ahead and print one anyway--we don't know how else to do it") (\BOUT OUTSTREAM (CHARCODE CR)))) (if (< NBYTES 0) then (* ; "Text ended in eol") (RETURN))) NIL) (\BOUT OUTSTREAM CH))) -) - -(\NSMAIL.COPY.NSTEXTFILE -(LAMBDA (INSTREAM OUTSTREAM END OFFSET) (* ; "Edited 22-May-90 10:37 by bvm") (* ;; "Copies the serialized text file from INSTREAM to OUTSTREAM. If there's a formatting item, sets *FORMAT-STREAM*. Just in case of trouble, END is the file pointer where we expect the file to end. If OFFSET is specified, it is an initial number of bytes to skip.") (\NSMAIL.CHECK.SERIALIZED.VERSION INSTREAM) (* ; "Now Sequence of Filing.Attribute") (to (\WIN INSTREAM) bind TYPE do (SETQ TYPE (COURIER.READ INSTREAM NIL (QUOTE LONGCARDINAL))) (if (AND (EQL TYPE (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)) (NOT *FORMAT-STREAM*)) then (* ; "Read formatting") (\NSMAIL.READ.STRING.AS.STREAM INSTREAM (SETQ *FORMAT-STREAM* (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) else (* ; "Skip over the value") (COURIER.SKIP.SEQUENCE INSTREAM NIL (QUOTE UNSPECIFIED)))) (* ;; "Now read the text content. This is adapted from \nsmail.read.serialized.content") (if (NOT OFFSET) then (SETQ OFFSET 0)) (bind LASTSEGMENT? BYTE BYTECOUNT do (SETQ LASTSEGMENT? (NEQ (\WIN INSTREAM) 0)) (COND ((NEQ (SETQ BYTECOUNT (UNFOLD (\WIN INSTREAM) BYTESPERWORD)) 0) (if (AND (> OFFSET 0) (LET ((SKIPLENGTH (MIN OFFSET BYTECOUNT))) (* ; "How much of this segment to skip") (SETFILEPTR INSTREAM (+ (GETFILEPTR INSTREAM) SKIPLENGTH)) (SETQ OFFSET (- OFFSET SKIPLENGTH)) (EQ (SETQ BYTECOUNT (- BYTECOUNT SKIPLENGTH)) 0))) then (* ; "We skipped the entire segment") (if LASTSEGMENT? then (* ; "Have to consume the lastByteIsSignificant flag") (\WIN INSTREAM)) else (COPYBYTES INSTREAM OUTSTREAM (SUB1 BYTECOUNT)) (SETQ BYTE (\BIN INSTREAM)) (* ; "Final byte of this segment. Don't copy until we know whether it's significant") (COND ((OR (NULL LASTSEGMENT?) (NEQ (\WIN INSTREAM) 0)) (* ; "Not last segment, or the word after says the final byte was significant") (\BOUT OUTSTREAM BYTE))))) (LASTSEGMENT? (* ; "Null body. Throw out the lastByteIsSignificant flag") (\WIN INSTREAM))) repeatuntil LASTSEGMENT?) (LET ((NCHILDREN (\WIN INSTREAM))) (if (> NCHILDREN 0) then (HELP "nsTextFile has children!! -- return to skip them" NCHILDREN) (SETFILEPTR INSTREAM END)))) -) - -(\NSMAIL.READ.HEADING -(LAMBDA (BULKSTREAM HEADING-END) (* ; "Edited 21-Dec-89 17:09 by bvm") (* ;; "Read a Heading body part, which consists of Sequence of Heading Attribute. Returns 4 values: headerfields (an alist), formatstream (if there was tedit formatting item), forwardInfo (if there was a forwarding structure), malformedP (if we had to advance the file pointer manually to HEADING-END") (LET (TYPE VALUE HEADERFIELDS TYPEINFO DISCARDED FORMATSTREAM FORWARDINFO MALFORMED COURIERTYPE) (to (\WIN BULKSTREAM) do (SETQ TYPE (COURIER.READ BULKSTREAM NIL (QUOTE LONGCARDINAL))) (COND ((NOT (find old TYPEINFO in \NSMAIL.HEADING.ATTRIBUTES suchthat (EQ (CADR TYPEINFO) TYPE))) (* ; "We don't understand this attribute") (if NSMAILDEBUGFLG then (push DISCARDED TYPE)) (COURIER.SKIP.SEQUENCE BULKSTREAM NIL (QUOTE UNSPECIFIED))) ((EQ (SETQ TYPE (CAR TYPEINFO)) (QUOTE LispFormatting)) (* ; "Save the formatting so we can munge it") (SETQ FORMATSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.READ.STRING.AS.STREAM BULKSTREAM FORMATSTREAM)) (T (LET ((VALUE-END (+ (UNFOLD (\WIN BULKSTREAM) BYTESPERWORD) (GETFILEPTR BULKSTREAM))) (COURIERTYPE (CADDR TYPEINFO)) HERE) (* ; "Note careful order of args to +") (if (EQ TYPE (QUOTE ForwardedHeadings)) then (SETQ FORWARDINFO (\NSMAIL.READ.FORWARDING BULKSTREAM VALUE-END)) else (CL:MULTIPLE-VALUE-BIND (VALUE CONDITION) (IGNORE-ERRORS (COURIER.READ BULKSTREAM (QUOTE NEW.MAILTRANSPORT) COURIERTYPE)) (if (OR CONDITION (NOT (EQL (SETQ HERE (GETFILEPTR BULKSTREAM)) VALUE-END))) then (if (NOT CONDITION) then (SETQ CONDITION "wrong length")) (if NSMAILDEBUGFLG then (HELP (CL:FORMAT NIL "Error reading attribute ~A: ~A" TYPE CONDITION))) (push HEADERFIELDS (CONS (MKSTRING TYPE) (CL:FORMAT NIL "XNS encoding error: ~A" CONDITION))) (if (< HERE VALUE-END) then (SETFILEPTR BULKSTREAM VALUE-END) elseif (AND (> HERE VALUE-END) (< HERE HEADING-END)) then (SETFILEPTR BULKSTREAM HEADING-END) (push HEADERFIELDS (QUOTE ("Header-Errors" . "Malformed XNS heading, some fields may be missing."))) (* ; "Exit this heading reader loop") (RETURN (SETQ MALFORMED T))) else (* ; "Save field") (push HEADERFIELDS (CONS TYPE (if (EQ TYPE (QUOTE Immutable)) then (* ; "Strange null-valued type") "True" elseif (LISTP COURIERTYPE) then (if (EQUAL COURIERTYPE (QUOTE (SEQUENCE IP.MESSAGEID))) then (MAPCAR VALUE (FUNCTION \NSMAIL.TRANSLATE.IP.MESSAGEID)) else VALUE) else (SELECTQ COURIERTYPE (TIME (\NSMAIL.GDATE VALUE)) (IP.MESSAGEID (\NSMAIL.TRANSLATE.IP.MESSAGEID VALUE)) VALUE))))))))))) (if DISCARDED then (push HEADERFIELDS (CONS "Discarded-Fields" (CONCATLIST (CDR (for D in (REVERSE DISCARDED) join (LIST ", " D))))))) (CL:VALUES HEADERFIELDS FORMATSTREAM FORWARDINFO MALFORMED))) -) - -(\NSMAIL.PARSE.ANNOTATION -(LAMBDA (ANNOTATION OUTSTREAM HEADERFIELDS) (* ; "Edited 21-Dec-89 13:10 by bvm") (* ;; "ANNOTATION is the value of the TextAnnotation heading. We parse it and print it to OUTSTREAM. HEADERFIELDS is an alist of other headers the caller will be printing.") (bind (LEN _ (NCHARS ANNOTATION)) (START _ 1) (NEXT _ 1) CR while (SETQ CR (STRPOS " -" ANNOTATION NEXT)) do (CASE (AND (< CR LEN) (CL:CHAR ANNOTATION CR)) ((#\Space #\Tab) (* ; "Whitespace denoting continuation line")) (T (\NSMAIL.EMIT.ANNOTATION (SUBSTRING ANNOTATION START (SUB1 CR)) OUTSTREAM HEADERFIELDS) (SETQ START (ADD1 CR)))) (SETQ NEXT (ADD1 CR)) finally (\NSMAIL.EMIT.ANNOTATION (SUBSTRING ANNOTATION START) OUTSTREAM HEADERFIELDS))) -) - -(\NSMAIL.EMIT.ANNOTATION -(LAMBDA (STR OUTSTREAM HEADERFIELDS) (* ; "Edited 10-Jul-90 15:55 by bvm") (DECLARE (SPECVARS *ORIGINAL-DATE*)) (* ;; "Print extra field STR to OUTSTREAM. We don't know exactly what it looks like, so we need to ensure that it is syntactically ok. If it is one of HEADERFIELDS, we make sure to rename it to avoid a clash. If it is the Date field, we print it and set *ORIGINAL-DATE* to the value portion.") (PROG (I LEN FIELD) (if (AND STR (> (SETQ LEN (NCHARS STR)) 0)) then (if (NOT (SETQ FIELD (for old I from 0 to (SUB1 LEN) do (CASE (CL:CHAR STR I) (#\: (* ; "valid field") (RETURN (SUBSTRING STR 1 I))) ((#\Space #\Tab) (* ; "Space before colon? Malformed") (RETURN NIL)))))) then (* ; "Malformed field") (PRIN3 "Other-Field: " OUTSTREAM) elseif (CL:ASSOC FIELD HEADERFIELDS :TEST (QUOTE STRING-EQUAL)) then (* ; "We already have a field of this name, so rename it") (if (AND (< I (- LEN 2)) (EQL (CL:CHAR STR (ADD1 I)) #\Tab)) then (* ; "field: looks a little weird when we add text to the front") (CL:SETF (CL:CHAR STR (ADD1 I)) #\Space)) (PRIN3 "Original-" OUTSTREAM) elseif (STRING-EQUAL FIELD "Date") then (SETQ *ORIGINAL-DATE* (LA.TRIM.WHITESPACE (SUBSTRING STR (+ I 2))))) (PRIN3 STR OUTSTREAM) (TERPRI OUTSTREAM)))) -) - -(LA.TRIM.WHITESPACE -(LAMBDA (STR) (* ; "Edited 14-May-90 16:35 by bvm") (CL:STRING-TRIM (QUOTE (#\Space #\Tab)) STR))) - -(\NSMAIL.READ.FORWARDING -(LAMBDA (INSTREAM VALUE-END) (* ; "Edited 21-Dec-89 18:39 by bvm") (* ;; "Read the attribute ForwardedHeadings = Sequence of ForwardedMessageInfo. We do this instead of a straight COURIER.READ so that we can play with the headings field. Returns NIL if the attribute is malformed.") (to (\WIN INSTREAM) collect (create FORWARD ENVELOPE _ (COURIER.READ INSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE ENVELOPE)) HEADINGS _ (CL:MULTIPLE-VALUE-BIND (HEADINGS FORMATSTREAM FORWARDINFO MALFORMED) (\NSMAIL.READ.HEADING INSTREAM VALUE-END) (if MALFORMED then (RETURN NIL) else (* ;; "Note that we ignore FORWARDINFO (not allowed anyway, as messages are not quite recursive) and FORMATSTREAM (who would have had it anyway, though it would be cute to be able to use it).") HEADINGS)) PARTS _ (COURIER.READ.SEQUENCE INSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE BODY.PART.INDEX)) PARENT _ (if (NEQ (\WIN INSTREAM) 0) then (* ; "Open coding of (choice (null 0 (record)) (nested 1 cardinal))") (\WIN INSTREAM))))) -) - -(\NSMAIL.NEW.PRINT.HEADING -(LAMBDA (OUTSTREAM HEADERFIELDS ENVELOPE) (* ; "Edited 26-Sep-90 11:35 by bvm") (* ;; "Compose message header from HEADERFIELDS and ENVELOPE, printing to OUTSTREAM. ") (PROG (*ORIGINAL-DATE* ORIGIDATE POSTED.DATE ORIGINATOR RETURN-TO VALUE TYPE SENDER FROMFIELD FULLFROMFIELD) (DECLARE (SPECVARS *ORIGINAL-DATE* *BODY-OFFSET*)) (for PAIR in (SETQ HEADERFIELDS (REVERSE HEADERFIELDS)) do (* ; "Before we start printing anything, look for some special fields") (CASE (CAR PAIR) (Sender (SETQ SENDER (CDR PAIR))) (From (SETQ FULLFROMFIELD (CDR PAIR)) (COND ((NULL (CDDR PAIR)) (* ; "Only interesting to eliminate if there's only one") (SETQ FROMFIELD (CADR PAIR))))) ((TextAnnotation newTextAnnotation) (\NSMAIL.PARSE.ANNOTATION (CDR PAIR) OUTSTREAM HEADERFIELDS) (RPLACD PAIR NIL)) (BodyOffset (* ; "Says how much of body duplicates the textannotation") (SETQ *BODY-OFFSET* (CDR PAIR)) (RPLACD PAIR NIL)))) (* ;; "Look at the envelope to see if there is any additional info we should supply that wasn't in the headers") (for PAIR in ENVELOPE do (SETQ VALUE (CADR PAIR)) (CASE (SETQ TYPE (CAR PAIR)) (Originator (if (OR (NULL (OR SENDER FROMFIELD)) (NOT (EQUAL.RNAMES VALUE (OR SENDER FROMFIELD)))) then (SETQ ORIGINATOR VALUE))) (RETURN.TO.NAME (SETQ RETURN-TO VALUE)) (Message-ID (if *NSMAIL-DISPLAY-TRANSPORT-ID* then (CL:FORMAT OUTSTREAM "XNS-Transport-ID: ~{~4,'0x~}~%%" VALUE))) (Postmark (SETQ POSTED.DATE (COURIER.FETCH (NEW.MAILTRANSPORT . POSTMARK) TIME of VALUE)) (if *NSMAIL-DISPLAY-POSTMARK* then (CL:FORMAT OUTSTREAM "Postmark: ~A at ~A~%%" (RNAME.TO.STRING (COURIER.FETCH (NEW.MAILTRANSPORT . POSTMARK) POSTED.AT of VALUE) T) (GDATE POSTED.DATE (DATEFORMAT TIME.ZONE))))))) (if POSTED.DATE then (* ; "Date is found only in the envelope") (if (AND *ORIGINAL-DATE* (SETQ ORIGIDATE (IDATE *ORIGINAL-DATE*)) (< (IABS (- POSTED.DATE ORIGIDATE)) (TIMES 5 60))) then (* ; "Text-annotation portion gave a date that is within 5 minutes, so don't bother mentioning the posting date.") else (if *ORIGINAL-DATE* then (* ; "Already have a Date field printed, so this one we'll call %"Posted-Date%"") (PRINTOUT OUTSTREAM "Posted-")) (PRINTOUT OUTSTREAM "Date: " (\NSMAIL.GDATE POSTED.DATE) T))) (if (NULL FULLFROMFIELD) then (* ; "Derive From field from somewhere else") (if SENDER then (RPLNODE (ASSOC (QUOTE Sender) HEADERFIELDS) (QUOTE From) (LIST SENDER)) (if ORIGINATOR then (push HEADERFIELDS (CONS (QUOTE Sender) ORIGINATOR))) elseif ORIGINATOR then (* ; "Neither From nor Sender in heading, take it out of envelope") (push HEADERFIELDS (LIST (QUOTE From) (SETQ SENDER ORIGINATOR)))) elseif (NULL SENDER) then (* ; "From but no Sender") (if ORIGINATOR then (* ; "ORIGINATOR only set when it's different from From") (push HEADERFIELDS (CONS (QUOTE Sender) (SETQ SENDER ORIGINATOR))) else (SETQ SENDER FROMFIELD)) elseif (AND FROMFIELD (EQUAL.RNAMES SENDER FROMFIELD)) then (* ; "Sender is redundant with From--get rid of it, unless the envelope originator is different") (RPLACD (ASSOC (QUOTE Sender) HEADERFIELDS) ORIGINATOR) elseif ORIGINATOR then (* ; "Three distinct fields") (push HEADERFIELDS (CONS (QUOTE Originator) ORIGINATOR))) (if (AND RETURN-TO (OR (NULL SENDER) (NOT (EQUAL.RNAMES RETURN-TO SENDER))) *NSMAIL-DISPLAY-ERRORS-TO*) then (* ;; "Usually same as originator, so we omit. (NULL SENDER) is only true when there's no originator in envelope, allegedly illegal") (push HEADERFIELDS (CONS (QUOTE Errors-To) RETURN-TO))) (if (NOT (type? NSNAME SENDER)) then (* ; "Can't resolve domain/orgs against this") (SETQ SENDER NIL)) (for PAIR in (SORT HEADERFIELDS (FUNCTION (LAMBDA (X Y) (* ;; "X sorts before Y if X is in the well-known order and either Y appears after it or doesn't appear at all. Non-symbols sort after everything") (AND (LITATOM (CAR X)) (OR (NOT (LITATOM (CAR Y))) (AND (SETQ X (FMEMB (CAR X) NSMAIL.HEADER.ORDER)) (OR (FMEMB (CAR Y) X) (NULL (FMEMB (CAR Y) NSMAIL.HEADER.ORDER))))))))) when (SETQ VALUE (CDR PAIR)) do (printout OUTSTREAM (SETQ TYPE (CAR PAIR)) ": ") (CASE TYPE ((From To cc bcc Reply-to) (\NSMAIL.NEW.PRINT.NAMES VALUE OUTSTREAM (SELECTQ TYPE (From (* ; "Always fully qualified. Also check against sender.") (if (AND SENDER (NOT (for NAME in VALUE always (OR (EQ NAME SENDER) (AND (STRING-EQUAL (fetch NSDOMAIN of NAME) (fetch NSDOMAIN of SENDER)) (STRING-EQUAL (fetch NSORGANIZATION of NAME) (fetch NSORGANIZATION of SENDER))))))) then (* ; "Ugh, From and Sender are different domains. To reduce confusion, force everything to be fully qualified") (SETQ SENDER NIL)) NIL) (Reply-to (* ; "always full-qualified") NIL) SENDER))) ((Sender Originator Errors-To) (printout OUTSTREAM (RNAME.TO.STRING VALUE T))) (T (if (LISTP VALUE) then (* ; "List of things we'll print as each thing separated by spaces (e.g., References)") (SETQ VALUE (CONCATLIST (CDR (for X in VALUE join (LIST " " X)))))) (while (AND (> (NCHARS VALUE) 0) (EQ (NTHCHARCODE VALUE -1) (CHARCODE CR))) do (* ; "Trailing cr's, e.g., in the Subject line, will cause the header not to parse") (SETQ VALUE (SUBSTRING VALUE 1 -2))) (bind (CR _ 1) while (SETQ CR (STRPOS " -" VALUE CR)) do (* ; "Given internal CR, have to make sure subsequent lines are continuation lines, i.e., start with whitespace.") (SELCHARQ (NTHCHARCODE VALUE (ADD1 CR)) ((SPACE TAB) (* ; "It's ok, let it go") (SETQ CR (ADD1 CR))) (PROGN (* ; "Not followed by whitespace, so print this much (including cr), then a tab.") (PRIN3 (SUBSTRING VALUE 1 CR) OUTSTREAM) (PRINTCCODE (CHARCODE TAB) OUTSTREAM) (SETQ VALUE (SUBSTRING VALUE (ADD1 CR))) (SETQ CR 1)))) (PRIN3 VALUE OUTSTREAM))) (TERPRI OUTSTREAM)))) -) - -(\NSMAIL.NEW.PRINT.NAMES -(LAMBDA (RNAMES OUTSTREAM DEFAULTNAME) (* ; "Edited 4-Apr-90 17:32 by bvm") (for NAME in RNAMES bind (FIRSTTIME _ T) ORGDIFFERS do (if (type? NSNAME NAME) then (COND (FIRSTTIME (SETQ FIRSTTIME NIL)) (T (PRIN3 ", " OUTSTREAM))) (PRIN3 (fetch NSOBJECT of NAME) OUTSTREAM) (LET ((ORG (fetch NSORGANIZATION of NAME)) (DOM (fetch NSDOMAIN of NAME))) (if (OR (SETQ ORGDIFFERS (NOT (AND DEFAULTNAME (OR (STRING-EQUAL ORG (fetch NSORGANIZATION of DEFAULTNAME)) (EQ (NCHARS ORG) 0))))) (NOT (OR (STRING-EQUAL DOM (fetch NSDOMAIN of DEFAULTNAME)) (EQ (NCHARS DOM) 0)))) then (* ;; "Have to print the domain. The null string tests are because there exists buggy software that doesn't fill in the domain and org--we want them to default correctly eventually.") (PRIN3 ":" OUTSTREAM) (PRIN3 DOM OUTSTREAM) (if ORGDIFFERS then (* ; "Have to print the org, too") (PRIN3 ":" OUTSTREAM) (PRIN3 ORG OUTSTREAM)))) else (PRIN3 (RNAME.TO.STRING NAME) OUTSTREAM)))) -) - -(\NSMAIL.EMIT.FORWARDING -(LAMBDA (FORWARDINFO FORWARDSTREAM OUTSTREAM PARENT-INDEX) (* ; "Edited 22-May-90 10:41 by bvm") (* ;; "Recursively emit Forwarded body structure. In this pass, we print all the body parts subsidiary to the PARENT-INDEXth item, or the top level items if PARENT-INDEX is nil.") (for FINFO in FORWARDINFO as I from 0 bind NTHTIME when (EQ (fetch (FORWARD PARENT) of FINFO) PARENT-INDEX) do (* ;; "This bit of forwarding info describes a child of PARENT-INDEX") (LET ((*BODY-OFFSET* 0)) (DECLARE (SPECVARS *BODY-OFFSET*)) (* ; "set by \nsmail.new.print.heading") (TERPRI OUTSTREAM) (PRIN3 (if NTHTIME then (* ; "%"Next Message%"") (CADDR LAFITEFORWARDSTRINGS) else (SETQ NTHTIME T) (* ; "%"Begin Forwarded Messages%"") (CADR LAFITEFORWARDSTRINGS)) OUTSTREAM) (TERPRI OUTSTREAM) (\NSMAIL.NEW.PRINT.HEADING OUTSTREAM (fetch (FORWARD HEADINGS) of FINFO) (fetch (FORWARD ENVELOPE) of FINFO)) (* ; "Print header of this part") (TERPRI OUTSTREAM) (for INDEX in (fetch (FORWARD PARTS) of FINFO) bind (MAP _ (fetch (FORWARD MAP) of FINFO)) MAPENTRY NTHPART do (if NTHPART then (* ; "Yet another body part") (PRIN3 " -- - - - - - - - -" OUTSTREAM) else (SETQ NTHPART T)) (if (NOT (SETQ MAPENTRY (CDR (ASSOC INDEX MAP)))) then (PRIN3 "[Missing part] -" OUTSTREAM) elseif (CDR MAPENTRY) then (* ; "(start length)") (SETFILEPTR FORWARDSTREAM (+ (CAR MAPENTRY) *BODY-OFFSET*)) (COPYBYTES FORWARDSTREAM OUTSTREAM (CADR MAPENTRY)) (SETQ *BODY-OFFSET* 0) else (* ; "(attachment#)") (if (CL:FORMAT OUTSTREAM "[See Attachment #~D]~%%" (CAR MAPENTRY)))))) (* ; "If there are children, do them") (\NSMAIL.EMIT.FORWARDING FORWARDINFO FORWARDSTREAM OUTSTREAM I) finally (if NTHTIME then (* ; "Yes, we printed some parts, so time for %"End Forwarded Messages%"") (TERPRI OUTSTREAM) (PRIN3 (CADDDR LAFITEFORWARDSTRINGS) OUTSTREAM)))) -) - -(\NSMAIL.GDATE -(LAMBDA (TIME) (* ; "Edited 11-Jul-90 18:03 by bvm") (GDATE TIME (DATEFORMAT SPACES TIME.ZONE)))) - -(\NSMAIL.TRANSLATE.IP.MESSAGEID -(LAMBDA (ID) (* ; "Edited 11-May-90 10:45 by bvm") (LET ((RNAME (COURIER.FETCH (NEW.MAILTRANSPORT . IP.MESSAGEID) ORIGINATOR of ID)) (USTRING (COURIER.FETCH (NEW.MAILTRANSPORT . IP.MESSAGEID) UNIQUESTRING of ID))) (if (NOT (NULL.NSNAME RNAME)) then (* ; "Really has name") (CONCAT #\< USTRING #\* (RNAME.TO.STRING RNAME T) #\>) elseif (AND (EQ (CL:CHAR USTRING 0) #\<) (EQ (CL:CHAR USTRING (SUB1 (NCHARS USTRING))) #\>)) then (* ; "It's already in msg-id format") USTRING else (\NSMAIL.MAYBE.QUOTE USTRING)))) -) - -(\NSMAIL.MAYBE.QUOTE -(LAMBDA (STR) (* ; "Edited 11-May-90 10:44 by bvm") (* ;; "return STR with string quotes around it if it contains any characters that RFC822 says are special") (if (for I from 1 to (NCHARS STR) bind CH thereis (OR (< (SETQ CH (NTHCHARCODE STR I)) (CHARCODE SPACE)) (>= CH (CHARCODE DEL)) (FMEMB CH (CHARCODE ("(" ")" "<" ">" "@" "," ";" ":" \ %" "." "[" "]"))))) then (CONCAT #\" (if (STRPOSL (CHARCODE (\ %")) STR) then (* ; "Have to quote these") (CONCATLIST (for I from 0 to (SUB1 (NCHARS STR)) bind CH join (CASE (SETQ CH (CL:CHAR STR I)) ((#\\ #\") (LIST #\\ CH)) (T (LIST CH))))) else STR) #\") else STR)) -) - -(NULL.NSNAME -(LAMBDA (NAME) (* ; "Edited 21-Aug-90 11:32 by bvm") (AND (type? NSNAME NAME) (EQL (NCHARS (fetch NSDOMAIN of NAME)) 0) (EQL (NCHARS (fetch NSORGANIZATION of NAME)) 0) (PROGN (* ; "Kludge in new gateway due to bug in backward compatibility--object = single char is also %"null%"") (< (NCHARS (fetch NSOBJECT of NAME)) 2)))) -) - -(\NSMAIL.HANDLE.DELIVERY.REPORT -(LAMBDA (OUTSTREAM REPORT-RECORD ENVELOPE) (* ; "Edited 29-Jun-90 18:06 by bvm") (LET* ((POSTED.DATE (COURIER.FETCH (NEW.MAILTRANSPORT . POSTMARK) TIME of (CADR (ASSOC (QUOTE Postmark) ENVELOPE)))) (OLD.ENVELOPE (COURIER.FETCH (NEW.MAILTRANSPORT . REPORT) ORIGINAL.ENVELOPE of REPORT-RECORD)) (REPORT (COURIER.FETCH (NEW.MAILTRANSPORT . REPORT) REPORT.TYPE of REPORT-RECORD)) (REPORTVALUE (CADR REPORT)) (FATE (COURIER.FETCH (NEW.MAILTRANSPORT . REPORT) FATE of REPORT-RECORD)) (SENDER (CADR (ASSOC (QUOTE Originator) ENVELOPE))) (RETURN-TO (CADR (ASSOC (QUOTE RETURN.TO.NAME) ENVELOPE))) BADNAMES GOODNAMES) (if POSTED.DATE then (PRINTOUT OUTSTREAM "Date: " (\NSMAIL.GDATE POSTED.DATE) T)) (if SENDER then (PRINTOUT OUTSTREAM "From: " (RNAME.TO.STRING SENDER T) T)) (if (AND RETURN-TO (NOT (EQUAL.RNAMES SENDER RETURN-TO))) then (PRINTOUT OUTSTREAM "Errors-to: " (RNAME.TO.STRING RETURN-TO T) T)) (PRINTOUT OUTSTREAM "Subject: ") (if (EQ (CAR FATE) (QUOTE NOT.DELIVERED)) then (* ; "Bizarre") (PRINTOUT OUTSTREAM "Return of non-delivery notice" T T "This non-delivery report could not be delivered because " (CAR (CADR FATE)) T T "Original-Subject: ")) (CASE (CAR REPORT) (DLMEMBER (* ; "Bad member notification") (SETQ BADNAMES (COURIER.FETCH (NEW.MAILTRANSPORT . DLREPORT) INVALID.RECIPIENTS of REPORTVALUE)) (PRINTOUT OUTSTREAM "Bad group membership notification" T T) (CL:FORMAT OUTSTREAM "A message from ~A could not be delivered to the following member~P of ~A:" (RNAME.TO.STRING (CADR (ASSOC (QUOTE Originator) OLD.ENVELOPE)) T) (LENGTH BADNAMES) (RNAME.TO.STRING (COURIER.FETCH (NEW.MAILTRANSPORT . DLREPORT) DLNAME of REPORTVALUE) T))) (OTHER (SETQ BADNAMES (COURIER.FETCH (NEW.MAILTRANSPORT . OTHER.REPORT) FAILED of REPORTVALUE)) (SETQ GOODNAMES (COURIER.FETCH (NEW.MAILTRANSPORT . OTHER.REPORT) SUCCEEDED of REPORTVALUE)) (if BADNAMES then (PRINTOUT OUTSTREAM "Undeliverable mail" T T) (CL:FORMAT OUTSTREAM "This message could not be delivered to the following recipient~P:" (LENGTH BADNAMES)) else (* ; "Strictly a delivery report") (PRINTOUT OUTSTREAM "Delivery report"))) (T (* ; "Shouldn't happen") (PRINTOUT OUTSTREAM "Erroneous (non-)delivery report" T T REPORT))) (PRINTOUT OUTSTREAM T T) (for PAIR in BADNAMES do (PRINTCCODE (CHARCODE TAB) OUTSTREAM) (PRINTOUT OUTSTREAM (\NSMAIL.RECIPIENT.NAME (COURIER.FETCH (NEW.MAILTRANSPORT . NON.DELIVERED.RECIPIENT) RECIPIENT of PAIR)) " -- " (COURIER.FETCH (NEW.MAILTRANSPORT . NON.DELIVERED.RECIPIENT) REASON of PAIR) T)) (if GOODNAMES then (* ; "A delivery report") (if BADNAMES then (TERPRI OUTSTREAM)) (CL:FORMAT OUTSTREAM "This message was delivered to the following recipient~P:~2%%" (LENGTH GOODNAMES)) (for PAIR in GOODNAMES do (PRINTCCODE (CHARCODE TAB) OUTSTREAM) (PRINTOUT OUTSTREAM (\NSMAIL.RECIPIENT.NAME (COURIER.FETCH (NEW.MAILTRANSPORT . DELIVERED.RECIPIENT) RECIPIENT of PAIR)) " at " (\NSMAIL.GDATE (COURIER.FETCH (NEW.MAILTRANSPORT . DELIVERED.RECIPIENT) WHEN of PAIR) (DATEFORMAT TIME.ZONE)) T))) OLD.ENVELOPE)) -) - -(\NSMAIL.RECIPIENT.NAME -(LAMBDA (RECIPIENT) (* ; "Edited 4-Apr-90 17:26 by bvm") (* ;; "Printable rep for a MailTransport.Recipient") (RNAME.TO.STRING (COURIER.FETCH (NEW.MAILTRANSPORT . RECIPIENT) NAME of RECIPIENT) T)) -) - -(NEW.INBASKET.CALL -(CL:LAMBDA (MAILBOX PROCEDURE &REST ARGS) (* ; "Edited 13-Dec-89 17:17 by bvm") (PROG ((STREAM (fetch NSMAILSTREAM of MAILBOX)) RESULT) LP (if (AND (EQ (CAR (LISTP (SETQ RESULT (CL:APPLY (FUNCTION COURIER.CALL) STREAM (QUOTE NEW.INBASKET) PROCEDURE ARGS)))) (QUOTE ERROR)) (CASE (CAR (LAST ARGS)) (NOERROR NIL) (RETURNERRORS (* ; "We'll only handle stream lost--caller gets the rest") (EQ (CADR RESULT) (QUOTE STREAM.LOST))) (T (* ; "Probably an error was already signaled") T))) then (SETQ STREAM (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX (QUOTE NEW.INBASKET) PROCEDURE)) (GO LP) else (RETURN RESULT)))) -) - -(NEWNS.CLOSEMAILBOX -(LAMBDA (MAILBOX FLUSH?) (* ; "Edited 18-Dec-89 17:35 by bvm") (COND (FLUSH? (* ; "Delete everything we retrieved") (LET ((INDICES (REVERSE (fetch NSMAILENVELOPES of MAILBOX))) (SESSION (fetch NSMAILSESSION of MAILBOX))) (while INDICES do (* ; "Delete a message or more. To keep the calls down, try to delete consecutive ranges when possible.") (LET* ((START (CAR INDICES)) (END START)) (while (AND (SETQ INDICES (CDR INDICES)) (EQL (CAR INDICES) (ADD1 END))) do (SETQ END (ADD1 END))) (NEW.INBASKET.CALL MAILBOX (QUOTE DELETE) (COURIER.CREATE (NEW.INBASKET . RANGE) LOW _ START HIGH _ END) SESSION)))))) (\NSMAIL.NEW.LOGOFF (fetch NSMAILSTATE of MAILBOX) (fetch NSMAILSTREAM of MAILBOX))) -) - -(\NSMAIL.NEW.LOGOFF -(LAMBDA (STATE STREAM) (* ; "Edited 19-Dec-89 11:08 by bvm") (* ;; "Executes the Inbasket.Logoff procedure and clears appropriate state. Returns true if LOGOFF call succeeded.") (LET ((RESULT (COURIER.CALL STREAM (QUOTE NEW.INBASKET) (QUOTE LOGOFF) (fetch STATESESSION of STATE) (QUOTE RETURNERRORS)))) (PROG1 (NEQ (CAR (LISTP RESULT)) (QUOTE ERROR)) (replace STATESESSION of STATE with NIL) (CLOSEF STREAM)))) -) -) - -(RPAQQ \NSMAIL.GOOD.BODY.PARTS (0 5 6 2)) - -(RPAQQ \NSMAIL.DISCARDABLE.BODY.PARTS ((201 "Tioga formatting") (202 "Tioga header"))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \NSMAIL.GOOD.BODY.PARTS \NSMAIL.DISCARDABLE.BODY.PARTS) -) - -(ADDTOVAR LAFITEMODELST (NS 1 \NSMAIL.NEW.SEND.PARSE \NSMAIL.NEW.SEND \NSMAIL.MAKEANSWERFORM \NSMAIL.NEW.AUTHENTICATE \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.LOGIN)) - -(FILESLOAD NSMAIL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) - -(DECLARE%: EVAL@COMPILE - -(RECORD FORWARD (ENVELOPE HEADINGS PARTS PARENT . MAP)) -) - -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \NSMAIL.BODY.PART.TYPE MACRO (ARGS (COND ((CADR (ASSOC (CAR ARGS) \NSMAIL.BODY.PART.TYPES))) (T (ERROR "Unknown body part type" (CAR ARGS)) (QUOTE IGNOREMACRO))))) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \NSMAIL.BODY.PART.TYPES \NSMAIL.HEADING.ATTRIBUTES) -) - - -(CL:PROCLAIM (QUOTE (CL:SPECIAL *RETRIEVAL-ERROR*))) - - -(FILESLOAD (SOURCE) LAFITEDECLS) - - -(FILESLOAD (LOADCOMP) NSMAIL) - - -(RPAQQ \NSMAIL.CONTENTS.TYPES ((\CT.NULL 0) (\CT.STANDARD.MESSAGE 4) (\CT.REPORT 6))) -(DECLARE%: EVAL@COMPILE - -(RPAQQ \CT.NULL 0) - -(RPAQQ \CT.STANDARD.MESSAGE 4) - -(RPAQQ \CT.REPORT 6) - - -(CONSTANTS (\CT.NULL 0) (\CT.STANDARD.MESSAGE 4) (\CT.REPORT 6)) -) -DOCOPY - -(RPAQQ \NSMAIL.BODY.PART.TYPES ((HEADING 0) (VPFOLDER 1) (NSTEXTFILE 2) (VPDOCUMENT 3) (OTHERNSFILE 4) (MULTINATIONAL.NOTE 5) (IA5.NOTE 6) (PILOTFILE 7) (G3FAX 8) (TELETEX 9) (TELEX 10) (ISO6937.NOTE 11) (INTERPRESS 12))) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA) - -(ADDTOVAR NLAML) - -(ADDTOVAR LAMA NEW.INBASKET.CALL) -) -(PUTPROPS NEWNSMAIL COPYRIGHT ("Xerox Corporation" 1989 1990 1992 1993)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (11794 13309 (\NS.NEW.READ.ENVELOPE.ITEM 11804 . 12569) (\NS.NEW.WRITE.ENVELOPE.ITEM -12571 . 13307)) (14045 15723 (\NS.READ.HEADING.ATTRIBUTE 14055 . 15033) (\NS.WRITE.HEADING.ATTRIBUTE -15035 . 15721)) (16610 18013 (\NSMAIL.READ.RNAME 16620 . 17178) (\NSMAIL.WRITE.RNAME 17180 . 17671) ( -\NSMAIL.RNAME.LENGTH 17673 . 18011)) (18109 20183 (RNAME.TO.STRING 18119 . 18298) (X400.NAME.TO.STRING - 18300 . 19987) (EQUAL.RNAMES 19989 . 20181)) (20208 39801 (\NSMAIL.NEW.SEND.PARSE 20218 . 22560) ( -\NSMAIL.CHECK.ENUMERATION 22562 . 23481) (\NSMAIL.NEW.SEND 23483 . 31975) ( -\NSMAIL.NEW.INVALID.RECIPIENTS 31977 . 32558) (\NSMAIL.BUILD.HEADING 32560 . 33859) ( -\NSMAIL.POST.BODY.PART 33861 . 35692) (\NSMAIL.NEW.PREPARE.ATTACHMENT 35694 . 37343) ( -\NSMAIL.CHECK.ABORT 37345 . 37703) (\NSMAIL.NEW.FINDSERVER 37705 . 38760) (\NSMAIL.NEW.CHECKSERVER -38762 . 39799)) (41678 81632 (\NSMAIL.NEW.AUTHENTICATE 41688 . 42896) (NEWNS.POLLNEWMAIL 42898 . 43213 -) (NEWNS.OPENMAILBOX 43215 . 43899) (\NSMAIL.NEW.CHECK 43901 . 47923) (NEWNS.NEXTMESSAGE 47925 . 48419 -) (NEWNS.RETRIEVEMESSAGE 48421 . 52285) (\NSMAIL.READ.BODY.PARTS 52287 . 57698) (\NSMAIL.COPY.IA5 -57700 . 58449) (\NSMAIL.COPY.NSTEXTFILE 58451 . 60600) (\NSMAIL.READ.HEADING 60602 . 63337) ( -\NSMAIL.PARSE.ANNOTATION 63339 . 64073) (\NSMAIL.EMIT.ANNOTATION 64075 . 65343) (LA.TRIM.WHITESPACE -65345 . 65467) (\NSMAIL.READ.FORWARDING 65469 . 66494) (\NSMAIL.NEW.PRINT.HEADING 66496 . 72120) ( -\NSMAIL.NEW.PRINT.NAMES 72122 . 73098) (\NSMAIL.EMIT.FORWARDING 73100 . 74934) (\NSMAIL.GDATE 74936 . -75052) (\NSMAIL.TRANSLATE.IP.MESSAGEID 75054 . 75601) (\NSMAIL.MAYBE.QUOTE 75603 . 76241) (NULL.NSNAME - 76243 . 76585) (\NSMAIL.HANDLE.DELIVERY.REPORT 76587 . 79618) (\NSMAIL.RECIPIENT.NAME 79620 . 79847) -(NEW.INBASKET.CALL 79849 . 80473) (NEWNS.CLOSEMAILBOX 80475 . 81191) (\NSMAIL.NEW.LOGOFF 81193 . 81630 -))))) -STOP diff --git a/lispusers/BMENCODE.LCOM.~2~ b/lispusers/BMENCODE.LCOM.~2~ deleted file mode 100644 index 10d948d67caf27f7c10f3dc0d0ecc0521b1e6402..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2996 zcmb_eU2oG?7l?p>?BTxV2nLls4lz*9^%w^W67{dS<+K0?4(gt}gL8oRi^zb>Y^)VJB~PukCyetO3JVqD2)KMk+2U4~cf z)Ms?NKU}^@|FH+-!p^aO=RNHGTy9LGbNGX8{AFyh*d9xPec99s>zLvMEx{zA! zE&cjp|L4?;cKSDSz~+A6Gg%;eIsWt3^GjR%xjVloR_t9g3&nF{7yi+8L2}jUT!8>fZeDuW7 zK=&|DKA+Ffm^rZ@RBJ9EJVqy?CQ#oEbl=rI)39~y5CN;L6}11SBxUdev`!1PTRK}7 zO{|0@XNX>dQPKHhLxFX}b~^z!u?XUYSOp*;3W83=L4vTN4w?ZA<7jy$F8uIvxXP5* zU7>pJ<#L@|_fimEVV(D=ZineNS$@d~uf86pcU~K>+OLc^Z1m1|7wGsuT>B+=yp^;c zhF|>q_GRigNP6h3HY>GT=qiLraJO!tS(N3Nx9H*kNv8UvCt#qfqGZ8wv8ow2)N|1G zVxAQ#X;o%@Qk97$p^DKjgJwFu-n_|-Xz^?lCz60k6|EepqG!nrb!M zi(am~yc1q#o!Jz(-Ht^zOoywllb64_Su53f`-&;;^KIs-s5dlJk07o^@Jui77Z>_0 zUJbi=15m>au+*Zj5qc%yEYDT9w--7=5H_HLA98U2Xw;n!#v}CECRTmCY&0GF@MC2( z?H`WzhO@{?9D1r?lkcEd;TWVg8at}zgK+N0h^>ct3^HsZm`BYn5fr4Q;V_+==#iO5 zrYzHGEz_yvO+nM2o1J#flby~&?-B|xa4^I92`IdXxtlCto{S+oIkbQe;bjCYIQ-ai wDYl47&>VNyGg|EcKeheo-Uu(!9&|>7$M`Khm_FfwROzQ@RjD8}+b}c#0gySs2><{9 diff --git a/lispusers/COMPAREDIRECTORIES.~270~ b/lispusers/COMPAREDIRECTORIES.~270~ deleted file mode 100644 index f4be30cc..00000000 --- a/lispusers/COMPAREDIRECTORIES.~270~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Oct-2020 13:45:01"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;270 62511 changes to%: (FNS CDFILES) previous date%: "14-Oct-2020 21:18:16" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;269) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 14-Oct-2020 21:15 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 21-Sep-2020 16:56 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1615 16646 (COMPAREDIRECTORIES 1625 . 10115) (CDFILES 10117 . 14692) ( COMPAREDIRECTORIES.INFOS 14694 . 16209) (MATCHNAME 16211 . 16644)) (16647 23832 (CDPRINT 16657 . 21457 ) (CDPRINT.LINE 21459 . 23830)) (23833 25585 (CDMAP 23843 . 24539) (CDENTRY 24541 . 24709) (CDSUBSET 24711 . 25583)) (25586 31117 (BINCOMP 25596 . 29885) (EOLTYPE 29887 . 31115)) (31330 44537 ( FIND-UNCOMPILED-FILES 31340 . 34983) (FIND-UNSOURCED-FILES 34985 . 37794) (FIND-SOURCE-FILES 37796 . 39500) (FIND-COMPILED-FILES 39502 . 41580) (FIND-UNLOADED-FILES 41582 . 42326) (FIND-LOADED-FILES 42328 . 42882) (FIND-MULTICOMPILED-FILES 42884 . 44535)) (44538 52570 (CREATED-AS 44548 . 49345) ( SOURCE-FOR-COMPILED-P 49347 . 51875) (COMPILE-SOURCE-DATE-DIFF 51877 . 52568)) (52571 61578 ( FIX-DIRECTORY-DATES 52581 . 54577) (FIX-EQUIV-DATES 54579 . 55839) (COPY-COMPARED-FILES 55841 . 57965) (COPY-MISSING-FILES 57967 . 59806) (COMPILED-ON-SAME-SOURCE 59808 . 61576)) (61733 62344 ( COMPARE-ENTRY-SOURCE-FILES 61743 . 62342))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~271~ b/lispusers/COMPAREDIRECTORIES.~271~ deleted file mode 100644 index 3d21c8f8..00000000 --- a/lispusers/COMPAREDIRECTORIES.~271~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "23-Oct-2020 12:29:12"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;271 62619 changes to%: (FNS SOURCE-FOR-COMPILED-P) previous date%: "16-Oct-2020 13:45:01" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;270) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 14-Oct-2020 21:15 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 23-Oct-2020 12:13 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSE (LISTP DFASLMARGIN) ELSEIF (IGREATERP DFASLMARGIN 0) THEN (LIST DFASLMARGIN 0) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES) (* ; "Edited 6-Sep-2020 15:08 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) (ITIMES 120 ONESECOND)) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1629 16660 (COMPAREDIRECTORIES 1639 . 10129) (CDFILES 10131 . 14706) ( COMPAREDIRECTORIES.INFOS 14708 . 16223) (MATCHNAME 16225 . 16658)) (16661 23846 (CDPRINT 16671 . 21471 ) (CDPRINT.LINE 21473 . 23844)) (23847 25599 (CDMAP 23857 . 24553) (CDENTRY 24555 . 24723) (CDSUBSET 24725 . 25597)) (25600 31131 (BINCOMP 25610 . 29899) (EOLTYPE 29901 . 31129)) (31344 44551 ( FIND-UNCOMPILED-FILES 31354 . 34997) (FIND-UNSOURCED-FILES 34999 . 37808) (FIND-SOURCE-FILES 37810 . 39514) (FIND-COMPILED-FILES 39516 . 41594) (FIND-UNLOADED-FILES 41596 . 42340) (FIND-LOADED-FILES 42342 . 42896) (FIND-MULTICOMPILED-FILES 42898 . 44549)) (44552 52678 (CREATED-AS 44562 . 49359) ( SOURCE-FOR-COMPILED-P 49361 . 51983) (COMPILE-SOURCE-DATE-DIFF 51985 . 52676)) (52679 61686 ( FIX-DIRECTORY-DATES 52689 . 54685) (FIX-EQUIV-DATES 54687 . 55947) (COPY-COMPARED-FILES 55949 . 58073) (COPY-MISSING-FILES 58075 . 59914) (COMPILED-ON-SAME-SOURCE 59916 . 61684)) (61841 62452 ( COMPARE-ENTRY-SOURCE-FILES 61851 . 62450))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~274~ b/lispusers/COMPAREDIRECTORIES.~274~ deleted file mode 100644 index 32658929..00000000 --- a/lispusers/COMPAREDIRECTORIES.~274~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-Oct-2020 09:13:05"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;274 62687 changes to%: (FNS SOURCE-FOR-COMPILED-P FIX-DIRECTORY-DATES) previous date%: "23-Oct-2020 12:29:12" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;271) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents of two directories.") (FNS COMPAREDIRECTORIES CDFILES COMPAREDIRECTORIES.INFOS MATCHNAME) (FNS CDPRINT CDPRINT.LINE) (FNS CDMAP CDENTRY CDSUBSET) (FNS BINCOMP EOLTYPE) (RECORDS CDENTRY CDINFO) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES FIND-UNSOURCED-FILES FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES FIND-MULTICOMPILED-FILES) (FNS CREATED-AS SOURCE-FOR-COMPILED-P COMPILE-SOURCE-DATE-DIFF) (FNS FIX-DIRECTORY-DATES FIX-EQUIV-DATES COPY-COMPARED-FILES COPY-MISSING-FILES COMPILED-ON-SAME-SOURCE) [VARS (ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"] (INITVARS (LASTCDENTRIES NIL)) (COMS (FNS COMPARE-ENTRY-SOURCE-FILES) (FILES COMPARESOURCES)))) (* ;; "Compare the contents of two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (DIR1 DIR2 SELECT FILEPATTERNS EXTENSIONSTOAVOID USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS) (* ; "Edited 14-Oct-2020 21:15 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is with respect to the the LISP filecreated dates if evailable.") (* ;; "") (* ;; "If OUTPUTFILE is NIL, the list of compared entries is returned. Otherwise the selected entries are printed on OUTPUTFILE (T for the display).") [SETQ SELECT (SELECTQ SELECT (NIL '(< > -* *-)) (T '(< > -* *- =)) (FOR S IN (MKLIST SELECT) COLLECT (SELECTQ S ((AFTER >) '>) ((BEFORE <) '<) ((SAME SAMEDATE =) '=) (AUTHOR 'AUTHOR) (-* '-*) (*- '*-) (ERROR "UNRECOGNIZED SELECT PARAMETER" S] (PROG (INFOS1 INFOS2 CANDIDATES SELECTED COMPAREDATE DEPTH1 DEPTH2) [SETQ COMPAREDATE (INTERSECTION SELECT '(< > =] (* ;; "DIRECTORYNAME here to get unrelativized specifications for header.") (* ;; "Allow all subdirectories if a directory ends in *, but peel it off for the resolution") (CL:WHEN (EQ '* (NTHCHAR DIR1 -1)) (SETQ DEPTH1 T) (SETQ DIR1 (SUBSTRING DIR1 1 -2))) (CL:WHEN (EQ '* (NTHCHAR DIR2 -1)) (SETQ DEPTH2 T) (SETQ DIR2 (SUBSTRING DIR2 1 -2))) (SETQ DIR1 (OR (DIRECTORYNAME (OR DIR1 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR1))) (SETQ DIR2 (OR (DIRECTORYNAME (OR DIR2 T)) (ERROR "DIRECTORY DOES NOT EXIST" DIR2))) (PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE) " selecting " SELECT " ... ") (SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH1) USEDIRECTORYDATE)) (SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH2) USEDIRECTORYDATE)) (CL:UNLESS (AND INFOS2 INFOS1) (RETURN)) (* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.") (* ;;  "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname") [SETQ CANDIDATES (FOR I1 IN INFOS1 JOIN (IF ALLVERSIONS THEN (OR (FOR I2 IN INFOS2 WHEN (EQ (CAR I2) (CAR I1)) COLLECT (LIST (CAR I1) (CDR I1) (CDR I2))) (CONS (LIST (CAR I1) (CDR I1) NIL))) ELSE (CONS (LIST (CAR I1) (CDR I1) (CDR (ASSOC (CAR I1) INFOS2] (* ;; "Could be some 2's without 1's") (SORT [NCONC CANDIDATES (FOR I2 IN INFOS2 UNLESS (ASSOC (CAR I2) CANDIDATES) COLLECT (LIST (CAR I2) NIL (CDR I2] T) (* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)") (* ;; "Do the SELECT filtering and insert the date relation.") [SETQ SELECTED (FOR C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP IN CANDIDATES EACHTIME (SETQ MATCHNAME (POP C)) (SETQ INFO1 (POP C)) (SETQ INFO2 (POP C)) (IF (AND INFO1 INFO2) THEN (SETQ IDATE1 (IDATE (FETCH DATE OF INFO1))) (SETQ IDATE2 (IDATE (FETCH DATE OF INFO2))) (SETQ DATEREL (IF (IGREATERP IDATE1 IDATE2) THEN '> ELSEIF (ILESSP IDATE1 IDATE2) THEN '< ELSE '=)) ELSE (* ;; "Just for printing--no comparison") (SETQ DATEREL '*)) WHEN (IF (AND INFO1 INFO2) THEN (OR (NULL COMPAREDATE) (SELECTQ DATEREL (> (MEMB '> SELECT)) (< (MEMB '< SELECT)) (= (MEMB '= SELECT)) (SHOULDNT))) ELSEIF INFO1 THEN (* ;; "OK if INFO2 is missing?") (MEMB '*- SELECT) ELSE (* ;; "OK if INFO1 is missing?") (MEMB '-* SELECT)) COLLECT (CREATE CDENTRY MATCHNAME _ MATCHNAME INFO1 _ INFO1 DATEREL _ DATEREL INFO2 _ INFO2 EQUIV _ (CL:UNLESS (EQ DATEREL '*) (BINCOMP (FETCH FULLNAME OF INFO1) (FETCH FULLNAME OF INFO2) T (FETCH EOL OF INFO1) (FETCH EOL OF INFO2)))] (PRINTOUT T (LENGTH SELECTED) " entries" T) (PUSH SELECTED (LIST DIR1 DIR2 SELECT (DATE))) (SETQ LASTCDENTRIES SELECTED) (CL:UNLESS OUTPUTFILE (RETURN SELECTED)) (RETURN (CDPRINT SELECTED OUTPUTFILE (MEMB 'AUTHOR SELECT SELECT]) (CDFILES [LAMBDA (DIR FILEPATTERNS EXTENSIONSTOAVOID ALLVERSIONS DEPTH) (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria") (* ;; "For each name returned by (DIRECTORY DIR), assumes that FILEPATTERNS applies to the suffix after the directory (i.e. after NAMEPOS). That includes possibly subdirectories, dotted files in ultimate file names, and versions.") (* ;; " Exclude subdirectories unless FILEPATTERNS includes *>*") (* ;; " Exclude dotted files (.xxx) unless FILEPATTERNS includes .*") (* ;; " Exclude files with extensions in EXTENSIONSTOAVOID (*=NIL does no filtering)") (* ;; " Exclude older versions unless ALLVERSIONS=T") (* ;; " DEPTH is the number of subdirectories below the ones specified in DIR (NIL top-level of DIR only, T = any depth)") (* ;; "Resolve relative directories, so we can suppress subdirectory matches. ") (SETQ EXTENSIONSTOAVOID (MKLIST (U-CASE EXTENSIONSTOAVOID))) [SETQ FILEPATTERNS (MKLIST (OR FILEPATTERNS '*] (FOR FP FN FPNAME FPEXT EXCLUDEDOTTED (TOPDIR _ (DIRECTORYNAME (OR DIR T))) IN FILEPATTERNS JOIN [SETQ FPNAME (U-CASE (FILENAMEFIELD FP 'NAME] [SETQ FPEXT (U-CASE (FILENAMEFIELD FP 'EXTENSION] (CL:UNLESS FPNAME (IF FPEXT THEN (* ;; ".XY") (SETQ FPNAME (PACK* "." FPEXT)) ELSE (SETQ FPNAME '*))) (CL:UNLESS FPEXT (SETQ FPEXT '*)) (SETQ EXCLUDEDOTTED (NEQ (CHARCODE %.) (CHCON1 FPNAME))) (SETQ FN (PACKFILENAME.STRING 'VERSION (CL:IF ALLVERSIONS '* "") 'DIRECTORY TOPDIR 'NAME '* 'EXTENSION '*)) (* ;; "DEPTH is the number of internal %">%"") [IF (EQ DEPTH T) THEN (SETQ DEPTH MAX.SMALLP) ELSEIF DEPTH ELSE (SETQ DEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FN 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT] (FOR FULLNAME NAME EXT THISDEPTH IN (DIRECTORY FN) EACHTIME [SETQ NAME (U-CASE (FILENAMEFIELD FULLNAME 'NAME] [SETQ EXT (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION] (CL:UNLESS NAME (IF EXT THEN (* ;; ".XY") (SETQ NAME (PACK* "." EXT)) (SETQ EXT NIL))) (CL:WHEN (AND EXCLUDEDOTTED (EQ (CHARCODE %.) (CHCON1 NAME))) (GO $$ITERATE)) (SETQ THISDEPTH (BIND (CNT _ 0) (POS _ 0) (FNDIR _ (FILENAMEFIELD FULLNAME 'DIRECTORY)) WHILE (SETQ POS (STRPOS ">" FNDIR (ADD1 POS))) DO (ADD CNT 1) FINALLY (RETURN CNT))) (* ;; "An empty subdirectory may appear without name or extensions") WHEN (AND (OR NAME EXT) (OR (EQ FPNAME '*) (EQ FPNAME NAME)) (OR (EQ FPEXT '*) (EQ FPEXT EXT))) UNLESS [OR (IGREATERP THISDEPTH DEPTH) (AND EXT (OR (MEMB '* EXTENSIONSTOAVOID) (MEMB EXT EXTENSIONSTOAVOID] COLLECT FULLNAME) FINALLY (CL:UNLESS $$VAL (PRINTOUT T "No relevant files in " TOPDIR T]) (COMPAREDIRECTORIES.INFOS [LAMBDA (FILES USEDIRECTORYDATE) (* ; "Edited 13-Oct-2020 08:42 by rmk:") (* ;; "Value is a list of CDINFOS with the match-name consed on to the front") (FOR FULLNAME TYPE LDATE IN FILES COLLECT (* ;; "GDATE/IDATE in case Y2K") (SETQ LDATE (FILEDATE FULLNAME)) (* ; "Is it a Lisp file?") (CONS (MATCHNAME FULLNAME) (CREATE CDINFO FULLNAME _ FULLNAME DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO FULLNAME 'CREATIONDATE) ELSEIF (OR LDATE (GETFILEINFO FULLNAME 'CREATIONDATE] LENGTH _ (GETFILEINFO FULLNAME 'LENGTH) AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR) TYPE _ (IF LDATE THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) *COMPILED-EXTENSIONS*) 'COMPILED 'SOURCE) ELSE (PRINTFILETYPE FULLNAME)) EOL _ (EOLTYPE FULLNAME]) (MATCHNAME [LAMBDA (NAME) (* ; "Edited 5-Sep-2020 13:41 by rmk:") (* ;; "The NAME.DIR for matching related files") (LET ((M (PACKFILENAME 'HOST NIL 'VERSION NIL 'DIRECTORY NIL 'BODY NAME))) (* ;; "Strip off the nuisance period") (CL:IF (EQ (CHARCODE %.) (NTHCHARCODE M -1)) (SUBATOM M 1 -2) M)]) ) (DEFINEQ (CDPRINT [LAMBDA (CDENTRIES FILE PRINTAUTHOR) (* ; "Edited 13-Oct-2020 08:38 by rmk:") (* ;; "Typically CDENTRIES will have a header. If not, we fake one up, at least for the directories and today's date.") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (RESETLST (LET (INFO1 TEXT STREAM DATE1POS ENDDATE1 DIR1 DIR2 (HEADER (CAR CDENTRIES)) NCHARSDIR1) (CL:UNLESS (STRINGP (CADR HEADER)) (SETQ HEADER (LIST [FOR E IN CDENTRIES WHEN (FETCH INFO1 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO1 OF E] [FOR E IN CDENTRIES WHEN (FETCH INFO2 OF E) DO (RETURN (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY (FETCH FULLNAME OF (FETCH INFO2 OF E] NIL (DATE))) (PUSH CDENTRIES HEADER)) (SETQ DIR1 (CAR HEADER)) (SETQ NCHARSDIR1 (NCHARS DIR1)) (SETQ DIR2 (CADR HEADER)) (CL:UNLESS (SETQ STREAM (GETSTREAM FILE 'OUTPUT T)) [RESETSAVE (SETQ STREAM (OPENSTREAM (PACKFILENAME 'EXTENSION 'TXT 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE]) (CL:WHEN DIR1 (PRINTOUT STREAM "Comparing " DIR1 6 "vs. " DIR2 T "as of " (CADDDR HEADER)) (CL:WHEN (CADDR HEADER) (PRINTOUT STREAM " selecting " (CADDR HEADER))) (PRINTOUT STREAM -2 (LENGTH (CDR CDENTRIES)) " entries" T T)) (LINELENGTH 1000 STREAM) (* ; "Don't wrap") (* ;; "DATE1POS is the position of the first character of INFO1's date, used for tabbing. We have to measure the filename, date, size, and author if desired") (IF (CDR CDENTRIES) THEN (FOR E INFO1 (MAXDATE1WIDTH _ 0) (SPACEWIDTH _ 1) (PARENWIDTH _ 2) IN (CDR CDENTRIES) WHEN (SETQ INFO1 (FETCH INFO1 OF E)) LARGEST [SETQ MAXDATE1WIDTH (IMAX MAXDATE1WIDTH (NCHARS (FETCH DATE OF INFO1] (IPLUS (- (NCHARS (FETCH FULLNAME OF INFO1)) NCHARSDIR1) (NCHARS (FETCH LENGTH OF INFO1)) (CL:IF PRINTAUTHOR (IPLUS SPACEWIDTH PARENWIDTH (NCHARS (FETCH AUTHOR OF INFO1))) 0)) FINALLY (* ;;  "First 4 for width of equiv. $$EXTREME is NIL if there are no INFO1's") (SETQ DATE1POS (IPLUS (OR $$EXTREME 10) 4 (ITIMES 3 SPACEWIDTH))) (SETQ ENDDATE1 (IPLUS DATE1POS MAXDATE1WIDTH) )) (FOR E IN (CDR CDENTRIES) DO (CDPRINT.LINE STREAM E PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 (NCHARS DIR2))) ELSE (PRINTOUT T "CDENTRIES is empty" T)) (AND STREAM (CLOSEF? STREAM))))]) (CDPRINT.LINE [LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2) (* ; "Edited 13-Oct-2020 08:51 by rmk:") (* ;; "Format one line of the directory comparison listing. If PRINTAUTHOR and AUTHOR1 or AUTHOR2 are non-NIL, list the author in parens; otherwise omit it.") (LET ((INFO1 (FETCH INFO1 OF ENTRY)) (INFO2 (FETCH INFO2 OF ENTRY))) (PRINTOUT STREAM (SELECTQ (FETCH EQUIV OF ENTRY) (T "==") (NIL " ") (PROGN (SELECTQ (FETCH EOL OF INFO1) (CR 'C) (LF 'L) (CRLF 2) " ") (SELECTQ (FETCH EOL OF INFO2) (CR 'C) (LF 'L) (CRLF 2) " "))) " ") (CL:WHEN INFO1 (PRINTOUT STREAM (SUBSTRING (FETCH FULLNAME OF INFO1) (ADD1 NCHARSDIR1) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO1) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO1) .TAB0 DATE1POS (FETCH DATE OF INFO1))) (PRINTOUT STREAM .TAB0 ENDDATE1 " " (FETCH DATEREL OF ENTRY) " ") (CL:WHEN INFO2 (PRINTOUT STREAM (FETCH DATE OF INFO2) " " (SUBSTRING (FETCH FULLNAME OF INFO2) (ADD1 NCHARSDIR2) NIL (CONSTANT (CONCAT))) " ") (CL:WHEN PRINTAUTHOR (PRINTOUT STREAM "(" (FETCH AUTHOR OF INFO2) ") ")) (PRINTOUT STREAM (FETCH LENGTH OF INFO2))) (TERPRI STREAM]) ) (DEFINEQ (CDMAP [LAMBDA (CDENTRIES FN) (* ; "Edited 6-Sep-2020 15:58 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) DO (APPLY* FN CDE]) (CDENTRY [LAMBDA (MATCHNAME CDENTRIES) (* ; "Edited 5-Sep-2020 21:09 by rmk:") (ASSOC MATCHNAME (OR CDENTRIES LASTCDENTRIES]) (CDSUBSET [LAMBDA (CDENTRIES FN) (* ; "Edited 15-Sep-2020 13:49 by rmk:") (CL:UNLESS CDENTRIES (PRINTOUT T T "Note: Using LASTCDENTRIES" T T) (SETQ CDENTRIES LASTCDENTRIES)) (CONS (CAR CDENTRIES) (FOR CDE MATCHNAME INFO1 DATEREL INFO2 EQUIV IN (CDR CDENTRIES) DECLARE (SPECVARS MATCHNAME INFO1 DATEREL INFO2 EQUIV) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ INFO1 (FETCH INFO1 OF CDE)) (SETQ DATEREL (FETCH DATEREL OF CDE)) (SETQ INFO2 (FETCH INFO2 OF CDE)) (SETQ EQUIV (FETCH EQUIV OF CDE)) WHEN (APPLY* FN CDE) COLLECT CDE]) ) (DEFINEQ (BINCOMP [LAMBDA (FILE1 FILE2 EOLDIFFOK EOL1 EOL2) (* ; "Edited 13-Oct-2020 08:53 by rmk:") (* ;; "Returns T if FILE1 and FILE2 are byte-equivalent. Returns EOLDIFF if they are byte equivalent except for CR/LF/CRLF exchanges. ") (* ;; "If EOLDIFFOK, return indicates that the files are the same except for EOL mappings. If EOL1 and EOL2 are not provided, they are computed here.") (IF (IEQP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) THEN [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (* ;; "Simpler code to recompute eol's even if provided") (BIND B1 B2 EOL1 EOL2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS (AND EOLDIFFOK (SELCHARQ B1 (CR (CL:WHEN (EQ EOL1 'LF) (RETURN NIL)) (SETQ EOL1 'CR) (SETQ EOL2 'LF) (EQ B2 (CHARCODE LF))) (LF (CL:WHEN (EQ EOL1 'CR) (RETURN NIL)) (SETQ EOL1 'LF) (SETQ EOL2 'CR) (EQ B2 (CHARCODE CR))) NIL)) (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T] ELSEIF EOLDIFFOK THEN (* ;; "Lengths are different possibly because of CRLF to CR/LF substitutions.") (* ;;  "More complex code could detect the EOLTYPE incrementally without separate passes, but ...") (CL:UNLESS EOL1 (SETQ EOL1 (EOLTYPE FILE1))) (CL:UNLESS EOL2 (SETQ EOL2 (EOLTYPE FILE2))) (CL:WHEN (IF [AND (EQ EOL1 'CRLF) (MEMB EOL2 '(LF CR] ELSEIF [AND (EQ EOL2 'CRLF) (MEMB EOL1 '(LF CR] THEN (SWAP FILE1 FILE2)) (* ;; "FILE1 is now CRLF, FILE2 is not. If FILE1 isn't longer, it can't have a CRLF that corresponds to a CR or LF.") (CL:WHEN (IGREATERP (GETFILEINFO FILE1 'LENGTH) (GETFILEINFO FILE2 'LENGTH)) [CL:WITH-OPEN-FILE (STREAM1 FILE1 :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM2 FILE2 :DIRECTION :INPUT) (SETFILEINFO STREAM1 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND B1 B2 EOLDIFF WHILE (SETQ B1 (\BIN STREAM1)) UNLESS (EQ B1 (SETQ B2 (\BIN STREAM2))) DO (CL:UNLESS [AND (EQ (CHARCODE CR) B1) (EQ (CHARCODE LF) (\BIN STREAM1)) (MEMB B2 (CHARCODE (CR LF] (RETURN NIL)) (CL:UNLESS EOLDIFF (SETQ EOLDIFF (LIST EOL1 EOL2))) FINALLY (RETURN (OR EOLDIFF T]))]) (EOLTYPE [LAMBDA (FILE) (* ; "Edited 3-Sep-2020 17:05 by rmk:") (* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL)) (BIND EOLTYPE DO (SELCHARQ (OR (\BIN STREAM) (RETURN EOLTYPE)) (CR (IF (EQ (CHARCODE LF) (\PEEKBIN STREAM T)) THEN (CL:WHEN (MEMB EOLTYPE '(LF CR)) (RETURN NIL)) (\BIN STREAM) (SETQ EOLTYPE 'CRLF) ELSEIF (MEMB EOLTYPE '(LF CRLF)) THEN (RETURN NIL) ELSE (SETQ EOLTYPE 'CR))) (LF (CL:WHEN (MEMB EOLTYPE '(CR CRLF)) (RETURN NIL)) (SETQ EOLTYPE 'LF)) NIL]) ) (DECLARE%: EVAL@COMPILE (RECORD CDENTRY (MATCHNAME INFO1 DATEREL INFO2 . EQUIV)) (RECORD CDINFO (FULLNAME DATE LENGTH AUTHOR TYPE EOL)) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 20-Sep-2020 23:04 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;; "Produces a list of the source files in FILES that have no corresponding compiled file") (* ;; "This determines whether there is at least one compiled file. If there are two or more, that's a problem") (* ;; "We want the most recent version only") (* ;; "Source files have a 2-element created-as with a non-NIL date") (SETQ FILES (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) UNLESS (MEMB (SETQ F (PACKFILENAME 'VERSION NIL 'BODY F)) $$VAL) COLLECT F)) (FOR F SCREATION FILES IN FILES WHEN (AND (CADR (SETQ SCREATION (CREATED-AS F))) (NOT (CDDR SCREATION))) WHEN [SETQ FILES (FOR CEXT CF IN (OR COMPILEEXTS *COMPILED-EXTENSIONS*) WHEN (SETQ CF (INFILEP (PACKFILENAME 'EXTENSION CEXT 'VERSION NIL 'BODY F))) COLLECT (CL:WHEN (SOURCE-FOR-COMPILED-P SCREATION CF DFASLMARGIN) (RETURN NIL)) CF FINALLY (* ;; "If we found some compiled files, they weren't on this source. If there weren't any compiled files to check, maybe there weren't any functions.") (* ;;  "NLSETQ because we don't want to stop if there is an error, typically from a package problem") (RETURN (OR $$VAL (LET [(FCOMS (CAR (NLSETQ (GETDEF (FILECOMS F) 'VARS F] (IF (NULL FCOMS) THEN (* ;;  "GETDEF caused an error. Maybe a package problem. ") (AND NIL 'NOCOMMANDS) ELSEIF (INFILECOMS? NIL '(FUNCTIONS FNS) FCOMS) THEN T] COLLECT (CONS F (SELECTQ FILES (T NIL) (NOCOMMANDS (CONS "No commands")) (FOR CF IN FILES COLLECT (* ;;  "Positive means that compiled is later than source, normal order but maybe by too much.") (* ;;  "Negative means that compiled came before source. Odd") (LIST CF (COMPILE-SOURCE-DATE-DIFF CF SCREATION]) (FIND-UNSOURCED-FILES [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") (* ; "Edited 3-Nov-94 15:17 by jds") (* ;;  "Produces a list of compiled FILES for which no source file can be found in the same directory.") (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") (* ;; "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) (FILDIR (PACKFILENAME 'EXTENSION CEXT 'VERSION "" 'BODY '*] WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) (* ;; "CCREATEDS is now a list of CREATED-AS items") (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY (CAR CC] (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) CC DFASLMARGIN)) COLLECT [LIST (CAR CC) (AND SF (LIST (CAR SF) (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) (ALPHORDER (FILENAMEFIELD (CAR CF1) 'NAME) (FILENAMEFIELD (CAR CF2) 'NAME]) (FIND-SOURCE-FILES [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) (CDDR (SETQ CCREATED (CREATED-AS CF))) (SETQ SFILES (FOR SD SF IN SDIRS WHEN (AND (SETQ SF (INFILEP (PACKFILENAME 'NAME (FILENAMEFIELD CF 'NAME) 'BODY SD))) (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-COMPILED-FILES [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") (* ;; "FILEDATE is true for source files and compiled files") (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) (SETQ SCREATED (CREATED-AS SF)) (NOT (CDDR SCREATED)) (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) IN *COMPILED-EXTENSIONS* JOIN (FOR CD CF IN CDIRS WHEN (AND (SETQ CF (INFILEP (PACKFILENAME 'NAME ROOT 'EXTENSION CEXT 'BODY CD))) (SOURCE-FOR-COMPILED-P SCREATED CF DFASLMARGIN)) COLLECT CF] COLLECT (CONS SNAME CFILES )) (FUNCTION (LAMBDA (P1 P2) (ALPHORDER (FILENAMEFIELD (CAR P1)) (FILENAMEFIELD (CAR P2]) (FIND-UNLOADED-FILES [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) (CAR F) F))) (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) (* ;; "PUSHNEW because we haven't filtered out versions") (PUSHNEW [CDR (OR (ASSOC NAME SFILES) (CAR (PUSH SFILES (CONS NAME] EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO THEN `[,(CAR S) ,(CADAR (FIND-LOADED-FILES (CAR S))) ,(CREATED-AS (CAR S)) ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT 'BODY (CAR S] ELSE (CAR S]) ) (DEFINEQ (CREATED-AS [LAMBDA (FILE) (* ; "Edited 20-Sep-2020 23:06 by rmk:") (* ;; "For lisp source files, returns (filecreatename filecreateddate)") (* ;; "For lisp compiled files, returns (cfilename cfiledate sfilecreatename sfilecreateddate)") (* ;; "For other files, (fullfilename NIL)") (* ;; "The cfilename is just the current directory name for DFASLs.") (* ;; "So: (CADR value) is non-NIL for Lisp files. Of those, (CDDR value) is non-NIL for compiled files.") (* ;; "We disable the package delimiter because the atoms in changes may have a packages that we don't know.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (FILEDATE FILENAME SOURCEDATE SOURCENAME LINE POS) [IF (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) THEN (* ; "Managed source or LCOM") (RESETLST [LET (FORM SFORM (RDTBL (FIND-READTABLE "OLD-INTERLISP-FILE"))) (SETQ POS (GETFILEPTR STREAM)) (READCCODE STREAM) (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM RDTBL)) THEN (* ;; "Reading is package-safe") (SETFILEPTR STREAM POS) (SETQ FORM (READ STREAM RDTBL)) (SETQ RDTBL (FIND-READTABLE (LISTGET (CDR FORM) :READTABLE))) ELSE (SETFILEPTR STREAM POS)) (CL:WHEN (EQ 'PACKAGEDELIM (GETSYNTAX '%: RDTBL)) [RESETSAVE (SETSYNTAX '%: 'OTHER RDTBL) `(SETSYNTAX %: PACKAGEDELIM ,RDTBL]) (* ;; "One way or the other, we're ready for the filecreated") (CL:WHEN (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (SETQ FORM (READ STREAM RDTBL)) (CL:WHEN (MEMB (U-CASE (CAR FORM)) '(FILECREATED IL%:FILECREATED)) (* ;; "IL%%:FILECREATED because we screwed the readtable.") (IF [STREQUAL "compiled on " (CAR (LISTP (CADDR FORM] THEN (* ; "LCOM, get source info") (IF [AND (EQ (CHARCODE %() (SKIPSEPRCODES STREAM)) (MEMB [U-CASE (CAR (SETQ SFORM (READ STREAM RDTBL] '(FILECREATED IL%:FILECREATED] THEN (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM)) (SETQ SOURCENAME (CADDR SFORM)) (SETQ SOURCEDATE (CADR SFORM)) ELSE (SETQ FILENAME (FULLNAME STREAM)) (SETQ FILEDATE (CADR FORM))) ELSE (SETQ FILENAME (CADDR FORM)) (SETQ FILEDATE (CADR FORM)))))]) ELSEIF (SETQ POS (STRPOS "XCL Compiler output for source file " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) THEN (* ; "DFASL compiled?") (SETQ SOURCENAME (SUBATOM LINE POS)) (CL:WHEN (SETQ POS (STRPOS "Source file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ SOURCEDATE (GDATE (IDATE (SUBSTRING LINE POS] (CL:WHEN (SETQ POS (STRPOS "FASL file created " (SETQ LINE (CL:READ-LINE STREAM)) 1 NIL NIL T)) [SETQ FILEDATE (GDATE (IDATE (SUBSTRING LINE POS]))] (* ;; "Revert filenames to Interlisp package if needed:") (CL:WHEN (STRPOS "IL:" FILENAME) (SETQ FILENAME (SUBATOM FILENAME 4))) (CL:WHEN (STRPOS "IL:" SOURCENAME) (SETQ SOURCENAME (MKATOM SOURCENAME 4))) (* ;; "Return DATE NIL if file is not a Lisp file") `(,(OR FILENAME (FULLNAME STREAM)) ,(AND FILEDATE (GDATE (IDATE FILEDATE))) ,@(CL:WHEN SOURCENAME (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:") (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") (* ;; "") (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") (* ;; "Default is (20 0).") (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) (CL:UNLESS (LISTP COMPILED) (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN (* ;;  "If compiled is later than source by less than 20 minutes, it's probably OK") '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSEIF (LISTP DFASLMARGIN) ELSEIF (NOT (FIXP DFASLMARGIN)) THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) DFASLMARGIN) ELSE (LIST DFASLMARGIN 0))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) (OR (EQ T (CADR DFASLMARGIN)) (GEQ TIMEDIFF (CADR DFASLMARGIN]) (COMPILE-SOURCE-DATE-DIFF [LAMBDA (CFILE SFILE) (* ; "Edited 20-Sep-2020 22:59 by rmk:") (* ;; "Positive means that compiled is later than source, normal order but maybe by too much. Negative means that compiled came before source, i.e., compiled on a source that didn't yet exist.") (* ;; "Value is in minutes") (ROUND (FQUOTIENT [IDIFFERENCE [IDATE (CADDDR (OR (LISTP CFILE) (CREATED-AS CFILE] (IDATE (CADR (OR (LISTP SFILE) (CREATED-AS SFILE] (TIMES 60 ONESECOND]) ) (DEFINEQ (FIX-DIRECTORY-DATES [LAMBDA (FILES MARGIN) (* ; "Edited 30-Oct-2020 22:01 by rmk:") (* ;; "For Lisp source and compiled files, ensures that the directory file date corresponds to the filecreated date. Returns the list of files whose dates were changed.") (* ;; "This allows for the fact that directory dates that are no later than, say, 30 seconds of the filecreated date are probably OK--the directory date may be set when the file is closed.") (* ;; "Use IDATEs in case FDCDATE is not Y2K.") (* ;; "Stop if directory date is more than 2 minutes earlier than the filecreated date. Earlier could be because the dates are asserted at different points in the filing process. But 2 minutes is worth thinking about. Returning from HELP will get them aligned.") (SETQ MARGIN (ITIMES (OR MARGIN 2) 60 ONESECOND)) (FOR F DIDATE FCDATE IN (OR (LISTP FILES) (FILDIR FILES)) WHEN (SETQ FCDATE (FILEDATE F)) UNLESS (IEQP (SETQ DIDATE (GETFILEINFO F 'ICREATIONDATE)) (SETQ FCDATE (IDATE FCDATE))) COLLECT (CL:WHEN (IGREATERP (IDIFFERENCE FCDATE DIDATE) MARGIN) (HELP "DIRECTORY DATE EARLIER THAN FILECREATED DATE" (LIST F (GDATE DIDATE) (GDATE FCDATE)))) (SETFILEINFO F 'ICREATIONDATE FCDATE) F]) (FIX-EQUIV-DATES [LAMBDA (CDENTRIES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "For every entry whose files are EQUIVALENT and whose filedates are different, sets the directory of the file with the later date to be the date of the one with the earlier date. This preumes that the later one must have been a copy. ") (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (FOR CDE EARLY LATE IN (CDR CDENTRIES) WHEN (FETCH EQUIV OF CDE) UNLESS (EQ '= (FETCH DATEREL OF CDE)) COLLECT (SELECTQ (FETCH DATEREL OF CDE) (> (SETQ EARLY (FETCH INFO2 OF CDE)) (SETQ LATE (FETCH INFO1 OF CDE))) (< (SETQ EARLY (FETCH INFO1 OF CDE)) (SETQ LATE (FETCH INFO2 OF CDE))) (SHOULDNT)) (SETFILEINFO (FETCH FULLNAME OF LATE) 'ICREATIONDATE (GETFILEINFO (FETCH FULLNAME OF EARLY) 'ICREATIONDATE)) (FETCH FULLNAME OF LATE]) (COPY-COMPARED-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:20 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO MATCHNAME IN (CDR CDENTRIES) EACHTIME (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) WHEN (AND (FETCH FULLNAME OF SINFO) (FETCH FULLNAME OF TINFO)) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'VERSION NIL 'BODY (FETCH FULLNAME OF TINFO))) MATCHNAME]) (COPY-MISSING-FILES [LAMBDA (CDENTRIES TARGET MATCHNAMES) (* ; "Edited 1-Sep-2020 16:21 by rmk:") (* ;; "Copies source files to target files whose matchname belongs to MATCHNAMES, if given.") (* ;; "TARGET is 1 or 2, indicating which side of the CD entry is the target. Value is the list of matchnames whose files have been copied.") (* ;; "Directory filedates and other properties are preserved.") (CL:UNLESS (MEMB TARGET '(1 2)) (ERROR "INVALID TARGET" TARGET)) (CL:UNLESS CDENTRIES (PRINTOUT T "Note: Using LASTCDENTRIES" T) (SETQ CDENTRIES LASTCDENTRIES)) (CL:UNLESS (STRINGP (CADR (CAR CDENTRIES))) (ERROR "(CAR CDENTRIES) IS NOT A VALID PARAMETER LIST" (CAR CDENTRIES))) (SETQ MATCHNAMES (MKLIST MATCHNAMES)) (FOR CDE SINFO TINFO TDIR MATCHNAME (TDIR _ (CL:IF (EQ TARGET 1) (CAAR CDENTRIES) (CADAR CDENTRIES))) IN (CDR CDENTRIES) EACHTIME (SETQ MATCHNAME (FETCH MATCHNAME OF CDE)) (SETQ SINFO (FETCH INFO1 OF CDE)) (SETQ TINFO (FETCH INFO2 OF CDE)) (CL:WHEN (EQ TARGET 1) (SWAP SINFO TINFO)) WHEN (AND (FETCH FULLNAME OF SINFO) (NOT (FETCH FULLNAME OF TINFO))) UNLESS (AND MATCHNAMES (NOT (MEMB MATCHNAME MATCHNAMES))) COLLECT (* ;; "Using the source fullname in the target should preserve the version number") (COPYFILE (FETCH FULLNAME OF SINFO) (PACKFILENAME 'BODY TDIR 'BODY (FETCH FULLNAME OF SINFO))) MATCHNAME]) (COMPILED-ON-SAME-SOURCE [LAMBDA (CDENTRIES) (* ; "Edited 9-Sep-2020 13:00 by rmk:") (* ;; "Returms a subset of CDENTRIES consisting of files that are compiled on the same source (i.e. their source names or dates are the same). Preserves the header.") (CDSUBSET CDENTRIES (FUNCTION (LAMBDA (CDE) (DECLARE (USEDFREE INFO1 INFO2)) (LET (CREATED1 CREATED2) (CL:WHEN [AND (EQ 'COMPILED (FETCH TYPE OF INFO1)) (EQ 'COMPILED (FETCH TYPE OF INFO2)) [CDDR (SETQ CREATED1 (CREATED-AS (FETCH FULLNAME OF INFO1] (CDDR (SETQ CREATED2 (CREATED-AS (FETCH FULLNAME OF INFO2] (OR (EQUAL (CADDR CREATED1) (CADDR CREATED2)) (EQUAL (CADDDR CREATED1) (CADDDR CREATED2))))]) ) (RPAQ ONESECOND (IDIFFERENCE (IDATE "1-Jan-2020 12:00:01") (IDATE "1-Jan-2020 12:00:00"))) (RPAQ? LASTCDENTRIES NIL) (DEFINEQ (COMPARE-ENTRY-SOURCE-FILES [LAMBDA (CDENTRY LISTSTREAM EXAMINE DW?) (* ; "Edited 30-Aug-2020 12:22 by rmk:") (* ;; "Wrapper to call COMPARESOURCES on the Lisp source files of CDENTRY") (CL:WHEN [AND (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO1 OF CDENTRY))) (EQ 'SOURCE (FETCH TYPE OF (FETCH INFO2 OF CDENTRY] (COMPARESOURCES (FETCH FULLNAME OF (FETCH INFO1 OF CDENTRY)) (FETCH FULLNAME OF (FETCH INFO2 OF CDENTRY)) EXAMINE DW? LISTSTREAM))]) ) (FILESLOAD COMPARESOURCES) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1649 16680 (COMPAREDIRECTORIES 1659 . 10149) (CDFILES 10151 . 14726) ( COMPAREDIRECTORIES.INFOS 14728 . 16243) (MATCHNAME 16245 . 16678)) (16681 23866 (CDPRINT 16691 . 21491 ) (CDPRINT.LINE 21493 . 23864)) (23867 25619 (CDMAP 23877 . 24573) (CDENTRY 24575 . 24743) (CDSUBSET 24745 . 25617)) (25620 31151 (BINCOMP 25630 . 29919) (EOLTYPE 29921 . 31149)) (31364 44571 ( FIND-UNCOMPILED-FILES 31374 . 35017) (FIND-UNSOURCED-FILES 35019 . 37828) (FIND-SOURCE-FILES 37830 . 39534) (FIND-COMPILED-FILES 39536 . 41614) (FIND-UNLOADED-FILES 41616 . 42360) (FIND-LOADED-FILES 42362 . 42916) (FIND-MULTICOMPILED-FILES 42918 . 44569)) (44572 52774 (CREATED-AS 44582 . 49379) ( SOURCE-FOR-COMPILED-P 49381 . 52079) (COMPILE-SOURCE-DATE-DIFF 52081 . 52772)) (52775 61754 ( FIX-DIRECTORY-DATES 52785 . 54753) (FIX-EQUIV-DATES 54755 . 56015) (COPY-COMPARED-FILES 56017 . 58141) (COPY-MISSING-FILES 58143 . 59982) (COMPILED-ON-SAME-SOURCE 59984 . 61752)) (61909 62520 ( COMPARE-ENTRY-SOURCE-FILES 61919 . 62518))))) STOP \ No newline at end of file diff --git a/lispusers/COMPAREDIRECTORIES.~2~ b/lispusers/COMPAREDIRECTORIES.~2~ deleted file mode 100644 index 68a41d69..00000000 --- a/lispusers/COMPAREDIRECTORIES.~2~ +++ /dev/null @@ -1,335 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Dec-98 08:41:59" {DSK}medley2.0>lispusers>COMPAREDIRECTORIES.;6 21429 - - changes to%: (FNS COMPAREDIRS.FORMATLINE COMPAREDIRECTORIES) - - previous date%: "29-Dec-98 06:39:50" {DSK}medley2.0>lispusers>COMPAREDIRECTORIES.;3) - - -(* ; " -Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) - -(RPAQQ COMPAREDIRECTORIESCOMS ( - (* ;; "Compare the contents to two directories.") - - (FNS COMPAREDIRECTORIES COMPAREDIRS.FORMATLINE - COMPAREDIRECTORIES.NEWPAGEFN COMPARE-DIRECTORIES) - - (* ;; "look for compiled files older than the sources") - - (FNS FIND-UNCOMPILED-FILES))) - - - -(* ;; "Compare the contents to two directories.") - -(DEFINEQ - -(COMPAREDIRECTORIES - [LAMBDA (FROMDIR TODIR SHOW=FILESTOO USELISPFILEDATE FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID) - (* ; "Edited 29-Dec-98 08:39 by rmk:") - - (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an image stream, or NIL to go to the display.") - - (LET [(LISTINGSTREAM (COND - [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE NIL '(LANDSCAPE T] - (T NIL))) - (TO-FILES (for FILE in [DIRECTORY (PACKFILENAME.STRING 'BODY TODIR 'BODY - (OR FILEPATTERN '*.*;] - collect (PACKFILENAME.STRING 'VERSION NIL 'BODY FILE] - (COND - (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) - [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR) - (CONCAT "as of " (DATE] - (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) - [for FILENAME infiles (PACKFILENAME.STRING 'BODY FROMDIR 'BODY (OR FILEPATTERN - '*.*;)) - bind DT1 DT2 TON SHORT-FROM SHORT-TO - when [PROGN [SETQ TO-FILES (CL:DELETE (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL - 'DEVICE NIL 'VERSION NIL 'BODY FILENAME) - TO-FILES :TEST #'(LAMBDA (ITEM SEQUENCE-ITEM) - (STRING-EQUAL - ITEM - (PACKFILENAME.STRING - 'HOST NIL 'DIRECTORY NIL - 'DEVICE NIL 'VERSION NIL - 'BODY SEQUENCE-ITEM] - (NOT (CL:MEMBER (UNPACKFILENAME.STRING FILENAME 'EXTENSION) - EXTENSIONSTOAVOID :TEST #'STRING-EQUAL] - do (AND NIL (PRINTOUT T FILENAME T)) - (COND - [[SETQ TON (INFILEP (PACKFILENAME.STRING 'DIRECTORY TODIR 'VERSION NIL - 'BODY - (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL - 'DIRECTORY NIL 'DEVICE NIL - 'BODY FILENAME] - (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL - 'BODY TON)) - [IF (AND USELISPFILEDATE (SETQ DT1 (FILEDATE FILENAME)) - (SETQ DT2 (FILEDATE TON))) - THEN (SETQ DT1 (IDATE DT1)) - (SETQ DT2 (IDATE DT2)) - ELSE (SETQ DT1 (GETFILEINFO FILENAME 'ICREATIONDATE)) - (SETQ DT2 (GETFILEINFO TON 'ICREATIONDATE] - (COND - [(EQUAL DT1 DT2) (* ; "same") - (COND - (SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM "" - (GDATE DT1) - "==" - (GDATE DT2) - SHORT-TO ""] - (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO - FILENAME - 'AUTHOR) - (GDATE DT1) - (COND - ((LESSP DT1 DT2) - "< ") - (T " >")) - (GDATE DT2) - SHORT-TO - (GETFILEINFO TON 'AUTHOR] - (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO - FILENAME - 'AUTHOR) - (GETFILEINFO FILENAME 'CREATIONDATE) - "**" NIL ""] - [bind SHORT-TO DT2 for FILENAME in TO-FILES - when (NOT (CL:MEMBER (UNPACKFILENAME.STRING FILENAME 'EXTENSION) - EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) - do (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL - 'BODY FILENAME)) - (SETQ DT2 (GETFILEINFO FILENAME 'ICREATIONDATE)) - (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" NIL NIL "**" (GDATE DT2) - SHORT-TO - (GETFILEINFO FILENAME 'AUTHOR] - (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) - -(COMPAREDIRS.FORMATLINE - [LAMBDA (STREAM FROM FROMAUTHOR FDATE COMP TDATE TO TOAUTHOR) - (* ; "Edited 29-Dec-98 08:41 by rmk:") - - (* ;; "Format one line of the directory comparison listing. If FROMAUTHOR or TOAUTHOR are non-NIL, list the author in parens; otherwise omit it.") - - (COND - (STREAM (* ; - "It's an image stream, where TAB doesn't work right.") - (LET* [(COMPFONT (FONTCREATE 'MODERN 8 'BOLD NIL STREAM)) - (MAINFONT (FONTCREATE 'MODERN 8 NIL NIL STREAM)) - (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) - STREAM)) - (LEFTMARGIN (DSPLEFTMARGIN NIL STREAM)) - (RIGHTMARGIN (DSPRIGHTMARGIN NIL STREAM)) - (CENTER (IQUOTIENT (+ LEFTMARGIN RIGHTMARGIN) - 2)) - (COMPWIDTH (IQUOTIENT (IMAX (STRINGWIDTH " >" COMPFONT) - (STRINGWIDTH "< " COMPFONT) - (STRINGWIDTH "==" COMPFONT) - (STRINGWIDTH "**" COMPFONT)) - 2)) - (LEFTSIDE (- CENTER 353 COMPWIDTH)) - (RIGHTSIDE (+ CENTER COMPWIDTH 353)) - (FROM-STRING (COND - (FROM (CL:FORMAT NIL "~A (~A; ~A)" FROM FROMAUTHOR FDATE)) - (T ""))) - (TO-STRING (COND - (TO (CL:FORMAT NIL "~A (~A; ~A)" TO TOAUTHOR TDATE)) - (T ""] - (DSPFONT COMPFONT STREAM) - (DSPXPOSITION (- CENTER (IQUOTIENT (STRINGWIDTH COMP COMPFONT) - 2)) - STREAM) - (PRIN1 COMP STREAM) - (DSPFONT MAINFONT STREAM) - (DSPXPOSITION (- LEFTSIDE (STRINGWIDTH FROM-STRING MAINFONT)) - STREAM) - (PRIN1 FROM-STRING STREAM) - (DSPXPOSITION RIGHTSIDE STREAM) - (PRINTOUT STREAM TO-STRING T))) - (T (* ; - "the display, where TAB does work.") - (PRINTOUT STREAM FROM (COND - (FROMAUTHOR (CONCAT "(" FROMAUTHOR ")")) - (T " ")) - 45 - (IF FDATE - THEN (CONCAT "[" FDATE "]") - ELSEIF TDATE - THEN (SPACES (IPLUS 2 (NCHARS TDATE))) - ELSE "") - -2 COMP -2 (IF TDATE - THEN (CONCAT "[" TDATE "]") - ELSE "") - -1 TO (COND - (TOAUTHOR (CONCAT "(" TOAUTHOR ")")) - (T "")) - T]) - -(COMPAREDIRECTORIES.NEWPAGEFN [LAMBDA (LISTINGSTREAM) (* ; "Edited 15-Nov-88 19:20 by jds") (* ;; "Print the new-page headings on a COMPARE-DIRECTORIES page.") (LET* ((LEFT (DSPLEFTMARGIN NIL LISTINGSTREAM)) (RIGHT (DSPRIGHTMARGIN NIL LISTINGSTREAM)) (TITLEFONT (FONTCREATE 'MODERN 10 'BOLD NIL LISTINGSTREAM)) (TITLE (STREAMPROP LISTINGSTREAM 'TITLE)) (HEAD-WIDTH (IQUOTIENT (STRINGWIDTH (CAR TITLE) TITLEFONT) 2)) (CENTER (IQUOTIENT (+ LEFT RIGHT) 2))) (DSPFONT TITLEFONT LISTINGSTREAM) (MOVETO (- CENTER HEAD-WIDTH) (DSPTOPMARGIN NIL LISTINGSTREAM) LISTINGSTREAM) (PRIN1 (CAR TITLE) LISTINGSTREAM) (MOVETO (- RIGHT (STRINGWIDTH (CDR TITLE) TITLEFONT)) 1270 LISTINGSTREAM) (PRIN1 (CDR TITLE) LISTINGSTREAM) (MOVETO LEFT [IDIFFERENCE (DSPTOPMARGIN NIL LISTINGSTREAM) (FIXR (FTIMES 1.5 (FONTPROP TITLEFONT 'HEIGHT] LISTINGSTREAM]) - -(COMPARE-DIRECTORIES - [LAMBDA (FROMDIR TODIR SHOW=FILESTOO FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID) - (* ; "Edited 3-Nov-94 15:06 by jds") - - (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.") - - (LET ((LISTINGSTREAM (COND - [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'INTERPRESS '(LANDSCAPE T] - (T NIL))) - FROM-GENERATOR TO-GENERATOR) - (COND - (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) - [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR) - (CONCAT "as of " (DATE] - (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) - [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY - (OR FILEPATTERN '*.*;)) - NIL - '(SORT] - [SETQ TO-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY TODIR 'BODY - (OR FILEPATTERN '*.*;)) - NIL - '(SORT] - [bind FROM-FILE TO-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) - repeatwhile (OR FROM-FILE TO-FILE) bind DT1 DT2 TON SHORT-FROM SHORT-TO - do (COND - ((AND FROM-FILE (CL:MEMBER (UNPACKFILENAME.STRING FROM-FILE 'EXTENSION) - EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) - - (* ;; "FROM file is on the prohibited-extension list. Skip it.") - - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - ((AND TO-FILE (CL:MEMBER (UNPACKFILENAME.STRING TO-FILE 'EXTENSION) - EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) - - (* ;; "TO file is on the prohibited-extension list. Skip it.") - - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) - (T (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL - 'BODY FROM-FILE)) - (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL - 'BODY TO-FILE)) - (HELP) - (COND - ((NOT FROM-FILE) - - (* ;; " Ran out of FROM files first; print the missing-FROM marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" - (GETFILEINFO TO-FILE 'CREATIONDATE) - SHORT-TO - (GETFILEINFO TO-FILE 'AUTHOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) - ((NOT TO-FILE) - - (* ;; " Ran out of TO files first; print the missing-TO marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO - FROM-FILE - 'AUTHOR) - (GETFILEINFO FROM-FILE 'CREATIONDATE) - "**" "" "" "") - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - ((CL:STRING-LESSP SHORT-FROM SHORT-TO) - - (* ;; - "This FROM file has no TO equivalent. Print the missing-FROM marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO - FROM-FILE - 'AUTHOR) - (GETFILEINFO FROM-FILE 'CREATIONDATE) - "**" "" "" "") - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - ((CL:STRING-LESSP SHORT-TO SHORT-FROM) - - (* ;; - "This TO file has no FROM equivalent. Print the missing-TO marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" - (GETFILEINFO TO-FILE 'CREATIONDATE) - SHORT-TO - (GETFILEINFO TO-FILE 'AUTHOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) - ([= (SETQ DT1 (GETFILEINFO FROM-FILE 'ICREATIONDATE)) - (SETQ DT2 (GETFILEINFO TO-FILE 'ICREATIONDATE] - (AND SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM - "" (GDATE DT1) - "==" - (GDATE DT2) - SHORT-TO "")) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM - (GETFILEINFO FROM-FILE 'AUTHOR) - (GDATE DT1) - (COND - ((LESSP DT1 DT2) - "<<") - (T ">>")) - (GDATE DT2) - SHORT-TO - (GETFILEINFO TO-FILE 'AUTHOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR] - (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) -) - - - -(* ;; "look for compiled files older than the sources") - -(DEFINEQ - -(FIND-UNCOMPILED-FILES - [LAMBDA (FROMDIR TODIR LISTINGFILE) (* ; "Edited 3-Nov-94 15:17 by jds") - - (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.") - - (LET ((LISTINGSTREAM (COND - [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'POSTSCRIPT '(LANDSCAPE T] - (T NIL))) - FROM-GENERATOR TO-GENERATOR) - (COND - (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) - [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT "Compiled-file search of " FROMDIR - " vs " TODIR) - (CONCAT "as of " (DATE] - (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) - [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY "*.;") - NIL - '(SORT] - (bind FROM-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)) - repeatwhile FROM-FILE bind DT1 DT2 TON SHORT-FROM SHORT-TO - do (COND - [[SETQ TO-FILE (OR (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL - 'EXTENSION - 'DFASL - 'BODY FROM-FILE)) - (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL - 'EXTENSION - 'LCOM - 'BODY FROM-FILE] - (COND - ((< (GETFILEINFO TO-FILE 'ICREATIONDATE) - (GETFILEINFO FROM-FILE 'ICREATIONDATE)) - (PRINTOUT LISTINGSTREAM FROM-FILE " (" (GETFILEINFO FROM-FILE - 'CREATIONDATE) - ") vs " TO-FILE " (" (GETFILEINFO TO-FILE 'CREATIONDATE) - ")" T] - (T (PRINTOUT LISTINGSTREAM FROM-FILE " has no compiled equivalent." T))) - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) -) -(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 -)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1061 18391 (COMPAREDIRECTORIES 1071 . 6944) (COMPAREDIRS.FORMATLINE 6946 . 10232) ( -COMPAREDIRECTORIES.NEWPAGEFN 10234 . 11501) (COMPARE-DIRECTORIES 11503 . 18389)) (18456 21300 ( -FIND-UNCOMPILED-FILES 18466 . 21298))))) -STOP diff --git a/lispusers/COMPAREDIRECTORIES.~43~ b/lispusers/COMPAREDIRECTORIES.~43~ deleted file mode 100644 index fcfeb89c..00000000 --- a/lispusers/COMPAREDIRECTORIES.~43~ +++ /dev/null @@ -1,145 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-May-2018 16:32:02"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;43 26134 changes to%: (FNS FIND-UNCOMPILED-FILES COMPAREDIRECTORIES) previous date%: " 9-May-2018 16:25:36" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPAREDIRECTORIES.;42) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994, 1998, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) (RPAQQ COMPAREDIRECTORIESCOMS ( (* ;; "Compare the contents to two directories.") (FNS COMPAREDIRECTORIES COMPAREDIRS.FORMATLINE COMPAREDIRECTORIES.NEWPAGEFN COMPARE-DIRECTORIES) (* ;; "look for compiled files older than the sources") (FNS FIND-UNCOMPILED-FILES))) (* ;; "Compare the contents to two directories.") (DEFINEQ (COMPAREDIRECTORIES [LAMBDA (FROMDIR TODIR SHOW FILEPATTERN EXTENSIONSTOAVOID USEDIRECTORYDATE LISTINGFILE ALLVERSIONS) (* ; "Edited 9-May-2018 16:25 by rmk:") (* ; "Edited 9-May-2018 16:24 by rmk:") (* ; "Edited 4-May-2018 23:28 by rmk:") (* ; "Edited 4-May-2018 23:26 by rmk:") (* ; "Edited 4-May-2018 16:20 by rmk:") (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW is or contains SAME, BEFORE, AFTER, then files where the FROM is the same as, earlier than, or later than the TO are shown. SHOW NIL is the same as (BEFORE AFTER), T is the same as (BEFORE AFTER SAME).") (* ;; "") (* ;; "Unless USEDIRECTORYDATE, comparison is respect to the the LISP filedate if evailable.") (* ;; "") (* ;; "If LISTINGFILE is NIL, output goes to the display. If a filename ending in TXT or TEXT, then output goes to a text file. Otherwise, output goes to an image stream.") (* ;; "Looks only at latest version unless ALLVERSIONS") (CL:UNLESS FILEPATTERN (SETQ FILEPATTERN '*.*;)) (SETQ EXTENSIONSTOAVOID (MKLIST EXTENSIONSTOAVOID)) (CL:UNLESS ALLVERSIONS (SETQ FILEPATTERN (PACKFILENAME.STRING 'VERSION "" 'BODY FILEPATTERN))) (SETQ FROMDIR (DIRECTORYNAME FROMDIR)) (* ; "Resolve relative directories, so we can suppress subdirectory matches. Don't know why DIRECTORY produces them ") (SETQ TODIR (DIRECTORYNAME TODIR)) (PROG (TEXT LISTINGSTREAM (TONAMEPOS (ADD1 (NCHARS TODIR))) (FROMNAMEPOS (ADD1 (NCHARS FROMDIR))) (FROMPATTERN (PACKFILENAME.STRING 'DIRECTORY FROMDIR 'BODY FILEPATTERN)) (TOPATTERN (PACKFILENAME.STRING 'DIRECTORY TODIR 'BODY FILEPATTERN)) FROM-FILES TO-FILES) [SETQ LISTINGSTREAM (AND LISTINGFILE (IF (EQMEMB (U-CASE (FILENAMEFIELD LISTINGFILE 'EXTENSION)) '(TXT TEXT)) THEN (SETQ TEXT T) (OPENSTREAM LISTINGFILE 'OUTPUT) ELSE (OPENIMAGESTREAM LISTINGFILE NIL '(LANDSCAPE T] (* ;; "Pack may have put on a < or / incorrectly for relative directories") (* ;; "(CL:UNLESS (MEMB (NTHCHAR FROMDIR 1) '(/ \ <)) (SETQ FROMPATTERN (SUBSTRING FROMPATTERN 2 -1)))(CL:UNLESS (MEMB (NTHCHAR TODIR 1) '(/ \ <)) (SETQ TOPATTERN (SUBSTRING TOPATTERN 2 -1)))") (* ;; "Filter extensions") (CL:WHEN (MEMB '* EXTENSIONSTOAVOID) (SETQ FROMPATTERN (PACKFILENAME.STRING 'EXTENSION "" 'BODY FROMPATTERN)) (SETQ TOPATTERN (PACKFILENAME.STRING 'EXTENSION "" 'BODY TOPATTERN))) (* ;; "> test to skip subdirectories") (SETQ FROM-FILES (for FROMFILE in (DIRECTORY FROMPATTERN) UNLESS (IF (STRPOS ">" FROMFILE FROMNAMEPOS) ELSEIF (MEMB '* EXTENSIONSTOAVOID) THEN (* ;;  "For some unknown reason, DIRECTORY let's some through") (FILENAMEFIELD FROMFILE 'EXTENSION) ELSE (CL:MEMBER (UNPACKFILENAME.STRING FROMFILE 'EXTENSION) EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) collect FROMFILE)) (SETQ TO-FILES (for TOFILE in (DIRECTORY TOPATTERN) UNLESS (IF (STRPOS ">" TOFILE TONAMEPOS) ELSEIF (MEMB '* EXTENSIONSTOAVOID) THEN (FILENAMEFIELD TOFILE 'EXTENSION) ELSE (CL:MEMBER (UNPACKFILENAME.STRING TOFILE 'EXTENSION) EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) collect TOFILE)) (CL:UNLESS (AND TO-FILES FROM-FILES) (CL:UNLESS FROM-FILES (PRINTOUT T "FROMDIR " FROMDIR " is empty" T)) (CL:UNLESS TO-FILES (PRINTOUT T "TODIR " TODIR " is empty" T)) (RETURN)) (PRINTOUT T "Comparing " FROMDIR 6 "vs. " TODIR T "as of " (DATE) T) [COND (LISTINGSTREAM (IF TEXT THEN (LINELENGTH 1000 LISTINGSTREAM) (* ; "Don't wrap") (PRINTOUT LISTINGSTREAM "Comparing " FROMDIR 6 "vs. " TODIR T "as of " (DATE) T T) ELSE (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR) (CONCAT "as of " (DATE] (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM] (FOR FROMNAME IN FROM-FILES BIND TONAME DT1 DT2 FROMMATCH SHORT-FROM SHORT-TO EACHTIME (SETQ SHORT-FROM (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FROMNAME)) (SETQ FROMMATCH (PACKFILENAME.STRING 'VERSION NIL 'BODY SHORT-FROM)) [SETQ DT1 (IF USEDIRECTORYDATE THEN [IDATE (OR (FILEDATE FROMNAME) (GETFILEINFO FROMNAME 'CREATIONDATE] ELSE (GETFILEINFO FROMNAME 'ICREATIONDATE] DO (FOR TONAME IN TO-FILES WHEN (STREQUAL FROMMATCH (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL 'BODY TONAME)) DO (SETQ TO-FILES (CL:DELETE TONAME TO-FILES)) [SETQ DT2 (IF USEDIRECTORYDATE THEN (GETFILEINFO TONAME 'ICREATIONDATE) ELSE (IDATE (OR (FILEDATE TONAME) (GETFILEINFO TONAME 'CREATIONDATE] (SETQ SHORT-TO (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY TONAME)) (COND [(IEQP DT1 DT2) (* ; "same") (COND ((EQMEMB SHOW '(T SAME)) (EQ SHOW FILESTOO) (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM "" (GDATE DT1) " =" (GDATE DT2) SHORT-TO "" TEXT] ([OR [AND (ILESSP DT1 DT2) (EQMEMB SHOW '(NIL BEFORE] (AND (IGREATERP DT1 DT2) (EQMEMB SHOW '(NIL AFTER] (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO FROMNAME 'AUTHOR) (GDATE DT1) (COND ((LESSP DT1 DT2) "< ") (T " >")) (GDATE DT2) SHORT-TO (GETFILEINFO TONAME 'AUTHOR) TEXT))) (RETURN) FINALLY (* ;; "No match for a FROMFILE") (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO FROMNAME 'AUTHOR) (GDATE DT1) "**" NIL NIL NIL TEXT))) (* ;; "The TO-FILES that didn't match a FROM-FILE. GDATE to expand 19xx to 4 digits (Y2K)") (FOR TONAME SHORT-TO IN TO-FILES DO (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL 'BODY TONAME)) (COMPAREDIRS.FORMATLINE LISTINGSTREAM NIL NIL NIL "**" [GDATE (IF USEDIRECTORYDATE THEN (GETFILEINFO TONAME 'ICREATIONDATE) ELSE (IDATE (OR (FILEDATE TONAME) (GETFILEINFO TONAME 'CREATIONDATE] SHORT-TO (GETFILEINFO TONAME 'AUTHOR) TEXT)) (RETURN (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) (COMPAREDIRS.FORMATLINE [LAMBDA (STREAM FROM FROMAUTHOR FDATE COMP TDATE TO TOAUTHOR TEXT) (* ; "Edited 2-May-2018 16:49 by rmk:") (* ;; "Format one line of the directory comparison listing. If FROMAUTHOR or TOAUTHOR are non-NIL, list the author in parens; otherwise omit it.") (COND ((AND STREAM (NOT TEXT)) (* ;  "It's an image stream, where TAB doesn't work right.") (LET* [(COMPFONT (FONTCREATE 'MODERN 8 'BOLD NIL STREAM)) (MAINFONT (FONTCREATE 'MODERN 8 NIL NIL STREAM)) (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM)) (LEFTMARGIN (DSPLEFTMARGIN NIL STREAM)) (RIGHTMARGIN (DSPRIGHTMARGIN NIL STREAM)) (CENTER (IQUOTIENT (+ LEFTMARGIN RIGHTMARGIN) 2)) (COMPWIDTH (IQUOTIENT (IMAX (STRINGWIDTH " >" COMPFONT) (STRINGWIDTH "< " COMPFONT) (STRINGWIDTH "==" COMPFONT) (STRINGWIDTH "**" COMPFONT)) 2)) (LEFTSIDE (- CENTER 353 COMPWIDTH)) (RIGHTSIDE (+ CENTER COMPWIDTH 353)) (FROM-STRING (COND (FROM (CL:FORMAT NIL "~A (~A; ~A)" FROM FROMAUTHOR FDATE)) (T ""))) (TO-STRING (COND (TO (CL:FORMAT NIL "~A (~A; ~A)" TO TOAUTHOR TDATE)) (T ""] (DSPFONT COMPFONT STREAM) (DSPXPOSITION (- CENTER (IQUOTIENT (STRINGWIDTH COMP COMPFONT) 2)) STREAM) (PRIN1 COMP STREAM) (DSPFONT MAINFONT STREAM) (DSPXPOSITION (- LEFTSIDE (STRINGWIDTH FROM-STRING MAINFONT)) STREAM) (PRIN1 FROM-STRING STREAM) (DSPXPOSITION RIGHTSIDE STREAM) (PRINTOUT STREAM TO-STRING T))) (T (* ;  "the display, where TAB does work.") (PRINTOUT STREAM (OR FROM "") (COND (FROMAUTHOR (CONCAT " (" FROMAUTHOR ")")) (T " ")) 45 (IF FDATE THEN (CONCAT "[" FDATE "]") ELSEIF TDATE THEN (SPACES (IPLUS 2 (NCHARS TDATE)) STREAM) "") -2 COMP -2 (IF TDATE THEN (CONCAT "[" TDATE "]") ELSE "") -1 (OR TO "") (COND (TOAUTHOR (CONCAT " (" TOAUTHOR ")")) (T "")) T]) (COMPAREDIRECTORIES.NEWPAGEFN [LAMBDA (LISTINGSTREAM) (* ; "Edited 15-Nov-88 19:20 by jds") (* ;; "Print the new-page headings on a COMPARE-DIRECTORIES page.") (LET* ((LEFT (DSPLEFTMARGIN NIL LISTINGSTREAM)) (RIGHT (DSPRIGHTMARGIN NIL LISTINGSTREAM)) (TITLEFONT (FONTCREATE 'MODERN 10 'BOLD NIL LISTINGSTREAM)) (TITLE (STREAMPROP LISTINGSTREAM 'TITLE)) (HEAD-WIDTH (IQUOTIENT (STRINGWIDTH (CAR TITLE) TITLEFONT) 2)) (CENTER (IQUOTIENT (+ LEFT RIGHT) 2))) (DSPFONT TITLEFONT LISTINGSTREAM) (MOVETO (- CENTER HEAD-WIDTH) (DSPTOPMARGIN NIL LISTINGSTREAM) LISTINGSTREAM) (PRIN1 (CAR TITLE) LISTINGSTREAM) (MOVETO (- RIGHT (STRINGWIDTH (CDR TITLE) TITLEFONT)) 1270 LISTINGSTREAM) (PRIN1 (CDR TITLE) LISTINGSTREAM) (MOVETO LEFT [IDIFFERENCE (DSPTOPMARGIN NIL LISTINGSTREAM) (FIXR (FTIMES 1.5 (FONTPROP TITLEFONT 'HEIGHT] LISTINGSTREAM]) (COMPARE-DIRECTORIES - [LAMBDA (FROMDIR TODIR SHOW=FILESTOO FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID) - (* ; "Edited 3-Nov-94 15:06 by jds") - - (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.") - - (LET ((LISTINGSTREAM (COND - [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'INTERPRESS '(LANDSCAPE T] - (T NIL))) - FROM-GENERATOR TO-GENERATOR) - (COND - (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) - [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR) - (CONCAT "as of " (DATE] - (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) - [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY - (OR FILEPATTERN '*.*;)) - NIL - '(SORT] - [SETQ TO-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY TODIR 'BODY - (OR FILEPATTERN '*.*;)) - NIL - '(SORT] - [bind FROM-FILE TO-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) - repeatwhile (OR FROM-FILE TO-FILE) bind DT1 DT2 TON SHORT-FROM SHORT-TO - do (COND - ((AND FROM-FILE (CL:MEMBER (UNPACKFILENAME.STRING FROM-FILE 'EXTENSION) - EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) - - (* ;; "FROM file is on the prohibited-extension list. Skip it.") - - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - ((AND TO-FILE (CL:MEMBER (UNPACKFILENAME.STRING TO-FILE 'EXTENSION) - EXTENSIONSTOAVOID :TEST #'STRING-EQUAL)) - - (* ;; "TO file is on the prohibited-extension list. Skip it.") - - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) - (T (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL - 'BODY FROM-FILE)) - (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL - 'BODY TO-FILE)) - (HELP) - (COND - ((NOT FROM-FILE) - - (* ;; " Ran out of FROM files first; print the missing-FROM marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" - (GETFILEINFO TO-FILE 'CREATIONDATE) - SHORT-TO - (GETFILEINFO TO-FILE 'AUTHOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) - ((NOT TO-FILE) - - (* ;; " Ran out of TO files first; print the missing-TO marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO - FROM-FILE - 'AUTHOR) - (GETFILEINFO FROM-FILE 'CREATIONDATE) - "**" "" "" "") - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - ((CL:STRING-LESSP SHORT-FROM SHORT-TO) - - (* ;; - "This FROM file has no TO equivalent. Print the missing-FROM marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO - FROM-FILE - 'AUTHOR) - (GETFILEINFO FROM-FILE 'CREATIONDATE) - "**" "" "" "") - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - ((CL:STRING-LESSP SHORT-TO SHORT-FROM) - - (* ;; - "This TO file has no FROM equivalent. Print the missing-TO marker") - - (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" - (GETFILEINFO TO-FILE 'CREATIONDATE) - SHORT-TO - (GETFILEINFO TO-FILE 'AUTHOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))) - ([= (SETQ DT1 (GETFILEINFO FROM-FILE 'ICREATIONDATE)) - (SETQ DT2 (GETFILEINFO TO-FILE 'ICREATIONDATE] - (AND SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM - "" (GDATE DT1) - "==" - (GDATE DT2) - SHORT-TO "")) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM - (GETFILEINFO FROM-FILE 'AUTHOR) - (GDATE DT1) - (COND - ((LESSP DT1 DT2) - "<<") - (T ">>")) - (GDATE DT2) - SHORT-TO - (GETFILEINFO TO-FILE 'AUTHOR)) - (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)) - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR] - (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) ) (* ;; "look for compiled files older than the sources") (DEFINEQ (FIND-UNCOMPILED-FILES - [LAMBDA (FROMDIR TODIR LISTINGFILE) (* ; "Edited 3-Nov-94 15:17 by jds") - - (* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other. If SHOW=FILESTOO, then files that are the same are also listed. LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.") - - (LET ((LISTINGSTREAM (COND - [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'POSTSCRIPT '(LANDSCAPE T] - (T NIL))) - FROM-GENERATOR TO-GENERATOR) - (COND - (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN) - [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT "Compiled-file search of " FROMDIR - " vs " TODIR) - (CONCAT "as of " (DATE] - (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM))) - [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY "*.;") - NIL - '(SORT] - (bind FROM-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)) - repeatwhile FROM-FILE bind DT1 DT2 TON SHORT-FROM SHORT-TO - do (COND - [[SETQ TO-FILE (OR (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL - 'EXTENSION - 'DFASL - 'BODY FROM-FILE)) - (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL - 'EXTENSION - 'LCOM - 'BODY FROM-FILE] - (COND - ((< (GETFILEINFO TO-FILE 'ICREATIONDATE) - (GETFILEINFO FROM-FILE 'ICREATIONDATE)) - (PRINTOUT LISTINGSTREAM FROM-FILE " (" (GETFILEINFO FROM-FILE - 'CREATIONDATE) - ") vs " TO-FILE " (" (GETFILEINFO TO-FILE 'CREATIONDATE) - ")" T] - (T (PRINTOUT LISTINGSTREAM FROM-FILE " has no compiled equivalent." T))) - (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))) - (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM]) ) (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1114 23091 (COMPAREDIRECTORIES 1124 . 11760) (COMPAREDIRS.FORMATLINE 11762 . 14932) ( COMPAREDIRECTORIES.NEWPAGEFN 14934 . 16201) (COMPARE-DIRECTORIES 16203 . 23089)) (23156 26000 ( FIND-UNCOMPILED-FILES 23166 . 25998))))) STOP \ No newline at end of file diff --git a/lispusers/COMPARESOURCES.LCOM.~3~ b/lispusers/COMPARESOURCES.LCOM.~3~ deleted file mode 100644 index 0c2890bce87d339db72e30a8870427616df9a60f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 10362 zcmb_iYit`=cIHs_IxlHONmdj^wQmX6rHn|+8NSuj%MnRgBayrchcYGS!N{f(DRv}7 zvfB-c0>yTL7T7jv3#?-VyV->c1YKaekYp2Rk`~1FUr?aM0tH&MzYFY-MWMDSP_#hY z@7%|5Mxx{Wv4%BsALpKX?z!il^W8Iy6-#qYwKO&7luJ`ib&j($OLk$=zEomSr&=%7 z%8t7fWoK$7yI8kp%SW1LZMVeC_+)>K7!*KNFBMsorKa5Vn^RWYiZe4e6Srm(@hFQ$ zuWi45bMwY}i*0X#sQ-70?&9yhxV*c*vwQLS+RYnlTNlgQ*Vb-ae0#lhWBr}Pbn4=b z&E1>Vws+P=;kKYG@XC^1E4h5RRw%jCzmb>(uiTV!>gg6y3C&Q#{?)Hrv%zbBf`}Qs7U&{3Kbd(dq-&%_hIv~95_`-3~hW{TPV*b*}{?7~tF#x+IObAh2H%`T9EbsJK$ zL0FuiNMek%ORA<>u~aC-2v$)^>BizBYo|@Z|;Y_%SVS^bt+<})dgS2 zkI?bjLREBJS!_R5Zl8LBWcms{nnRz3_|Ruz{GFh`$cc!vP$)h_eVvL};>T6-`o!@w z{XH<1Q~74PJ1oT-o);t9r^HGIjg}z_haWb_JAAA?%*Qvzn`6z<4j&0ONA@4ueEfWK zZ0|oGOK5fp9Wnd;5d*Axb6wTM%~4}PP&daqeAFQF(J&tq|3`I)e2@M)A3Io6I`(g) zSO6b?o%A9|MW-l@_t;m(fsYDB@G1hRYHukQ{GKW_l_k z0g)^AVrhz;RH-%v&*Id0wNk3qSpthVzDO&R>D8J_Xc?_!+AAis_AD!-RAX5tyHu)^ z%Mn4@ifbBj_)_a8bf!v}O_ze>%#=riwJ92JJ`?ki7BCI=bo!EAo29^Sn%Kn3WparK z3mK@`E|MguNMkudpG|q>*?5;aW9k*AQ)+5xUCNL|kaen(Ya*rTEKk_1qRV+?h^%Rd z3%Fu0m%W{wuG^PfmIlmFTZ^!kgo*lUVvqjuO3BUyt8#a#R4&hzFQHk}5^vB}mheuCSrPZ0 zIcg@O0_vogzfzxfsx-`EtGbBDU3Ezq1n#Q4BI0`>+*>N#OMD=eM3`ZP%`v#Ju3K`c z0l-3m0#v-^k+7(znALz?^M)Wz3#72Lc!`!MS~8+#l}NLqh|M^8iJc0ai2TVD`H1-p zAL?tL<|9KZ`FY{muZAM=r|0*6(-)X1gtUkF7{bnIbELzE!p)(*zvE-)o1=UG)iO}) z`+$$Mr}&WQ5BIfyj!?N`EAGDv?yI&8URT55?(9j7(H!AJ&+Yy6aWf%)9+~N8aHiGy zd#wXUM5lsSL#H5uPiOYS&4|%IABlXGPxQ6thKJ{!4H4DEqtGwlz^mUCwaR!SKYlIW zX@ES!Szr6b;n&Gd_lF|!ME>yJ ze&{0}{Ym(&V9k2VL|zrv$>p~KiGO!V-#ISV)0{=-3u zqxOD={ov;ST*S5y2e*Cyp(}TTfXkOqT~t)G&IpeJJLV(yv;4f6(%?Ksi|saSpy82= z4db8D9^_F&Y=l%gc!mvnpi5#dZ?O}gY^wE=Cja^Pny=gWmaSDQ-{Jg6tp^|ve@z+B zaeI2J6&V`$tt0fW5c_Hf3pvZv5|REN&kkJ;^Y~kb-{IC))4Z*SH}*sSEq81G;k415zFr8{)NAIzBvPF{Q7MyD5d20p0^*21-iy`r*mF(`05} z(dH$Y#P;AU@9^M~s%!(s(_~XWG-$7iI8?zG!=Nog4*~1^A@k1(2 z+?5xij{U8?y)iy6y@;gFkG4ldNj%Ug+yzB3itMGLL$Ny%M_`ggD~UVa6iChiet5;W9t@Bm zB&jY}ST?6YQ8p{N*F`f$MhUdDK)h0b3+a|S`#p9PR1C4ZugDhX@vMh|-h=yrK3F08@-H3FaLW z07h}F5qQr`B;#yq3g(3H&Tnn3@1O|ws%T|$tm3!@SXDYBOBtA8!7kQV5}Pz5GHebl ze5y*&Gno{ahO%yQQxX8IlB$Fh$SSj75rNc+B(pLCzyM)Ec)NzTyxAyHoy?N(&xF0p z)ZR-3HB^z%t4VhWLZz^Apvn5i`tCYg+gTT|Qsm`K6EpPc$l)FoWyq+#y}os87rC$; zE(FN@tuS+vWwSuOUMHKnNcc6INp=ZvLnCNhLLzQ`cXxApYZp=^aioBN*WcLOLR#(W zJE&N=e-Po^?X7FK1Q|nO?YNn#d{RcCK`cCn0|Yo&x1F+pgF@c~29YkrtpRNku*Ly3 z9VCtdFfhrS;#^h0L#0wtgQsxnxcpEGNMTCK0V$+82Y}kegLGY?B+(qMN*dl7KY5}r z^p$-3DVyS%@mG1fl~*yYqhj7ivg>=1eBbOrrX>BG@U105(V10mf14sxul#=KKUxvv zL@{EVEE_A=D+3hLBd4l;?aLcOtM}hn?7^Zjq#6~I#vq*Y*~XyosfYJZHwOC<=-!ha zcW?sb-Ob2-uJ8F*Y@u8nnSTJyg%=hZuAuf{s3VMJj`Ub+aMocx z>-&5_Zh@ZYqXh((Bu>8!CW)>WPULiKNGRuRvINd4`5Oz@fnXLRfqSZCVd0{z-4nT9 znbH>Kh;!{l56io>TbNxkwc=V16P`~op%bfooHxYuhQOaFx@Nk;~z?S;0kZ@4s zP|#UM3{%3wZ={r~nq)@eq!9||!x8(${AyqO#KxfUa;xvp_Cr5w$@BSsN4)pW$m(~* z>)l1wdq?)ZEO9l4{hR2QH<%CXMJK$9#3gPzdVpqkU9!6)UVE<|?JftpFCOil3Ur^< z-AbB2lD!Y)72y?o;_hPE7T(|w?Zu68?G`t#?4=AzdUsJSVDH>Qd%|886j$0q%fN$I z)PQSGbru#E!sE|%obdh^{}hT@l+#q$%*v#6won6w;I@(Vc^OL!2@Q977CVBR7NF4* zcNtD|rBs>4uG7KnCYCG&`8lUX2n3mvDo3(TRB$}K3MK1gvx(?fx@?#8Wp3kK02dTF zKCg9KVCqL&ka_a;r!uleu0rJEQm}8$!fQ<8)5Wnya$Gc#M@2x3FRcOrLv|%XXr>OQJm&7i^=E- z3|YsKaVK$xnl9?Q7&s~wdP!!N21rKE5f1j z0~B(K@E$Zkef;!R=D3&b+8nP{q-PL|TA`JkMH<7%8|s|iA6A9GQ11tQn}bpkIM>>e z{nFRz`xq5oLIRB5-V`cqOk*Nf`yV8}pmTwAR;cjE6yV?XQ3|kS*v8@apdK54Di!GI z^DNpTMrgiuFx=Wa{83`C{j^ZwJc9DjH)+r>P8tb^orTX2=JRTYq`Uf-;5RFdwE#D= zXg`u@Rz&7OXQ7+6LMye9sQpC4pF%W7saoB}2OFlpI@YhAY=VO{p;((I*Wj;km5$Q{G=N48*qXu&K9bcCY`A8x zfN=&m(_IO_0>B7fD~h{_k52)g;hj=XLsz_{BUe(A=Me)S+NGLZ@o}n`DobVL+`mMu zBdqXcNe}Y)=rf@^)WLY>Jn4_13qk(M@XHR&m&;2_AtO!}@>qboO zGerf-6A>(Me^paGZVfc8RJ2mHU)e{Umr`~N=d@m5C1r_Rm(rU0wG3)5gp|JNco&O_ zpN|AP0@)S)i<#rMacc2HE4N<^^f$?TMKI(~%3rL|=x)UHa~J+rc6Ys`&}P?($!@FNYWPMJV!mdKZf*_VG^d?%YG!gm|T%u zKPEkH;zqu`;pM=^iQ zCW;JR)NZvlMG^`>uVVN$+AYE9sQu`=kSbs`x(8cg7m*W$7{LgrwcxW}(D;0ZGEu)Z z1!mCZq$lWZP_GSSu`VV*c2y9-Uf*7bj}9INTERNAL>LIBRARY>COMPARESOURCES.;2 13793 changes to%: (FNS COMPARESOURCES \CS.COMPARE.MASTERS) (VARS COMPARESOURCESCOMS) previous date%: "13-Jan-87 15:00:32" {ERINYES}INTERNAL>LIBRARY>COMPARESOURCES.;1) (* " Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPARESOURCESCOMS) (RPAQQ COMPARESOURCESCOMS ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE) (FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS) (VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE) (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)))) (DEFINEQ (COMPARESOURCES (LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 15-Apr-88 14:41 by bvm") (* ;;; "Compare two lisp source files, reporting differences.") (DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES)) (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY) (SETQ FILEX (OR (FINDFILE FILEX T) (RETURN (printout LISTSTREAM FILEX " not found" T)))) (SETQ FILEY (OR (FINDFILE FILEY T) (RETURN (printout LISTSTREAM FILEY " not found" T)))) (* ;; "Read the two files, throwing out extraneous forms & such:") (CL:MULTIPLE-VALUE-SETQ (BODYX ENVX) (READFILE FILEX)) (SETQ BODYX (\CS.FILTER.GARBAGE BODYX)) (CL:MULTIPLE-VALUE-SETQ (BODYY ENVY) (READFILE FILEY)) (SETQ BODYY (\CS.FILTER.GARBAGE BODYY)) (printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX (QUOTE CREATIONDATE)) " and " FILEY " dated " (GETFILEINFO FILEY (QUOTE CREATIONDATE)) ":" T T) (SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) (QUOTE DECLARE%:)))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX)) (SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) (QUOTE DECLARE%:)))) (SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY)) (WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT)) (\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM) (* ;; "Done with the non-DECLARE: expressions. Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare") (SETQ BODYX (\CS.SORT.DECLARES DECLAREX)) (SETQ BODYY (\CS.SORT.DECLARES DECLAREY)) (SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y)) unless (SASSOC (CAR Y) BODYX)))) (* ; "Add placeholders for any declaration types in Y not in X to simplify what follows") (for X in BODYX bind Y TYPE do (SETQ Y (SASSOC (CAR X) BODYY)) (SETQ TYPE (CAR X)) (SETQ X (LDIFFERENCE (CDR X) (PROG1 (CDR Y) (SETQ Y (LDIFFERENCE (CDR Y) X))))) (COND ((OR X Y) (printout LISTSTREAM T "------" (CONS (QUOTE DECLARE%:) (APPEND (CL:SET-DIFFERENCE TYPE DEFAULT.DECLARE.TAGS) (QUOTE (--)))) " forms------" T) (* ; "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order") (\CS.COMPARE.MASTERS (REVERSE X) (REVERSE Y) DW? LISTSTREAM)))) (TERPRI LISTSTREAM)) (RETURN (REVERSE DIFFERENCES)))) ) (\CS.COMPARE.MASTERS (LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 15-Apr-88 14:41 by bvm") (LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS) (DECLARE (USEDFREE DIFFERENCES)) (SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX)) (SETQ FNSX (for BOD in FNSX join (CDR BOD))) (SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY)) (SETQ FNSY (for BOD in FNSY join (CDR BOD))) (COND ((OR FNSX FNSY) (printout LISTSTREAM "---Functions: " T) (COND (DW? (LET ((NOSPELLFLG T)) (DECLARE (SPECVARS NOSPELLFLG)) (for X in FNSX when (SETQ Y (ASSOC (CAR X) FNSY)) do (* ; "Only bother dwimifying the ones that look different") (DWIMIFY (CADR X) T) (DWIMIFY (CADR Y) T))))) (COND ((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL (FUNCTION (LAMBDA (X Y STREAM) (COMPARELISTS (CADR X) (CADR Y) STREAM))) (FUNCTION CAR) LISTSTREAM)) (push DIFFERENCES (CONS (QUOTE FNS) DIFS)))))) (for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE) (SETQ DEFFERS (GET TYPE :DEFINED-BY))) do (* ;; "handle definer based things") (for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X when (EQ (CAR X) DEFFER))) (SETQ YTHING (for X in BODYY collect X when (EQ (CAR X) DEFFER))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (CONCAT (OR (CL:DOCUMENTATION TYPE (QUOTE DEFINE-TYPES)) TYPE) " defined by " DEFFER) NIL (GET DEFFER :DEFINITION-NAME) LISTSTREAM)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS)))))))) (for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE)) (SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X))) (SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (OR (fetch (CSTYPE TITLE) of TYPE) (L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE) of TYPE)) T)) (fetch (CSTYPE COMPAREFN) of TYPE) (OR (fetch (CSTYPE IDFN) of TYPE) (FUNCTION CADR)) LISTSTREAM)) (SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS))))))) (SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX (SETQ BODYX (LDIFFERENCE BODYX BODYY))))) (COND ((OR BODYX BODYY) (printout LISTSTREAM T "---Expressions:" T) (LET ((COMMENTX 0) (COMMENTY 0) EXTRAS) (* ; "Remove comments") (SETQ BODYX (for X in BODYX collect X unless (COND ((EQ (CAR X) COMMENTFLG) (add COMMENTX 1) T)))) (SETQ BODYY (for Y in BODYY collect Y unless (COND ((EQ (CAR Y) COMMENTFLG) (add COMMENTY 1) T)))) (COND ((OR (NEQ COMMENTX 0) (NEQ COMMENTY 0)) (printout LISTSTREAM |.I1| COMMENTX " comments -> " |.I1| COMMENTY " comments." T T))) (COND ((SETQ EXTRAS (COND (BODYX (COND (BODYY (COMPARELISTS BODYX BODYY LISTSTREAM) NIL) (T (printout LISTSTREAM "These are not on " FILEY) BODYX))) (BODYY (printout LISTSTREAM "These are not on " FILEX) BODYY))) (printout LISTSTREAM ":" T) (for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3)))) (COND ((AND (OR BODYX BODYY) (OR (EQ EXAMINE T) (EQMEMB (QUOTE MISC) EXAMINE))) (EDITE (LIST BODYX BODYY)))) (OR (ASSOC (QUOTE Other) DIFFERENCES) (push DIFFERENCES (LIST (QUOTE Other) (QUOTE --))))))))) ) (\CS.COMPARE.TYPES (LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN. Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT)))) ) (\CS.SORT.DECLARES (LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT)) ) (\CS.SORT.DECLARE1 (LAMBDA (DEC TAGLST) (* bvm%: "15-Nov-85 19:09") (DECLARE (USEDFREE RESULT)) (* ;;; "Process one DECLARE: expression, partitioning it into subdeclarations put on RESULT assuming that the default tags in effect by the time you get here are in TAGLST") (for TAIL on (CDR DEC) bind CURRENT TAG COMPLEMENT do (COND ((NLISTP (SETQ TAG (CAR TAIL))) (* ; "Canonicalize tag") (SELECTQ TAG (DOEVAL@LOAD (SETQQ TAG EVAL@LOAD)) (DOEVAL@COMPILE (SETQQ TAG EVAL@COMPILE)) (DOCOPY (SETQQ TAG COPY)) NIL) (COND ((NOT (MEMB TAG TAGLST)) (SETQ TAGLST (COND ((STRPOS (QUOTE WHEN) TAG) (* ; "These take an extra expression") (APPEND TAGLST (LIST TAG (CAR (SETQ TAIL (CDR TAIL)))))) ((FMEMB (SETQ COMPLEMENT (SELECTQ TAG (COPY (QUOTE DONTCOPY)) (DONTCOPY (QUOTE COPY)) (EVAL@COMPILE (QUOTE DONTEVAL@COMPILE)) (DONTEVAL@COMPILE (QUOTE EVAL@COMPILE)) (EVAL@LOAD (QUOTE DONTEVAL@LOAD)) (DONTEVAL@LOAD (QUOTE EVAL@LOAD)) (FIRST (QUOTE NOTFIRST)) (NOTFIRST (QUOTE FIRST)) NIL)) TAGLST) (SUBST TAG COMPLEMENT TAGLST)) (T (APPEND TAGLST (LIST TAG))))) (SETQ CURRENT NIL)))) ((EQ (CAR TAG) (QUOTE DECLARE%:)) (* ; "Process embedded declaration") (\CS.SORT.DECLARE1 TAG TAGLST)) (T (* ; "Stick this expression on the entry for the tags that tell when to eval it") (COND ((AND (NOT CURRENT) (NOT (SETQ CURRENT (SASSOC TAGLST RESULT)))) (SETQ RESULT (NCONC1 RESULT (SETQ CURRENT (LIST TAGLST)))))) (push (CDR CURRENT) TAG))))) ) (\CS.FILTER.GARBAGE (LAMBDA (FILECONTENTS) (* ; "Edited 29-Dec-86 10:44 by jds") (* ;;; "Remove %"Uninteresting%" items from files to be compared. Removes FILECREATED form, filemap, copyright notice, and DECLARE: DONTCOPY items.") (for X in FILECONTENTS collect X unless (OR (EQ (CAR X) (QUOTE FILECREATED)) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (EQ (CADR X) (QUOTE DONTCOPY)) (LISTP (CADDR X)) (OR (FMEMB (QUOTE COPYRIGHT) (CADDR X)) (FMEMB (QUOTE FILEMAP) (CADDR X))))))) ) ) (DEFINEQ (\CS.ISVARFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL))) (\CS.COMPARE.VARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compares two variable setting forms") (COND ((EQ (CAR X) (CAR Y)) (* ; "Same type of setting fn") (COMPARELISTS (CADDR X) (CADDR Y) STREAM)) (T (LET ((XVAL (COND ((EQ (CAR X) (QUOTE RPAQQ)) (KWOTE (CADDR X))) (T (CADDR X)))) (YVAL (COND ((EQ (CAR Y) (QUOTE RPAQQ)) (KWOTE (CADDR Y))) (T (CADDR Y))))) (COND ((EQUAL XVAL YVAL) (* ; "Same value, different setter") (printout STREAM (COND ((EQ (CAR X) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) " -> " (COND ((EQ (CAR Y) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) T)) (T (COMPARELISTS XVAL YVAL STREAM))))))) ) (\CS.ISMACROFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:19") (SELECTQ (CAR X) (DEFMACRO T) (PUTPROPS (FMEMB (CADDR X) MACROPROPS)) NIL)) ) (\CS.ISRECFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:20") (FMEMB (CAR X) CLISPRECORDTYPES))) (\CS.ISCOURIERFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:21") (EQ (CAR X) (QUOTE COURIERPROGRAM)))) (\CS.ISTEMPLATEFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:20") (EQ (CAR X) (QUOTE SETTEMPLATE)))) (\CS.COMPARE.TEMPLATES (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Templates usually look like (SETTEMPLATE (QUOTE FN) (QUOTE TEMPLATE))") (COND ((AND (EQUAL (CADR X) (CADR Y)) (EQ (CAR (CADDR X)) (QUOTE QUOTE)) (EQ (CAR (CADDR Y)) (QUOTE QUOTE))) (COMPARELISTS (CADR (CADDR X)) (CADR (CADDR Y)) STREAM)) (T (COMPARELISTS X Y STREAM)))) ) (\CS.ISPROPFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:34") (* ;;; "(PUTPROPS SYMBOL PROP VALUE)") (AND (EQ (CAR X) (QUOTE PUTPROPS)) (NULL (CDDDDR X)))) ) (\CS.PROP.NAME (LAMBDA (X) (* bvm%: "13-Mar-86 16:29") (* ;;; "The 'Name' of a property is its atom/value pair") (LIST (CADR X) (CADDR X))) ) (\CS.COMPARE.PROPS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compare the values") (COMPARELISTS (CADDDR X) (CADDDR Y) STREAM)) ) (\CS.ISADDVARFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:40") (EQ (CAR X) (QUOTE ADDTOVAR)))) (\CS.COMPARE.ADDVARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "(ADDTOVAR ListName . values)") (COMPARELISTS (CDDR X) (CDDR Y) STREAM)) ) (\CS.ISFPKGCOMFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:50") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (AND (EQ (CAR X) (QUOTE PUTDEF)) (EQUAL (CADDR X) (QUOTE (QUOTE FILEPKGCOMS))))) ) (\CS.COMPARE.FPKGCOMS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM)) ) ) (RPAQQ COMPARESOURCETYPES ((VARS \CS.ISVARFORM \CS.COMPARE.VARS) (MACROS \CS.ISMACROFORM) (RECORDS \CS.ISRECFORM) (PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties") (ADDVARS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS CADR "Additions to lists") (TEMPLATES \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES CADADR) (COURIERPROGRAMS \CS.ISCOURIERFORM) (FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR))) (RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD CSTYPE (FPKGTYPE PREDFN COMPAREFN IDFN TITLE)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS) ) ) (PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1056 10234 (COMPARESOURCES 1066 . 3301) (\CS.COMPARE.MASTERS 3303 . 6734) ( \CS.COMPARE.TYPES 6736 . 7985) (\CS.SORT.DECLARES 7987 . 8330) (\CS.SORT.DECLARE1 8332 . 9752) ( \CS.FILTER.GARBAGE 9754 . 10232)) (10235 12963 (\CS.ISVARFORM 10245 . 10350) (\CS.COMPARE.VARS 10352 . 11014) (\CS.ISMACROFORM 11016 . 11154) (\CS.ISRECFORM 11156 . 11249) (\CS.ISCOURIERFORM 11251 . 11351) (\CS.ISTEMPLATEFORM 11353 . 11451) (\CS.COMPARE.TEMPLATES 11453 . 11818) (\CS.ISPROPFORM 11820 . 11975) (\CS.PROP.NAME 11977 . 12122) (\CS.COMPARE.PROPS 12124 . 12281) (\CS.ISADDVARFORM 12283 . 12376) (\CS.COMPARE.ADDVARS 12378 . 12543) (\CS.ISFPKGCOMFORM 12545 . 12752) (\CS.COMPARE.FPKGCOMS 12754 . 12961))))) STOP \ No newline at end of file diff --git a/lispusers/COMPARESOURCES.~2~ b/lispusers/COMPARESOURCES.~2~ deleted file mode 100644 index 6fa1b2f2..00000000 --- a/lispusers/COMPARESOURCES.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Apr-2018 10:50:03"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;2 15689 changes to%: (FNS COMPARESOURCES) previous date%: "15-Apr-88 14:42:45" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 2018 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPARESOURCESCOMS) (RPAQQ COMPARESOURCESCOMS ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE) (FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS) (VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE) (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)))) (DEFINEQ (COMPARESOURCES [LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 19-Apr-2018 10:49 by rmk:") (* ;;; "Compare two lisp source files, reporting differences.") (DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES)) (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY) [SETQ FILEX (OR (FINDFILE FILEX T) (RETURN (printout LISTSTREAM FILEX " not found" T] [SETQ FILEY (OR (FINDFILE FILEY T) (RETURN (printout LISTSTREAM FILEY " not found" T] (* ;; "Read the two files, throwing out extraneous forms & such:") (CL:MULTIPLE-VALUE-SETQ (BODYX ENVX) (READFILE FILEX)) (SETQ BODYX (\CS.FILTER.GARBAGE BODYX)) (CL:MULTIPLE-VALUE-SETQ (BODYY ENVY) (READFILE FILEY)) (SETQ BODYY (\CS.FILTER.GARBAGE BODYY)) (printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE) " and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE) ":" T T) [SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) 'DECLARE%:] (SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX)) [SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) 'DECLARE%:] (SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY)) (WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT)) (\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM) (* ;; "Done with the non-DECLARE: expressions. Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare") (SETQ BODYX (\CS.SORT.DECLARES DECLAREX)) (SETQ BODYY (\CS.SORT.DECLARES DECLAREY)) [SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y)) unless (SASSOC (CAR Y) BODYX] (* ;  "Add placeholders for any declaration types in Y not in X to simplify what follows") [for X in BODYX bind Y TYPE do (SETQ Y (SASSOC (CAR X) BODYY)) (SETQ TYPE (CAR X)) [SETQ X (LDIFFERENCE (CDR X) (PROG1 (CDR Y) (SETQ Y (LDIFFERENCE (CDR Y) X)))] (COND ((OR X Y) (printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND ( CL:SET-DIFFERENCE TYPE DEFAULT.DECLARE.TAGS ) '(--] " forms------" T) (* ;  "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order") (\CS.COMPARE.MASTERS (REVERSE X) (REVERSE Y) DW? LISTSTREAM] (TERPRI LISTSTREAM)) (RETURN (OR (REVERSE DIFFERENCES) 'SAME]) (\CS.COMPARE.MASTERS (LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 15-Apr-88 14:41 by bvm") (LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS) (DECLARE (USEDFREE DIFFERENCES)) (SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX)) (SETQ FNSX (for BOD in FNSX join (CDR BOD))) (SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY)) (SETQ FNSY (for BOD in FNSY join (CDR BOD))) (COND ((OR FNSX FNSY) (printout LISTSTREAM "---Functions: " T) (COND (DW? (LET ((NOSPELLFLG T)) (DECLARE (SPECVARS NOSPELLFLG)) (for X in FNSX when (SETQ Y (ASSOC (CAR X) FNSY)) do (* ; "Only bother dwimifying the ones that look different") (DWIMIFY (CADR X) T) (DWIMIFY (CADR Y) T))))) (COND ((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL (FUNCTION (LAMBDA (X Y STREAM) (COMPARELISTS (CADR X) (CADR Y) STREAM))) (FUNCTION CAR) LISTSTREAM)) (push DIFFERENCES (CONS (QUOTE FNS) DIFS)))))) (for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE) (SETQ DEFFERS (GET TYPE :DEFINED-BY))) do (* ;; "handle definer based things") (for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X when (EQ (CAR X) DEFFER))) (SETQ YTHING (for X in BODYY collect X when (EQ (CAR X) DEFFER))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (CONCAT (OR (CL:DOCUMENTATION TYPE (QUOTE DEFINE-TYPES)) TYPE) " defined by " DEFFER) NIL (GET DEFFER :DEFINITION-NAME) LISTSTREAM)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS)))))))) (for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE)) (SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X))) (SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (OR (fetch (CSTYPE TITLE) of TYPE) (L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE) of TYPE)) T)) (fetch (CSTYPE COMPAREFN) of TYPE) (OR (fetch (CSTYPE IDFN) of TYPE) (FUNCTION CADR)) LISTSTREAM)) (SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS))))))) (SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX (SETQ BODYX (LDIFFERENCE BODYX BODYY))))) (COND ((OR BODYX BODYY) (printout LISTSTREAM T "---Expressions:" T) (LET ((COMMENTX 0) (COMMENTY 0) EXTRAS) (* ; "Remove comments") (SETQ BODYX (for X in BODYX collect X unless (COND ((EQ (CAR X) COMMENTFLG) (add COMMENTX 1) T)))) (SETQ BODYY (for Y in BODYY collect Y unless (COND ((EQ (CAR Y) COMMENTFLG) (add COMMENTY 1) T)))) (COND ((OR (NEQ COMMENTX 0) (NEQ COMMENTY 0)) (printout LISTSTREAM |.I1| COMMENTX " comments -> " |.I1| COMMENTY " comments." T T))) (COND ((SETQ EXTRAS (COND (BODYX (COND (BODYY (COMPARELISTS BODYX BODYY LISTSTREAM) NIL) (T (printout LISTSTREAM "These are not on " FILEY) BODYX))) (BODYY (printout LISTSTREAM "These are not on " FILEX) BODYY))) (printout LISTSTREAM ":" T) (for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3)))) (COND ((AND (OR BODYX BODYY) (OR (EQ EXAMINE T) (EQMEMB (QUOTE MISC) EXAMINE))) (EDITE (LIST BODYX BODYY)))) (OR (ASSOC (QUOTE Other) DIFFERENCES) (push DIFFERENCES (LIST (QUOTE Other) (QUOTE --))))))))) ) (\CS.COMPARE.TYPES (LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN. Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT)))) ) (\CS.SORT.DECLARES (LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT)) ) (\CS.SORT.DECLARE1 (LAMBDA (DEC TAGLST) (* bvm%: "15-Nov-85 19:09") (DECLARE (USEDFREE RESULT)) (* ;;; "Process one DECLARE: expression, partitioning it into subdeclarations put on RESULT assuming that the default tags in effect by the time you get here are in TAGLST") (for TAIL on (CDR DEC) bind CURRENT TAG COMPLEMENT do (COND ((NLISTP (SETQ TAG (CAR TAIL))) (* ; "Canonicalize tag") (SELECTQ TAG (DOEVAL@LOAD (SETQQ TAG EVAL@LOAD)) (DOEVAL@COMPILE (SETQQ TAG EVAL@COMPILE)) (DOCOPY (SETQQ TAG COPY)) NIL) (COND ((NOT (MEMB TAG TAGLST)) (SETQ TAGLST (COND ((STRPOS (QUOTE WHEN) TAG) (* ; "These take an extra expression") (APPEND TAGLST (LIST TAG (CAR (SETQ TAIL (CDR TAIL)))))) ((FMEMB (SETQ COMPLEMENT (SELECTQ TAG (COPY (QUOTE DONTCOPY)) (DONTCOPY (QUOTE COPY)) (EVAL@COMPILE (QUOTE DONTEVAL@COMPILE)) (DONTEVAL@COMPILE (QUOTE EVAL@COMPILE)) (EVAL@LOAD (QUOTE DONTEVAL@LOAD)) (DONTEVAL@LOAD (QUOTE EVAL@LOAD)) (FIRST (QUOTE NOTFIRST)) (NOTFIRST (QUOTE FIRST)) NIL)) TAGLST) (SUBST TAG COMPLEMENT TAGLST)) (T (APPEND TAGLST (LIST TAG))))) (SETQ CURRENT NIL)))) ((EQ (CAR TAG) (QUOTE DECLARE%:)) (* ; "Process embedded declaration") (\CS.SORT.DECLARE1 TAG TAGLST)) (T (* ; "Stick this expression on the entry for the tags that tell when to eval it") (COND ((AND (NOT CURRENT) (NOT (SETQ CURRENT (SASSOC TAGLST RESULT)))) (SETQ RESULT (NCONC1 RESULT (SETQ CURRENT (LIST TAGLST)))))) (push (CDR CURRENT) TAG))))) ) (\CS.FILTER.GARBAGE (LAMBDA (FILECONTENTS) (* ; "Edited 29-Dec-86 10:44 by jds") (* ;;; "Remove %"Uninteresting%" items from files to be compared. Removes FILECREATED form, filemap, copyright notice, and DECLARE: DONTCOPY items.") (for X in FILECONTENTS collect X unless (OR (EQ (CAR X) (QUOTE FILECREATED)) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (EQ (CADR X) (QUOTE DONTCOPY)) (LISTP (CADDR X)) (OR (FMEMB (QUOTE COPYRIGHT) (CADDR X)) (FMEMB (QUOTE FILEMAP) (CADDR X))))))) ) ) (DEFINEQ (\CS.ISVARFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL))) (\CS.COMPARE.VARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compares two variable setting forms") (COND ((EQ (CAR X) (CAR Y)) (* ; "Same type of setting fn") (COMPARELISTS (CADDR X) (CADDR Y) STREAM)) (T (LET ((XVAL (COND ((EQ (CAR X) (QUOTE RPAQQ)) (KWOTE (CADDR X))) (T (CADDR X)))) (YVAL (COND ((EQ (CAR Y) (QUOTE RPAQQ)) (KWOTE (CADDR Y))) (T (CADDR Y))))) (COND ((EQUAL XVAL YVAL) (* ; "Same value, different setter") (printout STREAM (COND ((EQ (CAR X) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) " -> " (COND ((EQ (CAR Y) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) T)) (T (COMPARELISTS XVAL YVAL STREAM))))))) ) (\CS.ISMACROFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:19") (SELECTQ (CAR X) (DEFMACRO T) (PUTPROPS (FMEMB (CADDR X) MACROPROPS)) NIL)) ) (\CS.ISRECFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:20") (FMEMB (CAR X) CLISPRECORDTYPES))) (\CS.ISCOURIERFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:21") (EQ (CAR X) (QUOTE COURIERPROGRAM)))) (\CS.ISTEMPLATEFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:20") (EQ (CAR X) (QUOTE SETTEMPLATE)))) (\CS.COMPARE.TEMPLATES (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Templates usually look like (SETTEMPLATE (QUOTE FN) (QUOTE TEMPLATE))") (COND ((AND (EQUAL (CADR X) (CADR Y)) (EQ (CAR (CADDR X)) (QUOTE QUOTE)) (EQ (CAR (CADDR Y)) (QUOTE QUOTE))) (COMPARELISTS (CADR (CADDR X)) (CADR (CADDR Y)) STREAM)) (T (COMPARELISTS X Y STREAM)))) ) (\CS.ISPROPFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:34") (* ;;; "(PUTPROPS SYMBOL PROP VALUE)") (AND (EQ (CAR X) (QUOTE PUTPROPS)) (NULL (CDDDDR X)))) ) (\CS.PROP.NAME (LAMBDA (X) (* bvm%: "13-Mar-86 16:29") (* ;;; "The 'Name' of a property is its atom/value pair") (LIST (CADR X) (CADDR X))) ) (\CS.COMPARE.PROPS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compare the values") (COMPARELISTS (CADDDR X) (CADDDR Y) STREAM)) ) (\CS.ISADDVARFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:40") (EQ (CAR X) (QUOTE ADDTOVAR)))) (\CS.COMPARE.ADDVARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "(ADDTOVAR ListName . values)") (COMPARELISTS (CDDR X) (CDDR Y) STREAM)) ) (\CS.ISFPKGCOMFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:50") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (AND (EQ (CAR X) (QUOTE PUTDEF)) (EQUAL (CADDR X) (QUOTE (QUOTE FILEPKGCOMS))))) ) (\CS.COMPARE.FPKGCOMS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM)) ) ) (RPAQQ COMPARESOURCETYPES ((VARS \CS.ISVARFORM \CS.COMPARE.VARS) (MACROS \CS.ISMACROFORM) (RECORDS \CS.ISRECFORM) (PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties") (ADDVARS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS CADR "Additions to lists") (TEMPLATES \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES CADADR) (COURIERPROGRAMS \CS.ISCOURIERFORM) (FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR))) (RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD CSTYPE (FPKGTYPE PREDFN COMPAREFN IDFN TITLE)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS) ) ) (PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1153 12054 (COMPARESOURCES 1163 . 5121) (\CS.COMPARE.MASTERS 5123 . 8554) ( \CS.COMPARE.TYPES 8556 . 9805) (\CS.SORT.DECLARES 9807 . 10150) (\CS.SORT.DECLARE1 10152 . 11572) ( \CS.FILTER.GARBAGE 11574 . 12052)) (12055 14783 (\CS.ISVARFORM 12065 . 12170) (\CS.COMPARE.VARS 12172 . 12834) (\CS.ISMACROFORM 12836 . 12974) (\CS.ISRECFORM 12976 . 13069) (\CS.ISCOURIERFORM 13071 . 13171) (\CS.ISTEMPLATEFORM 13173 . 13271) (\CS.COMPARE.TEMPLATES 13273 . 13638) (\CS.ISPROPFORM 13640 . 13795) (\CS.PROP.NAME 13797 . 13942) (\CS.COMPARE.PROPS 13944 . 14101) (\CS.ISADDVARFORM 14103 . 14196) (\CS.COMPARE.ADDVARS 14198 . 14363) (\CS.ISFPKGCOMFORM 14365 . 14572) (\CS.COMPARE.FPKGCOMS 14574 . 14781))))) STOP \ No newline at end of file diff --git a/lispusers/COMPARESOURCES.~3~ b/lispusers/COMPARESOURCES.~3~ deleted file mode 100644 index 78d7104d..00000000 --- a/lispusers/COMPARESOURCES.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 5-Sep-2020 19:02:30"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;3 20197 changes to%: (FNS \CS.COMPARE.MASTERS) previous date%: "19-Apr-2018 10:50:03" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPARESOURCESCOMS) (RPAQQ COMPARESOURCESCOMS ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE) (FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS) (VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE) (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)))) (DEFINEQ (COMPARESOURCES [LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 19-Apr-2018 10:49 by rmk:") (* ;;; "Compare two lisp source files, reporting differences.") (DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES)) (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY) [SETQ FILEX (OR (FINDFILE FILEX T) (RETURN (printout LISTSTREAM FILEX " not found" T] [SETQ FILEY (OR (FINDFILE FILEY T) (RETURN (printout LISTSTREAM FILEY " not found" T] (* ;; "Read the two files, throwing out extraneous forms & such:") (CL:MULTIPLE-VALUE-SETQ (BODYX ENVX) (READFILE FILEX)) (SETQ BODYX (\CS.FILTER.GARBAGE BODYX)) (CL:MULTIPLE-VALUE-SETQ (BODYY ENVY) (READFILE FILEY)) (SETQ BODYY (\CS.FILTER.GARBAGE BODYY)) (printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE) " and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE) ":" T T) [SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) 'DECLARE%:] (SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX)) [SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) 'DECLARE%:] (SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY)) (WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT)) (\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM) (* ;; "Done with the non-DECLARE: expressions. Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare") (SETQ BODYX (\CS.SORT.DECLARES DECLAREX)) (SETQ BODYY (\CS.SORT.DECLARES DECLAREY)) [SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y)) unless (SASSOC (CAR Y) BODYX] (* ;  "Add placeholders for any declaration types in Y not in X to simplify what follows") [for X in BODYX bind Y TYPE do (SETQ Y (SASSOC (CAR X) BODYY)) (SETQ TYPE (CAR X)) [SETQ X (LDIFFERENCE (CDR X) (PROG1 (CDR Y) (SETQ Y (LDIFFERENCE (CDR Y) X)))] (COND ((OR X Y) (printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND ( CL:SET-DIFFERENCE TYPE DEFAULT.DECLARE.TAGS ) '(--] " forms------" T) (* ;  "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order") (\CS.COMPARE.MASTERS (REVERSE X) (REVERSE Y) DW? LISTSTREAM] (TERPRI LISTSTREAM)) (RETURN (OR (REVERSE DIFFERENCES) 'SAME]) (\CS.COMPARE.MASTERS [LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 5-Sep-2020 19:01 by rmk:") (* ; "Edited 15-Apr-88 14:41 by bvm") (LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS) (DECLARE (USEDFREE DIFFERENCES)) [SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) 'DEFINEQ] (SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX)) (SETQ FNSX (for BOD in FNSX join (CDR BOD))) [SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) 'DEFINEQ] (SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY)) (SETQ FNSY (for BOD in FNSY join (CDR BOD))) [COND ((OR FNSX FNSY) (printout LISTSTREAM "---Functions: " T) [COND (DW? (LET ((NOSPELLFLG T)) (DECLARE (SPECVARS NOSPELLFLG)) (for X in FNSX when (SETQ Y (ASSOC (CAR X) FNSY)) do (* ;  "Only bother dwimifying the ones that look different") (DWIMIFY (CADR X) T) (DWIMIFY (CADR Y) T] (COND ((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL [FUNCTION (LAMBDA (X Y STREAM) (COMPARELISTS (CADR X) (CADR Y) STREAM] (FUNCTION CAR) LISTSTREAM)) (push DIFFERENCES (CONS 'FNS DIFS] [for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE) (SETQ DEFFERS (GET TYPE :DEFINED-BY))) do (* ;; "handle definer based things") (for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X when (EQ (CAR X) DEFFER))) (SETQ YTHING (for X in BODYY collect X when (EQ (CAR X) DEFFER))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (CONCAT (OR (CL:DOCUMENTATION TYPE 'DEFINE-TYPES) TYPE) " defined by " DEFFER) NIL (GET DEFFER :DEFINITION-NAME) LISTSTREAM)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS] [for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE)) (SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X))) (SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (OR (fetch (CSTYPE TITLE) of TYPE) (L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE) of TYPE)) T)) (fetch (CSTYPE COMPAREFN) of TYPE) (OR (fetch (CSTYPE IDFN) of TYPE) (FUNCTION CADR)) LISTSTREAM)) (SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS] [SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX (SETQ BODYX (LDIFFERENCE BODYX BODYY)))] (COND ((OR BODYX BODYY) (printout LISTSTREAM T "---Expressions:" T) (LET ((COMMENTX 0) (COMMENTY 0) EXTRAS) (* ; "Remove comments") [SETQ BODYX (for X in BODYX collect X unless (COND ((EQ (CAR X) COMMENTFLG) (add COMMENTX 1) T] [SETQ BODYY (for Y in BODYY collect Y unless (COND ((EQ (CAR Y) COMMENTFLG) (add COMMENTY 1) T] (COND ((OR (NEQ COMMENTX 0) (NEQ COMMENTY 0)) (printout LISTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments." T T ))) [COND ((SETQ EXTRAS (COND (BODYX (COND (BODYY (COMPARELISTS BODYX BODYY LISTSTREAM) NIL) (T (printout LISTSTREAM "These are not on " FILEY) BODYX))) (BODYY (printout LISTSTREAM "These are not on " FILEX) BODYY))) (printout LISTSTREAM ":" T) (for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3] [COND ((AND (OR BODYX BODYY) (OR (EQ EXAMINE T) (EQMEMB 'MISC EXAMINE))) (IF (EQMEMB 2WINDOWS EXAMINE) THEN (EDITE BODYX) (EDITE BODYY) ELSE (EDITE (LIST BODYX BODYY] (OR (ASSOC 'Other DIFFERENCES) (push DIFFERENCES (LIST 'Other '--]) (\CS.COMPARE.TYPES (LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN. Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT)))) ) (\CS.SORT.DECLARES (LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT)) ) (\CS.SORT.DECLARE1 (LAMBDA (DEC TAGLST) (* bvm%: "15-Nov-85 19:09") (DECLARE (USEDFREE RESULT)) (* ;;; "Process one DECLARE: expression, partitioning it into subdeclarations put on RESULT assuming that the default tags in effect by the time you get here are in TAGLST") (for TAIL on (CDR DEC) bind CURRENT TAG COMPLEMENT do (COND ((NLISTP (SETQ TAG (CAR TAIL))) (* ; "Canonicalize tag") (SELECTQ TAG (DOEVAL@LOAD (SETQQ TAG EVAL@LOAD)) (DOEVAL@COMPILE (SETQQ TAG EVAL@COMPILE)) (DOCOPY (SETQQ TAG COPY)) NIL) (COND ((NOT (MEMB TAG TAGLST)) (SETQ TAGLST (COND ((STRPOS (QUOTE WHEN) TAG) (* ; "These take an extra expression") (APPEND TAGLST (LIST TAG (CAR (SETQ TAIL (CDR TAIL)))))) ((FMEMB (SETQ COMPLEMENT (SELECTQ TAG (COPY (QUOTE DONTCOPY)) (DONTCOPY (QUOTE COPY)) (EVAL@COMPILE (QUOTE DONTEVAL@COMPILE)) (DONTEVAL@COMPILE (QUOTE EVAL@COMPILE)) (EVAL@LOAD (QUOTE DONTEVAL@LOAD)) (DONTEVAL@LOAD (QUOTE EVAL@LOAD)) (FIRST (QUOTE NOTFIRST)) (NOTFIRST (QUOTE FIRST)) NIL)) TAGLST) (SUBST TAG COMPLEMENT TAGLST)) (T (APPEND TAGLST (LIST TAG))))) (SETQ CURRENT NIL)))) ((EQ (CAR TAG) (QUOTE DECLARE%:)) (* ; "Process embedded declaration") (\CS.SORT.DECLARE1 TAG TAGLST)) (T (* ; "Stick this expression on the entry for the tags that tell when to eval it") (COND ((AND (NOT CURRENT) (NOT (SETQ CURRENT (SASSOC TAGLST RESULT)))) (SETQ RESULT (NCONC1 RESULT (SETQ CURRENT (LIST TAGLST)))))) (push (CDR CURRENT) TAG))))) ) (\CS.FILTER.GARBAGE (LAMBDA (FILECONTENTS) (* ; "Edited 29-Dec-86 10:44 by jds") (* ;;; "Remove %"Uninteresting%" items from files to be compared. Removes FILECREATED form, filemap, copyright notice, and DECLARE: DONTCOPY items.") (for X in FILECONTENTS collect X unless (OR (EQ (CAR X) (QUOTE FILECREATED)) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (EQ (CADR X) (QUOTE DONTCOPY)) (LISTP (CADDR X)) (OR (FMEMB (QUOTE COPYRIGHT) (CADDR X)) (FMEMB (QUOTE FILEMAP) (CADDR X))))))) ) ) (DEFINEQ (\CS.ISVARFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL))) (\CS.COMPARE.VARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compares two variable setting forms") (COND ((EQ (CAR X) (CAR Y)) (* ; "Same type of setting fn") (COMPARELISTS (CADDR X) (CADDR Y) STREAM)) (T (LET ((XVAL (COND ((EQ (CAR X) (QUOTE RPAQQ)) (KWOTE (CADDR X))) (T (CADDR X)))) (YVAL (COND ((EQ (CAR Y) (QUOTE RPAQQ)) (KWOTE (CADDR Y))) (T (CADDR Y))))) (COND ((EQUAL XVAL YVAL) (* ; "Same value, different setter") (printout STREAM (COND ((EQ (CAR X) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) " -> " (COND ((EQ (CAR Y) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) T)) (T (COMPARELISTS XVAL YVAL STREAM))))))) ) (\CS.ISMACROFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:19") (SELECTQ (CAR X) (DEFMACRO T) (PUTPROPS (FMEMB (CADDR X) MACROPROPS)) NIL)) ) (\CS.ISRECFORM (LAMBDA (X) (* bvm%: "25-Sep-85 12:20") (FMEMB (CAR X) CLISPRECORDTYPES))) (\CS.ISCOURIERFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:21") (EQ (CAR X) (QUOTE COURIERPROGRAM)))) (\CS.ISTEMPLATEFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:20") (EQ (CAR X) (QUOTE SETTEMPLATE)))) (\CS.COMPARE.TEMPLATES (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Templates usually look like (SETTEMPLATE (QUOTE FN) (QUOTE TEMPLATE))") (COND ((AND (EQUAL (CADR X) (CADR Y)) (EQ (CAR (CADDR X)) (QUOTE QUOTE)) (EQ (CAR (CADDR Y)) (QUOTE QUOTE))) (COMPARELISTS (CADR (CADDR X)) (CADR (CADDR Y)) STREAM)) (T (COMPARELISTS X Y STREAM)))) ) (\CS.ISPROPFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:34") (* ;;; "(PUTPROPS SYMBOL PROP VALUE)") (AND (EQ (CAR X) (QUOTE PUTPROPS)) (NULL (CDDDDR X)))) ) (\CS.PROP.NAME (LAMBDA (X) (* bvm%: "13-Mar-86 16:29") (* ;;; "The 'Name' of a property is its atom/value pair") (LIST (CADR X) (CADDR X))) ) (\CS.COMPARE.PROPS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compare the values") (COMPARELISTS (CADDDR X) (CADDDR Y) STREAM)) ) (\CS.ISADDVARFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:40") (EQ (CAR X) (QUOTE ADDTOVAR)))) (\CS.COMPARE.ADDVARS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "(ADDTOVAR ListName . values)") (COMPARELISTS (CDDR X) (CDDR Y) STREAM)) ) (\CS.ISFPKGCOMFORM (LAMBDA (X) (* bvm%: "13-Mar-86 16:50") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (AND (EQ (CAR X) (QUOTE PUTDEF)) (EQUAL (CADDR X) (QUOTE (QUOTE FILEPKGCOMS))))) ) (\CS.COMPARE.FPKGCOMS (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM)) ) ) (RPAQQ COMPARESOURCETYPES ((VARS \CS.ISVARFORM \CS.COMPARE.VARS) (MACROS \CS.ISMACROFORM) (RECORDS \CS.ISRECFORM) (PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties") (ADDVARS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS CADR "Additions to lists") (TEMPLATES \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES CADADR) (COURIERPROGRAMS \CS.ISCOURIERFORM) (FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR))) (RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD CSTYPE (FPKGTYPE PREDFN COMPAREFN IDFN TITLE)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS) ) ) (PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1166 16557 (COMPARESOURCES 1176 . 5134) (\CS.COMPARE.MASTERS 5136 . 13057) ( \CS.COMPARE.TYPES 13059 . 14308) (\CS.SORT.DECLARES 14310 . 14653) (\CS.SORT.DECLARE1 14655 . 16075) ( \CS.FILTER.GARBAGE 16077 . 16555)) (16558 19286 (\CS.ISVARFORM 16568 . 16673) (\CS.COMPARE.VARS 16675 . 17337) (\CS.ISMACROFORM 17339 . 17477) (\CS.ISRECFORM 17479 . 17572) (\CS.ISCOURIERFORM 17574 . 17674) (\CS.ISTEMPLATEFORM 17676 . 17774) (\CS.COMPARE.TEMPLATES 17776 . 18141) (\CS.ISPROPFORM 18143 . 18298) (\CS.PROP.NAME 18300 . 18445) (\CS.COMPARE.PROPS 18447 . 18604) (\CS.ISADDVARFORM 18606 . 18699) (\CS.COMPARE.ADDVARS 18701 . 18866) (\CS.ISFPKGCOMFORM 18868 . 19075) (\CS.COMPARE.FPKGCOMS 19077 . 19284))))) STOP \ No newline at end of file diff --git a/lispusers/COMPARETEXT.LCOM.~2~ b/lispusers/COMPARETEXT.LCOM.~2~ deleted file mode 100644 index b04cd113ee82a1a437454bdaa25809161eff5420..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8347 zcmb7JZERcTbtbRuEcU8QauhGtJokiMGpdLfUVccF76iN`uf!`}^3vp0^kJu}tV^4e zXwjhLq~1ELE!JNfhAdbE3~LcIz>onOFiMVqHEuwx`?KuVFa(&44g0h1quqwd+x`u$ z_q^x5Brhq+YXqD3z2`medB4ti&c_XA^f{xTPtF;pK4}!@EV@$CwT!K$Oq~Ko!PZNr zQ7#7PN>NMawD~^b#BflIOJjtsXDASfPG%|_lQRiYr)R@6v*Boff`N_3?K`!4#i7PF z1?bl@<=n5oa;MqYtZeMQdb{G(EBB(I_^b8W&YinEmFCW?f`7eP*{yteH}osf2^tPW z)yakRZI(MTtA=M|i2yY#UAY_8_3c}gozKsbkxyIsqE^yFY0JdI>`+!KXG7`iVj)-d z^a?7~wjnyt3m~k3FfL7Vck6X3-`i>2-6b_LS!lc=rVWKc0dm%Nv57#Bszzob>TEO` zc=9>KXVu83-#0~P60sP$d!yY3wuj>`9NWed_dG$t*R)cZ++(rzWgE@%1l?&?-l#S1 z?(nXJ=zyA#yN!|>n~gZ62n20f>D|;X~k@)q|X~xfg;40Vy_f+ zQpqwiLWc@kUZ*e>^rg<*#02^N{EW|cCRsc0!=EM}qk$n~znR@{R5!D$w?qf`E>y?y zSKTzO^=LV!rP5CA=-qbxlC$mqpZYsYYklD$__P??ZiwG6i60iz=H@x^-e!i+h-T{* zW|IqOyX%odU7EYNK3a{%R7ZS4H8Ddlq+-b+H4z~^3o1+`+-Xg9Y4I*C)}=*eJeupO zvKooeyl%TEs;Y^u{P46Zbw;JMi8)~qHpQm|yEt05@o4|68YO@L-vdo`o6u?%JyOCF z`mH5W!(v%Nq)Ujagv*<^vlQ*LFbo*!rSWtjetR_G&;=hW81k&r< zzr0H~YugUpXzW(es#kVq(K|CufnvR~zEh!{JC%*v&3m*?Z-TG!Cf#f_X}4NoW^!sb zZ&sR>?TrfEYOdd@!XSHAk+PNxRz~k?qe|}5p>3c~&>Zxx$8Kt6JH!L#pq&GBsmF3W z)N|6O_>|)Qb4AvY;Nda{#m2Sj0O)}S>VU2Ax&g}$bFI{sio4!!Z0TF`KlxS z>;5cDdELKtw0}9Th{toLq9}PqxzxswAMM(uc22q0`fb=&Bq3Cr5nWZMJvWwt-!iq8 zkkI;2#+aMaOL`%#hxihq$#D;FUN6n-p~XVlDiq*0^i0QR%y^CObgl?xN;$T&!^sYOTGanlZkm&I&7Bg_eq4G*TWtk!A!K1PNhauuUg_E3S z-;tigFwJnTl}g&m#Bjkd2UPR~Kitt*)#C`l#L6txZylPTjE0pY?%B^a#6Jwd49Ck( zQt`8n;0Z4O;mT5K-Csad(JA@6Qo=i_4}S;&CrB; zjDG!GniV6(I&$=0>fju|w>~Ec@5s03-2QL!>u<7aXARdxU8H|vVCd3fj!5eqzgxHgipMn+2`*4WU& z(AW2TU$vgUa9!^s{XIypC$rWwo8whyDRBEI!#~4dIBsf2VUU*Zt(#jlr|NY6L=4pV zb37ZVRlD%Ib_L5){A+aZx^=}-{Cpr5h<@H}{WC1odd9jqZjtlB+3I+;x1zPnZEO7C zvURySzBa!0eA^mR*2db_MQh}fwTtb&$5*V&FRqQZTR*g}j4zCT*m~E$c4gtBvPSKb z=i3qRhVw&B#%ta_RHRS<58KLNfkY-zXip67y_0zd8 zz_6#hgQD^1se_`ism>r+dO2$?NjDOiO3-!THqsG_OhtQbz;~C9s7{!pyS51Yy608J zQUNALVZIa1A>fmQB_o5tN>$_i@8N_C3|c0GV5~?p2+9`Sh>QuqHaXc6O~(-Y7t)$d zQxKcA7R?L{Ndy;O*N`_d8BFMYzo*&AZZT4BxSns;m%7`UEir9kGpY?`ocsJ0EgiC4I979cF0OC zAQ0$6Ul?JrsSEe?DsmG4=!lOoWb}n0W9Z;ac0@WVww=|3^V$3VX(%hLf8m(sffj>d~B4f(Mvd9u}qteGnVi{)B zzwhQw_47yje=22lM%EQ~=oj6gzayA_$#4aHZD4|g&Kj=p2;YBrHt~@hz2|$M)uG+` z6Ri3VIs@L_^SvdOcmEx+xchHCd1+18NA2r!o^QA-!&%?YvX~T$dBwyW_otpDtR)js z8Lu6d07{6%1V;q;D4$ZIicHr{ZiSAE)YJQl`Mj?X;(Y~BbSIeMoVpX|0YklvU7?&n z$31<*JdqYNibZ47WX=IU0eU6TK;|zV49LK?DG71{^FdY->@gdhNE&gb%FqYEC*3j` z0TaNn&z~ova_?Z=P4mCBAUxBgom@ed^#<_y;=Vxcs_x2Cg* z6jX|I3ON*)q!ZG*Q}WTyN>xfh=#o~-ltXjoybSL>`GHvO8;VHt$e;X9btLIu7E$SU zla8|geB0Q6)=<8U+|F;{Kdav#CY2k$*55+ugx;YGzlY$&Q~VcffVSX&zG76>gH_n-$lz+SJoVtpY=6?9)mZGu zPjyiuB2w{g<;1O#MNsbP2M85#-!00DGN&xc0)u5sWC^kr6%lNwk}B#=J?Wj|qNu>~ zp)*2pr59ex9ghgSGhCnnTmoRLS3*^%69WWzhklOOzz}#mH!T*E!sTWVw4<`zormIa z`pTIh(JQ>b=e`2}D;F5WhYs)TBHs4A3$LS!xI4{XVQSmA@CoAX_SOyu%&1f%&R%KU zrQ3IRc4?w8@| z!jT9(N+LNKN{*^S*%hQEsHU#^rLi6S+=72on4>I*JxF~!r{qvu1&HPpB4z~@Z z^_PH0=)|I1QspQ}AWIi5gGKmJdqsTdfqmG=zAX(0OGWMK)j>K+Vn~5aIAMHl(qGfe zq>zB5iufa9nS!RJWdvNz(S0`!L@Tb{pN2>?+BLZgL=_&ok_IsS~gk6J)H|^P?+;UJb!*&*Ru1AP` zhdbOzP;8fr3L&!WtX|?il#f9ctZN+*aoLC0D2zioHkUX~3gTOA+FFEx1BYY-Qq2qm zp`h(KS>7UybvOvn5a`(VxfwcCTq!XK1_R5LX5-70ZZz*Sn(Mo@#x_0y;xo7SiQ@<9 MBYqMPFACKE2kZMEDLEY>DICTTOOL.;14 91631 changes to%: (FNS Dict.AddCommands) (VARS DICTTOOLCOMS) previous date%: "28-Feb-89 10:54:26" {ERINYES}MEDLEY>DICTTOOL.;13) (* " Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DICTTOOLCOMS) (RPAQQ DICTTOOLCOMS ((COMS * DICTTOOLDEPENDENCIES) (FILES ANALYZER (FROM {PIGLET/N}DICTSERVER>LISP>) DICTCLIENT) (* ;; "1/6/89 jtm: fixed TEdit.PrintDefinition so that SimpleDicts would print their entries in the definition window.") (* ;; "1/6/89 jtm: changed TEdit.SetDictionary and DictForStream so that TEdit.DefaultDictionary reflects the default dictionary to use if no other is specified.") (* ;; "2/28/89 jtm: changed FILES so that DICTCLIENT is loaded from PIGLET.") (* ;;  "5/31/89 jtm: changed Dict.AddCommands to put Dictionary menu item on Lafite display windows.") (FNS TEDIT.INCLUDESTREAM TEdit.PrintDefinition DictTool.PrintDefinition Dict.PrintDefinition DictTool.GetEntry TEdit.SetDictionary DictForStream DictTool.Dictionaries PARSEBYCOLONS PrintPronunciationGuide ConvertPronunciation) (FNS TEdit.PrintSearch DictTool.PrintSearch DictTool.MergeSearch NerdForStream TEdit.SetNerd DictTool.PromptForCutoff DictTool.PromptForKeywordCutoff PARSESELECTION) (FNS TEdit.PrintPhraseSearch DictTool.PrintPhraseSearch) (FNS TEdit.PrintSynonyms REMOVEALL CONVERTFUNCTIONSTOFORMS TEdit.PrintNounSynonyms DictTool.PrintNounSynonyms DictTool.PrintVerbSynonyms DictTool.PrintAdjSynonyms TEdit.PrintVerbSynonyms TEdit.PrintAdjSynonyms DictTool.PrintSynonyms) (FNS DictTool.TEditWrapper Dict.OutputStream DictTool.PromptStream) (FNS DictTool.Init DictTool.Open DictTool.OpenDictionary DictTool.OpenAnalyzer DictTool.OpenNerd Dict.AddCommands DictTool.Close) (FNS DictTool.Analyze DictTool.Analyzers DictTool.Pronunciation DictTool.Corrections DictTool.CountWords) (COMS (* * FINDWORD & SUBSTITUTEWORD) (FNS DictTool.FindWord DictTool.SubstituteWord DictTool.CreateConjugationMap DictTool.FindWordInit) (FNS LingFns.FindWord LingFns.Capitalize LingFns.Capitalization) (P (DictTool.FindWordInit))) (INITVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary (DictTool.MinKeywords 2) (DictTool.MaxWords 100)) (GLOBALVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.MinKeywords DictTool.MaxWords DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary) (P (DictTool.Init)) (VARS PronunciationGuide PronunciationMap))) (RPAQQ DICTTOOLDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'DICTTOOL 'DEPENDENCIES (for FILE in (FILECOMSLST 'DICTTOOL 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES DICTTOOL) (P (for FILE FILEDATE in (GETPROP 'DICTTOOL 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (printout T "Flushing old version of " (CAR FILE) T) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS DICTTOOL DEPENDENCIES ((ANALYZER . " 9-Mar-89 15:24:58") (DICTCLIENT . " 8-Oct-87 15:15:08"))) [for FILE FILEDATE in (GETPROP 'DICTTOOL 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force  FILESLOAD to reload the file.) (printout T "Flushing old version of " (CAR FILE) T) (PUTPROP (CAR FILE) 'FILEDATES NIL] (FILESLOAD ANALYZER (FROM {PIGLET/N}DICTSERVER>LISP>) DICTCLIENT) (* ;; "1/6/89 jtm: fixed TEdit.PrintDefinition so that SimpleDicts would print their entries in the definition window." ) (* ;; "1/6/89 jtm: changed TEdit.SetDictionary and DictForStream so that TEdit.DefaultDictionary reflects the default dictionary to use if no other is specified." ) (* ;; "2/28/89 jtm: changed FILES so that DICTCLIENT is loaded from PIGLET.") (* ;; "5/31/89 jtm: changed Dict.AddCommands to put Dictionary menu item on Lafite display windows." ) (DEFINEQ (TEDIT.INCLUDESTREAM [LAMBDA (TEXTSTREAM INCLUDEDSTREAM) (* jtm%: "28-Oct-87 14:41") (LET (STARTPOS) (SETQ STARTPOS (ADD1 (GETEOFPTR TEXTSTREAM))) (TEDIT.COPY (TEDIT.SETSEL INCLUDEDSTREAM 1 (GETEOFPTR INCLUDEDSTREAM) 'LEFT) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'LEFT)) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'LEFT) (TEDIT.NORMALIZECARET TEXTSTREAM) (TEDIT.STREAMCHANGEDP TEXTSTREAM T]) (TEdit.PrintDefinition [LAMBDA (stream dict words) (* ; "Edited 6-Jan-89 11:46 by jtm:") (* * prints out the definition of the currently selected text.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (OR dict (DictForStream stream)) [FUNCTION (LAMBDA (dict selection stream) (LET (printFn entry) (for word exists in (PARSEBYCOLONS selection) do [COND ((AND (SETQ printFn (fetch (Dict printEntryFn) of dict)) (NEQ printFn 'NILL)) (SETQ exists (OR (APPLY* printFn dict word stream) exists))) ((SETQ printFn (fetch (Dict getEntryFn) of dict)) (SETQ entry (APPLY* printFn dict word NIL)) [for def (left _ (LENGTH entry)) inside entry first (TEDIT.INSERT stream (CONCAT word ": ")) do [COND ((STREAMP def) (SETQ def (STREAM.FETCHSTRING def 0 (GETEOFPTR def] (TEDIT.INSERT stream def) (add left -1) (COND ((IGEQ left 1) (TEDIT.INSERT stream ", ")) (T (TEDIT.INSERT stream " "] (SETQ exists (OR entry exists] finally (RETURN exists] stream words "word to look up:" "Getting definition for"]) (DictTool.PrintDefinition [LAMBDA (dict words stream) (* jtm%: "17-Nov-87 11:02") (PROG (def looks found pos (offset 0)) [for word inside (PARSEBYCOLONS words) do (SETQ def (Dict.GetEntry dict word)) (SETQ looks (Dict.Prop dict 'Looks)) (COND ((AND (NULL looks) (Dict.Prop dict 'RemoteDict)) [SETQ looks (DICTCLIENT.GETLOOKS (Dict.Prop dict 'RemoteDict] (Dict.Prop dict 'Looks looks))) (COND [(STRINGP def) (SETQ found T) (TEDIT.INSERT stream def) (for I from 1 to 2 when (NEQ 13 (NTHCHARCODE def (IMINUS I))) do (TEDIT.INSERT stream (CHARACTER 13] ([AND (STRINGP (CAR def)) (NOT (STREQUAL "" (CAR def] (SETQ found T) (TEDIT.INSERT stream (CAR def) NIL (CDAR looks)) (for I from 1 to 2 when (NEQ 13 (NTHCHARCODE def (IMINUS I))) do (TEDIT.INSERT stream (CHARACTER 13))) (* assumes that the first look given  is the default for the dictionary.) (SETQ pos (TEDIT.GETPOINT stream)) (* setting looks moves the selection) (for i in (CDR def) do (TEDIT.LOOKS stream (CDR (FASSOC (CADDR i) looks)) (IPLUS (CAR i) offset) (CADR i))) (SETQ offset (SUB1 pos)) (TEDIT.SETSEL stream pos 0 'LEFT)) (NIL (TEDIT.INSERT stream (CONCAT word ": not found.")) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) 1 (ADD1 (NCHARS word))) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) (IPLUS 2 (NCHARS word)) 11] (RETURN found]) (Dict.PrintDefinition [LAMBDA (dict word stream) (* jtm%: "13-Oct-87 10:27") (PROG (scratch start) [COND ((NULL stream) (SETQ stream (Dict.OutputStream] [SETQ scratch (OPENTEXTSTREAM NIL NIL NIL NIL '(LEAVETTY] (COND ((Dict.PrintEntry dict word scratch) (TEDIT.INSERT scratch (CONCAT (CHARACTER 13) (CHARACTER 13)) (ADD1 (GETEOFPTR scratch))) (SETQ start (ADD1 (GETEOFPTR stream))) (TEDIT.COPY (TEDIT.SETSEL scratch 1 (GETEOFPTR scratch) 'LEFT) (TEDIT.SETSEL stream start 0 'LEFT)) (CLOSEF scratch) (TEDIT.SETSEL stream start 0 'RIGHT) (TEDIT.NORMALIZECARET stream) (TEDIT.STREAMCHANGEDP stream T) (RETURN T]) (DictTool.GetEntry [LAMBDA (dict uniqueID prop) (* jtm%: " 7-Apr-87 08:39") (COND [(NUMBERP uniqueID) (DICTCLIENT.ENUMERATE uniqueID (Dict.Prop dict 'RemoteDict] (T (DICTCLIENT.GETDEFINITION uniqueID (Dict.Prop dict 'RemoteDict]) (TEdit.SetDictionary [LAMBDA (stream dict) (* ; "Edited 6-Jan-89 12:24 by jtm:") (* * sets the dictionary property for the window) (PROG (menuItems) (OR stream (SETQ stream (Dict.OutputStream))) [COND ((NULL dict) [SETQ menuItems (for i in Dict.DictionaryList collect (LIST (Dict.Name i) (LIST 'QUOTE i) (if (Dict.Prop i 'RemoteDict) then "Calls the remote dictionary server"] [COND ((NULL menuItems) (TEDIT.PROMPTPRINT stream "Sorry, no dictionaries loaded." T)) ((EQ 1 (LENGTH menuItems)) (SETQ dict (CAR Dict.DictionaryList))) (T (SETQ dict (MENU (create MENU ITEMS _ menuItems TITLE _ "dictionaries" CENTERFLG _ T] (COND ((NULL dict) (SETQ dict (STREAMPROP stream 'dict)) (TEDIT.PROMPTPRINT stream (CONCAT "Dictionary is " (AND dict (Dict.Name dict)) ".") T) (RETURN] (TEDIT.PROMPTPRINT stream (CONCAT "Setting dictionary to " (AND dict (Dict.Name dict)) "...") T) (Dict.Open dict) (STREAMPROP stream 'dict dict) (* ;; "1/6/89 jtm: set TEdit.DefaultDictionary if this is the dictionary window or if it hasn't already been set.") (if [OR (NULL TEdit.DefaultDictionary) (AND (WINDOWP Dict.DefWindow) (EQ stream (WINDOWPROP Dict.DefWindow 'TEXTSTREAM] then (SETQ TEdit.DefaultDictionary dict)) (TEDIT.PROMPTPRINT stream "done.")) dict]) (DictForStream [LAMBDA (stream) (* ; "Edited 6-Jan-89 12:26 by jtm:") (* ;; "1/6/89 jtm: Try TEdit.DefaultDictionary if the stream doesn't have it's own dictionary.") (COND ((STREAMPROP stream 'dict)) (TEdit.DefaultDictionary) (T (TEdit.SetDictionary (Dict.OutputStream]) (DictTool.Dictionaries [LAMBDA (dict errorStream) (* jtm%: "13-Nov-86 10:57") (DICTCLIENT.DICTIONARIES]) (PARSEBYCOLONS [LAMBDA (STRING COLONSORSPACES) (* ; "Edited 11-Jan-89 13:55 by jtm:") (* * Actually, parse by SEMI-colons.) (LET (WORDS SEPARATOR (OLDPOS 1) (POS 0)) (COND ((STRINGP STRING) (SETQ SEPARATOR (COND ([AND COLONSORSPACES (NULL (STRPOS ";" STRING (ADD1 POS] " ") (T ";"))) [while (SETQ POS (STRPOS SEPARATOR STRING (ADD1 POS))) do (push WORDS (SUBSTRING STRING OLDPOS (SUB1 POS))) (SETQ OLDPOS (for I from (ADD1 POS) thereis (NEQ 32 (NTHCHARCODE STRING I] [COND ((AND (NEQ OLDPOS 0) (ILEQ OLDPOS (NCHARS STRING))) (push WORDS (SUBSTRING STRING OLDPOS (NCHARS STRING] (OR (DREVERSE WORDS) STRING)) (T STRING]) (PrintPronunciationGuide [LAMBDA (stream) (* jtm%: " 9-Feb-87 08:40") (LET (startPos) (SETQ startPos (GETFILEPTR stream)) [for i pronCode on PronunciationGuide do (SETQ pronCode (CAR i)) (TEDIT.INSERT stream (CONCAT (ConvertPronunciation (CAR pronCode)) ": " (CADR pronCode) " " (ConvertPronunciation (CADDR pronCode)) (COND ((CDR i) "; ") (T ""] (TEDIT.LOOKS stream '(FAMILY CLASSIC SIZE 10 FACE STANDARD) (ADD1 startPos) (IDIFFERENCE (GETFILEPTR stream) startPos]) (ConvertPronunciation [LAMBDA (string) (* jtm%: " 6-Feb-87 17:38") (CONCATLIST (for i char nschars from 1 to (NCHARS string) join (SETQ char (NTHCHAR string i)) (SETQ nschars (CDR (FASSOC char PronunciationMap))) (COND ((NULL nschars) (LIST char)) ((LISTP nschars) (COPY nschars)) (T (LIST nschars]) ) (DEFINEQ (TEdit.PrintSearch [LAMBDA (stream dict words) (* jtm%: "13-Oct-87 10:11") (* * prints out the definition of the currently selected text.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (OR dict (NerdForStream stream)) 'DictTool.PrintSearch stream words "Type keywords to search on:" "Searching for words using" 'SEARCHKEYS]) (DictTool.PrintSearch [LAMBDA (dict selection stream) (* jtm%: " 7-Apr-87 09:52") (LET (looks venn) (SETQ venn (DictTool.MergeSearch dict selection)) [for i pos in venn do (* printout header) (SETQ pos (TEDIT.GETPOINT stream)) [for header on (CAR i) do (TEDIT.INSERT stream (CONCAT (CAR header) (COND ((CDR header) " ") (T ": "] (push looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) pos))) [for word on (CADR i) do (TEDIT.INSERT stream (CONCAT (CAR word) (COND ((CDR word) "; ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (TEDIT.INSERT stream (CHARACTER (CHARCODE CR] (* do the looks last to avoid messing  up the text placement.) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) 1 (TEDIT.GETPOINT stream)) (for look in looks do (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) (CAR look) (CDR look))) venn]) (DictTool.MergeSearch [LAMBDA (dict synonymclasses minKeywords minWord maxWord) (* jtm%: " 2-Aug-88 13:15") (LET (minWord maxWord VennSearchFn) [for i on synonymclasses do (COND ((NLISTP (CAR i)) (RPLACA i (LIST (CAR i] [COND ((AND (NULL minWord) (NULL maxWord)) (COND ((AND (EQUAL synonymclasses DictTool.LastSearch) (NEQ 0 DictTool.MaxWords)) (COND ((NULL DictTool.LastWord) (SETQ DictTool.LastWord 0))) (SETQ minWord (ADD1 DictTool.LastWord)) [SETQ maxWord (COND ((EQ 0 DictTool.MaxWords) 0) (T (IPLUS DictTool.MaxWords DictTool.LastWord] (SETQ DictTool.LastWord maxWord)) (T (SETQ minWord 0) (SETQ maxWord DictTool.MaxWords) (SETQ DictTool.LastSearch synonymclasses) (SETQ DictTool.LastWord maxWord] (COND [(InvertedDict.Prop dict 'RemoteDict) (DICTCLIENT.SEARCHFORWORD synonymclasses DictTool.MinKeywords (OR minWord 0) (OR maxWord DictTool.MaxWords) (InvertedDict.Prop dict 'RemoteDict] ((SETQ VennSearchFn (InvertedDict.Prop dict 'VENNSEARCHFN)) (APPLY* VennSearchFn dict synonymclasses DictTool.MinKeywords (OR minWord 0) (OR maxWord DictTool.MaxWords))) (T (InvertedDict.MergeSearch dict synonymclasses DictTool.MinKeywords (OR minWord 0) (OR maxWord DictTool.MaxWords]) (NerdForStream [LAMBDA (stream) (* jtm%: "17-Nov-87 11:14") (* * comment) (COND ((STREAMPROP stream 'nerd)) ((STREAMPROP (Dict.OutputStream) 'nerd)) (T (TEdit.SetNerd (Dict.OutputStream]) (TEdit.SetNerd [LAMBDA (stream nerd) (* jtm%: "14-Oct-87 12:50") (* * sets the dictionary property for the window) (PROG (menuItems) (OR stream (SETQ stream (Dict.OutputStream))) [COND ((NULL nerd) [SETQ menuItems (for i in InvertedDict.List collect (LIST (InvertedDict.Name i) (LIST 'QUOTE i) (if (InvertedDict.Prop i 'RemoteDict) then "Calls the remote dictionary server"] [COND ((NULL menuItems)) ((EQ 1 (LENGTH menuItems)) (SETQ nerd (CAR InvertedDict.List))) (T (SETQ nerd (MENU (create MENU ITEMS _ menuItems TITLE _ "databases" CENTERFLG _ T] (COND ((NULL nerd) (SETQ nerd (STREAMPROP stream 'nerd)) (TEDIT.PROMPTPRINT stream (CONCAT "Database is " (AND nerd (InvertedDict.Name nerd)) ".") T) (RETURN] (TEDIT.PROMPTPRINT stream (CONCAT "Setting database to " (AND nerd (InvertedDict.Name nerd)) "...") T) (InvertedDict.Open nerd) (STREAMPROP stream 'nerd nerd) (TEDIT.PROMPTPRINT stream "done.") (SETQ DictTool.LastSearch NIL) (* so that you can do the same search  on a different data base.) ) nerd]) (DictTool.PromptForCutoff [LAMBDA (STREAM) (* jtm%: " 2-Feb-87 11:33") (OR STREAM (SETQ STREAM (Dict.OutputStream))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Current maximum = " DictTool.MaxWords ".") T) (SETQ DictTool.MaxWords (RNUMBER "Enter the maximum number of words that each combination of keywords may return. (0 = no limit)" )) (TEDIT.PROMPTPRINT STREAM (CONCAT "New maximum = " DictTool.MaxWords ".") T]) (DictTool.PromptForKeywordCutoff [LAMBDA (STREAM) (* jtm%: " 2-Feb-87 11:33") (OR STREAM (SETQ STREAM (Dict.OutputStream))) (TEDIT.PROMPTPRINT STREAM (CONCAT "Current minimum = " DictTool.MinKeywords ".") T) (SETQ DictTool.MinKeywords (RNUMBER "Enter the minimum number of keywords that a word must have to be accepted. e.g. 2 = at least two keywords, 0 = all of the keywords given, -2 = all but two of the keywords given, etc." )) (TEDIT.PROMPTPRINT STREAM (CONCAT "New minimum = " DictTool.MinKeywords ".") T]) (PARSESELECTION [LAMBDA (selection) (* jtm%: "20-Mar-87 14:39") (LET (words temp) [for i charcode startPos alpha priorAlpha word from 1 to (ADD1 (NCHARS selection)) do (SETQ charcode (NTHCHARCODE selection i)) (SETQ priorAlpha alpha) [SETQ alpha (AND charcode (OR (ALPHACHARP charcode) (EQ charcode (CHARCODE -] [COND ((AND alpha (NULL priorAlpha)) (SETQ startPos i)) ((AND priorAlpha (NULL alpha)) (SETQ word (SUBSTRING selection startPos (SUB1 i))) (COND ((NULL temp) (push temp word)) (T (NCONC1 temp word] (COND ((EQ charcode (CHARCODE %()) (SETQ words (APPEND words temp)) (SETQ temp NIL)) ((EQ charcode (CHARCODE %))) (SETQ words (APPEND words (LIST temp))) (SETQ temp NIL] (SETQ words (APPEND words temp)) words]) ) (DEFINEQ (TEdit.PrintPhraseSearch [LAMBDA (stream dict words) (* jtm%: "26-May-87 09:26") (* * prints out the definitions that have a particular phrase in them.) (OR stream (SETQ stream (Dict.OutputStream))) (DictTool.TEditWrapper (NerdForStream stream) 'DictTool.PrintPhraseSearch stream words "Type phrase to search for:" "Searching for phrase using" 'SEARCHPHRASE]) (DictTool.PrintPhraseSearch [LAMBDA (dict selection stream) (* jtm%: "26-May-87 09:29") (LET (looks words fn pos) [SETQ words (COND [(InvertedDict.Prop dict 'RemoteDict) (DICTCLIENT.SEARCHFORPHRASE selection (InvertedDict.Prop dict 'RemoteDict] ((SETQ fn (InvertedDict.Prop dict 'SEARCHFORPHRASEFN)) (APPLY* fn dict selection] (SETQ pos (TEDIT.GETPOINT stream)) (TEDIT.INSERT stream (CONCAT "%"" selection "%": ")) (SETQ looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) pos))) [for word on words do (TEDIT.INSERT stream (CONCAT (CAR word) (COND ((CDR word) "; ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (* do the looks last to avoid messing  up the text placement.) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) 1 (TEDIT.GETPOINT stream)) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) (CAR looks) (CDR looks)) words]) ) (DEFINEQ (TEdit.PrintSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T 'DictTool.PrintSynonyms stream words "synonym to look up:" "Getting synonyms for" 'USERSYNONYM]) (REMOVEALL [LAMBDA (X L) (* jtm%: "14-Oct-87 12:39") (for TAIL on X unless (EQUAL L (CAR TAIL)) collect (COND ((LISTP (CAR TAIL)) (REMOVEALL (CAR TAIL) L)) (T (COPY (CAR TAIL]) (CONVERTFUNCTIONSTOFORMS [LAMBDA (LIST) (* jtm%: "14-Oct-87 12:57") (for ELT in LIST collect (COND [(EQ (CAR ELT) 'FUNCTION) (LIST 'QUOTE (LIST (CADR ELT] ((LISTP ELT) (CONVERTFUNCTIONSTOFORMS ELT)) (T (COPY ELT]) (TEdit.PrintNounSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:43") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T (FUNCTION DictTool.PrintNounSynonyms) stream words "synonym to look up:" "Getting noun synonyms for" 'USERSYNONYM]) (DictTool.PrintNounSynonyms [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:32") (DictTool.PrintSynonyms dict words stream "n"]) (DictTool.PrintVerbSynonyms [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:34") (DictTool.PrintSynonyms dict words stream "v"]) (DictTool.PrintAdjSynonyms [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:35") (DictTool.PrintSynonyms dict words stream "adj"]) (TEdit.PrintVerbSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T 'DictTool.PrintVerbSynonyms stream words "synonym to look up:" "Getting verb synonyms for" 'USERSYNONYM]) (TEdit.PrintAdjSynonyms [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") (* * prints out the synonyms of the selected word) (DictTool.TEditWrapper T 'DictTool.PrintAdjSynonyms stream words "synonym to look up:" "Getting adjective synonyms for" 'USERSYNONYM]) (DictTool.PrintSynonyms [LAMBDA (dict words stream form) (* jtm%: "14-Oct-87 12:31") (PROG (synonyms found startPos headerPos endPos) (for word inside words do (SETQ synonyms (DICTCLIENT.SYNONYMS word)) (AND synonyms (SETQ found T)) (SETQ startPos (TEDIT.GETPOINT stream)) (TEDIT.INSERT stream (CONCAT word ": ")) (SETQ headerPos (TEDIT.GETPOINT stream)) [for class in synonyms when (OR (NULL form) (EQUAL form (CAR class))) do (TEDIT.INSERT stream (CONCAT (CAR class) ": ")) [for word on (CDR class) do (TEDIT.INSERT stream (CONCAT (CAR word) (COND ((CDR word) ", ") (T ""] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR] (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (SETQ endPos (TEDIT.GETPOINT stream)) (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) startPos (IDIFFERENCE (SUB1 headerPos) startPos)) (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) headerPos (IDIFFERENCE endPos headerPos)) (TEDIT.SETSEL stream endPos 0 'LEFT)) (RETURN found]) ) (DEFINEQ (DictTool.TEditWrapper [LAMBDA (dict proc stream selection promptString waitString cachePropName) (* jtm%: "29-Jun-88 09:56") (* * handles the TEdit user interface) (PROG (scratchStream textStream startPos startTime textObj) (* * set things up) [COND ((NULL stream) (SETQ stream (Dict.OutputStream] [COND ((NULL dict) (TEDIT.PROMPTPRINT stream "Please select a dictionary." T) (RETURN)) ((NULL selection) (SETQ selection (TEDIT.SEL.AS.STRING stream)) (COND ((ILEQ (NCHARS selection) 1) (SETQ selection NIL))) (* * "rht 4/27/88: No longer passes value of PROMPTWINDOW textprop to MOUSECONFIRM since it could be DON'T. Now looks for promptwindow on the WINDOWPROP of the stream's main window.") (COND [(AND selection (MOUSECONFIRM (CONCAT "CONFIRM INPUT: " selection) "" (CAR (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ stream))) 'PROMPTWINDOW] ([NULL (SETQ selection (TEDIT.GETINPUT stream (OR promptString "input: ") (AND cachePropName (STREAMPROP stream cachePropName] (TEDIT.PROMPTPRINT stream " Aborted." T) (RETURN] (* * print the results.) (SETQ startTime (CLOCK 0)) (AND cachePropName (STREAMPROP stream cachePropName selection)) (TEDIT.PROMPTPRINT stream (CONCAT (OR waitString "processing") " '" selection "' . . . ") T) [RESETSAVE (OUTPUT (CAR (WINDOWPROP Dict.DefWindow 'PROMPTWINDOW] (* redirects errors to the  promptwindow) [SETQ scratchStream (OPENTEXTSTREAM NIL NIL NIL NIL '(LEAVETTY] (COND [(APPLY* proc dict selection scratchStream) (TEDIT.INCLUDESTREAM (Dict.OutputStream) scratchStream) (COND (DictTool.TimeOperation (TEDIT.PROMPTPRINT stream (CONCAT "Elapsed Time: " (QUOTIENT (DIFFERENCE (CLOCK 0) startTime) 1000.0) " seconds."))) (T (TEDIT.PROMPTPRINT stream "Done."] (T (TEDIT.PROMPTPRINT stream "not found.") (TEDIT.PROMPTFLASH stream))) (CLOSEF scratchStream]) (Dict.OutputStream [LAMBDA (REGION) (* ; "Edited 12-Oct-88 09:20 by rmk:") (* ; "Edited 7-Oct-88 12:01 by jtm:") (LET (TEXTSTREAM HIDDENFN UNHIDEFN) [COND ((AND Dict.DefWindow (NOT (OPENWP Dict.DefWindow)) (WINDOWPROP Dict.DefWindow 'TEXTSTREAM)) (* window is shrunk.) (OPENW Dict.DefWindow)) ((AND Dict.DefWindow (CL:FIND-PACKAGE "ROOMS") (SETQ HIDDENFN (CL:FIND-SYMBOL "WINDOW-HIDDEN?" "ROOMS")) (GETD HIDDENFN) (CL:FUNCALL HIDDENFN Dict.DefWindow)) (* the FIND-SYMBOL calls are used to avoid a break that happens when you access  the ROOMS package when it hasn't been loaded.) (SETQ UNHIDEFN (CL:FIND-SYMBOL "UN-HIDE-WINDOW" "ROOMS")) (CL:FUNCALL UNHIDEFN Dict.DefWindow)) ((OR (NULL Dict.DefWindow) (NOT (OPENWP Dict.DefWindow))) (SETQ Dict.DefWindow (CREATEW [OR REGION (AND Dict.DefWindow (WINDOWPROP Dict.DefWindow 'REGION] "Definitions")) (SETQ TEXTSTREAM (OPENTEXTSTREAM NIL Dict.DefWindow)) (replace TXTFILE of (TEXTOBJ TEXTSTREAM) with "Definitions") (* do the replace before you spawn a TEDIT process in order to avoid a race  condition where sometimes the label on the icon was "T") (PROCESSPROP (TEDIT TEXTSTREAM Dict.DefWindow NIL '(LEAVETTY)) 'NAME 'DICTIONARY] (TEXTSTREAM Dict.DefWindow]) (DictTool.PromptStream [LAMBDA (stream) (* jtm%: "29-Sep-86 11:11") (COND [(STREAMPROP stream) (for window inside (STREAMPROP stream 'WINDOW) do (COND ((WINDOWPROP window 'PROMPTWINDOW) (RETURN (WINDOWPROP window ' PROMPTWINDOW] (T PROMPTWINDOW]) ) (DEFINEQ (DictTool.Init [LAMBDA (serverName) (* jtm%: "13-Oct-87 11:37") (PROG (analyzer dict wordNerd) (* * start up the interface) (Dict.AddCommands) (* * create the analyzer) [Analyzer.Establish (SETQ analyzer (create Morphalyzer analyzerName _ 'DictServer openFn _ (FUNCTION DictTool.OpenAnalyzer) closeFn _ (FUNCTION DictTool.Close) analyzeFn _ (FUNCTION DictTool.Analyze) correctionsFn _ (FUNCTION DictTool.Corrections] (Analyzer.Prop analyzer 'CountWords (FUNCTION DictTool.CountWords)) (* * create the dictionary) [Dict.Establish (SETQ dict (create Dict dictName _ 'DictServer openFn _ (FUNCTION DictTool.OpenDictionary) closeFn _ (FUNCTION DictTool.Close) getEntryFn _ (FUNCTION DictTool.GetEntry) printEntryFn _ (FUNCTION DictTool.PrintDefinition] (* * create the remote inverted dict.) [InvertedDict.Establish (SETQ wordNerd (create INVERTEDDICT INVERTEDDICTNAME _ 'DictServer] (InvertedDict.Prop wordNerd 'OPENFN (FUNCTION DictTool.OpenNerd)) (InvertedDict.Prop wordNerd 'DICTIONARY dict]) (DictTool.Open [LAMBDA (analyzer errors) (* jtm%: "13-Oct-87 10:43") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (analyzers dictionaries menuItems) (COND [(type? Morphalyzer analyzer) (COND ((NULL (Analyzer.Prop analyzer 'RemoteDict)) (SETQ analyzers (DictTool.Analyzers analyzer errors)) [SETQ menuItems (for i in analyzers collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Analyzer.Prop analyzer 'RemoteDict (CAR analyzers))) (T (Analyzer.Prop analyzer 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) " analyzers") CENTERFLG _ T)) (CAR analyzers))) (for i analyzerName in analyzers do (SETQ analyzerName (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) ": " i))) (COND ([NOT (for j in Analyzer.List thereis (EQ analyzerName ( Analyzer.Name j] (push Analyzer.List (create Morphalyzer copying analyzer)) (Analyzer.Prop (CAR Analyzer.List) 'RemoteDict i] ((type? Dict analyzer) (COND ((NULL (Dict.Prop analyzer 'RemoteDict)) (SETQ dictionaries (DictTool.Dictionaries analyzer errors)) [SETQ menuItems (for i in dictionaries collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Dict.Prop analyzer 'RemoteDict (CAR dictionaries))) (T (Dict.Prop analyzer 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Dict dictName) of analyzer) " dictionaries") CENTERFLG _ T)) (CAR dictionaries))) (for i dictName in dictionaries do (SETQ dictName (MKATOM (CONCAT (fetch (Dict dictName) of analyzer) ": " i))) (COND ([NOT (for j in Dict.DictionaryList thereis (EQ dictName (Dict.Name j] (push Dict.DictionaryList (create Dict copying analyzer)) (Dict.Prop (CAR Dict.DictionaryList) 'RemoteDict i]) (DictTool.OpenDictionary [LAMBDA (dict errors) (* jtm%: "13-Oct-87 10:38") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (dictionaries menuItems) (COND ((type? Dict dict) (COND ((NULL (Dict.Prop dict 'RemoteDict)) (SETQ dictionaries (DICTCLIENT.DICTIONARIES)) [SETQ menuItems (for i in dictionaries collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Dict.Prop dict 'RemoteDict (CAR dictionaries))) (T (Dict.Prop dict 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Dict dictName) of dict) " dictionaries") CENTERFLG _ T)) (CAR dictionaries))) (for i dictName in dictionaries do (SETQ dictName (MKATOM (CONCAT (fetch (Dict dictName) of dict) ": " i))) (COND ([NOT (for j in Dict.DictionaryList thereis (EQ dictName (Dict.Name j] (push Dict.DictionaryList (create Dict copying dict)) (Dict.Prop (CAR Dict.DictionaryList) 'RemoteDict i]) (DictTool.OpenAnalyzer [LAMBDA (analyzer errors) (* jtm%: "13-Oct-87 10:43") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (analyzers menuItems) (COND ((type? Morphalyzer analyzer) (COND ((NULL (Analyzer.Prop analyzer 'RemoteDict)) (SETQ analyzers (DICTCLIENT.LANGUAGES)) [SETQ menuItems (for i in analyzers collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (Analyzer.Prop analyzer 'RemoteDict (CAR analyzers))) (T (Analyzer.Prop analyzer 'RemoteDict (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) " analyzers") CENTERFLG _ T)) (CAR analyzers))) (for i analyzerName in analyzers do (SETQ analyzerName (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) of analyzer) ": " i))) (COND ([NOT (for j in Analyzer.List thereis (EQ analyzerName ( Analyzer.Name j] (push Analyzer.List (create Morphalyzer copying analyzer)) (Analyzer.Prop (CAR Analyzer.List) 'RemoteDict i]) (DictTool.OpenNerd [LAMBDA (nerd errors) (* jtm%: "13-Oct-87 14:35") (* * we import the interface here instead of in DictTool.Init to avoid hanging  the LOAD.) (PROG (nerds menuItems dict remote) (COND ((type? INVERTEDDICT nerd) (COND ((NULL (InvertedDict.Prop nerd 'RemoteDict)) (SETQ nerds (DICTCLIENT.RESOURCES 'INDICES)) [SETQ menuItems (for i in nerds collect (LIST i (LIST 'QUOTE i] (COND ((IGEQ 1 (LENGTH menuItems)) (InvertedDict.Prop nerd 'RemoteDict (CAR nerds))) (T [InvertedDict.Prop nerd 'RemoteDict (SETQ remote (OR (MENU (create MENU ITEMS _ menuItems TITLE _ (CONCAT (fetch (INVERTEDDICT INVERTEDDICTNAME ) of nerd) " databases") CENTERFLG _ T)) (CAR nerds] (COND ((SETQ dict (InvertedDict.Prop nerd 'DICTIONARY)) (SETQ dict (COPYALL dict)) (Dict.Prop dict 'RemoteDict remote) (InvertedDict.Prop nerd 'DICTIONARY dict))) (for i in nerds do (COND ((NOT (InvertedDictFromName (fetch (INVERTEDDICT INVERTEDDICTNAME ) of nerd) i)) (push InvertedDict.List (create INVERTEDDICT copying nerd)) (InvertedDict.Prop (CAR InvertedDict.List) 'RemoteDict i) (COND ((SETQ dict (InvertedDict.Prop (CAR InvertedDict.List ) 'DICTIONARY)) (SETQ dict (COPYALL dict)) (Dict.Prop dict 'RemoteDict i) (InvertedDict.Prop (CAR InvertedDict.List) 'DICTIONARY dict]) (Dict.AddCommands [LAMBDA NIL (* ; "Edited 31-May-89 15:07 by jtm:") (* ; "Edited 31-May-89 15:06 by jtm:") (* ; "Edited 31-May-89 15:00 by jtm:") (* ; "Edited 31-May-89 13:36 by jtm:") (LET (menuItems) [SETQ menuItems '(Dictionary (FUNCTION TEdit.PrintDefinition) "Prints the definition of the selected word. Prompts the user for a word if there isn't a selection." (SUBITEMS (Set% Dictionary (FUNCTION TEdit.SetDictionary) "Gives the user a menu of dictionaries to select from." ) (Get% Definition (FUNCTION TEdit.PrintDefinition) "Prints the definition of the selected word. Prompts the user for a word if there isn't a selection." ) (Get% Synonyms (FUNCTION TEdit.PrintSynonyms) "Prints the synonyms of the selected word. Prompts the user for a word if there isn't a selection." (SUBITEMS (nouns (FUNCTION TEdit.PrintNounSynonyms) "Only prints the noun form synonyms." ) (verbs (FUNCTION TEdit.PrintVerbSynonyms) "Only prints the verb form synonyms.") (adjectives (FUNCTION TEdit.PrintAdjSynonyms) "Only prints the adjective form synonyms." ))) (|Search For Word| (FUNCTION TEdit.PrintSearch) "Prints the words in the dictionary containing at least two of the keywords in the selection. Prompts the user for keywords if there aren't any keywords selected." (SUBITEMS (Set% Database (FUNCTION TEdit.SetNerd) "Gives the user a menu of dictionaries to select from." ) (Max% Words (FUNCTION DictTool.PromptForCutoff) "Lets the user set the maximum number of words to be returned for a set of keywords." ) (Min% Keywords (FUNCTION DictTool.PromptForKeywordCutoff ) "Lets the user determine the minimum number of keywords needed by a word for it to accepted." ) (|Search For Phrase| (FUNCTION TEdit.PrintPhraseSearch) "Searches a dictionary for a particular phrase, using the Search For Word database to narrow the search. This can be an expensive operation, so please use it sparingly." ] (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU menuItems) (* ;; "add menu item to Lafite's display menu if Lafite has been loaded.") [COND ((BOUNDP '\LAFITE.ACTIVE) (pushnew LAFITE.EXTRA.DISPLAY.COMMANDS menuItems) (if \LAFITE.ACTIVE then (LAFITE.COMPUTE.CACHED.VARS] (PUTASSOC 'Dictionary (CONVERTFUNCTIONSTOFORMS (CDR menuItems)) BackgroundMenuCommands) (SETQ BackgroundMenu NIL]) (DictTool.Close [LAMBDA (analyzer) (* jtm%: "13-Nov-86 10:58") (CLOSEF DICTSERVERSTREAM]) ) (DEFINEQ (DictTool.Analyze [LAMBDA (analyzer stream fromLoc length analFn) (* jtm%: "14-Apr-87 14:16") (PROG (buffer bufferStream bufferLength char returnValue userWords (substring (ALLOCSTRING 0 32)) (maxBufferLength 5100) (offset fromLoc)) (SETQ userWords (Analyzer.Prop analyzer 'UserDict)) [COND ((NULL stream) NIL) [(STRINGP stream) (HELP "DictTool.Analyze not implemented for STRING") [SETQ returnValue (DICTCLIENT.PROOFREAD stream (Analyzer.Prop analyzer 'RemoteDict] (COND ((EQUAL 0 (CDR returnValue)) (RETURN (SETQ returnValue NIL] (T (* * break up the stream into strings of ~5000 characters.) (SETQ buffer (ALLOCSTRING (IMIN length maxBufferLength))) (SETQ bufferStream (OPENSTRINGSTREAM buffer 'OUTPUT)) (SETFILEPTR stream fromLoc) (while (IGREATERP length 0) do (SETFILEPTR bufferStream 0) (SETQ bufferLength 0) [do (SETQ char (BIN stream)) [COND ((OR (NOT (NUMBERP char)) (IGREATERP char 255)) (SETQ char (CHARCODE % ] (BOUT bufferStream char) (add length -1) (add bufferLength 1) (COND ((EQUAL length 0) (RETURN)) ((EQUAL bufferLength maxBufferLength) (RETURN)) ((IGREATERP bufferLength (IDIFFERENCE maxBufferLength 200)) (COND ([OR (EQ char (CHARCODE CR)) (AND (EQ char (CHARCODE SP)) (IGREATERP bufferLength (IDIFFERENCE maxBufferLength 50] (RETURN] [SETQ returnValue (DICTCLIENT.PROOFREAD (COND ((EQUAL bufferLength (NCHARS buffer) ) buffer) (T (SUBSTRING buffer 1 bufferLength substring))) (Analyzer.Prop analyzer 'RemoteDict] (COND ((EQUAL 0 (CDR returnValue)) (SETQ returnValue NIL) (add offset bufferLength)) ((AND userWords (Dict.GetEntry userWords (SUBSTRING buffer (ADD1 (CAR returnValue)) (IPLUS (CAR returnValue) (CDR returnValue)) substring))) [add length (IPLUS bufferLength (IMINUS (IPLUS (CAR returnValue) (CDR returnValue] (add offset (IPLUS (CAR returnValue) (CDR returnValue))) (SETFILEPTR stream offset) (SETQ returnValue NIL)) (returnValue (add (CAR returnValue) offset) (RETURN returnValue] (RETURN returnValue]) (DictTool.Analyzers [LAMBDA (analyzer errorStream) (* jtm%: "13-Nov-86 10:57") (* * wraps DictTool.RPCCall around a call to RemoteDict.Analyzers) (DICTCLIENT.LANGUAGES]) (DictTool.Pronunciation [LAMBDA (word dictName) (* jtm%: "13-Nov-86 10:58") [COND ((NOT (STRINGP word)) (SETQ word (MKSTRING word] [COND ((NULL dictName) (SETQ dictName 'AmericanHeritage] (DICTCLIENT.PRONUNCIATION word dictName]) (DictTool.Corrections [LAMBDA (analyzer stream loc len) (* jtm%: "13-Nov-86 10:58") (DICTCLIENT.CORRECTIONS (COND ((STRINGP stream) stream) (T (STREAM.FETCHSTRING stream loc len))) (Analyzer.Prop analyzer 'RemoteDict]) (DictTool.CountWords [LAMBDA (analyzer stream fromLoc length analFn) (* jtm%: "13-Nov-86 14:19") (PROG (buffer bufferStream bufferLength char (n 0) (substring (ALLOCSTRING 0 32)) (maxBufferLength 5100) (offset fromLoc)) [COND ((NULL stream) NIL) [(STRINGP stream) (HELP "DictTool.Analyze not implemented for STRING") [SETQ n (DICTCLIENT.PROOFREAD stream (Analyzer.Prop analyzer 'RemoteDict] (COND ((EQUAL 0 (CDR n)) (RETURN (SETQ n NIL] (T (* * break up the stream into strings of ~5000 characters.) (SETQ buffer (ALLOCSTRING (IMIN length maxBufferLength))) (SETQ bufferStream (OPENSTRINGSTREAM buffer 'OUTPUT)) (SETFILEPTR stream fromLoc) (while (IGREATERP length 0) do (SETFILEPTR bufferStream 0) (SETQ bufferLength 0) [do (SETQ char (BIN stream)) [COND ((OR (NOT (NUMBERP char)) (IGREATERP char 255)) (SETQ char (CHARCODE % ] (BOUT bufferStream char) (add length -1) (add bufferLength 1) (COND ((EQUAL length 0) (RETURN)) ((EQUAL bufferLength maxBufferLength) (RETURN)) ((IGREATERP bufferLength (IDIFFERENCE maxBufferLength 200)) (COND ([OR (EQ char (CHARCODE CR)) (AND (EQ char (CHARCODE SP)) (IGREATERP bufferLength (IDIFFERENCE maxBufferLength 50] (RETURN] [add n (DICTCLIENT.COUNTWORDS (COND ((EQUAL bufferLength (NCHARS buffer)) buffer) (T (SUBSTRING buffer 1 bufferLength substring) )) (Analyzer.Prop analyzer 'RemoteDict] (add offset bufferLength] (RETURN n]) ) (* * FINDWORD & SUBSTITUTEWORD) (DEFINEQ (DictTool.FindWord [LAMBDA (STREAM WORD CH) (* jtm%: "30-Apr-86 10:30") (* the TEDIT interface to FindWord) (PROG (SEL (TEXTOBJ (TEXTOBJ STREAM))) (* * prompt the user for a string if none is given.) [COND ((NULL WORD) (SETQ WORD (TEDIT.GETINPUT TEXTOBJ "Word to find: " (WINDOWPROP W ' TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC] (* * search for the word.) [COND (WORD (SETQ SEL (fetch SEL of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (LingFns.FindWord STREAM WORD CH)) (* * show the user what we found) (COND (CH (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (replace CH# of SEL with (CAR CH)) [replace DCH of SEL with (IPLUS (CAR CH) (IMINUS (CADR CH] (replace CHLIM of SEL with (ADD1 (CADR CH))) (replace POINT of SEL with 'RIGHT) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING WORD) (* And get it into the window) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found).") (\SHOWSEL SEL NIL T] (replace \INSERTNEXTCH of TEXTOBJ with -1]) (DictTool.SubstituteWord [LAMBDA (TEXTSTREAM PATTERN REPLACEMENT CONFIRM? DICTNAME) (* jtm%: "24-Mar-87 08:58") (* this procedure is a modification of  TEDIT.SUBSTITUTE.) (PROG (SEARCHSTRING REPLACESTRING ABORTFLG OUTOFRANGEFLG (TEXTOBJ (TEXTOBJ TEXTSTREAM)) ENDCHAR# STARTCHAR# RANGE (REPLACEDFLG 0) (YESLIST '("y" "Y" "yes" "Yes" "YES" "T")) CONFIRMFLG SEL PC# SELCH# SELCHLIM SELPOINT CRSEEN DICT) (COND ([NULL (SETQ SEARCHSTRING (OR PATTERN (TEDIT.GETINPUT TEXTOBJ "Search word:"] (* If the search pattern is empty,  bail out.) (TEDIT.PROMPTPRINT TEXTOBJ "[Aborted]") (RETURN))) (SETQ REPLACEMENT (OR REPLACEMENT (TEDIT.GETINPUT TEXTOBJ "Replace word:") "")) (* jtm%: use REPLACEMENT for the  original, REPLACESTRING for the  modified word.) (SETQ CRSEEN (STRPOS (CHARACTER (CHARCODE CR)) REPLACEMENT)) (* jtm%: use REPLACEMENT instead of  REPLACESTRING) (COND (PATTERN (* If a pattern is specd in the call,  use the caller's confirm flag.) (SETQ CONFIRMFLG CONFIRM?)) (T (* Otherwise, ask for one.) (SETQ CONFIRMFLG T) (* SETQ CONFIRMFLG (MEMBER  (TEDIT.GETINPUT TEXTOBJ  "Ask before each replace?" "Yes"  (CHARCODE (EOL SPACE ESCAPE LF TAB)))  YESLIST)) (* jtm%: change default to "Yes") )) (TEDIT.PROMPTPRINT TEXTOBJ "Substituting..." T) (SETQ DICT (DictTool.CreateConjugationMap DICTNAME SEARCHSTRING REPLACEMENT)) (SETQ SEL (fetch SEL of TEXTOBJ)) (* STARTCHAR# and ENDCHAR# are the  bound of the search) (\SHOWSEL SEL NIL NIL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* Turn off any blue pending delete) (SETQ STARTCHAR# (fetch CH# of SEL)) [SETQ ENDCHAR# (IPLUS STARTCHAR# (SUB1 (fetch DCH of SEL] (while (AND (SETQ RANGE (LingFns.FindWord TEXTSTREAM SEARCHSTRING STARTCHAR# DICT) (* jtm%: use FindWord for TEDIT.FIND) ) (NOT ABORTFLG)) do (SETQ REPLACESTRING (CADDR RANGE)) (* jtm%: add the suffix.) [PROG (PENDING.SEL CHOICE) (COND [CONFIRMFLG (SETQ PENDING.SEL (TEDIT.SETSEL TEXTSTREAM (CAR RANGE) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE))) 'RIGHT)) (TEDIT.SHOWSEL TEXTSTREAM T PENDING.SEL) (TEDIT.NORMALIZECARET TEXTOBJ SEL) [SETQ CHOICE (COND [(LISTP REPLACESTRING) (SETQ REPLACESTRING (MENU (create MENU ITEMS _ (CONS "*QUIT*" REPLACESTRING) CENTERFLG _ T CHANGEOFFSETFLG _ T TITLE _ "substitutions"] (T (TEDIT.GETINPUT TEXTOBJ (CONCAT "Substitute '" REPLACESTRING "'? ['q' quits]") "Yes" (CHARCODE (EOL SPACE ESCAPE LF TAB] (COND ((MEMBER CHOICE '("*QUIT*" "Q" "q")) (SETQ ABORTFLG T) (GO L1)) ((MEMBER CHOICE '(NIL "n" "N" "no" "NO")) (* turn off selection) (TEDIT.SHOWSEL TEXTSTREAM NIL PENDING.SEL) (RPLACA RANGE (IDIFFERENCE (CADR RANGE) (NCHARS REPLACESTRING))) (GO L1)) (T (* OK to replace) (TEDIT.DELETE TEXTSTREAM PENDING.SEL) (* make the replacement) (COND ((NOT (EQUAL REPLACESTRING "")) (* If the replacestring is nothing,  why bother to add nothing) (TEDIT.INSERT TEXTSTREAM REPLACESTRING (CAR RANGE)) [SETQ ENDCHAR# (IPLUS ENDCHAR# (IDIFFERENCE (NCHARS REPLACESTRING) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE] (add REPLACEDFLG 1] (T (* No confirmation required.  Do the substitutions without showing  intermediate work) (SETQ PC# (\DELETECH (CAR RANGE) (CADR RANGE) (ADD1 (IDIFFERENCE (CADR RANGE) (CAR RANGE))) TEXTOBJ)) (\FIXDLINES (fetch LINES of TEXTOBJ) SEL (CAR RANGE) (CADR RANGE) TEXTOBJ) [COND ((NOT (EQUAL REPLACESTRING "")) (* If the replacestring is nothing,  why bother to add nothing) (COND [CRSEEN (for ACHAR instring REPLACESTRING as NCH# from (CAR RANGE) by 1 do (SELCHARQ ACHAR (CR (\INSERTCR ACHAR NCH# TEXTOBJ)) (\INSERTCH ACHAR NCH# TEXTOBJ] (T (\INSERTCH REPLACESTRING (CAR RANGE) TEXTOBJ PC#))) (SETQ ENDCHAR# (IPLUS ENDCHAR# (IDIFFERENCE (NCHARS REPLACESTRING) (IDIFFERENCE (CADR RANGE) (SUB1 (CAR RANGE] (add REPLACEDFLG 1))) L1 (SETQ STARTCHAR# (IPLUS (CAR RANGE) (NCHARS REPLACESTRING] (* start looking where you left off)) (COND ((ZEROP REPLACEDFLG) (TEDIT.PROMPTPRINT TEXTOBJ "No replacements made." T)) ((EQUAL REPLACEDFLG 1) (TEDIT.PROMPTPRINT TEXTOBJ "1 Replacement made." T)) (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (MKSTRING REPLACEDFLG) " Replacements made.") T))) (COND ((AND (NOT CONFIRMFLG) (NOT (ZEROP REPLACEDFLG))) (* There WERE replacements, and they  were not confirmed.) (replace CHLIM of SEL with ENDCHAR#) [replace DCH of SEL with (ADD1 (IDIFFERENCE (fetch CHLIM of SEL) (fetch CH# of SEL] (\TEDIT.MARK.LINES.DIRTY TEXTOBJ (fetch CH# of SEL) (fetch CHLIM of SEL)) (TEDIT.UPDATE.SCREEN TEXTOBJ) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (RETURN REPLACEDFLG]) (DictTool.CreateConjugationMap [LAMBDA (language word1 word2) (* jtm%: "24-Mar-87 09:06") (* * creates a conjugation dictionary that maps word1 into word2.) (PROG [fullconj1 fullconj2 pp1 pp2 prior (dict (SimpleDict.New 'map] [COND [word2 (SETQ fullconj1 (DICTCLIENT.CONJUGATE word1 NIL NIL language)) (SETQ fullconj2 (DICTCLIENT.CONJUGATE word2 NIL NIL language)) (SETQ pp1 (FASSOC 'pp fullconj1)) (SETQ pp2 (FASSOC 'pp fullconj2)) [COND [(AND pp1 (NULL pp2) (FASSOC 'v fullconj2)) (push fullconj2 (CONS 'pp (CDR (FASSOC 'pst fullconj2] ((AND pp2 (NULL pp1) (FASSOC 'v fullconj1)) (push fullconj1 (CONS 'pp (CDR (FASSOC 'pst fullconj1] (for conj1 conj2 entry in fullconj1 do (SETQ conj2 (FASSOC (CAR conj1) fullconj2)) (AND conj2 (for caps oldValue newValue in '(NONE FIRST ALL) do (SETQ entry (LingFns.Capitalize (CADR conj1) caps)) (SETQ oldValue (Dict.GetEntry dict entry)) (SETQ newValue (LingFns.Capitalize (CADR conj2) caps)) (SETQ newValue (COND ((for i inside oldValue thereis (STREQUAL i newValue)) oldValue) ((LISTP oldValue) (CONS newValue oldValue)) (oldValue (LIST newValue oldValue)) (T newValue))) (Dict.PutEntry dict entry newValue] (T (for conjugation in (DICTCLIENT.CONJUGATE word1 NIL language) do (for caps in '(NONE FIRST ALL) do (Dict.PutEntry dict (LingFns.Capitalize (CADR conjugation) caps) T] (RETURN dict]) (DictTool.FindWordInit [LAMBDA NIL (* jtm%: "26-Feb-87 13:46") (* * add items to TEDIT's menu.) [for ITEM on (fetch (MENU ITEMS) of TEDIT.DEFAULT.MENU) do (COND [(EQ (CAR ITEM) 'Find) (RPLACA ITEM '(Find 'Find NIL (SUBITEMS (FindWord (FUNCTION DictTool.FindWord) "Looks for a word independent of its inflection or capitalization." ] ((EQ (CAR ITEM) 'Substitute) (RPLACA ITEM '(Substitute 'Substitute NIL (SUBITEMS (SubstituteWord (FUNCTION DictTool.SubstituteWord) "Substitutes one word for another, keeping the same capitalization and inflectional form." ] (* * force the menu to be recomputed.) (COND ((EQ (fetch MENUCOLUMNS of TEDIT.DEFAULT.MENU) 1) (* If there is only one column, force  a re-figuring of the number of rows) (replace MENUROWS of TEDIT.DEFAULT.MENU with NIL)) ((EQ (fetch MENUROWS of TEDIT.DEFAULT.MENU) 1) (* There's only one row, so recompute  %# of columns.) (replace MENUCOLUMNS of TEDIT.DEFAULT.MENU with NIL))) (replace ITEMWIDTH of TEDIT.DEFAULT.MENU with 10000) (replace ITEMHEIGHT of TEDIT.DEFAULT.MENU with 10000) (replace IMAGE of TEDIT.DEFAULT.MENU with NIL) (* Force it to create a new menu  image.) (UPDATE/MENU/IMAGE TEDIT.DEFAULT.MENU]) ) (DEFINEQ (LingFns.FindWord [LAMBDA (STREAM WORD CH DICT) (* jtm%: "24-Mar-87 09:28") (* * finds the next instance of WORD in the text stream, independent of how it is  conjugated or capitalized. returns the first character index, the last character  index, the suffix, and the capitalization.) (PROG (CHAR NODE END EXPO FIRSTCHAR LASTCHAR U-FIRSTCHAR EOFPTR dictCreated) (* * build the dictionary) [COND (WORD (SETQ WORD (MKSTRING WORD)) [COND ((NULL DICT) (SETQ DICT (STREAMPROP STREAM 'FINDWORDMAP)) (COND ((EQUAL WORD (CAR DICT)) (SETQ DICT (CDR DICT))) (T (SETQ DICT (DictTool.CreateConjugationMap NIL WORD)) (STREAMPROP STREAM 'FINDWORDMAP (CONS WORD DICT] (* * initialize.) [COND ((NULL CH) (SETQ CH (TEDIT.GETPOINT STREAM] (SETQ CH (SUB1 CH)) (SETQ EOFPTR (GETEOFPTR STREAM)) (COND ((GREATERP CH EOFPTR) (RETURN)) (T (SETFILEPTR STREAM CH))) [SETQ FIRSTCHAR (CHCON1 (L-CASE (NTHCHAR WORD 1] [SETQ U-FIRSTCHAR (CHCON1 (U-CASE (NTHCHAR WORD 1] (* * search for a word that begins with the first letter.) (while (NEQ EOFPTR (GETFILEPTR STREAM)) do (SETQ LASTCHAR CHAR) (SETQ CHAR (BIN STREAM)) (COND ([AND [OR (NULL LASTCHAR) (AND (NUMBERP LASTCHAR) (NOT (ALPHACHARP LASTCHAR] (NUMBERP CHAR) (SETQ NODE (FASSOC (CHARACTER CHAR) (fetch (SimpleDict.Node subnodes) of (fetch (Dict contents) of DICT] (SETQ CH (GETFILEPTR STREAM)) [while NODE do (COND ((EQP EOFPTR (GETFILEPTR STREAM)) (SETQ END EOFPTR) (RETURN)) ([AND (SETQ CHAR (BIN STREAM)) (NUMBERP CHAR) (ALPHACHARP CHAR) (SETQ NODE (FASSOC (CHARACTER CHAR) (fetch (SimpleDict.Node subnodes) of NODE] (* is this a legal character?) ) (T (RETURN] (COND ((SETQ EXPO (fetch (SimpleDict.Node value) of NODE)) (RETURN] (* * we are done.) (RETURN (COND ((AND EXPO CH) [COND ((NULL END) (SETQ END (SUB1 (GETFILEPTR STREAM] (LIST CH END EXPO]) (LingFns.Capitalize [LAMBDA (word caps) (* jtm%: " 6-Aug-84 12:53") (* * capitalizes word according to the parameter "caps") (COND ((LISTP word) (for w in word collect (LingFns.Capitalize w caps))) (T (PROG (stringP litAtom) (COND ((STRINGP word) (SETQ word (UNPACK word)) (SETQ stringP T)) ((LITATOM word) (SETQ word (UNPACK word)) (SETQ litAtom T))) [SELECTQ caps (FIRST [COND ((NOT (U-CASEP (CAR word))) (RPLACA word (U-CASE (CAR word] [for char on (CDR word) do (COND ((U-CASEP (CAR char)) (RPLACA char (L-CASE (CAR char]) (ALL [for char on word do (COND ((NOT (U-CASEP (CAR char))) (RPLACA char (U-CASE (CAR char]) (for char on word do (COND ((U-CASEP (CAR char)) (RPLACA char (L-CASE (CAR char] [COND [stringP (SETQ word (MKSTRING (PACK word] (litAtom (SETQ word (PACK word] (RETURN word]) (LingFns.Capitalization [LAMBDA (word) (* jtm%: "18-Jul-84 15:19") (* * returns NIL, ALL or FIRST) (COND ([OR (NULL word) (NOT (U-CASEP (CAR word] NIL) ([OR (NULL (CDR word)) (NOT (U-CASEP (CADR word] 'FIRST) (T 'ALL]) ) (DictTool.FindWordInit) (RPAQ? DictTool.TimeOperation NIL) (RPAQ? Dict.DefWindow NIL) (RPAQ? Dict.CommandsAdded NIL) (RPAQ? InvertedDict.List NIL) (RPAQ? DictTool.LastSearch NIL) (RPAQ? DictTool.LastWord NIL) (RPAQ? TEdit.DefaultDictionary NIL) (RPAQ? DictTool.MinKeywords 2) (RPAQ? DictTool.MaxWords 100) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.MinKeywords DictTool.MaxWords DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary) ) (DictTool.Init) (RPAQQ PronunciationGuide (("q" "cat" "(kqt)") ("A" "pay" "(pA)") ("Q" "care" "(kQr)") ("*" "father" "(f*%"T5r)") ("b" "bike" "(bIk)") ("ch" "church" "(ch/rch)") ("d" "deed" "(dEd)") ("4" "pet" "(p4t)") ("E" "seed" "(sEd)") ("I" "fife" "(fIf)") ("g" "gag" "(gqg)") ("h" "hat" "(hqt)") ("hw" "which" "(hw9ch)") ("9" "pit" "(p9t)") ("I" "lie" "(lI)") ("7" "pier" "(p7r)") ("j" "judge" "(j8j)") ("k" "kick" "(k9k)") ("l" "lid" "(l9d)") ("l" "needle" "(nEd%"l)") ("m" "mum" "(m8m)") ("n" "no, sudden" "(nO)") ("ng" "thing" "(th9ng)") ("0" "pot" "(p0t)") ("O" "toe" "(tO)") ("" "paw" "(p)") ("oi" "noise" "(noiz)") ("ou" "out" "(out)") ("1" "book" "(b1k)") ("|" "boot" "(b|t)") ("p" "people" "(pE%"p5l)") ("r" "roar" "(rr)") ("s" "sauce" "(ss)") ("sh" "ship" "(sh9p)") ("t" "tight" "(tIt)") ("th" "thin" "(th9n)") ("T" "this" "(T9s)") ("8" "cut" "(k8t)") ("/" "urge" "(/rj)") ("v" "valve" "(vqlv)") ("w" "with" "(w9T, w9th)") ("y" "yes" "(y4s)") ("z" "zebra" "(zE%"br5)") ("zh" "vision" "(v9zh%"5n)") ("5" "about" "(5-bout%")") ("KH" "loch" "(l0KH, l0k)") ("N" "bon" "(b0n; French bN)."))) (RPAQQ PronunciationMap ((%" %') (5 ÿ&fÿ) (/ Ï u) (8 Æ u) (T Î t h) (%| Å o Å o) (1 Æ o Æ o) (% ÿñÑÿ) (O Å o) (0 Æ o) (7 ÿñÀÿ) (I ÿñ¿ÿ) (9 ÿñ¾ÿ) (E Å e) (4 Æ e) (* ÿñ§ÿ) (Q ÿñ£ÿ) (A Å a) (q Æ a))) (PUTPROPS DICTTOOL COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5787 18593 (TEDIT.INCLUDESTREAM 5797 . 6308) (TEdit.PrintDefinition 6310 . 8564) ( DictTool.PrintDefinition 8566 . 11103) (Dict.PrintDefinition 11105 . 12068) (DictTool.GetEntry 12070 . 12369) (TEdit.SetDictionary 12371 . 14530) (DictForStream 14532 . 14899) (DictTool.Dictionaries 14901 . 15055) (PARSEBYCOLONS 15057 . 16106) (PrintPronunciationGuide 16108 . 17579) ( ConvertPronunciation 17581 . 18591)) (18594 27955 (TEdit.PrintSearch 18604 . 19054) ( DictTool.PrintSearch 19056 . 21319) (DictTool.MergeSearch 21321 . 23149) (NerdForStream 23151 . 23461) (TEdit.SetNerd 23463 . 25535) (DictTool.PromptForCutoff 25537 . 26084) ( DictTool.PromptForKeywordCutoff 26086 . 26734) (PARSESELECTION 26736 . 27953)) (27956 30011 ( TEdit.PrintPhraseSearch 27966 . 28428) (DictTool.PrintPhraseSearch 28430 . 30009)) (30012 34807 ( TEdit.PrintSynonyms 30022 . 30351) (REMOVEALL 30353 . 30853) (CONVERTFUNCTIONSTOFORMS 30855 . 31345) ( TEdit.PrintNounSynonyms 31347 . 31698) (DictTool.PrintNounSynonyms 31700 . 31884) ( DictTool.PrintVerbSynonyms 31886 . 32070) (DictTool.PrintAdjSynonyms 32072 . 32257) ( TEdit.PrintVerbSynonyms 32259 . 32601) (TEdit.PrintAdjSynonyms 32603 . 32948) (DictTool.PrintSynonyms 32950 . 34805)) (34808 40396 (DictTool.TEditWrapper 34818 . 38056) (Dict.OutputStream 38058 . 39852) ( DictTool.PromptStream 39854 . 40394)) (40397 58304 (DictTool.Init 40407 . 42137) (DictTool.Open 42139 . 45990) (DictTool.OpenDictionary 45992 . 47887) (DictTool.OpenAnalyzer 47889 . 50072) ( DictTool.OpenNerd 50074 . 53438) (Dict.AddCommands 53440 . 58153) (DictTool.Close 58155 . 58302)) ( 58305 65911 (DictTool.Analyze 58315 . 62363) (DictTool.Analyzers 62365 . 62595) ( DictTool.Pronunciation 62597 . 62917) (DictTool.Corrections 62919 . 63285) (DictTool.CountWords 63287 . 65909)) (65950 83282 (DictTool.FindWord 65960 . 67971) (DictTool.SubstituteWord 67973 . 78188) ( DictTool.CreateConjugationMap 78190 . 81065) (DictTool.FindWordInit 81067 . 83280)) (83283 89085 ( LingFns.FindWord 83293 . 87111) (LingFns.Capitalize 87113 . 88725) (LingFns.Capitalization 88727 . 89083))))) STOP \ No newline at end of file diff --git a/lispusers/DICTTOOL.~2~ b/lispusers/DICTTOOL.~2~ deleted file mode 100644 index 26962669..00000000 --- a/lispusers/DICTTOOL.~2~ +++ /dev/null @@ -1,1369 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Mar-94 10:43:44" |{IE:PARC:XEROX}MEDLEY>DICTTOOL.;4| 92411 changes to%: (FILES DICTCLIENT) (VARS DICTTOOLCOMS) (FNS TEdit.SearchMenu) previous date%: "27-Mar-91 17:20:45" {DSK}medley2.0>lispusers>DICTTOOL.;1) (* ; " Copyright (c) 1986, 1987, 1988, 1989, 1991, 1994 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DICTTOOLCOMS) (RPAQQ DICTTOOLCOMS ((COMS * DICTTOOLDEPENDENCIES) (FILES ANALYZER (FROM {NFS}DICTSERVER>LISP>) DICTCLIENT) (* ;; "1/6/89 jtm: fixed TEdit.PrintDefinition so that SimpleDicts would print their entries in the definition window.") (* ;; "1/6/89 jtm: changed TEdit.SetDictionary and DictForStream so that TEdit.DefaultDictionary reflects the default dictionary to use if no other is specified.") (* ;; "2/28/89 jtm: changed FILES so that DICTCLIENT is loaded from PIGLET.") (* ;;  "5/31/89 jtm: changed Dict.AddCommands to put Dictionary menu item on Lafite display windows.") (* ;; "3/27/91 jtm: added TEdit interface to the SearchMenu module") (* ;; "3/1/94 jtm: changed the loading of DICTCLIENT and SEARCHMENU") (FNS TEDIT.INCLUDESTREAM TEdit.PrintDefinition DictTool.PrintDefinition Dict.PrintDefinition DictTool.GetEntry TEdit.SetDictionary DictForStream DictTool.Dictionaries PARSEBYCOLONS PrintPronunciationGuide ConvertPronunciation) (FNS TEdit.SearchMenu TEdit.PrintSearch DictTool.PrintSearch DictTool.MergeSearch NerdForStream TEdit.SetNerd DictTool.PromptForCutoff DictTool.PromptForKeywordCutoff PARSESELECTION) (FNS TEdit.PrintPhraseSearch DictTool.PrintPhraseSearch) (FNS TEdit.PrintSynonyms REMOVEALL CONVERTFUNCTIONSTOFORMS TEdit.PrintNounSynonyms DictTool.PrintNounSynonyms DictTool.PrintVerbSynonyms DictTool.PrintAdjSynonyms TEdit.PrintVerbSynonyms TEdit.PrintAdjSynonyms DictTool.PrintSynonyms) (FNS DictTool.TEditWrapper Dict.OutputStream DictTool.PromptStream) (FNS DictTool.Init DictTool.Open DictTool.OpenDictionary DictTool.OpenAnalyzer DictTool.OpenNerd Dict.AddCommands DictTool.Close) (FNS DictTool.Analyze DictTool.Analyzers DictTool.Pronunciation DictTool.Corrections DictTool.CountWords) (COMS (* * FINDWORD & SUBSTITUTEWORD) (FNS DictTool.FindWord DictTool.SubstituteWord DictTool.CreateConjugationMap DictTool.FindWordInit) (FNS LingFns.FindWord LingFns.Capitalize LingFns.Capitalization) (P (DictTool.FindWordInit))) (INITVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary (DictTool.MinKeywords 2) (DictTool.MaxWords 100)) (GLOBALVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.MinKeywords DictTool.MaxWords DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary) (P (DictTool.Init)) (VARS PronunciationGuide PronunciationMap))) (RPAQQ DICTTOOLDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'DICTTOOL 'DEPENDENCIES (for FILE in (FILECOMSLST 'DICTTOOL 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES DICTTOOL) (P (for FILE FILEDATE in (GETPROP 'DICTTOOL 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (printout T "Flushing old version of " (CAR FILE) T) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS DICTTOOL DEPENDENCIES ((ANALYZER . " 9-Mar-89 15:24:58") (DICTCLIENT . " 8-Aug-88 16:01:50"))) [for FILE FILEDATE in (GETPROP 'DICTTOOL 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force  FILESLOAD to reload the file.) (printout T "Flushing old version of " (CAR FILE) T) (PUTPROP (CAR FILE) 'FILEDATES NIL] (FILESLOAD ANALYZER (FROM {NFS}DICTSERVER>LISP>) DICTCLIENT) (* ;; "1/6/89 jtm: fixed TEdit.PrintDefinition so that SimpleDicts would print their entries in the definition window." ) (* ;; "1/6/89 jtm: changed TEdit.SetDictionary and DictForStream so that TEdit.DefaultDictionary reflects the default dictionary to use if no other is specified." ) (* ;; "2/28/89 jtm: changed FILES so that DICTCLIENT is loaded from PIGLET.") (* ;; "5/31/89 jtm: changed Dict.AddCommands to put Dictionary menu item on Lafite display windows." ) (* ;; "3/27/91 jtm: added TEdit interface to the SearchMenu module") (* ;; "3/1/94 jtm: changed the loading of DICTCLIENT and SEARCHMENU") (DEFINEQ (TEDIT.INCLUDESTREAM - [LAMBDA (TEXTSTREAM INCLUDEDSTREAM) (* jtm%: "28-Oct-87 14:41") - (LET (STARTPOS) - (SETQ STARTPOS (ADD1 (GETEOFPTR TEXTSTREAM))) - (TEDIT.COPY (TEDIT.SETSEL INCLUDEDSTREAM 1 (GETEOFPTR INCLUDEDSTREAM) - 'LEFT) - (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'LEFT)) - (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'LEFT) - (TEDIT.NORMALIZECARET TEXTSTREAM) - (TEDIT.STREAMCHANGEDP TEXTSTREAM T]) (TEdit.PrintDefinition - [LAMBDA (stream dict words) (* ; "Edited 6-Jan-89 11:46 by jtm:") - - (* * prints out the definition of the currently selected text.) - - (OR stream (SETQ stream (Dict.OutputStream))) - (DictTool.TEditWrapper (OR dict (DictForStream stream)) - [FUNCTION (LAMBDA (dict selection stream) - (LET (printFn entry) - (for word exists in (PARSEBYCOLONS selection) - do [COND - ((AND (SETQ printFn (fetch (Dict printEntryFn) - of dict)) - (NEQ printFn 'NILL)) - (SETQ exists (OR (APPLY* printFn dict word stream) - exists))) - ((SETQ printFn (fetch (Dict getEntryFn) of dict)) - (SETQ entry (APPLY* printFn dict word NIL)) - [for def (left _ (LENGTH entry)) inside entry - first (TEDIT.INSERT stream (CONCAT word ": ")) - do [COND - ((STREAMP def) - (SETQ def (STREAM.FETCHSTRING def 0 - (GETEOFPTR def] - (TEDIT.INSERT stream def) - (add left -1) - (COND - ((IGEQ left 1) - (TEDIT.INSERT stream ", ")) - (T (TEDIT.INSERT stream " - -"] - (SETQ exists (OR entry exists] finally (RETURN exists] - stream words "word to look up:" "Getting definition for"]) (DictTool.PrintDefinition - [LAMBDA (dict words stream) (* jtm%: "17-Nov-87 11:02") - (PROG (def looks found pos (offset 0)) - [for word inside (PARSEBYCOLONS words) - do (SETQ def (Dict.GetEntry dict word)) - (SETQ looks (Dict.Prop dict 'Looks)) - (COND - ((AND (NULL looks) - (Dict.Prop dict 'RemoteDict)) - [SETQ looks (DICTCLIENT.GETLOOKS (Dict.Prop dict 'RemoteDict] - (Dict.Prop dict 'Looks looks))) - (COND - [(STRINGP def) - (SETQ found T) - (TEDIT.INSERT stream def) - (for I from 1 to 2 when (NEQ 13 (NTHCHARCODE def (IMINUS I))) - do (TEDIT.INSERT stream (CHARACTER 13] - ([AND (STRINGP (CAR def)) - (NOT (STREQUAL "" (CAR def] - (SETQ found T) - (TEDIT.INSERT stream (CAR def) - NIL - (CDAR looks)) - (for I from 1 to 2 when (NEQ 13 (NTHCHARCODE def (IMINUS I))) - do (TEDIT.INSERT stream (CHARACTER 13))) - (* assumes that the first look given - is the default for the dictionary.) - (SETQ pos (TEDIT.GETPOINT stream)) (* setting looks moves the selection) - (for i in (CDR def) do (TEDIT.LOOKS stream (CDR (FASSOC (CADDR i) - looks)) - (IPLUS (CAR i) - offset) - (CADR i))) - (SETQ offset (SUB1 pos)) - (TEDIT.SETSEL stream pos 0 'LEFT)) - (NIL (TEDIT.INSERT stream (CONCAT word ": not found.")) - (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) - 1 - (ADD1 (NCHARS word))) - (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) - (IPLUS 2 (NCHARS word)) - 11] - (RETURN found]) (Dict.PrintDefinition - [LAMBDA (dict word stream) (* jtm%: "13-Oct-87 10:27") - (PROG (scratch start) - [COND - ((NULL stream) - (SETQ stream (Dict.OutputStream] - [SETQ scratch (OPENTEXTSTREAM NIL NIL NIL NIL '(LEAVETTY] - (COND - ((Dict.PrintEntry dict word scratch) - (TEDIT.INSERT scratch (CONCAT (CHARACTER 13) - (CHARACTER 13)) - (ADD1 (GETEOFPTR scratch))) - (SETQ start (ADD1 (GETEOFPTR stream))) - (TEDIT.COPY (TEDIT.SETSEL scratch 1 (GETEOFPTR scratch) - 'LEFT) - (TEDIT.SETSEL stream start 0 'LEFT)) - (CLOSEF scratch) - (TEDIT.SETSEL stream start 0 'RIGHT) - (TEDIT.NORMALIZECARET stream) - (TEDIT.STREAMCHANGEDP stream T) - (RETURN T]) (DictTool.GetEntry - [LAMBDA (dict uniqueID prop) (* jtm%: " 7-Apr-87 08:39") - (COND - [(NUMBERP uniqueID) - (DICTCLIENT.ENUMERATE uniqueID (Dict.Prop dict 'RemoteDict] - (T (DICTCLIENT.GETDEFINITION uniqueID (Dict.Prop dict 'RemoteDict]) (TEdit.SetDictionary - [LAMBDA (stream dict) (* ; "Edited 6-Jan-89 12:24 by jtm:") - - (* * sets the dictionary property for the window) - - (PROG (menuItems) - (OR stream (SETQ stream (Dict.OutputStream))) - [COND - ((NULL dict) - [SETQ menuItems (for i in Dict.DictionaryList - collect (LIST (Dict.Name i) - (LIST 'QUOTE i) - (if (Dict.Prop i 'RemoteDict) - then "Calls the remote dictionary server"] - [COND - ((NULL menuItems) - (TEDIT.PROMPTPRINT stream "Sorry, no dictionaries loaded." T)) - ((EQ 1 (LENGTH menuItems)) - (SETQ dict (CAR Dict.DictionaryList))) - (T (SETQ dict (MENU (create MENU - ITEMS _ menuItems - TITLE _ "dictionaries" - CENTERFLG _ T] - (COND - ((NULL dict) - (SETQ dict (STREAMPROP stream 'dict)) - (TEDIT.PROMPTPRINT stream (CONCAT "Dictionary is " (AND dict (Dict.Name dict)) - ".") - T) - (RETURN] - (TEDIT.PROMPTPRINT stream (CONCAT "Setting dictionary to " (AND dict (Dict.Name dict)) - "...") - T) - (Dict.Open dict) - (STREAMPROP stream 'dict dict) - - (* ;; "1/6/89 jtm: set TEdit.DefaultDictionary if this is the dictionary window or if it hasn't already been set.") - - (if [OR (NULL TEdit.DefaultDictionary) - (AND (WINDOWP Dict.DefWindow) - (EQ stream (WINDOWPROP Dict.DefWindow 'TEXTSTREAM] - then (SETQ TEdit.DefaultDictionary dict)) - (TEDIT.PROMPTPRINT stream "done.")) - dict]) (DictForStream - [LAMBDA (stream) (* ; "Edited 6-Jan-89 12:26 by jtm:") - - (* ;; "1/6/89 jtm: Try TEdit.DefaultDictionary if the stream doesn't have it's own dictionary.") - - (COND - ((STREAMPROP stream 'dict)) - (TEdit.DefaultDictionary) - (T (TEdit.SetDictionary (Dict.OutputStream]) (DictTool.Dictionaries - [LAMBDA (dict errorStream) (* jtm%: "13-Nov-86 10:57") - (DICTCLIENT.DICTIONARIES]) (PARSEBYCOLONS - [LAMBDA (STRING COLONSORSPACES) (* ; "Edited 11-Jan-89 13:55 by jtm:") - - (* * Actually, parse by SEMI-colons.) - - (LET (WORDS SEPARATOR (OLDPOS 1) - (POS 0)) - (COND - ((STRINGP STRING) - (SETQ SEPARATOR (COND - ([AND COLONSORSPACES (NULL (STRPOS ";" STRING (ADD1 POS] - " ") - (T ";"))) - [while (SETQ POS (STRPOS SEPARATOR STRING (ADD1 POS))) - do (push WORDS (SUBSTRING STRING OLDPOS (SUB1 POS))) - (SETQ OLDPOS (for I from (ADD1 POS) - thereis (NEQ 32 (NTHCHARCODE STRING I] - [COND - ((AND (NEQ OLDPOS 0) - (ILEQ OLDPOS (NCHARS STRING))) - (push WORDS (SUBSTRING STRING OLDPOS (NCHARS STRING] - (OR (DREVERSE WORDS) - STRING)) - (T STRING]) (PrintPronunciationGuide - [LAMBDA (stream) (* jtm%: " 9-Feb-87 08:40") - (LET (startPos) - (SETQ startPos (GETFILEPTR stream)) - [for i pronCode on PronunciationGuide do (SETQ pronCode (CAR i)) - (TEDIT.INSERT stream (CONCAT (ConvertPronunciation - (CAR pronCode)) - ": " - (CADR pronCode) - " " - (ConvertPronunciation - (CADDR pronCode)) - (COND - ((CDR i) - "; ") - (T ""] - (TEDIT.LOOKS stream '(FAMILY CLASSIC SIZE 10 FACE STANDARD) - (ADD1 startPos) - (IDIFFERENCE (GETFILEPTR stream) - startPos]) (ConvertPronunciation - [LAMBDA (string) (* jtm%: " 6-Feb-87 17:38") - (CONCATLIST (for i char nschars from 1 to (NCHARS string) join (SETQ char (NTHCHAR string i)) - (SETQ nschars - (CDR (FASSOC char - PronunciationMap))) - (COND - ((NULL nschars) - (LIST char)) - ((LISTP nschars) - (COPY nschars)) - (T (LIST nschars]) ) (DEFINEQ (TEdit.SearchMenu [LAMBDA (stream dict words) (* ; "Edited 1-Mar-94 10:28 by jtm:") (LOAD? 'SEARCHMENU.MCOM) (if (NOT (OPENWP SearchMenu)) then (SearchMenu.Create]) (TEdit.PrintSearch - [LAMBDA (stream dict words) (* jtm%: "13-Oct-87 10:11") - - (* * prints out the definition of the currently selected text.) - - (OR stream (SETQ stream (Dict.OutputStream))) - (DictTool.TEditWrapper (OR dict (NerdForStream stream)) - 'DictTool.PrintSearch stream words "Type keywords to search on:" - "Searching for words using" 'SEARCHKEYS]) (DictTool.PrintSearch - [LAMBDA (dict selection stream) (* jtm%: " 7-Apr-87 09:52") - (LET (looks venn) - (SETQ venn (DictTool.MergeSearch dict selection)) - [for i pos in venn do (* printout header) - (SETQ pos (TEDIT.GETPOINT stream)) - [for header on (CAR i) do (TEDIT.INSERT stream (CONCAT - (CAR header) - (COND - ((CDR header) - " ") - (T ": "] - (push looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) - pos))) - [for word on (CADR i) do (TEDIT.INSERT stream (CONCAT (CAR word) - (COND - ((CDR word) - "; ") - (T ""] - (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) - (TEDIT.INSERT stream (CHARACTER (CHARCODE CR] - (* do the looks last to avoid messing - up the text placement.) - (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) - 1 - (TEDIT.GETPOINT stream)) - (for look in looks do (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) - (CAR look) - (CDR look))) - venn]) (DictTool.MergeSearch - [LAMBDA (dict synonymclasses minKeywords minWord maxWord) (* jtm%: " 2-Aug-88 13:15") - (LET (minWord maxWord VennSearchFn) - [for i on synonymclasses do (COND - ((NLISTP (CAR i)) - (RPLACA i (LIST (CAR i] - [COND - ((AND (NULL minWord) - (NULL maxWord)) - (COND - ((AND (EQUAL synonymclasses DictTool.LastSearch) - (NEQ 0 DictTool.MaxWords)) - (COND - ((NULL DictTool.LastWord) - (SETQ DictTool.LastWord 0))) - (SETQ minWord (ADD1 DictTool.LastWord)) - [SETQ maxWord (COND - ((EQ 0 DictTool.MaxWords) - 0) - (T (IPLUS DictTool.MaxWords DictTool.LastWord] - (SETQ DictTool.LastWord maxWord)) - (T (SETQ minWord 0) - (SETQ maxWord DictTool.MaxWords) - (SETQ DictTool.LastSearch synonymclasses) - (SETQ DictTool.LastWord maxWord] - (COND - [(InvertedDict.Prop dict 'RemoteDict) - (DICTCLIENT.SEARCHFORWORD synonymclasses DictTool.MinKeywords (OR minWord 0) - (OR maxWord DictTool.MaxWords) - (InvertedDict.Prop dict 'RemoteDict] - ((SETQ VennSearchFn (InvertedDict.Prop dict 'VENNSEARCHFN)) - (APPLY* VennSearchFn dict synonymclasses DictTool.MinKeywords (OR minWord 0) - (OR maxWord DictTool.MaxWords))) - (T (InvertedDict.MergeSearch dict synonymclasses DictTool.MinKeywords (OR minWord 0) - (OR maxWord DictTool.MaxWords]) (NerdForStream - [LAMBDA (stream) (* jtm%: "17-Nov-87 11:14") - - (* * comment) - - (COND - ((STREAMPROP stream 'nerd)) - ((STREAMPROP (Dict.OutputStream) - 'nerd)) - (T (TEdit.SetNerd (Dict.OutputStream]) (TEdit.SetNerd - [LAMBDA (stream nerd) (* jtm%: "14-Oct-87 12:50") - - (* * sets the dictionary property for the window) - - (PROG (menuItems) - (OR stream (SETQ stream (Dict.OutputStream))) - [COND - ((NULL nerd) - [SETQ menuItems (for i in InvertedDict.List - collect (LIST (InvertedDict.Name i) - (LIST 'QUOTE i) - (if (InvertedDict.Prop i 'RemoteDict) - then "Calls the remote dictionary server"] - [COND - ((NULL menuItems)) - ((EQ 1 (LENGTH menuItems)) - (SETQ nerd (CAR InvertedDict.List))) - (T (SETQ nerd (MENU (create MENU - ITEMS _ menuItems - TITLE _ "databases" - CENTERFLG _ T] - (COND - ((NULL nerd) - (SETQ nerd (STREAMPROP stream 'nerd)) - (TEDIT.PROMPTPRINT stream (CONCAT "Database is " (AND nerd (InvertedDict.Name - nerd)) - ".") - T) - (RETURN] - (TEDIT.PROMPTPRINT stream (CONCAT "Setting database to " (AND nerd (InvertedDict.Name - nerd)) - "...") - T) - (InvertedDict.Open nerd) - (STREAMPROP stream 'nerd nerd) - (TEDIT.PROMPTPRINT stream "done.") - (SETQ DictTool.LastSearch NIL) (* so that you can do the same search - on a different data base.) - ) - nerd]) (DictTool.PromptForCutoff - [LAMBDA (STREAM) (* jtm%: " 2-Feb-87 11:33") - (OR STREAM (SETQ STREAM (Dict.OutputStream))) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Current maximum = " DictTool.MaxWords ".") - T) - (SETQ DictTool.MaxWords (RNUMBER - "Enter the maximum number of words that each combination of keywords may return. (0 = no limit)" - )) - (TEDIT.PROMPTPRINT STREAM (CONCAT "New maximum = " DictTool.MaxWords ".") - T]) (DictTool.PromptForKeywordCutoff - [LAMBDA (STREAM) (* jtm%: " 2-Feb-87 11:33") - (OR STREAM (SETQ STREAM (Dict.OutputStream))) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Current minimum = " DictTool.MinKeywords ".") - T) - (SETQ DictTool.MinKeywords (RNUMBER "Enter the minimum number of keywords that a word must have to be accepted. e.g. 2 = at least two keywords, 0 = all of the keywords given, -2 = all but two of the keywords given, etc." - )) - (TEDIT.PROMPTPRINT STREAM (CONCAT "New minimum = " DictTool.MinKeywords ".") - T]) (PARSESELECTION - [LAMBDA (selection) (* jtm%: "20-Mar-87 14:39") - (LET (words temp) - [for i charcode startPos alpha priorAlpha word from 1 to (ADD1 (NCHARS selection)) - do (SETQ charcode (NTHCHARCODE selection i)) - (SETQ priorAlpha alpha) - [SETQ alpha (AND charcode (OR (ALPHACHARP charcode) - (EQ charcode (CHARCODE -] - [COND - ((AND alpha (NULL priorAlpha)) - (SETQ startPos i)) - ((AND priorAlpha (NULL alpha)) - (SETQ word (SUBSTRING selection startPos (SUB1 i))) - (COND - ((NULL temp) - (push temp word)) - (T (NCONC1 temp word] - (COND - ((EQ charcode (CHARCODE %()) - (SETQ words (APPEND words temp)) - (SETQ temp NIL)) - ((EQ charcode (CHARCODE %))) - (SETQ words (APPEND words (LIST temp))) - (SETQ temp NIL] - (SETQ words (APPEND words temp)) - words]) ) (DEFINEQ (TEdit.PrintPhraseSearch - [LAMBDA (stream dict words) (* jtm%: "26-May-87 09:26") - - (* * prints out the definitions that have a particular phrase in them.) - - (OR stream (SETQ stream (Dict.OutputStream))) - (DictTool.TEditWrapper (NerdForStream stream) - 'DictTool.PrintPhraseSearch stream words "Type phrase to search for:" - "Searching for phrase using" 'SEARCHPHRASE]) (DictTool.PrintPhraseSearch - [LAMBDA (dict selection stream) (* jtm%: "26-May-87 09:29") - (LET (looks words fn pos) - [SETQ words (COND - [(InvertedDict.Prop dict 'RemoteDict) - (DICTCLIENT.SEARCHFORPHRASE selection (InvertedDict.Prop dict 'RemoteDict] - ((SETQ fn (InvertedDict.Prop dict 'SEARCHFORPHRASEFN)) - (APPLY* fn dict selection] - (SETQ pos (TEDIT.GETPOINT stream)) - (TEDIT.INSERT stream (CONCAT "%"" selection "%": ")) - (SETQ looks (CONS pos (IDIFFERENCE (TEDIT.GETPOINT stream) - pos))) - [for word on words do (TEDIT.INSERT stream (CONCAT (CAR word) - (COND - ((CDR word) - "; ") - (T ""] - (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) - (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) (* do the looks last to avoid messing - up the text placement.) - (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) - 1 - (TEDIT.GETPOINT stream)) - (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) - (CAR looks) - (CDR looks)) - words]) ) (DEFINEQ (TEdit.PrintSynonyms - [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") - - (* * prints out the synonyms of the selected word) - - (DictTool.TEditWrapper T 'DictTool.PrintSynonyms stream words "synonym to look up:" - "Getting synonyms for" 'USERSYNONYM]) (REMOVEALL - [LAMBDA (X L) (* jtm%: "14-Oct-87 12:39") - (for TAIL on X unless (EQUAL L (CAR TAIL)) collect (COND - ((LISTP (CAR TAIL)) - (REMOVEALL (CAR TAIL) - L)) - (T (COPY (CAR TAIL]) (CONVERTFUNCTIONSTOFORMS - [LAMBDA (LIST) (* jtm%: "14-Oct-87 12:57") - (for ELT in LIST collect (COND - [(EQ (CAR ELT) - 'FUNCTION) - (LIST 'QUOTE (LIST (CADR ELT] - ((LISTP ELT) - (CONVERTFUNCTIONSTOFORMS ELT)) - (T (COPY ELT]) (TEdit.PrintNounSynonyms - [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:43") - - (* * prints out the synonyms of the selected word) - - (DictTool.TEditWrapper T (FUNCTION DictTool.PrintNounSynonyms) - stream words "synonym to look up:" "Getting noun synonyms for" 'USERSYNONYM]) (DictTool.PrintNounSynonyms - [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:32") - (DictTool.PrintSynonyms dict words stream "n"]) (DictTool.PrintVerbSynonyms - [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:34") - (DictTool.PrintSynonyms dict words stream "v"]) (DictTool.PrintAdjSynonyms - [LAMBDA (dict words stream) (* jtm%: "14-Oct-87 12:35") - (DictTool.PrintSynonyms dict words stream "adj"]) (TEdit.PrintVerbSynonyms - [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") - - (* * prints out the synonyms of the selected word) - - (DictTool.TEditWrapper T 'DictTool.PrintVerbSynonyms stream words "synonym to look up:" - "Getting verb synonyms for" 'USERSYNONYM]) (TEdit.PrintAdjSynonyms - [LAMBDA (stream dict words) (* jtm%: "14-Oct-87 12:44") - - (* * prints out the synonyms of the selected word) - - (DictTool.TEditWrapper T 'DictTool.PrintAdjSynonyms stream words "synonym to look up:" - "Getting adjective synonyms for" 'USERSYNONYM]) (DictTool.PrintSynonyms - [LAMBDA (dict words stream form) (* jtm%: "14-Oct-87 12:31") - (PROG (synonyms found startPos headerPos endPos) - (for word inside words - do (SETQ synonyms (DICTCLIENT.SYNONYMS word)) - (AND synonyms (SETQ found T)) - (SETQ startPos (TEDIT.GETPOINT stream)) - (TEDIT.INSERT stream (CONCAT word ": ")) - (SETQ headerPos (TEDIT.GETPOINT stream)) - [for class in synonyms when (OR (NULL form) - (EQUAL form (CAR class))) - do (TEDIT.INSERT stream (CONCAT (CAR class) - ": ")) - [for word on (CDR class) do (TEDIT.INSERT stream (CONCAT (CAR word) - (COND - ((CDR word) - ", ") - (T ""] - (TEDIT.INSERT stream (CHARACTER (CHARCODE CR] - (TEDIT.INSERT stream (CHARACTER (CHARCODE CR))) - (SETQ endPos (TEDIT.GETPOINT stream)) - (TEDIT.LOOKS stream '(FAMILY HELVETICA SIZE 10 FACE BOLD) - startPos - (IDIFFERENCE (SUB1 headerPos) - startPos)) - (TEDIT.LOOKS stream '(FAMILY TIMESROMAN SIZE 10 FACE STANDARD) - headerPos - (IDIFFERENCE endPos headerPos)) - (TEDIT.SETSEL stream endPos 0 'LEFT)) - (RETURN found]) ) (DEFINEQ (DictTool.TEditWrapper - [LAMBDA (dict proc stream selection promptString waitString cachePropName) - (* jtm%: "29-Jun-88 09:56") - - (* * handles the TEdit user interface) - - (PROG (scratchStream textStream startPos startTime textObj) - - (* * set things up) - - [COND - ((NULL stream) - (SETQ stream (Dict.OutputStream] - [COND - ((NULL dict) - (TEDIT.PROMPTPRINT stream "Please select a dictionary." T) - (RETURN)) - ((NULL selection) - (SETQ selection (TEDIT.SEL.AS.STRING stream)) - (COND - ((ILEQ (NCHARS selection) - 1) - (SETQ selection NIL))) - - (* * "rht 4/27/88: No longer passes value of PROMPTWINDOW textprop to MOUSECONFIRM since it could be DON'T. Now looks for promptwindow on the WINDOWPROP of the stream's main window.") - - (COND - [(AND selection (MOUSECONFIRM (CONCAT "CONFIRM INPUT: " selection) - "" - (CAR (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) - of (TEXTOBJ stream))) - 'PROMPTWINDOW] - ([NULL (SETQ selection (TEDIT.GETINPUT stream (OR promptString "input: ") - (AND cachePropName (STREAMPROP stream cachePropName] - (TEDIT.PROMPTPRINT stream " Aborted." T) - (RETURN] - - (* * print the results.) - - (SETQ startTime (CLOCK 0)) - (AND cachePropName (STREAMPROP stream cachePropName selection)) - (TEDIT.PROMPTPRINT stream (CONCAT (OR waitString "processing") - " '" selection "' . . . ") - T) - [RESETSAVE (OUTPUT (CAR (WINDOWPROP Dict.DefWindow 'PROMPTWINDOW] - (* redirects errors to the - promptwindow) - [SETQ scratchStream (OPENTEXTSTREAM NIL NIL NIL NIL '(LEAVETTY] - (COND - [(APPLY* proc dict selection scratchStream) - (TEDIT.INCLUDESTREAM (Dict.OutputStream) - scratchStream) - (COND - (DictTool.TimeOperation (TEDIT.PROMPTPRINT stream (CONCAT "Elapsed Time: " - (QUOTIENT - (DIFFERENCE (CLOCK 0) - startTime) - 1000.0) - " seconds."))) - (T (TEDIT.PROMPTPRINT stream "Done."] - (T (TEDIT.PROMPTPRINT stream "not found.") - (TEDIT.PROMPTFLASH stream))) - (CLOSEF scratchStream]) (Dict.OutputStream - [LAMBDA (REGION) (* ; "Edited 12-Oct-88 09:20 by rmk:") - (* ; "Edited 7-Oct-88 12:01 by jtm:") - (LET (TEXTSTREAM HIDDENFN UNHIDEFN) - [COND - ((AND Dict.DefWindow (NOT (OPENWP Dict.DefWindow)) - (WINDOWPROP Dict.DefWindow 'TEXTSTREAM)) (* window is shrunk.) - (OPENW Dict.DefWindow)) - ((AND Dict.DefWindow (CL:FIND-PACKAGE "ROOMS") - (SETQ HIDDENFN (CL:FIND-SYMBOL "WINDOW-HIDDEN?" "ROOMS")) - (GETD HIDDENFN) - (CL:FUNCALL HIDDENFN Dict.DefWindow)) - - (* the FIND-SYMBOL calls are used to avoid a break that happens when you access - the ROOMS package when it hasn't been loaded.) - - (SETQ UNHIDEFN (CL:FIND-SYMBOL "UN-HIDE-WINDOW" "ROOMS")) - (CL:FUNCALL UNHIDEFN Dict.DefWindow)) - ((OR (NULL Dict.DefWindow) - (NOT (OPENWP Dict.DefWindow))) - (SETQ Dict.DefWindow (CREATEW [OR REGION (AND Dict.DefWindow (WINDOWPROP Dict.DefWindow - 'REGION] - "Definitions")) - (SETQ TEXTSTREAM (OPENTEXTSTREAM NIL Dict.DefWindow)) - (replace TXTFILE of (TEXTOBJ TEXTSTREAM) with "Definitions") - - (* do the replace before you spawn a TEDIT process in order to avoid a race - condition where sometimes the label on the icon was "T") - - (PROCESSPROP (TEDIT TEXTSTREAM Dict.DefWindow NIL '(LEAVETTY)) - 'NAME - 'DICTIONARY] - (TEXTSTREAM Dict.DefWindow]) (DictTool.PromptStream - [LAMBDA (stream) (* jtm%: "29-Sep-86 11:11") - (COND - [(STREAMPROP stream) - (for window inside (STREAMPROP stream 'WINDOW) do (COND - ((WINDOWPROP window 'PROMPTWINDOW) - (RETURN (WINDOWPROP window ' - PROMPTWINDOW] - (T PROMPTWINDOW]) ) (DEFINEQ (DictTool.Init - [LAMBDA (serverName) (* jtm%: "13-Oct-87 11:37") - (PROG (analyzer dict wordNerd) - - (* * start up the interface) - - (Dict.AddCommands) - - (* * create the analyzer) - - [Analyzer.Establish (SETQ analyzer (create Morphalyzer - analyzerName _ 'DictServer - openFn _ (FUNCTION DictTool.OpenAnalyzer) - closeFn _ (FUNCTION DictTool.Close) - analyzeFn _ (FUNCTION DictTool.Analyze) - correctionsFn _ (FUNCTION DictTool.Corrections] - (Analyzer.Prop analyzer 'CountWords (FUNCTION DictTool.CountWords)) - - (* * create the dictionary) - - [Dict.Establish (SETQ dict (create Dict - dictName _ 'DictServer - openFn _ (FUNCTION DictTool.OpenDictionary) - closeFn _ (FUNCTION DictTool.Close) - getEntryFn _ (FUNCTION DictTool.GetEntry) - printEntryFn _ (FUNCTION DictTool.PrintDefinition] - - (* * create the remote inverted dict.) - - [InvertedDict.Establish (SETQ wordNerd (create INVERTEDDICT - INVERTEDDICTNAME _ 'DictServer] - (InvertedDict.Prop wordNerd 'OPENFN (FUNCTION DictTool.OpenNerd)) - (InvertedDict.Prop wordNerd 'DICTIONARY dict]) (DictTool.Open - [LAMBDA (analyzer errors) (* jtm%: "13-Oct-87 10:43") - - (* * we import the interface here instead of in DictTool.Init to avoid hanging - the LOAD.) - - (PROG (analyzers dictionaries menuItems) - (COND - [(type? Morphalyzer analyzer) - (COND - ((NULL (Analyzer.Prop analyzer 'RemoteDict)) - (SETQ analyzers (DictTool.Analyzers analyzer errors)) - [SETQ menuItems (for i in analyzers collect (LIST i (LIST 'QUOTE i] - (COND - ((IGEQ 1 (LENGTH menuItems)) - (Analyzer.Prop analyzer 'RemoteDict (CAR analyzers))) - (T (Analyzer.Prop analyzer 'RemoteDict - (OR (MENU (create MENU - ITEMS _ menuItems - TITLE _ (CONCAT (fetch (Morphalyzer analyzerName) - of analyzer) - " analyzers") - CENTERFLG _ T)) - (CAR analyzers))) - (for i analyzerName in analyzers - do (SETQ analyzerName (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) - of analyzer) - ": " i))) - (COND - ([NOT (for j in Analyzer.List thereis (EQ analyzerName ( - Analyzer.Name - j] - (push Analyzer.List (create Morphalyzer copying analyzer)) - (Analyzer.Prop (CAR Analyzer.List) - 'RemoteDict i] - ((type? Dict analyzer) - (COND - ((NULL (Dict.Prop analyzer 'RemoteDict)) - (SETQ dictionaries (DictTool.Dictionaries analyzer errors)) - [SETQ menuItems (for i in dictionaries collect (LIST i (LIST 'QUOTE i] - (COND - ((IGEQ 1 (LENGTH menuItems)) - (Dict.Prop analyzer 'RemoteDict (CAR dictionaries))) - (T (Dict.Prop analyzer 'RemoteDict - (OR (MENU (create MENU - ITEMS _ menuItems - TITLE _ (CONCAT (fetch (Dict dictName) of analyzer) - " dictionaries") - CENTERFLG _ T)) - (CAR dictionaries))) - (for i dictName in dictionaries - do (SETQ dictName (MKATOM (CONCAT (fetch (Dict dictName) of analyzer) - ": " i))) - (COND - ([NOT (for j in Dict.DictionaryList thereis (EQ dictName - (Dict.Name j] - (push Dict.DictionaryList (create Dict copying analyzer)) - (Dict.Prop (CAR Dict.DictionaryList) - 'RemoteDict i]) (DictTool.OpenDictionary - [LAMBDA (dict errors) (* jtm%: "13-Oct-87 10:38") - - (* * we import the interface here instead of in DictTool.Init to avoid hanging - the LOAD.) - - (PROG (dictionaries menuItems) - (COND - ((type? Dict dict) - (COND - ((NULL (Dict.Prop dict 'RemoteDict)) - (SETQ dictionaries (DICTCLIENT.DICTIONARIES)) - [SETQ menuItems (for i in dictionaries collect (LIST i (LIST 'QUOTE i] - (COND - ((IGEQ 1 (LENGTH menuItems)) - (Dict.Prop dict 'RemoteDict (CAR dictionaries))) - (T (Dict.Prop dict 'RemoteDict - (OR (MENU (create MENU - ITEMS _ menuItems - TITLE _ (CONCAT (fetch (Dict dictName) of dict) - " dictionaries") - CENTERFLG _ T)) - (CAR dictionaries))) - (for i dictName in dictionaries - do (SETQ dictName (MKATOM (CONCAT (fetch (Dict dictName) of dict) - ": " i))) - (COND - ([NOT (for j in Dict.DictionaryList thereis (EQ dictName - (Dict.Name j] - (push Dict.DictionaryList (create Dict copying dict)) - (Dict.Prop (CAR Dict.DictionaryList) - 'RemoteDict i]) (DictTool.OpenAnalyzer - [LAMBDA (analyzer errors) (* jtm%: "13-Oct-87 10:43") - - (* * we import the interface here instead of in DictTool.Init to avoid hanging - the LOAD.) - - (PROG (analyzers menuItems) - (COND - ((type? Morphalyzer analyzer) - (COND - ((NULL (Analyzer.Prop analyzer 'RemoteDict)) - (SETQ analyzers (DICTCLIENT.LANGUAGES)) - [SETQ menuItems (for i in analyzers collect (LIST i (LIST 'QUOTE i] - (COND - ((IGEQ 1 (LENGTH menuItems)) - (Analyzer.Prop analyzer 'RemoteDict (CAR analyzers))) - (T (Analyzer.Prop analyzer 'RemoteDict - (OR (MENU (create MENU - ITEMS _ menuItems - TITLE _ (CONCAT (fetch (Morphalyzer analyzerName) - of analyzer) - " analyzers") - CENTERFLG _ T)) - (CAR analyzers))) - (for i analyzerName in analyzers - do (SETQ analyzerName (MKATOM (CONCAT (fetch (Morphalyzer analyzerName) - of analyzer) - ": " i))) - (COND - ([NOT (for j in Analyzer.List thereis (EQ analyzerName ( - Analyzer.Name - j] - (push Analyzer.List (create Morphalyzer copying analyzer)) - (Analyzer.Prop (CAR Analyzer.List) - 'RemoteDict i]) (DictTool.OpenNerd - [LAMBDA (nerd errors) (* jtm%: "13-Oct-87 14:35") - - (* * we import the interface here instead of in DictTool.Init to avoid hanging - the LOAD.) - - (PROG (nerds menuItems dict remote) - (COND - ((type? INVERTEDDICT nerd) - (COND - ((NULL (InvertedDict.Prop nerd 'RemoteDict)) - (SETQ nerds (DICTCLIENT.RESOURCES 'INDICES)) - [SETQ menuItems (for i in nerds collect (LIST i (LIST 'QUOTE i] - (COND - ((IGEQ 1 (LENGTH menuItems)) - (InvertedDict.Prop nerd 'RemoteDict (CAR nerds))) - (T [InvertedDict.Prop nerd 'RemoteDict - (SETQ remote (OR (MENU (create MENU - ITEMS _ menuItems - TITLE _ (CONCAT (fetch (INVERTEDDICT - INVERTEDDICTNAME - ) of nerd) - " databases") - CENTERFLG _ T)) - (CAR nerds] - (COND - ((SETQ dict (InvertedDict.Prop nerd 'DICTIONARY)) - (SETQ dict (COPYALL dict)) - (Dict.Prop dict 'RemoteDict remote) - (InvertedDict.Prop nerd 'DICTIONARY dict))) - (for i in nerds do (COND - ((NOT (InvertedDictFromName (fetch (INVERTEDDICT - INVERTEDDICTNAME - ) - of nerd) - i)) - (push InvertedDict.List (create INVERTEDDICT - copying nerd)) - (InvertedDict.Prop (CAR InvertedDict.List) - 'RemoteDict i) - (COND - ((SETQ dict (InvertedDict.Prop (CAR - InvertedDict.List - ) - 'DICTIONARY)) - (SETQ dict (COPYALL dict)) - (Dict.Prop dict 'RemoteDict i) - (InvertedDict.Prop (CAR InvertedDict.List) - 'DICTIONARY dict]) (Dict.AddCommands - [LAMBDA NIL (* ; "Edited 27-Mar-91 17:19 by jtm:") - (* ; "Edited 31-May-89 15:06 by jtm:") - (* ; "Edited 31-May-89 15:00 by jtm:") - (* ; "Edited 31-May-89 13:36 by jtm:") - (LET (menuItems) - [SETQ menuItems '(Dictionary (FUNCTION TEdit.PrintDefinition) - "Prints the definition of the selected word. Prompts the user for a word if there isn't a selection." - (SUBITEMS (Set% Dictionary (FUNCTION TEdit.SetDictionary) - - "Gives the user a menu of dictionaries to select from." - ) - (Get% Definition (FUNCTION TEdit.PrintDefinition) - "Prints the definition of the selected word. Prompts the user for a word if there isn't a selection." - ) - (Get% Synonyms (FUNCTION TEdit.PrintSynonyms) - - "Prints the synonyms of the selected word. Prompts the user for a word if there isn't a selection." - (SUBITEMS (nouns (FUNCTION TEdit.PrintNounSynonyms) - "Only prints the noun form synonyms." - ) - (verbs (FUNCTION TEdit.PrintVerbSynonyms) - "Only prints the verb form synonyms.") - (adjectives (FUNCTION TEdit.PrintAdjSynonyms) - - "Only prints the adjective form synonyms." - ))) - (Relevance% Feedback (FUNCTION TEdit.SearchMenu)) - (|Search For Word| (FUNCTION TEdit.PrintSearch) - "Prints the words in the dictionary containing at least two of the keywords in the selection. Prompts the user for keywords if there aren't any keywords selected." - (SUBITEMS (Set% Database (FUNCTION TEdit.SetNerd) - - "Gives the user a menu of dictionaries to select from." - ) - (Max% Words (FUNCTION DictTool.PromptForCutoff) - - "Lets the user set the maximum number of words to be returned for a set of keywords." - ) - (Min% Keywords (FUNCTION - DictTool.PromptForKeywordCutoff - ) - - "Lets the user determine the minimum number of keywords needed by a word for it to accepted." - ) - (|Search For Phrase| (FUNCTION - TEdit.PrintPhraseSearch) - "Searches a dictionary for a particular phrase, using the Search For Word database to narrow the search. This can be an expensive operation, so please use it sparingly." - ] - (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU menuItems) - - (* ;; "add menu item to Lafite's display menu if Lafite has been loaded.") - - [COND - ((BOUNDP '\LAFITE.ACTIVE) - (pushnew LAFITE.EXTRA.DISPLAY.COMMANDS menuItems) - (if \LAFITE.ACTIVE - then (LAFITE.COMPUTE.CACHED.VARS] - (PUTASSOC 'Dictionary (CONVERTFUNCTIONSTOFORMS (CDR menuItems)) - BackgroundMenuCommands) - (SETQ BackgroundMenu NIL]) (DictTool.Close - [LAMBDA (analyzer) (* jtm%: "13-Nov-86 10:58") - (CLOSEF DICTSERVERSTREAM]) ) (DEFINEQ (DictTool.Analyze - [LAMBDA (analyzer stream fromLoc length analFn) (* jtm%: "14-Apr-87 14:16") - (PROG (buffer bufferStream bufferLength char returnValue userWords (substring (ALLOCSTRING 0 32)) - (maxBufferLength 5100) - (offset fromLoc)) - (SETQ userWords (Analyzer.Prop analyzer 'UserDict)) - [COND - ((NULL stream) - NIL) - [(STRINGP stream) - (HELP "DictTool.Analyze not implemented for STRING") - [SETQ returnValue (DICTCLIENT.PROOFREAD stream (Analyzer.Prop analyzer 'RemoteDict] - (COND - ((EQUAL 0 (CDR returnValue)) - (RETURN (SETQ returnValue NIL] - (T - - (* * break up the stream into strings of ~5000 characters.) - - (SETQ buffer (ALLOCSTRING (IMIN length maxBufferLength))) - (SETQ bufferStream (OPENSTRINGSTREAM buffer 'OUTPUT)) - (SETFILEPTR stream fromLoc) - (while (IGREATERP length 0) - do (SETFILEPTR bufferStream 0) - (SETQ bufferLength 0) - [do (SETQ char (BIN stream)) - [COND - ((OR (NOT (NUMBERP char)) - (IGREATERP char 255)) - (SETQ char (CHARCODE % ] - (BOUT bufferStream char) - (add length -1) - (add bufferLength 1) - (COND - ((EQUAL length 0) - (RETURN)) - ((EQUAL bufferLength maxBufferLength) - (RETURN)) - ((IGREATERP bufferLength (IDIFFERENCE maxBufferLength 200)) - (COND - ([OR (EQ char (CHARCODE CR)) - (AND (EQ char (CHARCODE SP)) - (IGREATERP bufferLength (IDIFFERENCE maxBufferLength 50] - (RETURN] - [SETQ returnValue (DICTCLIENT.PROOFREAD (COND - ((EQUAL bufferLength (NCHARS buffer) - ) - buffer) - (T (SUBSTRING buffer 1 bufferLength - substring))) - (Analyzer.Prop analyzer 'RemoteDict] - (COND - ((EQUAL 0 (CDR returnValue)) - (SETQ returnValue NIL) - (add offset bufferLength)) - ((AND userWords (Dict.GetEntry userWords (SUBSTRING buffer - (ADD1 (CAR returnValue)) - (IPLUS (CAR returnValue) - (CDR returnValue)) - substring))) - [add length (IPLUS bufferLength (IMINUS (IPLUS (CAR returnValue) - (CDR returnValue] - (add offset (IPLUS (CAR returnValue) - (CDR returnValue))) - (SETFILEPTR stream offset) - (SETQ returnValue NIL)) - (returnValue (add (CAR returnValue) - offset) - (RETURN returnValue] - (RETURN returnValue]) (DictTool.Analyzers - [LAMBDA (analyzer errorStream) (* jtm%: "13-Nov-86 10:57") - - (* * wraps DictTool.RPCCall around a call to RemoteDict.Analyzers) - - (DICTCLIENT.LANGUAGES]) (DictTool.Pronunciation - [LAMBDA (word dictName) (* jtm%: "13-Nov-86 10:58") - [COND - ((NOT (STRINGP word)) - (SETQ word (MKSTRING word] - [COND - ((NULL dictName) - (SETQ dictName 'AmericanHeritage] - (DICTCLIENT.PRONUNCIATION word dictName]) (DictTool.Corrections - [LAMBDA (analyzer stream loc len) (* jtm%: "13-Nov-86 10:58") - (DICTCLIENT.CORRECTIONS (COND - ((STRINGP stream) - stream) - (T (STREAM.FETCHSTRING stream loc len))) - (Analyzer.Prop analyzer 'RemoteDict]) (DictTool.CountWords - [LAMBDA (analyzer stream fromLoc length analFn) (* jtm%: "13-Nov-86 14:19") - (PROG (buffer bufferStream bufferLength char (n 0) - (substring (ALLOCSTRING 0 32)) - (maxBufferLength 5100) - (offset fromLoc)) - [COND - ((NULL stream) - NIL) - [(STRINGP stream) - (HELP "DictTool.Analyze not implemented for STRING") - [SETQ n (DICTCLIENT.PROOFREAD stream (Analyzer.Prop analyzer 'RemoteDict] - (COND - ((EQUAL 0 (CDR n)) - (RETURN (SETQ n NIL] - (T - - (* * break up the stream into strings of ~5000 characters.) - - (SETQ buffer (ALLOCSTRING (IMIN length maxBufferLength))) - (SETQ bufferStream (OPENSTRINGSTREAM buffer 'OUTPUT)) - (SETFILEPTR stream fromLoc) - (while (IGREATERP length 0) - do (SETFILEPTR bufferStream 0) - (SETQ bufferLength 0) - [do (SETQ char (BIN stream)) - [COND - ((OR (NOT (NUMBERP char)) - (IGREATERP char 255)) - (SETQ char (CHARCODE % ] - (BOUT bufferStream char) - (add length -1) - (add bufferLength 1) - (COND - ((EQUAL length 0) - (RETURN)) - ((EQUAL bufferLength maxBufferLength) - (RETURN)) - ((IGREATERP bufferLength (IDIFFERENCE maxBufferLength 200)) - (COND - ([OR (EQ char (CHARCODE CR)) - (AND (EQ char (CHARCODE SP)) - (IGREATERP bufferLength (IDIFFERENCE maxBufferLength 50] - (RETURN] - [add n (DICTCLIENT.COUNTWORDS (COND - ((EQUAL bufferLength (NCHARS buffer)) - buffer) - (T (SUBSTRING buffer 1 bufferLength substring) - )) - (Analyzer.Prop analyzer 'RemoteDict] - (add offset bufferLength] - (RETURN n]) ) (* * FINDWORD & SUBSTITUTEWORD) (DEFINEQ (DictTool.FindWord - [LAMBDA (STREAM WORD CH) (* jtm%: "30-Apr-86 10:30") - (* the TEDIT interface to FindWord) - (PROG (SEL (TEXTOBJ (TEXTOBJ STREAM))) - - (* * prompt the user for a string if none is given.) - - [COND - ((NULL WORD) - (SETQ WORD (TEDIT.GETINPUT TEXTOBJ "Word to find: " (WINDOWPROP W ' - TEDIT.LAST.FIND.STRING) - (CHARCODE (EOL LF ESC] - - (* * search for the word.) - - [COND - (WORD (SETQ SEL (fetch SEL of TEXTOBJ)) - (\SHOWSEL SEL NIL NIL) - (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) - (SETQ CH (LingFns.FindWord STREAM WORD CH)) - - (* * show the user what we found) - - (COND - (CH (TEDIT.PROMPTPRINT TEXTOBJ "Done.") - (replace CH# of SEL with (CAR CH)) - [replace DCH of SEL with (IPLUS (CAR CH) - (IMINUS (CADR CH] - (replace CHLIM of SEL with (ADD1 (CADR CH))) - (replace POINT of SEL with 'RIGHT) - (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) - (\FIXSEL SEL TEXTOBJ) - (TEDIT.NORMALIZECARET TEXTOBJ) - (\SHOWSEL SEL NIL T) - (WINDOWPROP W 'TEDIT.LAST.FIND.STRING WORD) - (* And get it into the window) - ) - (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found).") - (\SHOWSEL SEL NIL T] - (replace \INSERTNEXTCH of TEXTOBJ with -1]) (DictTool.SubstituteWord - [LAMBDA (TEXTSTREAM PATTERN REPLACEMENT CONFIRM? DICTNAME) (* jtm%: "24-Mar-87 08:58") - (* this procedure is a modification of - TEDIT.SUBSTITUTE.) - (PROG (SEARCHSTRING REPLACESTRING ABORTFLG OUTOFRANGEFLG (TEXTOBJ (TEXTOBJ TEXTSTREAM)) - ENDCHAR# STARTCHAR# RANGE (REPLACEDFLG 0) - (YESLIST '("y" "Y" "yes" "Yes" "YES" "T")) - CONFIRMFLG SEL PC# SELCH# SELCHLIM SELPOINT CRSEEN DICT) - (COND - ([NULL (SETQ SEARCHSTRING (OR PATTERN (TEDIT.GETINPUT TEXTOBJ "Search word:"] - (* If the search pattern is empty, - bail out.) - (TEDIT.PROMPTPRINT TEXTOBJ "[Aborted]") - (RETURN))) - (SETQ REPLACEMENT (OR REPLACEMENT (TEDIT.GETINPUT TEXTOBJ "Replace word:") - "")) (* jtm%: use REPLACEMENT for the - original, REPLACESTRING for the - modified word.) - (SETQ CRSEEN (STRPOS (CHARACTER (CHARCODE CR)) - REPLACEMENT)) (* jtm%: use REPLACEMENT instead of - REPLACESTRING) - (COND - (PATTERN (* If a pattern is specd in the call, - use the caller's confirm flag.) - (SETQ CONFIRMFLG CONFIRM?)) - (T (* Otherwise, ask for one.) - (SETQ CONFIRMFLG T) (* SETQ CONFIRMFLG (MEMBER - (TEDIT.GETINPUT TEXTOBJ - "Ask before each replace?" "Yes" - (CHARCODE (EOL SPACE ESCAPE LF TAB))) - YESLIST)) - (* jtm%: change default to "Yes") - )) - (TEDIT.PROMPTPRINT TEXTOBJ "Substituting..." T) - (SETQ DICT (DictTool.CreateConjugationMap DICTNAME SEARCHSTRING REPLACEMENT)) - (SETQ SEL (fetch SEL of TEXTOBJ)) (* STARTCHAR# and ENDCHAR# are the - bound of the search) - (\SHOWSEL SEL NIL NIL) - (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* Turn off any blue pending delete) - (SETQ STARTCHAR# (fetch CH# of SEL)) - [SETQ ENDCHAR# (IPLUS STARTCHAR# (SUB1 (fetch DCH of SEL] - (while (AND (SETQ RANGE (LingFns.FindWord TEXTSTREAM SEARCHSTRING STARTCHAR# DICT) - (* jtm%: use FindWord for TEDIT.FIND) - ) - (NOT ABORTFLG)) - do (SETQ REPLACESTRING (CADDR RANGE)) (* jtm%: add the suffix.) - [PROG (PENDING.SEL CHOICE) - (COND - [CONFIRMFLG (SETQ PENDING.SEL (TEDIT.SETSEL TEXTSTREAM (CAR RANGE) - (IDIFFERENCE (CADR RANGE) - (SUB1 (CAR RANGE))) - 'RIGHT)) - (TEDIT.SHOWSEL TEXTSTREAM T PENDING.SEL) - (TEDIT.NORMALIZECARET TEXTOBJ SEL) - [SETQ CHOICE - (COND - [(LISTP REPLACESTRING) - (SETQ REPLACESTRING - (MENU (create MENU - ITEMS _ (CONS "*QUIT*" REPLACESTRING) - CENTERFLG _ T - CHANGEOFFSETFLG _ T - TITLE _ "substitutions"] - (T (TEDIT.GETINPUT TEXTOBJ (CONCAT "Substitute '" REPLACESTRING - "'? ['q' quits]") - "Yes" - (CHARCODE (EOL SPACE ESCAPE LF TAB] - (COND - ((MEMBER CHOICE '("*QUIT*" "Q" "q")) - (SETQ ABORTFLG T) - (GO L1)) - ((MEMBER CHOICE '(NIL "n" "N" "no" "NO")) - (* turn off selection) - (TEDIT.SHOWSEL TEXTSTREAM NIL PENDING.SEL) - (RPLACA RANGE (IDIFFERENCE (CADR RANGE) - (NCHARS REPLACESTRING))) - (GO L1)) - (T (* OK to replace) - (TEDIT.DELETE TEXTSTREAM PENDING.SEL) - (* make the replacement) - (COND - ((NOT (EQUAL REPLACESTRING "")) - (* If the replacestring is nothing, - why bother to add nothing) - (TEDIT.INSERT TEXTSTREAM REPLACESTRING (CAR RANGE)) - [SETQ ENDCHAR# (IPLUS ENDCHAR# - (IDIFFERENCE - (NCHARS REPLACESTRING) - (IDIFFERENCE (CADR RANGE) - (SUB1 (CAR RANGE] - (add REPLACEDFLG 1] - (T (* No confirmation required. - Do the substitutions without showing - intermediate work) - (SETQ PC# (\DELETECH (CAR RANGE) - (CADR RANGE) - (ADD1 (IDIFFERENCE (CADR RANGE) - (CAR RANGE))) - TEXTOBJ)) - (\FIXDLINES (fetch LINES of TEXTOBJ) - SEL - (CAR RANGE) - (CADR RANGE) - TEXTOBJ) - [COND - ((NOT (EQUAL REPLACESTRING "")) - (* If the replacestring is nothing, - why bother to add nothing) - (COND - [CRSEEN (for ACHAR instring REPLACESTRING as NCH# - from (CAR RANGE) by 1 - do (SELCHARQ ACHAR - (CR (\INSERTCR ACHAR NCH# TEXTOBJ)) - (\INSERTCH ACHAR NCH# TEXTOBJ] - (T (\INSERTCH REPLACESTRING (CAR RANGE) - TEXTOBJ PC#))) - (SETQ ENDCHAR# (IPLUS ENDCHAR# (IDIFFERENCE - (NCHARS REPLACESTRING) - (IDIFFERENCE (CADR RANGE) - (SUB1 (CAR RANGE] - (add REPLACEDFLG 1))) - L1 (SETQ STARTCHAR# (IPLUS (CAR RANGE) - (NCHARS REPLACESTRING] - (* start looking where you left off)) - (COND - ((ZEROP REPLACEDFLG) - (TEDIT.PROMPTPRINT TEXTOBJ "No replacements made." T)) - ((EQUAL REPLACEDFLG 1) - (TEDIT.PROMPTPRINT TEXTOBJ "1 Replacement made." T)) - (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (MKSTRING REPLACEDFLG) - " Replacements made.") - T))) - (COND - ((AND (NOT CONFIRMFLG) - (NOT (ZEROP REPLACEDFLG))) (* There WERE replacements, and they - were not confirmed.) - (replace CHLIM of SEL with ENDCHAR#) - [replace DCH of SEL with (ADD1 (IDIFFERENCE (fetch CHLIM of SEL) - (fetch CH# of SEL] - (\TEDIT.MARK.LINES.DIRTY TEXTOBJ (fetch CH# of SEL) - (fetch CHLIM of SEL)) - (TEDIT.UPDATE.SCREEN TEXTOBJ) - (\FIXSEL SEL TEXTOBJ) - (\SHOWSEL SEL NIL T))) - (RETURN REPLACEDFLG]) (DictTool.CreateConjugationMap - [LAMBDA (language word1 word2) (* jtm%: "24-Mar-87 09:06") - - (* * creates a conjugation dictionary that maps word1 into word2.) - - (PROG [fullconj1 fullconj2 pp1 pp2 prior (dict (SimpleDict.New 'map] - [COND - [word2 (SETQ fullconj1 (DICTCLIENT.CONJUGATE word1 NIL NIL language)) - (SETQ fullconj2 (DICTCLIENT.CONJUGATE word2 NIL NIL language)) - (SETQ pp1 (FASSOC 'pp fullconj1)) - (SETQ pp2 (FASSOC 'pp fullconj2)) - [COND - [(AND pp1 (NULL pp2) - (FASSOC 'v fullconj2)) - (push fullconj2 (CONS 'pp (CDR (FASSOC 'pst fullconj2] - ((AND pp2 (NULL pp1) - (FASSOC 'v fullconj1)) - (push fullconj1 (CONS 'pp (CDR (FASSOC 'pst fullconj1] - (for conj1 conj2 entry in fullconj1 - do (SETQ conj2 (FASSOC (CAR conj1) - fullconj2)) - (AND conj2 (for caps oldValue newValue in '(NONE FIRST ALL) - do (SETQ entry (LingFns.Capitalize (CADR conj1) - caps)) - (SETQ oldValue (Dict.GetEntry dict entry)) - (SETQ newValue (LingFns.Capitalize (CADR conj2) - caps)) - (SETQ newValue (COND - ((for i inside oldValue - thereis (STREQUAL i newValue)) - oldValue) - ((LISTP oldValue) - (CONS newValue oldValue)) - (oldValue (LIST newValue oldValue)) - (T newValue))) - (Dict.PutEntry dict entry newValue] - (T (for conjugation in (DICTCLIENT.CONJUGATE word1 NIL language) - do (for caps in '(NONE FIRST ALL) do (Dict.PutEntry dict (LingFns.Capitalize - (CADR conjugation) - caps) - T] - (RETURN dict]) (DictTool.FindWordInit - [LAMBDA NIL (* jtm%: "26-Feb-87 13:46") - - (* * add items to TEDIT's menu.) - - [for ITEM on (fetch (MENU ITEMS) of TEDIT.DEFAULT.MENU) - do (COND - [(EQ (CAR ITEM) - 'Find) - (RPLACA ITEM '(Find 'Find NIL (SUBITEMS (FindWord (FUNCTION DictTool.FindWord) - - "Looks for a word independent of its inflection or capitalization." - ] - ((EQ (CAR ITEM) - 'Substitute) - (RPLACA ITEM '(Substitute 'Substitute NIL (SUBITEMS (SubstituteWord - (FUNCTION DictTool.SubstituteWord) - - "Substitutes one word for another, keeping the same capitalization and inflectional form." - ] - - (* * force the menu to be recomputed.) - - (COND - ((EQ (fetch MENUCOLUMNS of TEDIT.DEFAULT.MENU) - 1) (* If there is only one column, force - a re-figuring of the number of rows) - (replace MENUROWS of TEDIT.DEFAULT.MENU with NIL)) - ((EQ (fetch MENUROWS of TEDIT.DEFAULT.MENU) - 1) (* There's only one row, so recompute - %# of columns.) - (replace MENUCOLUMNS of TEDIT.DEFAULT.MENU with NIL))) - (replace ITEMWIDTH of TEDIT.DEFAULT.MENU with 10000) - (replace ITEMHEIGHT of TEDIT.DEFAULT.MENU with 10000) - (replace IMAGE of TEDIT.DEFAULT.MENU with NIL) (* Force it to create a new menu - image.) - (UPDATE/MENU/IMAGE TEDIT.DEFAULT.MENU]) ) (DEFINEQ (LingFns.FindWord - [LAMBDA (STREAM WORD CH DICT) (* jtm%: "24-Mar-87 09:28") - - (* * finds the next instance of WORD in the text stream, independent of how it is - conjugated or capitalized. returns the first character index, the last character - index, the suffix, and the capitalization.) - - (PROG (CHAR NODE END EXPO FIRSTCHAR LASTCHAR U-FIRSTCHAR EOFPTR dictCreated) - - (* * build the dictionary) - - [COND - (WORD (SETQ WORD (MKSTRING WORD)) - [COND - ((NULL DICT) - (SETQ DICT (STREAMPROP STREAM 'FINDWORDMAP)) - (COND - ((EQUAL WORD (CAR DICT)) - (SETQ DICT (CDR DICT))) - (T (SETQ DICT (DictTool.CreateConjugationMap NIL WORD)) - (STREAMPROP STREAM 'FINDWORDMAP (CONS WORD DICT] - - (* * initialize.) - - [COND - ((NULL CH) - (SETQ CH (TEDIT.GETPOINT STREAM] - (SETQ CH (SUB1 CH)) - (SETQ EOFPTR (GETEOFPTR STREAM)) - (COND - ((GREATERP CH EOFPTR) - (RETURN)) - (T (SETFILEPTR STREAM CH))) - [SETQ FIRSTCHAR (CHCON1 (L-CASE (NTHCHAR WORD 1] - [SETQ U-FIRSTCHAR (CHCON1 (U-CASE (NTHCHAR WORD 1] - - (* * search for a word that begins with the first letter.) - - (while (NEQ EOFPTR (GETFILEPTR STREAM)) - do (SETQ LASTCHAR CHAR) - (SETQ CHAR (BIN STREAM)) - (COND - ([AND [OR (NULL LASTCHAR) - (AND (NUMBERP LASTCHAR) - (NOT (ALPHACHARP LASTCHAR] - (NUMBERP CHAR) - (SETQ NODE (FASSOC (CHARACTER CHAR) - (fetch (SimpleDict.Node subnodes) - of (fetch (Dict contents) of DICT] - (SETQ CH (GETFILEPTR STREAM)) - [while NODE do (COND - ((EQP EOFPTR (GETFILEPTR STREAM)) - (SETQ END EOFPTR) - (RETURN)) - ([AND (SETQ CHAR (BIN STREAM)) - (NUMBERP CHAR) - (ALPHACHARP CHAR) - (SETQ NODE (FASSOC (CHARACTER CHAR) - (fetch (SimpleDict.Node - subnodes) - of NODE] - (* is this a legal character?) - ) - (T (RETURN] - (COND - ((SETQ EXPO (fetch (SimpleDict.Node value) of NODE)) - (RETURN] - - (* * we are done.) - - (RETURN (COND - ((AND EXPO CH) - [COND - ((NULL END) - (SETQ END (SUB1 (GETFILEPTR STREAM] - (LIST CH END EXPO]) (LingFns.Capitalize - [LAMBDA (word caps) (* jtm%: " 6-Aug-84 12:53") - - (* * capitalizes word according to the parameter "caps") - - (COND - ((LISTP word) - (for w in word collect (LingFns.Capitalize w caps))) - (T (PROG (stringP litAtom) - (COND - ((STRINGP word) - (SETQ word (UNPACK word)) - (SETQ stringP T)) - ((LITATOM word) - (SETQ word (UNPACK word)) - (SETQ litAtom T))) - [SELECTQ caps - (FIRST [COND - ((NOT (U-CASEP (CAR word))) - (RPLACA word (U-CASE (CAR word] - [for char on (CDR word) do (COND - ((U-CASEP (CAR char)) - (RPLACA char (L-CASE (CAR char]) - (ALL [for char on word do (COND - ((NOT (U-CASEP (CAR char))) - (RPLACA char (U-CASE (CAR char]) - (for char on word do (COND - ((U-CASEP (CAR char)) - (RPLACA char (L-CASE (CAR char] - [COND - [stringP (SETQ word (MKSTRING (PACK word] - (litAtom (SETQ word (PACK word] - (RETURN word]) (LingFns.Capitalization - [LAMBDA (word) (* jtm%: "18-Jul-84 15:19") - - (* * returns NIL, ALL or FIRST) - - (COND - ([OR (NULL word) - (NOT (U-CASEP (CAR word] - NIL) - ([OR (NULL (CDR word)) - (NOT (U-CASEP (CADR word] - 'FIRST) - (T 'ALL]) ) (DictTool.FindWordInit) (RPAQ? DictTool.TimeOperation NIL) (RPAQ? Dict.DefWindow NIL) (RPAQ? Dict.CommandsAdded NIL) (RPAQ? InvertedDict.List NIL) (RPAQ? DictTool.LastSearch NIL) (RPAQ? DictTool.LastWord NIL) (RPAQ? TEdit.DefaultDictionary NIL) (RPAQ? DictTool.MinKeywords 2) (RPAQ? DictTool.MaxWords 100) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DictTool.TimeOperation Dict.DefWindow Dict.CommandsAdded InvertedDict.List DictTool.MinKeywords DictTool.MaxWords DictTool.LastSearch DictTool.LastWord TEdit.DefaultDictionary) ) (DictTool.Init) (RPAQQ PronunciationGuide (("q" "cat" "(kqt)") ("A" "pay" "(pA)") ("Q" "care" "(kQr)") ("*" "father" "(f*%"T5r)") ("b" "bike" "(bIk)") ("ch" "church" "(ch/rch)") ("d" "deed" "(dEd)") ("4" "pet" "(p4t)") ("E" "seed" "(sEd)") ("I" "fife" "(fIf)") ("g" "gag" "(gqg)") ("h" "hat" "(hqt)") ("hw" "which" "(hw9ch)") ("9" "pit" "(p9t)") ("I" "lie" "(lI)") ("7" "pier" "(p7r)") ("j" "judge" "(j8j)") ("k" "kick" "(k9k)") ("l" "lid" "(l9d)") ("l" "needle" "(nEd%"l)") ("m" "mum" "(m8m)") ("n" "no, sudden" "(nO)") ("ng" "thing" "(th9ng)") ("0" "pot" "(p0t)") ("O" "toe" "(tO)") ("" "paw" "(p)") ("oi" "noise" "(noiz)") ("ou" "out" "(out)") ("1" "book" "(b1k)") ("|" "boot" "(b|t)") ("p" "people" "(pE%"p5l)") ("r" "roar" "(rr)") ("s" "sauce" "(ss)") ("sh" "ship" "(sh9p)") ("t" "tight" "(tIt)") ("th" "thin" "(th9n)") ("T" "this" "(T9s)") ("8" "cut" "(k8t)") ("/" "urge" "(/rj)") ("v" "valve" "(vqlv)") ("w" "with" "(w9T, w9th)") ("y" "yes" "(y4s)") ("z" "zebra" "(zE%"br5)") ("zh" "vision" "(v9zh%"5n)") ("5" "about" "(5-bout%")") ("KH" "loch" "(l0KH, l0k)") ("N" "bon" "(b0n; French bN)."))) (RPAQQ PronunciationMap ((%" %') (5 ÿ&fÿ) (/ Ï u) (8 Æ u) (T Î t h) (%| Å o Å o) (1 Æ o Æ o) (% ÿñÑÿ) (O Å o) (0 Æ o) (7 ÿñÀÿ) (I ÿñ¿ÿ) (9 ÿñ¾ÿ) (E Å e) (4 Æ e) (* ÿñ§ÿ) (Q ÿñ£ÿ) (A Å a) (q Æ a))) (PUTPROPS DICTTOOL COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989 1991 1994)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6223 19029 (TEDIT.INCLUDESTREAM 6233 . 6744) (TEdit.PrintDefinition 6746 . 9000) ( DictTool.PrintDefinition 9002 . 11539) (Dict.PrintDefinition 11541 . 12504) (DictTool.GetEntry 12506 . 12805) (TEdit.SetDictionary 12807 . 14966) (DictForStream 14968 . 15335) (DictTool.Dictionaries 15337 . 15491) (PARSEBYCOLONS 15493 . 16542) (PrintPronunciationGuide 16544 . 18015) ( ConvertPronunciation 18017 . 19027)) (19030 28623 (TEdit.SearchMenu 19040 . 19270) (TEdit.PrintSearch 19272 . 19722) (DictTool.PrintSearch 19724 . 21987) (DictTool.MergeSearch 21989 . 23817) ( NerdForStream 23819 . 24129) (TEdit.SetNerd 24131 . 26203) (DictTool.PromptForCutoff 26205 . 26752) ( DictTool.PromptForKeywordCutoff 26754 . 27402) (PARSESELECTION 27404 . 28621)) (28624 30679 ( TEdit.PrintPhraseSearch 28634 . 29096) (DictTool.PrintPhraseSearch 29098 . 30677)) (30680 35475 ( TEdit.PrintSynonyms 30690 . 31019) (REMOVEALL 31021 . 31521) (CONVERTFUNCTIONSTOFORMS 31523 . 32013) ( TEdit.PrintNounSynonyms 32015 . 32366) (DictTool.PrintNounSynonyms 32368 . 32552) ( DictTool.PrintVerbSynonyms 32554 . 32738) (DictTool.PrintAdjSynonyms 32740 . 32925) ( TEdit.PrintVerbSynonyms 32927 . 33269) (TEdit.PrintAdjSynonyms 33271 . 33616) (DictTool.PrintSynonyms 33618 . 35473)) (35476 41064 (DictTool.TEditWrapper 35486 . 38724) (Dict.OutputStream 38726 . 40520) ( DictTool.PromptStream 40522 . 41062)) (41065 59074 (DictTool.Init 41075 . 42805) (DictTool.Open 42807 . 46658) (DictTool.OpenDictionary 46660 . 48555) (DictTool.OpenAnalyzer 48557 . 50740) ( DictTool.OpenNerd 50742 . 54106) (Dict.AddCommands 54108 . 58923) (DictTool.Close 58925 . 59072)) ( 59075 66681 (DictTool.Analyze 59085 . 63133) (DictTool.Analyzers 63135 . 63365) ( DictTool.Pronunciation 63367 . 63687) (DictTool.Corrections 63689 . 64055) (DictTool.CountWords 64057 . 66679)) (66720 84052 (DictTool.FindWord 66730 . 68741) (DictTool.SubstituteWord 68743 . 78958) ( DictTool.CreateConjugationMap 78960 . 81835) (DictTool.FindWordInit 81837 . 84050)) (84053 89855 ( LingFns.FindWord 84063 . 87881) (LingFns.Capitalize 87883 . 89495) (LingFns.Capitalization 89497 . 89853))))) STOP \ No newline at end of file diff --git a/lispusers/DOC-OBJECTS.LCOM.~13~ b/lispusers/DOC-OBJECTS.LCOM.~13~ deleted file mode 100644 index f29690ceae7a6c23a28a96c79e29d84c80c0d445..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 25604 zcmeHQTWp-^S@zh;p1Mx$Y$$2iE}v$z8#`o1o*AFF-FiF+&mYezGvg%AW~)p*lgz}< zjPYTYKr2esJ1SLMXnRpwsih!5RLUlfL_x(uaKZMbAV9PiAR*LiQc;P^^1SbN{Qnsz z-tAI^N~9hC|9Af0^ZS19_wQIbll6+3NY=||B3?0D5-(IT$#gBbn9qo?SFB|!d9PXy zix5MB)>%SrLoP$0p_zGhs0nUhCf8 zY;QChqT4~E;onGCmp}EGGHI_S0%ePtY^jpTB`fJvsl1vkj*HE$<{Rzq?lx}^L;3bcsF<3c z1UB9e=ueL8B_>lBR=i3^Ax6xnXNQYkUJR@c4h#%j!+!&RO+WWnuF;=gZglC-iR1f? z_K9cr8`t>lh<+H^Z`|Y(p&y>#zt!mc=1&@}Q}{PJ7|J!g6VL1)|3zx`*=zLsH2sVW zjKwAK!f>^`*6U~15yh{bvrDWL8gSQBLt6S_#wk8y;D(p2unQUwsM$ZEYjnnnzK_sM~Q!3AF0X#I&K zGsIiTk=zr6vUdir-gxxG5M{n&X)!P8?N_Kg6ga^C#_o{Ak zgvY!W)jgB4-4oww6fi`g?-0rRQ@XkOdrI~C%SI8sihX-|#AlS=MIV$6S)w&W+v4z({WQaIcpxlnz|*1HYf#g8%n8Umb@wyq$~8sh&E22 z2Ah=g)!OOPpp^-{tD*2tB!TI%Ns$FTsR~fXX9h!{+`ZQ;l0ZTO3hvp_P{@0*B;PFC zLlU0IKKESz)@S>+UKp|6S!&$GD8Ygqn1Eu?+W~&)$ zFrh>Vi4PuA$}%PtITZ-Sl5P)zrU!GXciYez3$I>tibaziohs%F_MQjcPoPr6lp;njQ9{>6)up6Yixf)GN*YTOg18pSi1<)K8jxIsl@e+#@V-Y!Lr;-F z-oHk_8&Cdl6>|BscXa5>9z*c{$()qo@|VGQ|9h>GHh?oVE4*UWOJ~Xg5-Xpq)_8J& zX2!l<7KvFSAR$`-4Q^Gf!FUFy)75e+@0H6SGPzdlC=M#oqb;t~YNcY;-KST)SXzet zP9zE80uzQz29`xm8PS@4#r_lKC0itO07Y?8PQ8e~TEY^Lpwa-Lj{!nQMny$M*03-N4u+;f|b*G`M2QOwP0cZ0ePj zu`%FNs)t$m*WGK7VUsZXV{*T|i>fz2e|DvK$t$KK7`p~ZdzRTOTPa{`z&bTZd&_t zOn~~8OK*Me!~pDNTHv~>7<5`y-&+6lEwZ6K+K6|YcfzDi?5z#Lm2w*77zI~mGO&oD z(xo|BNLH4kd0?>`O?#EvDjADctGUu8XkXf{(G3Fl)(Rs&<0xm)vMx6*9)(~{%acJ^ zuypn7+PF{Gk}mdRk_mxkH$v9pooK^W0nq<^6!w}Fn-B^)sh3BGq@a8!``Uw{&%8bG zIr+*mRW@lol)Aa~?PNf`?n|cm?&T4J`Do|}*Ymjiqj*XqRW*O-d5hKLx@sd4s#@gl zom#(p(zgW0_uD`D)GflX+{6CqCqmD8UwHc`Z6Z4q8zJ0hvD|t`;uRfOw8;1<;TFV`7HLfo3a!dB{4fib=BY`Ypg3 zBa()cC@0Zj42+9jWyvdIwT>|m;}NA9LpG~pGy1GaYd*{w3#8wwCk5;fP0lkDz2?L; zq@MQTgF<=|#(}KUOND08gINRAWsZQ!^M6tJ_1VJz%RWU10oZ8K7waSXCW4}k)V3y` z9$EGc=#0V9k%88qJx(Zv-Y22tk(voepWOZ5l2(({URj>%%-+)rZPuRaUY|=`B*o0-`IV-1T zV~((akkXrRHKq}e0Xm??ObTdG-3j5sKoiHj?y&}a0z?JsWcS%|ldTh{TL64Rng^k}qVUfwlJSW_722 zdy~Lf-*K_!UzzQ%&3hQ^l}s7_Xbm<$G+j(w%4LeBa;Absq)SCvI>Dvz(Yy?WH_He~ zQnNH-Eoj9hvs?n_B~#HwGh9?CT~tlraKX!y-bdyl99n%fkRQONK}PH0U2U86AE$=bc~97mB50rIFI{(uvZC zN+*YD93rrpxSS4vmskRXCykY0vEzUe(Nj=BUce?$oNk*1cMBruX`^=Ej|L<(U^Vx2 zlF;chBh#1!R-bMbc1~>S;N>#uc!(m%eZVD}7P(T@TEtU=e5cYS)J(!#&adJjK@XSl z5O;(aDID35H%)1_Ll<0d+D5>methszN%fXXyxyRs4ISR=Z0BF9QNBhb#^lGt!oMFuE|f zz@`oJ(a8|WiMUuI0|W9~q8HM@Z!@vUAUAAmrmPBW$aARU1K4z#Dd!sIdn8vVDPzWq z6f>71*_C`=9UxkEu}%81i+@!=ABN1*;|&?MVGd=);A~98)fzEI3s~Sg90}t^8ZpLb zu+4f56k8QEP;5=WK(Q6PvVehNYmKsT<)^KFUo_R)56uj zGpI97gZEUB!EYr8i|F6Uy@4ybMnuZ<(~&1Nd5u4 z?IWbD5RK5bBTibBq9D81V5irl44PVEDkj2_i0E{8#GU4jxWS2Ak%-Mru^@4kLf_5G z$huTN;{nRL_q?;K5xJecr{rJk1^$593m@6RQp8zm!tP~CXfh7!Lc2moEE>hDWdigr z5qHQ&p>PN%1r{`lT6c)1^cOAh2Q2`{i%!r`LkIVM^<*Oz=|!6;Eq zr~3ywzepKix{@1527QxTGaJ8!nObMJ{62t5jWz^LAMvM(*DaJAYlCdM0)zmU%PIw39`L4hF{^@rFRkm0lj-USUFlG!F+jDtmF@+u5l9m} z3I+(_GbNy+Hr zBGe%J=hCqUS6IV2mlRl5oWT7AzO5kNPUyP{$MnPFZY!)EV@S(z&%=8Y`xkkng%Io9 z(a_-e#y8#`_!>95LXW?*5c=^K-X8evh4UxdBdQyUe{Ww3*-)DekBjm!{T#nA?hYvC zv)$Gyp6$WY3o^(!di-eq{)gpC+EV#nTnOx3F+jQaPDSOV_e+BU!apIV4AaTh#KNZ`YkLcYo&sSBiBY|3%LS0j$EZarEn{8 zehKA(!4N1zUSgV6MI3UPt~${RkrJgo(b+^CIf=R~>*1aV0>P8P64($pd*$3iB*cN# zEv-Y7>&ynN8N?hk8ByLa^bDVY@~x``0w$Q6E?~uDuyJs$CWXA%RS};s`Er;XhK#9+ z!Q`RSC#2Imc?dJ|U=N2bGwj7gd4ps(!G(}7l%3Rj{RPIiz5X&IU_<$@w2-Y5pPCTi zRK0VCA_E<|MHRzhl|t(@-}EUp%6J`%#9(MACdLJLerzmUM4K#P3b+?`VFhWLW>I_} zWNl-&(G+#jXy3Te+@c#H6n_Yh;}Th>(cba*Bo^lVpextzw3?#b;V~Lc$4>paGoOU9 zGaL1ySwv%ZtKGRNTJ^2QT6gmf&zf#;`+7qZ6N=D1-Q^gGnok@&%J?vyf5{bka&40^x?ArO<2 zuUq0SgsOo6cKZN8jzgtE6wEO~E@ZH1wnzB~(+CYP6ii(QHql z@4%j<53cQnUxx)fE5ZxuZn3+g`02HNLd!MkOTMy78hc#dzsZ@E`u*l6* zlz|*zWX{oxffuFp<6RF&cQSnS!T53yN`f@P8F)?vka?3sXTj`#Vp6W?$?BJ~K%xWK zv3$eWqxG>^CA=XYicp=U_?)5vAn;EIjt+$6St*-YHu=9?yTxc>tE$XA&xms$E7C%9 z`o9x2(+;Tf*=j?TR--*k!PtRnnJ208)EAgIF7UIo-AG!1`!y0+I*|JJ7jR}i=}ejL zMb|g!K3a^Ws4V9T$Aa#H8Ow+an0}T~46cpeGJ=@U(iq~wUx(G{I)wj}VV0~U<%LPa ziDZ#n8AU|oJNyZxYQtr=0-e&j34^#9%_-?Xu8;n3cg?YoVD;#EAwF#dgcDm%PDUoi zg(;7-5wzeFc5PKnA>38UJzaj&S>Rw~4w%Vh1|- zDhanCY6Nje3ZHBKdg+z01n6iT)lmC%U zY;*rzo54(ju7{IR+9Ty?yn9&(`ht#B$YrVG*~l15qthJ8y2S`0mSkE3>8O>_CjXAW z)zS357iFkQd21KsDdxTtzxq5&qolP%_AgkRncF7=EH}7m;IfP-;Y%p#uQ-bx2`&~?6Nifc*=2%iaace~R5+#N_4K7JzQm;Nc)(IH z1Oh>LPE9P9qg8i-=fgcaMi75({tA3akHao-^ML8SYPBRKK zEDk#}{928@GVM>zE8mQKEVO`R#-})_eVFW3>W+@ETprnPm~wNeZ5ZAuJ|IBO9uN3f zp0(^sZ1)KBuIKWY7PjaE)8IU=1iH2zg^?TgW)bF?lvW;V>iaJ3}^~~-HGTWti%AOaSZ4;>;QWXb12zn4mp&5jP#{K3Sg@SP@s>s z&#WD&jO7Gwi}HzNIVH_y($FN^5IJG7rtK)aND?%X>=Q>QT_?H71`Gfv4-9e)F}m+Q zifeX54@RHUO&D+^q1U9U8oc+yvU*~n@>Sp4{`tWxcmD=y{}je3RWpeB#W^g)HtS-( zlv);iU4twgnFCM3dC6N+CuGu5bpg$~kcb@WCS-~L;y6o^w^X54N9DH2;SjI9@{eF_^r%lZM zC_??gq~X0^S!Db^{ALbu+K(*Y_lsQcS^i}%lvV}#m=G)~>C7*4`p6(C(f(dNtXo1= zz}2VVCg1ybyzr5SC`$0y*ggps@-K{FIYTEKl7v|v4}G)MICbjs;LsoEaKgbm+qbDj zJ;d!uT&S0;MGBTcQLE%|e^Q;MJtlTv{O3(UZ`&1vuC)r zx4G4Qqm3~8b+m4GZ*J8$TX!%-L#(xT>N{+_%h_-2cGkEB z7}Njxr*j+uhdC#9FzZbO?;GO!9r~~pnP;CUox`9T8~Dr_Mcef#(t1TCSAACM%~pG@ zC9qfYZsL4FjX}G&`^FBgH%0STciXsrNJj)H@Qo_3*hP|SXtLFe$ZtyVHZYEvyUib; z+BWE;uZ0nq=2myN(=h$~MY`WOmY=BuHo*6;z^1qEh&6nWtd3paxa0<3 z$ZXYj&WSf$SRjG(Oama_YT{dWL>~=+bZ2*qTW{94cG_#Z8}%)*PG>mX8wLoN22oYu z5M$wo;6+2@uN+cfsmNS-Jh*8ggv+g6OxdSXANr9UZZ?4iaxJ6;;-za3rH-9!-Q+KY zDY66HvEz_o$O=D5Ju0&)1W)og<50phJDz9ZNW+o0?w7(#Th_ASw9Zi6%$!1s-= zBJlR@`c1TupN#{#ZEkL~`_dm~5oa=>y=x6YS2xdyv39f>RSck54r^-F@jX6Fcmvcw zeomaJ0vo_hwNu|j7eD=?S8FG7eRpT4+aZ3zw+jiz*A0CTIKkSj?gqO%R9Ve=*_v2y z-hmhOW(PAgch;ieVVsq*Y7}GD)oQ+!Opi+g*5DWoE+#8gG3F;xie9107N)wL8||&z zBz2fNsU8i6DJQPq0Gd{N2BO~l^}I3uW)O~faO|f}|HcZ)hOQt_A}$t@)HqK6FbBy+ z!QxLq_|d+*>ykNp2#1d8D5p*-IDH3M1vgbG=ke)}7P39>e2GqX#n9>#aH>}@<3SY% zb*LWKUOdzz_FT!<6+y>Lmj})#2o@R?!_Wj_B0GHBlF06WefutWqdUF>_(){oVAUBD zpbx+?FrNNq9}yt>?Sf-&7y-nBnLcGmjD?T*xyxrg=CHs4%lBU$Kh*l&L3`I998hnd zF1Epl5ENZpWyfZ=nLB$I9j0sAg70b5l84ioR6beByfhD#sSjX{;iSG)NgEQhH@naw z$cuD~OI}Ck?|POh)CT0M;ZDAkb17Y6gR{cSxSCr0r8Zkkk7YVUf_Y48Sld8(Qa$C? zN$DLF{DRY=o-U4I+*9Y+cfECdm9KXib9WAq>L+`G_vj(Rr0Z&T$4eq88}dE?bWF03 zXBmek4jPg&1W4t)EOv;1SeG{RXD*>nVT1M|Hp+~!#OBfkFIf6KbV{za=r6StpsG## zh{CUiuC1^L?&;&hukGRBw|6*_q2^S-XG9#AJfhYij^2UUX7^J-@UDi%@}r?6Rm|hD z>>$I?lpo;Zu+57|;3Of)DI_pBq#5JK_nWX>HtO3ug!O12wC7-{|2mm-8-lWaSvHb; zYjilYIw$_JM=EovmE3T*Dx0Vh79_qBnL5m>P_>aIgfp2`ufZ=!UDO%dqy!AChpl-*R)H}Y#==1mnBf@WJQrB11pfjy)opwl8a9Ce+7^JeO>hj5nkg_?dq_>86TU1}x}!N+X!VZrOtg+* zmq5T-!6g9l>GUxQ+yf;+Eaie$@X2-}Uo!Za3h`l1;spa2#RRsG+guwm($?hgEy;Th z|6l|il_1}OD`^kZ0AF&(C(KGkK(a=&>V^OgZqi8GhgWol_32NnkHyPE3j*4Bw$1jYa{efR`g+J_uIgM*@Gsqnf^c< zxIgN8P1jz?28}V(;$V|Zt(N(s*JL9)dOY-f23g+$NmU=hAPcNFVD+#G=?>ppf4KGj z&zTneQOBy#H6G+XIpzqR7V+zH_Tc-rFj`$Tc|2y`2faQ_FjY`@bb0_)T0k4gen9!Vr diff --git a/lispusers/DOC-OBJECTS.~1~ b/lispusers/DOC-OBJECTS.~1~ deleted file mode 100644 index ed04ae09..00000000 --- a/lispusers/DOC-OBJECTS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED " 3-Jun-93 12:54:04" |{PELE:MV:ENVOS}MEDLEY>DOC-OBJECTS.;4| 47984 changes to%: (VARS DOC-OBJECTSCOMS) (FNS DOCOBJ-INCLUDE-AFTERHARDCOPYFN DOCOBJ-INCLUDE-CLEANUPFN DOCOBJ-HRULE-GET-WIDTH DOCOBJ-INCLUDE-BEFOREHARDCOPYFN DOCOBJ-BEFOREHARDCOPYFN DOCOBJ-AFTERHARDCOPYFN) previous date%: " 1-Jun-93 17:25:11" |{PELE:MV:ENVOS}MEDLEY>DOC-OBJECTS.;3|) (* ; " Copyright (c) 1986, 1987, 1993 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT DOC-OBJECTSCOMS) (RPAQQ DOC-OBJECTSCOMS [ (* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc.") (FILES (SYSLOAD) TEDIT IMAGEOBJ) (VARS (DocObjectsMenu NIL) (DocObjectsConfirmEditMenu NIL)) [INITVARS (DocObjectsMenuCommands NIL) (DocObjectsMenuFont (FONTCREATE '(MODERN 12 BOLD] (COMS (* ;; "The hook into GET.OBJ.FROM.USER") (FNS DOCOBJ-ACQUIRE-OBJECT DOCOBJ-INIT DOCOBJ-TEDIT-MENU-ENTRY DOCOBJ-GET-LOOKS DOCOBJ-REGISTER-OBJECT DOCOBJ-STRING-IMAGEBOX DOCOBJ-WAIT-MOUSE DOCOBJ-INVOKE-IMAGEOBJFN DOCOBJ-BEFOREHARDCOPYFN DOCOBJ-AFTERHARDCOPYFN)) [COMS (* ;; "Eval'd Form") (FNS DOCOBJ-ACQUIRE-EVALED-OBJECT) (ADDVARS (DocObjectsMenuCommands ("Eval'd Form" (DOCOBJ-ACQUIRE-EVALED-OBJECT) "Insert the value of a form to be typed in"] [COMS (* ;; "Screen Snap") (FNS DOCOBJ-ACQUIRE-SNAPPED-OBJECT) (ADDVARS (DocObjectsMenuCommands ("Screen Snap" (DOCOBJ-ACQUIRE-SNAPPED-OBJECT) "Insert a snap from the screen"] [COMS (* ;; "Time Stamp") (DECLARE%: DONTCOPY (RECORDS DOCOBJ-TIMESTAMP)) (FILES (SYSLOAD) DATEFORMAT-EDITOR) (FNS DOCOBJ-EDIT-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS DOCOBJ-TIMESTAMP-BUTTONEVENTINFN DOCOBJ-TIMESTAMP-COPYFN DOCOBJ-TIMESTAMP-DISPLAYFN DOCOBJ-TIMESTAMP-GETFN DOCOBJ-TIMESTAMP-IMAGEBOXFN DOCOBJ-TIMESTAMP-PREPRINTFN DOCOBJ-TIMESTAMP-PUTFN DOCOBJ-TIMESTAMP-TO-STRING) (INITVARS (DocObjectsTimeStampFormat) (DOCOBJ-TIMESTAMP-IMAGEFNS (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("Time Stamp" (DOCOBJ-MAKE-TIMESTAMP) "Date & time this document is PUT"] [COMS (* ;; "File Stamp") (FNS DOCOBJ-MAKE-FILESTAMP DOCOBJ-MAKE-FILESTAMP-IMAGEFNS DOCOBJ-FILESTAMP-COPYFN DOCOBJ-FILESTAMP-DISPLAYFN DOCOBJ-FILESTAMP-GETFN DOCOBJ-FILESTAMP-IMAGEBOXFN DOCOBJ-FILESTAMP-GET-FULLNAME DOCOBJ-FILESTAMP-NEW-FULLNAME DOCOBJ-FILESTAMP-PREPRINTFN DOCOBJ-FILESTAMP-PUTFN) (INITVARS (DOCOBJ-FILESTAMP-IMAGEFNS (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("File Stamp" (DOCOBJ-MAKE-FILESTAMP) "Name of file to which this document was last PUT." ] (COMS (* ;; "Horizontal Rule") (FILES (SYSLOAD) HRULE READNUMBER) (FNS DOCOBJ-MAKE-HRULE DOCOBJ-EDIT-HRULE DOCOBJ-HRULE-INIT DOCOBJ-HRULE-GET-WIDTH DOCOBJ-HRULE-BUTTONEVENTINFN) (VARS (DOCOBJ-HRULE-RULE-PAD) (DOCOBJ-HRULE-BLANK-PAD)) (ADDVARS (DocObjectsMenuCommands ("Horizontal Rule" (DOCOBJ-MAKE-HRULE) "One or more horizontal rules"))) (P (DOCOBJ-HRULE-INIT))) [COMS (* ;; "INCLUDE") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS INCLOBJ)) (FNS DOCOBJ-MAKE-INCLUDE DOCOBJ-MAKE-INCLUDE-IMAGEFNS DOCOBJ-INCLUDE-CREATE-OBJ DOCOBJ-INCLUDE-EDIT DOCOBJ-INCLUDE-EDIT-WINDOWP DOCOBJ-INCLUDE-RESET-OBJ) (FNS DOCOBJ-INCLUDE-AFTERHARDCOPYFN DOCOBJ-INCLUDE-BEFOREHARDCOPYFN DOCOBJ-INCLUDE-CLEANUPFN DOCOBJ-INCLUDE-BUTTONEVENTINFN DOCOBJ-INCLUDE-COPYFN DOCOBJ-INCLUDE-DISPLAYFN DOCOBJ-INCLUDE-GETFN DOCOBJ-INCLUDE-IMAGEBOXFN DOCOBJ-INCLUDE-PREPRINTFN DOCOBJ-INCLUDE-PUTFN) (INITVARS (DOCOBJ-INCLUDE-EDITMENU) (DOCOBJ-INCLUDE-IMAGEFNS (DOCOBJ-MAKE-INCLUDE-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("Include" (DOCOBJ-MAKE-INCLUDE) "Include another document right here when hardcopying" ] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DOCOBJ-INIT))) (DECLARE%: EVAL@LOAD DONTCOPY (COMS (PROP FILETYPE DOC-OBJECTS) (PROP MAKEFILE-ENVIRONMENT DOC-OBJECTS]) (* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc." ) (FILESLOAD (SYSLOAD) TEDIT IMAGEOBJ) (RPAQQ DocObjectsMenu NIL) (RPAQQ DocObjectsConfirmEditMenu NIL) (RPAQ? DocObjectsMenuCommands NIL) (RPAQ? DocObjectsMenuFont (FONTCREATE '(MODERN 12 BOLD))) (* ;; "The hook into GET.OBJ.FROM.USER") (DEFINEQ (DOCOBJ-ACQUIRE-OBJECT [LAMBDA NIL (* ; "Edited 15-Oct-87 16:27 by Koomen") (* ;;; "This function is invoked by TEdit's GET.OBJ.FROM.USER (cf. the Library file IMAGEOBJ) after (CHANGENAME (QUOTE GET.OBJ.FROM.USER) (QUOTE PROMPTFOREVALED) (QUOTE DOCOBJ-ACQUIRE-OBJECT))") (* ;;; "When adding more items to the DocObjectsMenuCommands, do (SETQ DocObjectsMenu)") (DECLARE (GLOBALVARS DocObjectsMenu DocObjectsMenuCommands DocObjectsMenuFont)) (if (NOT (type? MENU DocObjectsMenu)) then (SETQ DocObjectsMenu (create MENU TITLE _ "Select object type: " CENTERFLG _ T ITEMS _ DocObjectsMenuCommands MENUFONT _ DocObjectsMenuFont))) (MENU DocObjectsMenu]) (DOCOBJ-INIT [LAMBDA NIL (* ;  "Edited 8-Oct-87 21:32 by Koomen") (* ;;; "This function changes the behavior of standard TEdit such that ^O will invoke the DocObjects system; an entry to invoke the DocObjects system is also added to TEdit's middle button menu.") (DECLARE (GLOBALVARS TEDIT.DEFAULT.MENU)) (CHANGENAME 'GET.OBJ.FROM.USER 'PROMPTFOREVALED ' DOCOBJ-ACQUIRE-OBJECT) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Object (FUNCTION DOCOBJ-TEDIT-MENU-ENTRY) "Insert a Document Object"]) (DOCOBJ-TEDIT-MENU-ENTRY [LAMBDA (TEXTSTREAM) (* ;  "Edited 8-Oct-87 21:31 by Koomen") (* ;;; "This is the entry point into the DocObjects system from TEdit's middle button menu. GET.OBJ.FROM.USER used to call PROMPTFOREVALED but DocObjects changes this into a call to DOCOBJ-ACQUIRE-OBJECT.") (GET.OBJ.FROM.USER TEXTSTREAM (TEXTOBJ TEXTSTREAM]) (DOCOBJ-GET-LOOKS [LAMBDA (TEXTOBJ CH#ORCHARLOOKS) (* Koomen " 4-Feb-87 23:37") (* * Adapted from {ERIS}TEDITLOOKS.;30 dated  "15-Oct-85 16:51:10" to return looks itself, rather  than a proplist.)  (* jds "10-Jul-85 16:02") (* Return a PLIST of  character looks) (PROG ((TEXTOBJ (TEXTOBJ TEXTOBJ)) LOOKS FONT NLOOKS) [COND ((type? CHARLOOKS CH#ORCHARLOOKS) (* He handed us a  CHARLOOKS. Unparse it for  him.) (SETQ LOOKS CH#ORCHARLOOKS)) ((ZEROP (fetch TEXTLEN of TEXTOBJ)) (* There's no text in the document.  Use the extant caret looks.) (SETQ LOOKS (fetch CARETLOOKS of TEXTOBJ))) [(FIXP CH#ORCHARLOOKS) (* He gave us a CH# to geth the looks of.  Grab it.) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) CH#ORCHARLOOKS) (fetch PCTB of TEXTOBJ] [(type? SELECTION CH#ORCHARLOOKS) (* Get the looks of the  selected text) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) (fetch (SELECTION CH#) of CH#ORCHARLOOKS)) (fetch PCTB of TEXTOBJ] ((NULL CH#ORCHARLOOKS) (* Get the looks of the  selected text) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) (fetch (SELECTION CH#) of (fetch SEL of TEXTOBJ))) (fetch PCTB of TEXTOBJ] (RETURN LOOKS) (* * Now break the looks apart into a PROPLIST) (SETQ NLOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST LOOKS)) (RETURN NLOOKS]) (DOCOBJ-REGISTER-OBJECT [LAMBDA (OBJECT) (* ; "Edited 23-Oct-87 14:48 by Koomen") (* ;; "The following ensures that all DocObjects get a chance to do whatever they want to before and after hardcopying. Each DocObject can associate a BEFOREHARDCOPYFN and/or an AFTERHARDCOPYFN with the ImageObj representing the DocObject") (DECLARE (SPECVARS TEXTOBJ)) (if OBJECT then (TEXTPROP TEXTOBJ 'BEFOREHARDCOPYFN (FUNCTION DOCOBJ-BEFOREHARDCOPYFN)) (TEXTPROP TEXTOBJ 'AFTERHARDCOPYFN (FUNCTION DOCOBJ-AFTERHARDCOPYFN)) OBJECT]) (DOCOBJ-STRING-IMAGEBOX [LAMBDA (STRING IMAGESTREAM) (* Koomen " 9-Feb-87 17:22") (DECLARE (SPECVARS CHNO TEXTOBJ)) (PROG (LOOKS CLOFFSET FONT DEVICE HEIGHT DESCENT) (SETQ LOOKS (DOCOBJ-GET-LOOKS TEXTOBJ CHNO)) (SETQ CLOFFSET (fetch (CHARLOOKS CLOFFSET) of LOOKS)) (SETQ FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) (if (NEQ (FONTPROP FONT 'DEVICE) (SETQ DEVICE (IMAGESTREAMTYPE IMAGESTREAM))) then (SETQ FONT (FONTCOPY FONT 'DEVICE DEVICE))) (SETQ HEIGHT (FONTHEIGHT FONT)) (SETQ DESCENT (FONTPROP FONT 'DESCENT)) (RETURN (create IMAGEBOX XSIZE _ (STRINGWIDTH STRING FONT) YSIZE _ (IPLUS HEIGHT (IABS CLOFFSET)) YDESC _ (IDIFFERENCE DESCENT CLOFFSET) XKERN _ 0]) (DOCOBJ-WAIT-MOUSE [LAMBDA (STREAM) (* ;  "Edited 8-Oct-87 23:46 by Koomen") (while (NOT (MOUSESTATE UP)) bind (REGION _ (DSPCLIPPINGREGION NIL STREAM)) do (if (NOT (INSIDEP REGION (LASTMOUSEX STREAM) (LASTMOUSEY STREAM))) then (RETURN NIL)) finally (RETURN T]) (DOCOBJ-INVOKE-IMAGEOBJFN [LAMBDA (CH# PIECE PC# IMAGEOBJFNNAME) (* ; "Edited 15-Oct-87 23:35 by Koomen") (* ;; "If PIECE is an IMAGEOBJ, invoke the function associated with the ImageObj property IMAGEOBJFNNAME on the IMAGEOBJ and the character position where the IMAGEOBJ is located. ") (PROG (IMAGEOBJ IMAGEOBJFN) (if (NOT (type? PIECE PIECE)) then (RETURN)) (SETQ IMAGEOBJ (fetch POBJ of PIECE)) (if (NOT (IMAGEOBJP IMAGEOBJ)) then (RETURN)) (SETQ IMAGEOBJFN (IMAGEOBJPROP IMAGEOBJ IMAGEOBJFNNAME)) (if (AND IMAGEOBJFN (DEFINEDP IMAGEOBJFN)) then (APPLY* IMAGEOBJFN IMAGEOBJ CH# PIECE PC#]) (DOCOBJ-BEFOREHARDCOPYFN [LAMBDA (TEXTSTREAM TEXTOBJ) (* ;  "Edited 25-May-93 13:07 by sybalsky:mv:envos") (* ;; "Bug in TEDIT.FORMAT.HARDCOPY!!! This function is called with the arguments TEXTSTREAM and TEXTOBJ, but TEXTSTREAM is undefined!") (* ;; "*DOCOBJ-FORMS* is used to enable insertion and deletion of pieces. DocObjects can postpone insertion or deletion by added appropriate forms to *DOCOBJ-FORMS*. Can't do it while under TEDIT.MAPPIECES as the pointers get screwed up. ") (DECLARE (SPECVARS *DOCOBJ-FORMS*)) (LET ((TEXTSTREAM (TEXTSTREAM TEXTOBJ)) (*DOCOBJ-FORMS*)) (TEXTPROP TEXTSTREAM 'DOCOBJ-VIRGINP (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ;; "After hardcopy, TEXTSTREAM is reset if this flag is T") (do (SETQ *DOCOBJ-FORMS*) (TEDIT.MAPPIECES TEXTOBJ (FUNCTION DOCOBJ-INVOKE-IMAGEOBJFN) 'BEFOREHARDCOPYFN) [WITHOUT-UPDATES TEXTOBJ (FETCH (TEXTOBJ SCRATCHSEL) OF TEXTOBJ) (for FRM in *DOCOBJ-FORMS* do (APPLY (CAR FRM) (CDR FRM] repeatwhile *DOCOBJ-FORMS*]) (DOCOBJ-AFTERHARDCOPYFN [LAMBDA (TEXTSTREAM TEXTOBJ) (* ;  "Edited 25-May-93 13:08 by sybalsky:mv:envos") (* ;; "Bug in TEDIT.FORMAT.HARDCOPY!!! This function is called with the arguments TEXTSTREAM and TEXTOBJ, but TEXTSTREAM is undefined, and TEXTOBJ is NIL!") (DECLARE (SPECVARS *DOCOBJ-FORMS*)) (LET ((*DOCOBJ-FORMS*)) (do (SETQ *DOCOBJ-FORMS*) (TEDIT.MAPPIECES TEXTOBJ (FUNCTION DOCOBJ-INVOKE-IMAGEOBJFN) 'AFTERHARDCOPYFN) [WITHOUT-UPDATES TEXTOBJ (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) (for FRM in *DOCOBJ-FORMS* do (APPLY (CAR FRM) (CDR FRM] repeatwhile *DOCOBJ-FORMS*) (COND ((TEXTPROP TEXTSTREAM 'DOCOBJ-VIRGINP) (TEDIT.STREAMCHANGEDP TEXTSTREAM T]) ) (* ;; "Eval'd Form") (DEFINEQ (DOCOBJ-ACQUIRE-EVALED-OBJECT [LAMBDA NIL (* Koomen "30-Sep-86 02:08") (* * This is the original function called under  GET.OBJ.FROM.USER * *) (PROMPTFOREVALED "Form to eval: "]) ) (ADDTOVAR DocObjectsMenuCommands ("Eval'd Form" (DOCOBJ-ACQUIRE-EVALED-OBJECT) "Insert the value of a form to be typed in")) (* ;; "Screen Snap") (DEFINEQ (DOCOBJ-ACQUIRE-SNAPPED-OBJECT [LAMBDA NIL (* Koomen "26-Sep-86 16:55") (GETREGION]) ) (ADDTOVAR DocObjectsMenuCommands ("Screen Snap" (DOCOBJ-ACQUIRE-SNAPPED-OBJECT) "Insert a snap from the screen")) (* ;; "Time Stamp") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD DOCOBJ-TIMESTAMP (IDATE DATESTR FORMAT)) ) ) (FILESLOAD (SYSLOAD) DATEFORMAT-EDITOR) (DEFINEQ (DOCOBJ-EDIT-TIMESTAMP [LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:08") (PROG [(FORMAT (EDIT-DATEFORMAT (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP] (if FORMAT then (replace (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP with FORMAT) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL) (RETURN TIMESTAMP]) (DOCOBJ-MAKE-TIMESTAMP [LAMBDA NIL (* Koomen " 4-Feb-87 13:54") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS DocObjectsTimeStampFormat)) (IMAGEOBJCREATE (create DOCOBJ-TIMESTAMP IDATE _ (IDATE) FORMAT _ DocObjectsTimeStampFormat) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:53 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-TIMESTAMP-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-TIMESTAMP-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-TIMESTAMP-PUTFN)) (GETFN (FUNCTION DOCOBJ-TIMESTAMP-GETFN)) (COPYFN (FUNCTION DOCOBJ-TIMESTAMP-COPYFN)) (BUTTONEVENTINFN (FUNCTION DOCOBJ-TIMESTAMP-BUTTONEVENTINFN)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-TIMESTAMP-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-TIMESTAMP-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ;  "Edited 8-Oct-87 23:43 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-EDIT-TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then 'CHANGED]) (DOCOBJ-TIMESTAMP-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 00:30") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-TIMESTAMP-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* Koomen " 4-Feb-87 14:11") (PRINTOUT IMAGESTREAM (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-TIMESTAMP-GETFN [LAMBDA (FILESTREAM) (* Koomen "31-Jan-87 00:19") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (READ FILESTREAM) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-TIMESTAMP-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* Koomen " 9-Feb-87 17:13") (LET* ((TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) (TIMESTRING (DOCOBJ-TIMESTAMP-TO-STRING TIMESTAMP))) (DOCOBJ-STRING-IMAGEBOX TIMESTRING IMAGESTREAM]) (DOCOBJ-TIMESTAMP-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ;  "Edited 8-Oct-87 22:29 by Koomen") (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-TIMESTAMP-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* Koomen " 4-Feb-87 14:08") (PROG [(TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (replace (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP with (IDATE)) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL) (PRINT TIMESTAMP FILESTREAM]) (DOCOBJ-TIMESTAMP-TO-STRING [LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:12") (OR (STRINGP (fetch (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP)) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with (GDATE (fetch (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP) (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP]) ) (RPAQ? DocObjectsTimeStampFormat ) (RPAQ? DOCOBJ-TIMESTAMP-IMAGEFNS (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("Time Stamp" (DOCOBJ-MAKE-TIMESTAMP) "Date & time this document is PUT")) (* ;; "File Stamp") (DEFINEQ (DOCOBJ-MAKE-FILESTAMP [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:55 by Koomen") (DECLARE (SPECVARS TEXTOBJ) (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (DOCOBJ-FILESTAMP-NEW-FULLNAME TEXTOBJ) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:54 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-FILESTAMP-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-FILESTAMP-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-FILESTAMP-PUTFN)) (GETFN (FUNCTION DOCOBJ-FILESTAMP-GETFN)) (COPYFN (FUNCTION DOCOBJ-FILESTAMP-COPYFN)) (BUTTONEVENTINFN (FUNCTION NILL)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-FILESTAMP-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-FILESTAMP-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 04:10") (DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-FILESTAMP-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ;  "Edited 8-Oct-87 22:56 by Koomen") (PRINTOUT IMAGESTREAM (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ]) (DOCOBJ-FILESTAMP-GETFN [LAMBDA (FILESTREAM) (* ;  "Edited 8-Oct-87 22:58 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (LET ((FULLNAME (READ FILESTREAM))) (IMAGEOBJCREATE (AND FULLNAME (MKSTRING FULLNAME)) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-FILESTAMP-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ;  "Edited 8-Oct-87 22:59 by Koomen") (LET ((FULLNAME (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ))) (DOCOBJ-STRING-IMAGEBOX FULLNAME IMAGESTREAM]) (DOCOBJ-FILESTAMP-GET-FULLNAME [LAMBDA (IMAGEOBJ NODEFAULTFLG) (* ;  "Edited 8-Oct-87 22:59 by Koomen") (PROG [(FULLNAME (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (RETURN (OR (if FULLNAME then (if (LITATOM FULLNAME) then (MKSTRING FULLNAME) elseif (STRINGP FULLNAME) then (COPYALL FULLNAME))) (if (NOT NODEFAULTFLG) then "-- not yet filed --"]) (DOCOBJ-FILESTAMP-NEW-FULLNAME [LAMBDA (TEXTOBJ) (* ;  "Edited 8-Oct-87 22:52 by Koomen") (PROG ((FULLNAME (FULLNAME TEXTOBJ))) (RETURN (if FULLNAME then (if (LITATOM FULLNAME) then (MKSTRING FULLNAME) elseif (STRINGP FULLNAME) then (COPYALL FULLNAME]) (DOCOBJ-FILESTAMP-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ;  "Edited 8-Oct-87 22:56 by Koomen") (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ T]) (DOCOBJ-FILESTAMP-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* ;  "Edited 8-Oct-87 22:39 by Koomen") (PROG [(FULLNAME (MKSTRING (FULLNAME FILESTREAM] (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM FULLNAME) (PRINT FULLNAME FILESTREAM]) ) (RPAQ? DOCOBJ-FILESTAMP-IMAGEFNS (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("File Stamp" (DOCOBJ-MAKE-FILESTAMP) "Name of file to which this document was last PUT.")) (* ;; "Horizontal Rule") (FILESLOAD (SYSLOAD) HRULE READNUMBER) (DEFINEQ (DOCOBJ-MAKE-HRULE [LAMBDA NIL (* Koomen " 4-Feb-87 16:12") (HRULE.CREATE (bind WIDTH for I from 1 while (AND (SETQ WIDTH (DOCOBJ-HRULE-GET-WIDTH (ODDP I) (EQ I 1))) (GREATERP WIDTH 0)) collect WIDTH]) (DOCOBJ-EDIT-HRULE [LAMBDA (IMAGEOBJ) (* Koomen " 4-Feb-87 15:45") (PROG [NEWWIDTH (OLDWIDTH (MKLIST (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH] (SETQ NEWWIDTH (COPYALL OLDWIDTH)) (if (AND (NLSETQ (EDITE NEWWIDTH)) (NOT (EQUAL NEWWIDTH OLDWIDTH))) then (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH NEWWIDTH) (RETURN IMAGEOBJ]) (DOCOBJ-HRULE-INIT [LAMBDA NIL (* Koomen " 4-Feb-87 16:13") (* * provide HRULE editing * *) (DECLARE (GLOBALVARS HRULE.IMAGEFNS)) (replace (IMAGEFNS BUTTONEVENTINFN) of HRULE.IMAGEFNS with (FUNCTION DOCOBJ-HRULE-BUTTONEVENTINFN)) NIL]) (DOCOBJ-HRULE-GET-WIDTH [LAMBDA (RULE? FIRST?) (* ;  "Edited 24-May-93 23:35 by sybalsky:mv:envos") (DECLARE (GLOBALVARS DOCOBJ-HRULE-BLANK-PAD DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY)) [COND ((NULL DOCOBJ-HRULE-RULE-PAD) (SETQ DOCOBJ-HRULE-RULE-PAD (CREATE.NUMBERPAD.READER "Rule width: " NIL NIL NIL T T)) (SETQ DOCOBJ-HRULE-BLANK-PAD (CREATE.NUMBERPAD.READER "Blank space: " NIL NIL NIL T T] (COND (FIRST? (MOVEW DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY) (MOVEW DOCOBJ-HRULE-BLANK-PAD LASTMOUSEX LASTMOUSEY))) (NUMBERPAD.READ (COND (RULE? DOCOBJ-HRULE-RULE-PAD) (T DOCOBJ-HRULE-BLANK-PAD)) T]) (DOCOBJ-HRULE-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ;  "Edited 8-Oct-87 23:43 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-EDIT-HRULE IMAGEOBJ) then 'CHANGED]) ) (RPAQQ DOCOBJ-HRULE-RULE-PAD NIL) (RPAQQ DOCOBJ-HRULE-BLANK-PAD NIL) (ADDTOVAR DocObjectsMenuCommands ("Horizontal Rule" (DOCOBJ-MAKE-HRULE) "One or more horizontal rules")) (DOCOBJ-HRULE-INIT) (* ;; "INCLUDE") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD INCLOBJ (FILENAME ENABLEDP)) ) ) (DEFINEQ (DOCOBJ-MAKE-INCLUDE [LAMBDA NIL (* ; "Edited 15-Oct-87 14:54 by Koomen") (DECLARE (SPECVARS TEXTOBJ)) (PROG ((SUBFILE (TEDIT.GETINPUT TEXTOBJ "Enter file name: "))) (if SUBFILE then (RETURN (DOCOBJ-INCLUDE-CREATE-OBJ SUBFILE)) else (TEDIT.PROMPTPRINT TEXTOBJ "... aborted."]) (DOCOBJ-MAKE-INCLUDE-IMAGEFNS [LAMBDA NIL (* ; "Edited 23-Oct-87 00:20 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-INCLUDE-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-INCLUDE-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-INCLUDE-PUTFN)) (GETFN (FUNCTION DOCOBJ-INCLUDE-GETFN)) (COPYFN (FUNCTION DOCOBJ-INCLUDE-COPYFN)) (BUTTONEVENTINFN (FUNCTION DOCOBJ-INCLUDE-BUTTONEVENTINFN)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-INCLUDE-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-INCLUDE-CREATE-OBJ [LAMBDA (INCLOBJ) (* ; "Edited 23-Oct-87 14:06 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-INCLUDE-IMAGEFNS)) (PROG (IMAGEOBJ) [if INCLOBJ then (if (NLISTP INCLOBJ) then (* ;; "Just a file name") (SETQ INCLOBJ (create INCLOBJ FILENAME _ (MKSTRING INCLOBJ) ENABLEDP _ T] (SETQ IMAGEOBJ (IMAGEOBJCREATE INCLOBJ DOCOBJ-INCLUDE-IMAGEFNS)) (DOCOBJ-INCLUDE-RESET-OBJ IMAGEOBJ) (DOCOBJ-REGISTER-OBJECT IMAGEOBJ) (RETURN IMAGEOBJ]) (DOCOBJ-INCLUDE-EDIT [LAMBDA (INCLOBJ) (* ; "Edited 26-Oct-87 19:57 by Koomen") (DECLARE (SPECVARS TEXTOBJ)) (SELECTQ [MENU (OR DOCOBJ-INCLUDE-EDITMENU (SETQ DOCOBJ-INCLUDE-EDITMENU (create MENU TITLE _ "Edit Include" ITEMS _ '(("New File" 'NEW.FILE "Include a different file") ("Edit File" 'EDIT.FILE "Edit the included file") ("Enable" 'ENABLE "Include the file during hardcopy" ) ("Disable" 'DISABLE "Do not include the file during hardcopy" )) CENTERFLG _ T MENUOFFSET _ '(-1 . 30) CHANGEOFFSETFLG _ 'Y] (NEW.FILE (LET [(NEWNAME (TEDIT.GETINPUT TEXTOBJ "Enter new file name: " (fetch (INCLOBJ FILENAME) of INCLOBJ] (if [AND NEWNAME (SETQ NEWNAME (MKSTRING NEWNAME)) (NOT (EQUAL NEWNAME (fetch (INCLOBJ FILENAME) of INCLOBJ] then (replace (INCLOBJ FILENAME) of INCLOBJ with NEWNAME) T))) (EDIT.FILE (for W in (OPENWINDOWS) bind (FULLNAME _ (INFILEP (fetch (INCLOBJ FILENAME) of INCLOBJ))) first (if (NULL FULLNAME) then (TEDIT.PROMPTPRINT TEXTOBJ "Can't find " T) (TEDIT.PROMPTPRINT TEXTOBJ (fetch (INCLOBJ FILENAME) of INCLOBJ)) (RETURN)) when (SETQ W (DOCOBJ-INCLUDE-EDIT-WINDOWP FULLNAME W)) do (TOTOPW W) (GIVE.TTY.PROCESS W) (RETURN) finally (TEDIT (MKATOM FULLNAME)))) (ENABLE (if (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ)) then (replace (INCLOBJ ENABLEDP) of INCLOBJ with T) T)) (DISABLE (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then (replace (INCLOBJ ENABLEDP) of INCLOBJ with NIL) T)) NIL]) (DOCOBJ-INCLUDE-EDIT-WINDOWP [LAMBDA (FILENAME WINDOW) (* ; "Edited 26-Oct-87 19:53 by Koomen") (if (WINDOWP WINDOW) then (OR (LET (TEXTOBJ TXTFILE) (if (AND (SETQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ)) (type? TEXTOBJ TEXTOBJ) (SETQ TXTFILE (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) (STREAMP TXTFILE) (SETQ TXTFILE (FULLNAME TXTFILE)) (OR (STRINGP TXTFILE) (LITATOM TXTFILE)) (STRING-EQUAL FILENAME TXTFILE)) then WINDOW)) (DOCOBJ-INCLUDE-EDIT-WINDOWP FILENAME (WINDOWPROP WINDOW 'ICONFOR]) (DOCOBJ-INCLUDE-RESET-OBJ [LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:09 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-INCLUDE-IMAGEFNS)) (PROG (INCLOBJ FNAME) (if (SETQ INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then (SETQ FNAME (fetch (INCLOBJ FILENAME) of INCLOBJ)) (IMAGEOBJPROP IMAGEOBJ 'INCLDISPLAYSTRING (CONCAT "@Include[" FNAME "]")) (IMAGEOBJPROP IMAGEOBJ 'DONTINCLDISPLAYSTRING (CONCAT "@DoNotInclude[" FNAME "]")) ) (IMAGEOBJPROP IMAGEOBJ 'BEFOREHARDCOPYFN (FUNCTION DOCOBJ-INCLUDE-BEFOREHARDCOPYFN)) (IMAGEOBJPROP IMAGEOBJ 'AFTERHARDCOPYFN (FUNCTION DOCOBJ-INCLUDE-AFTERHARDCOPYFN]) ) (DEFINEQ (DOCOBJ-INCLUDE-AFTERHARDCOPYFN [LAMBDA (IMAGEOBJ CH#) (* ;  "Edited 3-Jun-93 12:42 by sybalsky:mv:envos") (DECLARE (SPECVARS TEXTSTREAM)) (COND ((IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) (* ;; "Just record current position, let endmarker do the rest") (IMAGEOBJPROP IMAGEOBJ 'INCLSTARTPOS (ADD1 CH#))) (T (* ;; "Hit an end marker") (PROG (HEADOBJ STARTPOS) (SETQ HEADOBJ (IMAGEOBJPROP IMAGEOBJ 'INCLIMAGEOBJ)) (SETQ STARTPOS (IMAGEOBJPROP HEADOBJ 'INCLSTARTPOS)) (IMAGEOBJPROP HEADOBJ 'INCLUDEDP NIL) (push *DOCOBJ-FORMS* `(DOCOBJ-INCLUDE-CLEANUPFN ,TEXTSTREAM ,STARTPOS ,(ADD1 (IDIFFERENCE CH# STARTPOS]) (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN [LAMBDA (IMAGEOBJ CH#) (* ;  "Edited 1-Jun-93 10:56 by sybalsky:mv:envos") (DECLARE (SPECVARS *DOCOBJ-FORMS* TEXTOBJ)) (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (COND ([AND INCLOBJ (fetch (INCLOBJ ENABLEDP) of INCLOBJ) (NOT (IMAGEOBJPROP IMAGEOBJ 'INCLUDEDP] (* ;; "We're under MAP.PIECES -- dangerous to insert here, so postpone") (push *DOCOBJ-FORMS* (LIST [FUNCTION (LAMBDA (STARTPOS INCLFILE IMAGEOBJ ENDOBJ WINDOWS) (DECLARE (SPECVARS TEXTSTREAM)) (COND (WINDOWS (TEDIT.PROMPTPRINT TEXTSTREAM "Including " T) (TEDIT.PROMPTPRINT TEXTSTREAM INCLFILE) (TEDIT.PROMPTPRINT TEXTSTREAM "...")) (T (PROMPTPRINT "[TEdit hardcopy: including " INCLFILE "...]"))) (WITHOUT-UPDATES (TEXTOBJ TEXTSTREAM) (fetch (TEXTOBJ SCRATCHSEL) of (TEXTOBJ TEXTSTREAM )) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'RIGHT) (* ;; "Force paragraph boundary, so that the first paragraph of the included document doesn't inherit the paralooks of the paragraph containing the @Include.") (TEDIT.INSERT TEXTSTREAM " ") (TEDIT.PARALOOKS TEXTSTREAM '(NEWPAGEAFTER NIL NEWPAGEBEFORE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 0)) (* ;;  "For space efficiency, tell TEdit to assume that the file will exist as long as we need it.") (TEDIT.INCLUDE TEXTSTREAM (MKATOM INCLFILE) NIL NIL T) (TEDIT.INSERT.OBJECT ENDOBJ TEXTSTREAM) (IMAGEOBJPROP ENDOBJ 'INCLIMAGEOBJ IMAGEOBJ) (IMAGEOBJPROP IMAGEOBJ 'INCLUDEDP T)) (COND (WINDOWS (TEDIT.PROMPTPRINT TEXTSTREAM " done.")) (T (PROMPTPRINT "[TEdit hardcopy: including " INCLFILE "... done.]"] (ADD1 CH#) (fetch (INCLOBJ FILENAME) of INCLOBJ) IMAGEOBJ (DOCOBJ-INCLUDE-CREATE-OBJ) (fetch (TEXTOBJ \WINDOW) of TEXTOBJ]) (DOCOBJ-INCLUDE-CLEANUPFN [LAMBDA (TEXTSTREAM STARTPOS LEN) (* ;  "Edited 3-Jun-93 12:43 by sybalsky:mv:envos") (* ;; "Do the cleanup of removing an included file's pieces (and closing it) after hardcopying with inclusions.") (LET* ((SEL (TEDIT.SETSEL TEXTSTREAM STARTPOS LEN)) (PCS (TEDIT.SELECTED.PIECES (TEXTOBJ TEXTSTREAM) SEL))) (for PC in PCS when (AND (fetch (PIECE PFILE) of PC) (OPENP (fetch (PIECE PFILE) of PC))) do (CLOSEF (fetch (PIECE PFILE) of PC))) (TEDIT.DELETE TEXTSTREAM STARTPOS LEN) (BLOCK]) (DOCOBJ-INCLUDE-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ; "Edited 23-Oct-87 00:46 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-INCLUDE-EDIT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then (DOCOBJ-INCLUDE-RESET-OBJ IMAGEOBJ) 'CHANGED]) (DOCOBJ-INCLUDE-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* ; "Edited 23-Oct-87 00:13 by Koomen") (DOCOBJ-INCLUDE-CREATE-OBJ (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-INCLUDE-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ; "Edited 23-Oct-87 14:42 by Koomen") (PROG [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (if [AND INCLOBJ (OR (EQ IMAGESTREAMTYPE 'DISPLAY) (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ] then (printout IMAGESTREAM (IMAGEOBJPROP IMAGEOBJ (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then 'INCLDISPLAYSTRING else 'DONTINCLDISPLAYSTRING]) (DOCOBJ-INCLUDE-GETFN [LAMBDA (FILESTREAM) (* ; "Edited 26-Oct-87 22:00 by Koomen") (LET ((INCLOBJ (READ FILESTREAM))) (if (NLISTP INCLOBJ) then (* ;; "Version 1: Just filename as string") (* ;; "Version 2: List whose CAR is filename") (SETQ INCLOBJ (create INCLOBJ FILENAME _ INCLOBJ))) (if (NLISTP (CDR INCLOBJ)) then (* ;; "Version 3: List whose CADR is ENABLEDP flag") (NCONC1 INCLOBJ T)) (DOCOBJ-INCLUDE-CREATE-OBJ INCLOBJ]) (DOCOBJ-INCLUDE-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 23-Oct-87 14:41 by Koomen") (OR (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (if [AND INCLOBJ (OR (EQ (IMAGESTREAMTYPE IMAGESTREAM) 'DISPLAY) (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ] then (DOCOBJ-STRING-IMAGEBOX (IMAGEOBJPROP IMAGEOBJ (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then 'INCLDISPLAYSTRING else 'DONTINCLDISPLAYSTRING)) IMAGESTREAM))) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (DOCOBJ-INCLUDE-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:19 by Koomen") (fetch (INCLOBJ FILENAME) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-INCLUDE-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* ; "Edited 15-Oct-87 17:17 by Koomen") (PRINT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) FILESTREAM]) ) (RPAQ? DOCOBJ-INCLUDE-EDITMENU ) (RPAQ? DOCOBJ-INCLUDE-IMAGEFNS (DOCOBJ-MAKE-INCLUDE-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("Include" (DOCOBJ-MAKE-INCLUDE) "Include another document right here when hardcopying")) (DECLARE%: DONTEVAL@LOAD DOCOPY (DOCOBJ-INIT) ) (DECLARE%: EVAL@LOAD DONTCOPY (PUTPROPS DOC-OBJECTS FILETYPE :TCOMPL) (PUTPROPS DOC-OBJECTS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) ) (PUTPROPS DOC-OBJECTS COPYRIGHT ("Johannes A. G. M. Koomen" 1986 1987 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7841 17834 (DOCOBJ-ACQUIRE-OBJECT 7851 . 8725) (DOCOBJ-INIT 8727 . 9355) ( DOCOBJ-TEDIT-MENU-ENTRY 9357 . 9779) (DOCOBJ-GET-LOOKS 9781 . 12516) (DOCOBJ-REGISTER-OBJECT 12518 . 13172) (DOCOBJ-STRING-IMAGEBOX 13174 . 14122) (DOCOBJ-WAIT-MOUSE 14124 . 14584) ( DOCOBJ-INVOKE-IMAGEOBJFN 14586 . 15370) (DOCOBJ-BEFOREHARDCOPYFN 15372 . 16765) ( DOCOBJ-AFTERHARDCOPYFN 16767 . 17832)) (17864 18131 (DOCOBJ-ACQUIRE-EVALED-OBJECT 17874 . 18129)) ( 18335 18477 (DOCOBJ-ACQUIRE-SNAPPED-OBJECT 18345 . 18475)) (18820 23616 (DOCOBJ-EDIT-TIMESTAMP 18830 . 19359) (DOCOBJ-MAKE-TIMESTAMP 19361 . 19772) (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS 19774 . 20844) ( DOCOBJ-TIMESTAMP-BUTTONEVENTINFN 20846 . 21377) (DOCOBJ-TIMESTAMP-COPYFN 21379 . 21704) ( DOCOBJ-TIMESTAMP-DISPLAYFN 21706 . 21999) (DOCOBJ-TIMESTAMP-GETFN 22001 . 22241) ( DOCOBJ-TIMESTAMP-IMAGEBOXFN 22243 . 22599) (DOCOBJ-TIMESTAMP-PREPRINTFN 22601 . 22832) ( DOCOBJ-TIMESTAMP-PUTFN 22834 . 23203) (DOCOBJ-TIMESTAMP-TO-STRING 23205 . 23614)) (23914 28221 ( DOCOBJ-MAKE-FILESTAMP 23924 . 24265) (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS 24267 . 25309) ( DOCOBJ-FILESTAMP-COPYFN 25311 . 25626) (DOCOBJ-FILESTAMP-DISPLAYFN 25628 . 25916) ( DOCOBJ-FILESTAMP-GETFN 25918 . 26271) (DOCOBJ-FILESTAMP-IMAGEBOXFN 26273 . 26611) ( DOCOBJ-FILESTAMP-GET-FULLNAME 26613 . 27231) (DOCOBJ-FILESTAMP-NEW-FULLNAME 27233 . 27706) ( DOCOBJ-FILESTAMP-PREPRINTFN 27708 . 27917) (DOCOBJ-FILESTAMP-PUTFN 27919 . 28219)) (28548 31045 ( DOCOBJ-MAKE-HRULE 28558 . 28972) (DOCOBJ-EDIT-HRULE 28974 . 29446) (DOCOBJ-HRULE-INIT 29448 . 29780) ( DOCOBJ-HRULE-GET-WIDTH 29782 . 30593) (DOCOBJ-HRULE-BUTTONEVENTINFN 30595 . 31043)) (31433 38625 ( DOCOBJ-MAKE-INCLUDE 31443 . 31844) (DOCOBJ-MAKE-INCLUDE-IMAGEFNS 31846 . 32851) ( DOCOBJ-INCLUDE-CREATE-OBJ 32853 . 33642) (DOCOBJ-INCLUDE-EDIT 33644 . 36986) ( DOCOBJ-INCLUDE-EDIT-WINDOWP 36988 . 37850) (DOCOBJ-INCLUDE-RESET-OBJ 37852 . 38623)) (38626 47304 ( DOCOBJ-INCLUDE-AFTERHARDCOPYFN 38636 . 39520) (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN 39522 . 42877) ( DOCOBJ-INCLUDE-CLEANUPFN 42879 . 43646) (DOCOBJ-INCLUDE-BUTTONEVENTINFN 43648 . 44182) ( DOCOBJ-INCLUDE-COPYFN 44184 . 44402) (DOCOBJ-INCLUDE-DISPLAYFN 44404 . 45136) (DOCOBJ-INCLUDE-GETFN 45138 . 45861) (DOCOBJ-INCLUDE-IMAGEBOXFN 45863 . 46872) (DOCOBJ-INCLUDE-PREPRINTFN 46874 . 47093) ( DOCOBJ-INCLUDE-PUTFN 47095 . 47302))))) STOP \ No newline at end of file diff --git a/lispusers/DOC-OBJECTS.~7~ b/lispusers/DOC-OBJECTS.~7~ deleted file mode 100644 index 968f3a8d..00000000 --- a/lispusers/DOC-OBJECTS.~7~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED " 9-May-2018 11:09:43"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>DOC-OBJECTS.;7 50515 changes to%: (FNS DOCOBJ-INCLUDE-EDIT DOCOBJ-INCLUDE-BEFOREHARDCOPYFN) previous date%: " 9-May-2018 10:35:47" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>DOC-OBJECTS.;4) (* ; " Copyright (c) 1986, 1987, 1993, 2018 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT DOC-OBJECTSCOMS) (RPAQQ DOC-OBJECTSCOMS [ (* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc.") (FILES (SYSLOAD) TEDIT IMAGEOBJ) (VARS (DocObjectsMenu NIL) (DocObjectsConfirmEditMenu NIL)) [INITVARS (DocObjectsMenuCommands NIL) (DocObjectsMenuFont (FONTCREATE '(MODERN 12 BOLD] (COMS (* ;; "The hook into GET.OBJ.FROM.USER") (FNS DOCOBJ-ACQUIRE-OBJECT DOCOBJ-INIT DOCOBJ-TEDIT-MENU-ENTRY DOCOBJ-GET-LOOKS DOCOBJ-REGISTER-OBJECT DOCOBJ-STRING-IMAGEBOX DOCOBJ-WAIT-MOUSE DOCOBJ-INVOKE-IMAGEOBJFN DOCOBJ-BEFOREHARDCOPYFN DOCOBJ-AFTERHARDCOPYFN)) [COMS (* ;; "Eval'd Form") (FNS DOCOBJ-ACQUIRE-EVALED-OBJECT) (ADDVARS (DocObjectsMenuCommands ("Eval'd Form" (DOCOBJ-ACQUIRE-EVALED-OBJECT) "Insert the value of a form to be typed in"] [COMS (* ;; "Screen Snap") (FNS DOCOBJ-ACQUIRE-SNAPPED-OBJECT) (ADDVARS (DocObjectsMenuCommands ("Screen Snap" (DOCOBJ-ACQUIRE-SNAPPED-OBJECT) "Insert a snap from the screen"] [COMS (* ;; "Time Stamp") (DECLARE%: DONTCOPY (RECORDS DOCOBJ-TIMESTAMP)) (FILES (SYSLOAD) DATEFORMAT-EDITOR) (FNS DOCOBJ-EDIT-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS DOCOBJ-TIMESTAMP-BUTTONEVENTINFN DOCOBJ-TIMESTAMP-COPYFN DOCOBJ-TIMESTAMP-DISPLAYFN DOCOBJ-TIMESTAMP-GETFN DOCOBJ-TIMESTAMP-IMAGEBOXFN DOCOBJ-TIMESTAMP-PREPRINTFN DOCOBJ-TIMESTAMP-PUTFN DOCOBJ-TIMESTAMP-TO-STRING) (INITVARS (DocObjectsTimeStampFormat) (DOCOBJ-TIMESTAMP-IMAGEFNS (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("Time Stamp" (DOCOBJ-MAKE-TIMESTAMP) "Date & time this document is PUT"] [COMS (* ;; "File Stamp") (FNS DOCOBJ-MAKE-FILESTAMP DOCOBJ-MAKE-FILESTAMP-IMAGEFNS DOCOBJ-FILESTAMP-COPYFN DOCOBJ-FILESTAMP-DISPLAYFN DOCOBJ-FILESTAMP-GETFN DOCOBJ-FILESTAMP-IMAGEBOXFN DOCOBJ-FILESTAMP-GET-FULLNAME DOCOBJ-FILESTAMP-NEW-FULLNAME DOCOBJ-FILESTAMP-PREPRINTFN DOCOBJ-FILESTAMP-PUTFN) (INITVARS (DOCOBJ-FILESTAMP-IMAGEFNS (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("File Stamp" (DOCOBJ-MAKE-FILESTAMP) "Name of file to which this document was last PUT." ] (COMS (* ;; "Horizontal Rule") (FILES (SYSLOAD) HRULE READNUMBER) (FNS DOCOBJ-MAKE-HRULE DOCOBJ-EDIT-HRULE DOCOBJ-HRULE-INIT DOCOBJ-HRULE-GET-WIDTH DOCOBJ-HRULE-BUTTONEVENTINFN) (VARS (DOCOBJ-HRULE-RULE-PAD) (DOCOBJ-HRULE-BLANK-PAD)) (ADDVARS (DocObjectsMenuCommands ("Horizontal Rule" (DOCOBJ-MAKE-HRULE) "One or more horizontal rules"))) (P (DOCOBJ-HRULE-INIT))) [COMS (* ;; "INCLUDE") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS INCLOBJ)) (FNS DOCOBJ-MAKE-INCLUDE DOCOBJ-MAKE-INCLUDE-IMAGEFNS DOCOBJ-INCLUDE-CREATE-OBJ DOCOBJ-INCLUDE-EDIT DOCOBJ-INCLUDE-EDIT-WINDOWP DOCOBJ-INCLUDE-RESET-OBJ) (FNS DOCOBJ-INCLUDE-AFTERHARDCOPYFN DOCOBJ-INCLUDE-BEFOREHARDCOPYFN DOCOBJ-INCLUDE-CLEANUPFN DOCOBJ-INCLUDE-BUTTONEVENTINFN DOCOBJ-INCLUDE-COPYFN DOCOBJ-INCLUDE-DISPLAYFN DOCOBJ-INCLUDE-GETFN DOCOBJ-INCLUDE-IMAGEBOXFN DOCOBJ-INCLUDE-PREPRINTFN DOCOBJ-INCLUDE-PUTFN) (INITVARS (DOCOBJ-INCLUDE-EDITMENU) (DOCOBJ-INCLUDE-IMAGEFNS (DOCOBJ-MAKE-INCLUDE-IMAGEFNS))) (ADDVARS (DocObjectsMenuCommands ("Include" (DOCOBJ-MAKE-INCLUDE) "Include another document right here when hardcopying" ] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DOCOBJ-INIT))) (DECLARE%: EVAL@LOAD DONTCOPY (COMS (PROP FILETYPE DOC-OBJECTS) (PROP MAKEFILE-ENVIRONMENT DOC-OBJECTS]) (* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc." ) (FILESLOAD (SYSLOAD) TEDIT IMAGEOBJ) (RPAQQ DocObjectsMenu NIL) (RPAQQ DocObjectsConfirmEditMenu NIL) (RPAQ? DocObjectsMenuCommands NIL) (RPAQ? DocObjectsMenuFont (FONTCREATE '(MODERN 12 BOLD))) (* ;; "The hook into GET.OBJ.FROM.USER") (DEFINEQ (DOCOBJ-ACQUIRE-OBJECT [LAMBDA NIL (* ; "Edited 15-Oct-87 16:27 by Koomen") (* ;;; "This function is invoked by TEdit's GET.OBJ.FROM.USER (cf. the Library file IMAGEOBJ) after (CHANGENAME (QUOTE GET.OBJ.FROM.USER) (QUOTE PROMPTFOREVALED) (QUOTE DOCOBJ-ACQUIRE-OBJECT))") (* ;;; "When adding more items to the DocObjectsMenuCommands, do (SETQ DocObjectsMenu)") (DECLARE (GLOBALVARS DocObjectsMenu DocObjectsMenuCommands DocObjectsMenuFont)) (if (NOT (type? MENU DocObjectsMenu)) then (SETQ DocObjectsMenu (create MENU TITLE _ "Select object type: " CENTERFLG _ T ITEMS _ DocObjectsMenuCommands MENUFONT _ DocObjectsMenuFont))) (MENU DocObjectsMenu]) (DOCOBJ-INIT [LAMBDA NIL (* ;  "Edited 8-Oct-87 21:32 by Koomen") (* ;;; "This function changes the behavior of standard TEdit such that ^O will invoke the DocObjects system; an entry to invoke the DocObjects system is also added to TEdit's middle button menu.") (DECLARE (GLOBALVARS TEDIT.DEFAULT.MENU)) (CHANGENAME 'GET.OBJ.FROM.USER 'PROMPTFOREVALED ' DOCOBJ-ACQUIRE-OBJECT) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Object (FUNCTION DOCOBJ-TEDIT-MENU-ENTRY) "Insert a Document Object"]) (DOCOBJ-TEDIT-MENU-ENTRY [LAMBDA (TEXTSTREAM) (* ;  "Edited 8-Oct-87 21:31 by Koomen") (* ;;; "This is the entry point into the DocObjects system from TEdit's middle button menu. GET.OBJ.FROM.USER used to call PROMPTFOREVALED but DocObjects changes this into a call to DOCOBJ-ACQUIRE-OBJECT.") (GET.OBJ.FROM.USER TEXTSTREAM (TEXTOBJ TEXTSTREAM]) (DOCOBJ-GET-LOOKS [LAMBDA (TEXTOBJ CH#ORCHARLOOKS) (* Koomen " 4-Feb-87 23:37") (* * Adapted from {ERIS}TEDITLOOKS.;30 dated  "15-Oct-85 16:51:10" to return looks itself, rather  than a proplist.)  (* jds "10-Jul-85 16:02") (* Return a PLIST of  character looks) (PROG ((TEXTOBJ (TEXTOBJ TEXTOBJ)) LOOKS FONT NLOOKS) [COND ((type? CHARLOOKS CH#ORCHARLOOKS) (* He handed us a  CHARLOOKS. Unparse it for  him.) (SETQ LOOKS CH#ORCHARLOOKS)) ((ZEROP (fetch TEXTLEN of TEXTOBJ)) (* There's no text in the document.  Use the extant caret looks.) (SETQ LOOKS (fetch CARETLOOKS of TEXTOBJ))) [(FIXP CH#ORCHARLOOKS) (* He gave us a CH# to geth the looks of.  Grab it.) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) CH#ORCHARLOOKS) (fetch PCTB of TEXTOBJ] [(type? SELECTION CH#ORCHARLOOKS) (* Get the looks of the  selected text) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) (fetch (SELECTION CH#) of CH#ORCHARLOOKS)) (fetch PCTB of TEXTOBJ] ((NULL CH#ORCHARLOOKS) (* Get the looks of the  selected text) (SETQ LOOKS (fetch PLOOKS of (\CHTOPC (IMIN (fetch TEXTLEN of TEXTOBJ) (fetch (SELECTION CH#) of (fetch SEL of TEXTOBJ))) (fetch PCTB of TEXTOBJ] (RETURN LOOKS) (* * Now break the looks apart into a PROPLIST) (SETQ NLOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST LOOKS)) (RETURN NLOOKS]) (DOCOBJ-REGISTER-OBJECT [LAMBDA (OBJECT) (* ; "Edited 23-Oct-87 14:48 by Koomen") (* ;; "The following ensures that all DocObjects get a chance to do whatever they want to before and after hardcopying. Each DocObject can associate a BEFOREHARDCOPYFN and/or an AFTERHARDCOPYFN with the ImageObj representing the DocObject") (DECLARE (SPECVARS TEXTOBJ)) (if OBJECT then (TEXTPROP TEXTOBJ 'BEFOREHARDCOPYFN (FUNCTION DOCOBJ-BEFOREHARDCOPYFN)) (TEXTPROP TEXTOBJ 'AFTERHARDCOPYFN (FUNCTION DOCOBJ-AFTERHARDCOPYFN)) OBJECT]) (DOCOBJ-STRING-IMAGEBOX [LAMBDA (STRING IMAGESTREAM) (* Koomen " 9-Feb-87 17:22") (DECLARE (SPECVARS CHNO TEXTOBJ)) (PROG (LOOKS CLOFFSET FONT DEVICE HEIGHT DESCENT) (SETQ LOOKS (DOCOBJ-GET-LOOKS TEXTOBJ CHNO)) (SETQ CLOFFSET (fetch (CHARLOOKS CLOFFSET) of LOOKS)) (SETQ FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) (if (NEQ (FONTPROP FONT 'DEVICE) (SETQ DEVICE (IMAGESTREAMTYPE IMAGESTREAM))) then (SETQ FONT (FONTCOPY FONT 'DEVICE DEVICE))) (SETQ HEIGHT (FONTHEIGHT FONT)) (SETQ DESCENT (FONTPROP FONT 'DESCENT)) (RETURN (create IMAGEBOX XSIZE _ (STRINGWIDTH STRING FONT) YSIZE _ (IPLUS HEIGHT (IABS CLOFFSET)) YDESC _ (IDIFFERENCE DESCENT CLOFFSET) XKERN _ 0]) (DOCOBJ-WAIT-MOUSE [LAMBDA (STREAM) (* ;  "Edited 8-Oct-87 23:46 by Koomen") (while (NOT (MOUSESTATE UP)) bind (REGION _ (DSPCLIPPINGREGION NIL STREAM)) do (if (NOT (INSIDEP REGION (LASTMOUSEX STREAM) (LASTMOUSEY STREAM))) then (RETURN NIL)) finally (RETURN T]) (DOCOBJ-INVOKE-IMAGEOBJFN [LAMBDA (CH# PIECE PC# IMAGEOBJFNNAME) (* ; "Edited 15-Oct-87 23:35 by Koomen") (* ;; "If PIECE is an IMAGEOBJ, invoke the function associated with the ImageObj property IMAGEOBJFNNAME on the IMAGEOBJ and the character position where the IMAGEOBJ is located. ") (PROG (IMAGEOBJ IMAGEOBJFN) (if (NOT (type? PIECE PIECE)) then (RETURN)) (SETQ IMAGEOBJ (fetch POBJ of PIECE)) (if (NOT (IMAGEOBJP IMAGEOBJ)) then (RETURN)) (SETQ IMAGEOBJFN (IMAGEOBJPROP IMAGEOBJ IMAGEOBJFNNAME)) (if (AND IMAGEOBJFN (DEFINEDP IMAGEOBJFN)) then (APPLY* IMAGEOBJFN IMAGEOBJ CH# PIECE PC#]) (DOCOBJ-BEFOREHARDCOPYFN [LAMBDA (TEXTSTREAM TEXTOBJ) (* ;  "Edited 25-May-93 13:07 by sybalsky:mv:envos") (* ;; "Bug in TEDIT.FORMAT.HARDCOPY!!! This function is called with the arguments TEXTSTREAM and TEXTOBJ, but TEXTSTREAM is undefined!") (* ;; "*DOCOBJ-FORMS* is used to enable insertion and deletion of pieces. DocObjects can postpone insertion or deletion by added appropriate forms to *DOCOBJ-FORMS*. Can't do it while under TEDIT.MAPPIECES as the pointers get screwed up. ") (DECLARE (SPECVARS *DOCOBJ-FORMS*)) (LET ((TEXTSTREAM (TEXTSTREAM TEXTOBJ)) (*DOCOBJ-FORMS*)) (TEXTPROP TEXTSTREAM 'DOCOBJ-VIRGINP (NOT (TEDIT.STREAMCHANGEDP TEXTSTREAM))) (* ;; "After hardcopy, TEXTSTREAM is reset if this flag is T") (do (SETQ *DOCOBJ-FORMS*) (TEDIT.MAPPIECES TEXTOBJ (FUNCTION DOCOBJ-INVOKE-IMAGEOBJFN) 'BEFOREHARDCOPYFN) [WITHOUT-UPDATES TEXTOBJ (FETCH (TEXTOBJ SCRATCHSEL) OF TEXTOBJ) (for FRM in *DOCOBJ-FORMS* do (APPLY (CAR FRM) (CDR FRM] repeatwhile *DOCOBJ-FORMS*]) (DOCOBJ-AFTERHARDCOPYFN [LAMBDA (TEXTSTREAM TEXTOBJ) (* ;  "Edited 25-May-93 13:08 by sybalsky:mv:envos") (* ;; "Bug in TEDIT.FORMAT.HARDCOPY!!! This function is called with the arguments TEXTSTREAM and TEXTOBJ, but TEXTSTREAM is undefined, and TEXTOBJ is NIL!") (DECLARE (SPECVARS *DOCOBJ-FORMS*)) (LET ((*DOCOBJ-FORMS*)) (do (SETQ *DOCOBJ-FORMS*) (TEDIT.MAPPIECES TEXTOBJ (FUNCTION DOCOBJ-INVOKE-IMAGEOBJFN) 'AFTERHARDCOPYFN) [WITHOUT-UPDATES TEXTOBJ (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) (for FRM in *DOCOBJ-FORMS* do (APPLY (CAR FRM) (CDR FRM] repeatwhile *DOCOBJ-FORMS*) (COND ((TEXTPROP TEXTSTREAM 'DOCOBJ-VIRGINP) (TEDIT.STREAMCHANGEDP TEXTSTREAM T]) ) (* ;; "Eval'd Form") (DEFINEQ (DOCOBJ-ACQUIRE-EVALED-OBJECT [LAMBDA NIL (* Koomen "30-Sep-86 02:08") (* * This is the original function called under  GET.OBJ.FROM.USER * *) (PROMPTFOREVALED "Form to eval: "]) ) (ADDTOVAR DocObjectsMenuCommands ("Eval'd Form" (DOCOBJ-ACQUIRE-EVALED-OBJECT) "Insert the value of a form to be typed in")) (* ;; "Screen Snap") (DEFINEQ (DOCOBJ-ACQUIRE-SNAPPED-OBJECT [LAMBDA NIL (* Koomen "26-Sep-86 16:55") (GETREGION]) ) (ADDTOVAR DocObjectsMenuCommands ("Screen Snap" (DOCOBJ-ACQUIRE-SNAPPED-OBJECT) "Insert a snap from the screen")) (* ;; "Time Stamp") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD DOCOBJ-TIMESTAMP (IDATE DATESTR FORMAT)) ) ) (FILESLOAD (SYSLOAD) DATEFORMAT-EDITOR) (DEFINEQ (DOCOBJ-EDIT-TIMESTAMP [LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:08") (PROG [(FORMAT (EDIT-DATEFORMAT (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP] (if FORMAT then (replace (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP with FORMAT) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL) (RETURN TIMESTAMP]) (DOCOBJ-MAKE-TIMESTAMP [LAMBDA NIL (* Koomen " 4-Feb-87 13:54") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS DocObjectsTimeStampFormat)) (IMAGEOBJCREATE (create DOCOBJ-TIMESTAMP IDATE _ (IDATE) FORMAT _ DocObjectsTimeStampFormat) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:53 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-TIMESTAMP-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-TIMESTAMP-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-TIMESTAMP-PUTFN)) (GETFN (FUNCTION DOCOBJ-TIMESTAMP-GETFN)) (COPYFN (FUNCTION DOCOBJ-TIMESTAMP-COPYFN)) (BUTTONEVENTINFN (FUNCTION DOCOBJ-TIMESTAMP-BUTTONEVENTINFN)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-TIMESTAMP-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-TIMESTAMP-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ;  "Edited 8-Oct-87 23:43 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-EDIT-TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then 'CHANGED]) (DOCOBJ-TIMESTAMP-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 00:30") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-TIMESTAMP-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* Koomen " 4-Feb-87 14:11") (PRINTOUT IMAGESTREAM (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-TIMESTAMP-GETFN [LAMBDA (FILESTREAM) (* Koomen "31-Jan-87 00:19") (DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (READ FILESTREAM) DOCOBJ-TIMESTAMP-IMAGEFNS]) (DOCOBJ-TIMESTAMP-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* Koomen " 9-Feb-87 17:13") (LET* ((TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) (TIMESTRING (DOCOBJ-TIMESTAMP-TO-STRING TIMESTAMP))) (DOCOBJ-STRING-IMAGEBOX TIMESTRING IMAGESTREAM]) (DOCOBJ-TIMESTAMP-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ;  "Edited 8-Oct-87 22:29 by Koomen") (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-TIMESTAMP-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* Koomen " 4-Feb-87 14:08") (PROG [(TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (replace (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP with (IDATE)) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL) (PRINT TIMESTAMP FILESTREAM]) (DOCOBJ-TIMESTAMP-TO-STRING [LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:12") (OR (STRINGP (fetch (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP)) (replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with (GDATE (fetch (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP) (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP]) ) (RPAQ? DocObjectsTimeStampFormat ) (RPAQ? DOCOBJ-TIMESTAMP-IMAGEFNS (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("Time Stamp" (DOCOBJ-MAKE-TIMESTAMP) "Date & time this document is PUT")) (* ;; "File Stamp") (DEFINEQ (DOCOBJ-MAKE-FILESTAMP [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:55 by Koomen") (DECLARE (SPECVARS TEXTOBJ) (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (DOCOBJ-FILESTAMP-NEW-FULLNAME TEXTOBJ) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS [LAMBDA NIL (* ;  "Edited 8-Oct-87 22:54 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-FILESTAMP-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-FILESTAMP-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-FILESTAMP-PUTFN)) (GETFN (FUNCTION DOCOBJ-FILESTAMP-GETFN)) (COPYFN (FUNCTION DOCOBJ-FILESTAMP-COPYFN)) (BUTTONEVENTINFN (FUNCTION NILL)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-FILESTAMP-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-FILESTAMP-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 04:10") (DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (IMAGEOBJCREATE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-FILESTAMP-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ;  "Edited 8-Oct-87 22:56 by Koomen") (PRINTOUT IMAGESTREAM (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ]) (DOCOBJ-FILESTAMP-GETFN [LAMBDA (FILESTREAM) (* ;  "Edited 8-Oct-87 22:58 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS)) (LET ((FULLNAME (READ FILESTREAM))) (IMAGEOBJCREATE (AND FULLNAME (MKSTRING FULLNAME)) DOCOBJ-FILESTAMP-IMAGEFNS]) (DOCOBJ-FILESTAMP-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ;  "Edited 8-Oct-87 22:59 by Koomen") (LET ((FULLNAME (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ))) (DOCOBJ-STRING-IMAGEBOX FULLNAME IMAGESTREAM]) (DOCOBJ-FILESTAMP-GET-FULLNAME [LAMBDA (IMAGEOBJ NODEFAULTFLG) (* ;  "Edited 8-Oct-87 22:59 by Koomen") (PROG [(FULLNAME (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (RETURN (OR (if FULLNAME then (if (LITATOM FULLNAME) then (MKSTRING FULLNAME) elseif (STRINGP FULLNAME) then (COPYALL FULLNAME))) (if (NOT NODEFAULTFLG) then "-- not yet filed --"]) (DOCOBJ-FILESTAMP-NEW-FULLNAME [LAMBDA (TEXTOBJ) (* ;  "Edited 8-Oct-87 22:52 by Koomen") (PROG ((FULLNAME (FULLNAME TEXTOBJ))) (RETURN (if FULLNAME then (if (LITATOM FULLNAME) then (MKSTRING FULLNAME) elseif (STRINGP FULLNAME) then (COPYALL FULLNAME]) (DOCOBJ-FILESTAMP-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ;  "Edited 8-Oct-87 22:56 by Koomen") (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ T]) (DOCOBJ-FILESTAMP-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* ;  "Edited 8-Oct-87 22:39 by Koomen") (PROG [(FULLNAME (MKSTRING (FULLNAME FILESTREAM] (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM FULLNAME) (PRINT FULLNAME FILESTREAM]) ) (RPAQ? DOCOBJ-FILESTAMP-IMAGEFNS (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("File Stamp" (DOCOBJ-MAKE-FILESTAMP) "Name of file to which this document was last PUT.")) (* ;; "Horizontal Rule") (FILESLOAD (SYSLOAD) HRULE READNUMBER) (DEFINEQ (DOCOBJ-MAKE-HRULE [LAMBDA NIL (* Koomen " 4-Feb-87 16:12") (HRULE.CREATE (bind WIDTH for I from 1 while (AND (SETQ WIDTH (DOCOBJ-HRULE-GET-WIDTH (ODDP I) (EQ I 1))) (GREATERP WIDTH 0)) collect WIDTH]) (DOCOBJ-EDIT-HRULE [LAMBDA (IMAGEOBJ) (* Koomen " 4-Feb-87 15:45") (PROG [NEWWIDTH (OLDWIDTH (MKLIST (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH] (SETQ NEWWIDTH (COPYALL OLDWIDTH)) (if (AND (NLSETQ (EDITE NEWWIDTH)) (NOT (EQUAL NEWWIDTH OLDWIDTH))) then (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH NEWWIDTH) (RETURN IMAGEOBJ]) (DOCOBJ-HRULE-INIT [LAMBDA NIL (* Koomen " 4-Feb-87 16:13") (* * provide HRULE editing * *) (DECLARE (GLOBALVARS HRULE.IMAGEFNS)) (replace (IMAGEFNS BUTTONEVENTINFN) of HRULE.IMAGEFNS with (FUNCTION DOCOBJ-HRULE-BUTTONEVENTINFN)) NIL]) (DOCOBJ-HRULE-GET-WIDTH [LAMBDA (RULE? FIRST?) (* ;  "Edited 24-May-93 23:35 by sybalsky:mv:envos") (DECLARE (GLOBALVARS DOCOBJ-HRULE-BLANK-PAD DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY)) [COND ((NULL DOCOBJ-HRULE-RULE-PAD) (SETQ DOCOBJ-HRULE-RULE-PAD (CREATE.NUMBERPAD.READER "Rule width: " NIL NIL NIL T T)) (SETQ DOCOBJ-HRULE-BLANK-PAD (CREATE.NUMBERPAD.READER "Blank space: " NIL NIL NIL T T] (COND (FIRST? (MOVEW DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY) (MOVEW DOCOBJ-HRULE-BLANK-PAD LASTMOUSEX LASTMOUSEY))) (NUMBERPAD.READ (COND (RULE? DOCOBJ-HRULE-RULE-PAD) (T DOCOBJ-HRULE-BLANK-PAD)) T]) (DOCOBJ-HRULE-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ;  "Edited 8-Oct-87 23:43 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-EDIT-HRULE IMAGEOBJ) then 'CHANGED]) ) (RPAQQ DOCOBJ-HRULE-RULE-PAD NIL) (RPAQQ DOCOBJ-HRULE-BLANK-PAD NIL) (ADDTOVAR DocObjectsMenuCommands ("Horizontal Rule" (DOCOBJ-MAKE-HRULE) "One or more horizontal rules")) (DOCOBJ-HRULE-INIT) (* ;; "INCLUDE") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD INCLOBJ (FILENAME ENABLEDP)) ) ) (DEFINEQ (DOCOBJ-MAKE-INCLUDE [LAMBDA NIL (* ; "Edited 15-Oct-87 14:54 by Koomen") (DECLARE (SPECVARS TEXTOBJ)) (PROG ((SUBFILE (TEDIT.GETINPUT TEXTOBJ "Enter file name: "))) (if SUBFILE then (RETURN (DOCOBJ-INCLUDE-CREATE-OBJ SUBFILE)) else (TEDIT.PROMPTPRINT TEXTOBJ "... aborted."]) (DOCOBJ-MAKE-INCLUDE-IMAGEFNS [LAMBDA NIL (* ; "Edited 23-Oct-87 00:20 by Koomen") (LET ((DISPLAYFN (FUNCTION DOCOBJ-INCLUDE-DISPLAYFN)) (IMAGEBOXFN (FUNCTION DOCOBJ-INCLUDE-IMAGEBOXFN)) (PUTFN (FUNCTION DOCOBJ-INCLUDE-PUTFN)) (GETFN (FUNCTION DOCOBJ-INCLUDE-GETFN)) (COPYFN (FUNCTION DOCOBJ-INCLUDE-COPYFN)) (BUTTONEVENTINFN (FUNCTION DOCOBJ-INCLUDE-BUTTONEVENTINFN)) (COPYBUTTONEVENTINFN (FUNCTION NILL)) (WHENMOVEDFN (FUNCTION NILL)) (WHENINSERTEDFN (FUNCTION NILL)) (WHENDELETEDFN (FUNCTION NILL)) (WHENCOPIEDFN (FUNCTION NILL)) (WHENOPERATEDONFN (FUNCTION NILL)) (PREPRINTFN (FUNCTION DOCOBJ-INCLUDE-PREPRINTFN))) (IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN]) (DOCOBJ-INCLUDE-CREATE-OBJ [LAMBDA (INCLOBJ) (* ; "Edited 23-Oct-87 14:06 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-INCLUDE-IMAGEFNS)) (PROG (IMAGEOBJ) [if INCLOBJ then (if (NLISTP INCLOBJ) then (* ;; "Just a file name") (SETQ INCLOBJ (create INCLOBJ FILENAME _ (MKSTRING INCLOBJ) ENABLEDP _ T] (SETQ IMAGEOBJ (IMAGEOBJCREATE INCLOBJ DOCOBJ-INCLUDE-IMAGEFNS)) (DOCOBJ-INCLUDE-RESET-OBJ IMAGEOBJ) (DOCOBJ-REGISTER-OBJECT IMAGEOBJ) (RETURN IMAGEOBJ]) (DOCOBJ-INCLUDE-EDIT [LAMBDA (INCLOBJ) (* ; "Edited 9-May-2018 11:09 by rmk:") (* ; "Edited 9-May-2018 10:35 by rmk:") (* ;  "Edited 26-Oct-87 19:57 by Koomen") (DECLARE (SPECVARS TEXTOBJ)) (SELECTQ [MENU (OR DOCOBJ-INCLUDE-EDITMENU (SETQ DOCOBJ-INCLUDE-EDITMENU (create MENU TITLE _ "Edit Include" ITEMS _ '(("New File" 'NEW.FILE "Include a different file") ("Edit File" 'EDIT.FILE "Edit the included file") ("Enable" 'ENABLE "Include the file during hardcopy" ) ("Disable" 'DISABLE "Do not include the file during hardcopy" )) CENTERFLG _ T MENUOFFSET _ '(-1 . 30) CHANGEOFFSETFLG _ 'Y] (NEW.FILE (LET [(NEWNAME (TEDIT.GETINPUT TEXTOBJ "Enter new file name: " (fetch (INCLOBJ FILENAME) of INCLOBJ] (if [AND NEWNAME (SETQ NEWNAME (MKSTRING NEWNAME)) (NOT (EQUAL NEWNAME (fetch (INCLOBJ FILENAME) of INCLOBJ] then (replace (INCLOBJ FILENAME) of INCLOBJ with NEWNAME) T))) (EDIT.FILE (for W in (OPENWINDOWS) bind [FULLNAME _ (OR [FINDFILE (fetch (INCLOBJ FILENAME) of INCLOBJ ) T (CONS (PACKFILENAME.STRING 'HOST (FILENAMEFIELD (FETCH TXTFILE OF TEXTOBJ) 'HOST) 'DIRECTORY (FILENAMEFIELD (FETCH TXTFILE OF TEXTOBJ) 'DIRECTORY] (INFILEP (fetch (INCLOBJ FILENAME) of INCLOBJ] first (if (NULL FULLNAME) then (TEDIT.PROMPTPRINT TEXTOBJ "Can't find " T) (TEDIT.PROMPTPRINT TEXTOBJ (fetch (INCLOBJ FILENAME) of INCLOBJ)) (RETURN)) when (SETQ W (DOCOBJ-INCLUDE-EDIT-WINDOWP FULLNAME W)) do (TOTOPW W) (GIVE.TTY.PROCESS W) (RETURN) finally (TEDIT (MKATOM FULLNAME)))) (ENABLE (if (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ)) then (replace (INCLOBJ ENABLEDP) of INCLOBJ with T) T)) (DISABLE (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then (replace (INCLOBJ ENABLEDP) of INCLOBJ with NIL) T)) NIL]) (DOCOBJ-INCLUDE-EDIT-WINDOWP [LAMBDA (FILENAME WINDOW) (* ; "Edited 26-Oct-87 19:53 by Koomen") (if (WINDOWP WINDOW) then (OR (LET (TEXTOBJ TXTFILE) (if (AND (SETQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ)) (type? TEXTOBJ TEXTOBJ) (SETQ TXTFILE (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) (STREAMP TXTFILE) (SETQ TXTFILE (FULLNAME TXTFILE)) (OR (STRINGP TXTFILE) (LITATOM TXTFILE)) (STRING-EQUAL FILENAME TXTFILE)) then WINDOW)) (DOCOBJ-INCLUDE-EDIT-WINDOWP FILENAME (WINDOWPROP WINDOW 'ICONFOR]) (DOCOBJ-INCLUDE-RESET-OBJ [LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:09 by Koomen") (DECLARE (GLOBALVARS DOCOBJ-INCLUDE-IMAGEFNS)) (PROG (INCLOBJ FNAME) (if (SETQ INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then (SETQ FNAME (fetch (INCLOBJ FILENAME) of INCLOBJ)) (IMAGEOBJPROP IMAGEOBJ 'INCLDISPLAYSTRING (CONCAT "@Include[" FNAME "]")) (IMAGEOBJPROP IMAGEOBJ 'DONTINCLDISPLAYSTRING (CONCAT "@DoNotInclude[" FNAME "]")) ) (IMAGEOBJPROP IMAGEOBJ 'BEFOREHARDCOPYFN (FUNCTION DOCOBJ-INCLUDE-BEFOREHARDCOPYFN)) (IMAGEOBJPROP IMAGEOBJ 'AFTERHARDCOPYFN (FUNCTION DOCOBJ-INCLUDE-AFTERHARDCOPYFN]) ) (DEFINEQ (DOCOBJ-INCLUDE-AFTERHARDCOPYFN [LAMBDA (IMAGEOBJ CH#) (* ;  "Edited 3-Jun-93 12:42 by sybalsky:mv:envos") (DECLARE (SPECVARS TEXTSTREAM)) (COND ((IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) (* ;; "Just record current position, let endmarker do the rest") (IMAGEOBJPROP IMAGEOBJ 'INCLSTARTPOS (ADD1 CH#))) (T (* ;; "Hit an end marker") (PROG (HEADOBJ STARTPOS) (SETQ HEADOBJ (IMAGEOBJPROP IMAGEOBJ 'INCLIMAGEOBJ)) (SETQ STARTPOS (IMAGEOBJPROP HEADOBJ 'INCLSTARTPOS)) (IMAGEOBJPROP HEADOBJ 'INCLUDEDP NIL) (push *DOCOBJ-FORMS* `(DOCOBJ-INCLUDE-CLEANUPFN ,TEXTSTREAM ,STARTPOS ,(ADD1 (IDIFFERENCE CH# STARTPOS]) (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN [LAMBDA (IMAGEOBJ CH#) (* ; "Edited 9-May-2018 11:08 by rmk:") (* ; "Edited 9-May-2018 09:50 by rmk:") (* ; "Edited 9-May-2018 09:20 by rmk:") (* ;  "Edited 1-Jun-93 10:56 by sybalsky:mv:envos") (DECLARE (SPECVARS *DOCOBJ-FORMS* TEXTOBJ)) (* ;; "RMK: Changed to default to file in same directory as the including file. ") (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (COND ([AND INCLOBJ (fetch (INCLOBJ ENABLEDP) of INCLOBJ) (NOT (IMAGEOBJPROP IMAGEOBJ 'INCLUDEDP] (* ;; "We're under MAP.PIECES -- dangerous to insert here, so postpone") (push *DOCOBJ-FORMS* (LIST [FUNCTION (LAMBDA (STARTPOS INCLFILE IMAGEOBJ ENDOBJ WINDOWS) (DECLARE (SPECVARS TEXTSTREAM)) (COND (WINDOWS (TEDIT.PROMPTPRINT TEXTSTREAM "Including " T) (TEDIT.PROMPTPRINT TEXTSTREAM INCLFILE) (TEDIT.PROMPTPRINT TEXTSTREAM "...")) (T (PROMPTPRINT "[TEdit hardcopy: including " INCLFILE "...]"))) (WITHOUT-UPDATES (TEXTOBJ TEXTSTREAM) (fetch (TEXTOBJ SCRATCHSEL) of (TEXTOBJ TEXTSTREAM)) (TEDIT.SETSEL TEXTSTREAM STARTPOS 0 'RIGHT) (* ;; "Force paragraph boundary, so that the first paragraph of the included document doesn't inherit the paralooks of the paragraph containing the @Include.") (TEDIT.INSERT TEXTSTREAM " ") (TEDIT.PARALOOKS TEXTSTREAM '(NEWPAGEAFTER NIL NEWPAGEBEFORE NIL LINELEADING 0 POSTPARALEADING 0 PARALEADING 0)) (* ;;  "For space efficiency, tell TEdit to assume that the file will exist as long as we need it.") (TEDIT.INCLUDE TEXTSTREAM (OR [FINDFILE INCLFILE T (CONS (PACKFILENAME.STRING 'HOST (FILENAMEFIELD (FETCH TXTFILE OF (TEXTOBJ TEXTSTREAM )) 'HOST) 'DIRECTORY (FILENAMEFIELD (FETCH TXTFILE OF (TEXTOBJ TEXTSTREAM )) 'DIRECTORY] INCLFILE) NIL NIL T) (TEDIT.INSERT.OBJECT ENDOBJ TEXTSTREAM) (IMAGEOBJPROP ENDOBJ 'INCLIMAGEOBJ IMAGEOBJ) (IMAGEOBJPROP IMAGEOBJ 'INCLUDEDP T)) (COND (WINDOWS (TEDIT.PROMPTPRINT TEXTSTREAM " done.")) (T (PROMPTPRINT "[TEdit hardcopy: including " INCLFILE "... done.]"] (ADD1 CH#) (fetch (INCLOBJ FILENAME) of INCLOBJ) IMAGEOBJ (DOCOBJ-INCLUDE-CREATE-OBJ) (fetch (TEXTOBJ \WINDOW) of TEXTOBJ]) (DOCOBJ-INCLUDE-CLEANUPFN [LAMBDA (TEXTSTREAM STARTPOS LEN) (* ;  "Edited 3-Jun-93 12:43 by sybalsky:mv:envos") (* ;; "Do the cleanup of removing an included file's pieces (and closing it) after hardcopying with inclusions.") (LET* ((SEL (TEDIT.SETSEL TEXTSTREAM STARTPOS LEN)) (PCS (TEDIT.SELECTED.PIECES (TEXTOBJ TEXTSTREAM) SEL))) (for PC in PCS when (AND (fetch (PIECE PFILE) of PC) (OPENP (fetch (PIECE PFILE) of PC))) do (CLOSEF (fetch (PIECE PFILE) of PC))) (TEDIT.DELETE TEXTSTREAM STARTPOS LEN) (BLOCK]) (DOCOBJ-INCLUDE-BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON) (* ; "Edited 23-Oct-87 00:46 by Koomen") (if (AND (EQ BUTTON 'MIDDLE) (DOCOBJ-WAIT-MOUSE WINDOWSTREAM)) then (ALLOW.BUTTON.EVENTS) (if (DOCOBJ-INCLUDE-EDIT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) then (DOCOBJ-INCLUDE-RESET-OBJ IMAGEOBJ) 'CHANGED]) (DOCOBJ-INCLUDE-COPYFN [LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* ; "Edited 23-Oct-87 00:13 by Koomen") (DOCOBJ-INCLUDE-CREATE-OBJ (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-INCLUDE-DISPLAYFN [LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ; "Edited 23-Oct-87 14:42 by Koomen") (PROG [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (if [AND INCLOBJ (OR (EQ IMAGESTREAMTYPE 'DISPLAY) (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ] then (printout IMAGESTREAM (IMAGEOBJPROP IMAGEOBJ (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then 'INCLDISPLAYSTRING else 'DONTINCLDISPLAYSTRING]) (DOCOBJ-INCLUDE-GETFN [LAMBDA (FILESTREAM) (* ; "Edited 26-Oct-87 22:00 by Koomen") (LET ((INCLOBJ (READ FILESTREAM))) (if (NLISTP INCLOBJ) then (* ;; "Version 1: Just filename as string") (* ;; "Version 2: List whose CAR is filename") (SETQ INCLOBJ (create INCLOBJ FILENAME _ INCLOBJ))) (if (NLISTP (CDR INCLOBJ)) then (* ;; "Version 3: List whose CADR is ENABLEDP flag") (NCONC1 INCLOBJ T)) (DOCOBJ-INCLUDE-CREATE-OBJ INCLOBJ]) (DOCOBJ-INCLUDE-IMAGEBOXFN [LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 23-Oct-87 14:41 by Koomen") (OR (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (if [AND INCLOBJ (OR (EQ (IMAGESTREAMTYPE IMAGESTREAM) 'DISPLAY) (NOT (fetch (INCLOBJ ENABLEDP) of INCLOBJ] then (DOCOBJ-STRING-IMAGEBOX (IMAGEOBJPROP IMAGEOBJ (if (fetch (INCLOBJ ENABLEDP) of INCLOBJ) then 'INCLDISPLAYSTRING else 'DONTINCLDISPLAYSTRING)) IMAGESTREAM))) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (DOCOBJ-INCLUDE-PREPRINTFN [LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:19 by Koomen") (fetch (INCLOBJ FILENAME) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (DOCOBJ-INCLUDE-PUTFN [LAMBDA (IMAGEOBJ FILESTREAM) (* ; "Edited 15-Oct-87 17:17 by Koomen") (PRINT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM) FILESTREAM]) ) (RPAQ? DOCOBJ-INCLUDE-EDITMENU ) (RPAQ? DOCOBJ-INCLUDE-IMAGEFNS (DOCOBJ-MAKE-INCLUDE-IMAGEFNS)) (ADDTOVAR DocObjectsMenuCommands ("Include" (DOCOBJ-MAKE-INCLUDE) "Include another document right here when hardcopying")) (DECLARE%: DONTEVAL@LOAD DOCOPY (DOCOBJ-INIT) ) (DECLARE%: EVAL@LOAD DONTCOPY (PUTPROPS DOC-OBJECTS FILETYPE :TCOMPL) (PUTPROPS DOC-OBJECTS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) ) (PUTPROPS DOC-OBJECTS COPYRIGHT ("Johannes A. G. M. Koomen" 1986 1987 1993 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7690 17683 (DOCOBJ-ACQUIRE-OBJECT 7700 . 8574) (DOCOBJ-INIT 8576 . 9204) ( DOCOBJ-TEDIT-MENU-ENTRY 9206 . 9628) (DOCOBJ-GET-LOOKS 9630 . 12365) (DOCOBJ-REGISTER-OBJECT 12367 . 13021) (DOCOBJ-STRING-IMAGEBOX 13023 . 13971) (DOCOBJ-WAIT-MOUSE 13973 . 14433) ( DOCOBJ-INVOKE-IMAGEOBJFN 14435 . 15219) (DOCOBJ-BEFOREHARDCOPYFN 15221 . 16614) ( DOCOBJ-AFTERHARDCOPYFN 16616 . 17681)) (17713 17980 (DOCOBJ-ACQUIRE-EVALED-OBJECT 17723 . 17978)) ( 18184 18326 (DOCOBJ-ACQUIRE-SNAPPED-OBJECT 18194 . 18324)) (18669 23465 (DOCOBJ-EDIT-TIMESTAMP 18679 . 19208) (DOCOBJ-MAKE-TIMESTAMP 19210 . 19621) (DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS 19623 . 20693) ( DOCOBJ-TIMESTAMP-BUTTONEVENTINFN 20695 . 21226) (DOCOBJ-TIMESTAMP-COPYFN 21228 . 21553) ( DOCOBJ-TIMESTAMP-DISPLAYFN 21555 . 21848) (DOCOBJ-TIMESTAMP-GETFN 21850 . 22090) ( DOCOBJ-TIMESTAMP-IMAGEBOXFN 22092 . 22448) (DOCOBJ-TIMESTAMP-PREPRINTFN 22450 . 22681) ( DOCOBJ-TIMESTAMP-PUTFN 22683 . 23052) (DOCOBJ-TIMESTAMP-TO-STRING 23054 . 23463)) (23763 28070 ( DOCOBJ-MAKE-FILESTAMP 23773 . 24114) (DOCOBJ-MAKE-FILESTAMP-IMAGEFNS 24116 . 25158) ( DOCOBJ-FILESTAMP-COPYFN 25160 . 25475) (DOCOBJ-FILESTAMP-DISPLAYFN 25477 . 25765) ( DOCOBJ-FILESTAMP-GETFN 25767 . 26120) (DOCOBJ-FILESTAMP-IMAGEBOXFN 26122 . 26460) ( DOCOBJ-FILESTAMP-GET-FULLNAME 26462 . 27080) (DOCOBJ-FILESTAMP-NEW-FULLNAME 27082 . 27555) ( DOCOBJ-FILESTAMP-PREPRINTFN 27557 . 27766) (DOCOBJ-FILESTAMP-PUTFN 27768 . 28068)) (28397 30894 ( DOCOBJ-MAKE-HRULE 28407 . 28821) (DOCOBJ-EDIT-HRULE 28823 . 29295) (DOCOBJ-HRULE-INIT 29297 . 29629) ( DOCOBJ-HRULE-GET-WIDTH 29631 . 30442) (DOCOBJ-HRULE-BUTTONEVENTINFN 30444 . 30892)) (31282 39731 ( DOCOBJ-MAKE-INCLUDE 31292 . 31693) (DOCOBJ-MAKE-INCLUDE-IMAGEFNS 31695 . 32700) ( DOCOBJ-INCLUDE-CREATE-OBJ 32702 . 33491) (DOCOBJ-INCLUDE-EDIT 33493 . 38092) ( DOCOBJ-INCLUDE-EDIT-WINDOWP 38094 . 38956) (DOCOBJ-INCLUDE-RESET-OBJ 38958 . 39729)) (39732 49830 ( DOCOBJ-INCLUDE-AFTERHARDCOPYFN 39742 . 40626) (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN 40628 . 45403) ( DOCOBJ-INCLUDE-CLEANUPFN 45405 . 46172) (DOCOBJ-INCLUDE-BUTTONEVENTINFN 46174 . 46708) ( DOCOBJ-INCLUDE-COPYFN 46710 . 46928) (DOCOBJ-INCLUDE-DISPLAYFN 46930 . 47662) (DOCOBJ-INCLUDE-GETFN 47664 . 48387) (DOCOBJ-INCLUDE-IMAGEBOXFN 48389 . 49398) (DOCOBJ-INCLUDE-PREPRINTFN 49400 . 49619) ( DOCOBJ-INCLUDE-PUTFN 49621 . 49828))))) STOP \ No newline at end of file diff --git a/lispusers/EVALOBJ.LCOM.~2~ b/lispusers/EVALOBJ.LCOM.~2~ deleted file mode 100644 index 21408e2cb0fc84d37ae84f3e1d88b1e5742b3317..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6568 zcmeHMTaVk;5!S^>)3kEdX%GZ%kxrBtkqk%?soP2|98nT?#Wh9JBxSFQ7KpM^y>iyl zLMuB7;_ggz{S$pD`X_>-@9lTykRqvdf&}Sf7g#RO;hf9N zeDlqmvxUCCV_14=$1wGhVeQ!TlB;WdU+bDWolKV}H{Ko} zAC2cX%*Da@=*ENTW#yEgp%XRVtUud76w@*jhf` zuU6aDX1mhJe>DxisX~-f>T0Dy2Z!VNz3B<97T9;;w&r>iXx+1iUXhNM(?_$#!xP>z zMDo-K3=T6?T5Yw~uGPP}ft6w|GG~Qa*U2D-JRcoH zyjBQKDpKmhY$}y`GlicYP8Q{9MVT2NUD@XU?Dd zwvhVNep>wL@Q^pf>y>myww@6!7CPjwhjM}3Q=(r`K&vx!oYeS+@C(ShNJ7sB@GF!%@`Zf)9YXr0?)h6`@nzf5~ zP}BzdZ^Y4|R20%5jgKCVSF^?Z8tp8W4`{nC%%%7IzUGgH)NGIlD7Wu-O=>EMZ)%GW ztJ=u)#Zm*^?86_>pl7HvF3G- zvU|^7-rD2c2sqW6>|MCInuHOYn!s7JN`22^%^MAJT*InTz0NN+sKW8=_KDs>uYZl7VhU78Fq z1P5vo2d9~I>Qc-t0T?>5uD?`c4IpD6-R8n=gJ&=QX25PcmohWvh3_SRwZ~v!DL{i8 z2BR!Ctuc#)zAI?v?*#LQ1V6h|{ok z?-+f5fHo{>SpCwPTmh~PdpKutLp^8Gu1S?^N5M!wV}VxldpY zn2cktrG$7QU|dWpsSX?%7sIINn*wI#df|1`*7{UupfXie8;OELQ6d-ul&#hm;ZPtx z#9)+v@^DW&<~w#&tj)fKi>hGdpt1-|2-Z%7uh_B31@tfm_+LXF3ASr~m4_DNq-Z-+;q_9}MUxw>AFO zJuPWL)V#`*eSFv*9A!HQjgAZrIa-FsKwwwhz=u+4N#Gz$B@EQ4CEK;_WIG0|z#d>u z*R|c31*VjEk_2_e(a{We3}NKEBc19s@B$Ka$+t@|VF_-pN#Fr*WpLY2vwTxWH)u58 z3?L|^cL``GX(5pOo$ByHUWK$urKDo$#DodqxIIFSZKWrM8pfD7{)wlS%fElT7CH)%0Ely8Psm?+b%|v^Nut z4<%#s@bkU2@xtHsGN&)zJiELH=`1R|0yl~rPseyTZ+ZuM1BGeutjAQ+Vu)sZ1RLT(r4;RZfZvyS{Z zI}s-k)KSQ%vk9%H@2=>0yc|E6uBJY6ojN`mmb>l+%O2}27pSN9N^p^Pfh z3P99NWm9R^Y{Gh8<#&ms^IKOBGDn$1he6~<`b(1>P9}~#D8LX609b?sOijqlj_nzu zHYQYdi3kB8a3CfSB6j23j>w*f8jyx;z+OnE*xS00M+9Aa#f1eu*e-a3RFoKEh6|%f zCDzvSaa`bFx?llOSc%j4{=o1=6^&8~CEqK|OIV$)8{r97tVZH6+iR$%vz_kS|KOPM zKv8TRHX%Qr29>1FUww)}0%hR=-jehpsfdK(ZEOG>qOP-MOcMzK)F<#6c+v4)=q&J+ zoG4)kPd9yAZ2m%y43Z*{pyQ5#9V6fqDF~G;PLz`5{?Os-OlGjHPV5lC`m%;m{lbri=8z!BWztAXP6$aXWlXVf!G~#+(wyDZ$eB|FzRN_Ca?g$08^l{lYBwqSZG^4 z4W?_#99G8cWz8!~F;bA?L~1L?nW%w5CM!S0COpH!m>@w2kmh6eGoon!nfO7;UZs3= z(&Qr=9gOF%t>|DeUyX4QGJ7z-H>Jf}_ooLdamV4ffbv~&I^+xyXv&ukxdLE(>sF|} z=)<{@(;k8Zy8<_w1{C8%WudS4OwHACInlSpG##$;`Z)D*4HXR3_Z{2yy)w?y#Ud4u zjdS4w!O1$hatO^1oCOEVu!mz*9zepbpcY&=xzeQdb%spy;aASAa``Y{Mc`ug!$+ww zcDUYP4Div+a16s3BOEGdR-X!349{C5P#!Hl62 z(Zc!OV*Y5lT%FLt!{u^1U(w0*2oA<=gE+m9=karU;Cm`~qb@Eygi~{m#VRyjQExfL zo!IN&H{wAAlR^~XqxyddU+%ALfK=|*bEo&)c-oJ zE{4_G-2aa&N$4TYLVJAOxRUwfjWv6Qar8wI6|VQS0&4BGuM$z=3ST#%#K9~PSzi)S zNU0-V93R$cgYOXdCJg@&*`F>K?^18EJYFpM-W5r^)oO~zws^E~v5PBx@sAW-xQPSd Fe*t*sElL0Y diff --git a/lispusers/EVALOBJ.~1~ b/lispusers/EVALOBJ.~1~ deleted file mode 100644 index 28a21cae..00000000 --- a/lispusers/EVALOBJ.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 6-May-2000 09:24:45" {DSK}lfg>tedit>EVALOBJ.;25 14951 changes to%: (FNS EVALOBJ.CREATE) previous date%: "19-May-99 09:49:07" {DSK}lfg>tedit>EVALOBJ.;23) (* ; " Copyright (c) 1997, 1998, 1999, 2000 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EVALOBJCOMS) (RPAQQ EVALOBJCOMS [(FNS EVALOBJ.BUTTONEVENTINFN EVALOBJ.DISPLAYFN EVALOBJ.IMAGEBOXFN EVALOBJ.COPYFN EVALOBJ.CREATE EVALOBJ.GETFN EVALOBJ.PUTFN) (FNS PARAMS TEXTSTREAMPARAM) [COMS (FNS EVALOBJ.DISMANTLEFN EVALOBJ.SELTOOBJ) (P (AND (GETD 'ADDTOIMOBJAPPLICATIONMENU) (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ "Converts current selection to an evaluation object" (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'CREATE/LOAD] (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'HARDCOPY] [INITVARS (EVALOBJ.IMAGEFNS (IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN 'EVALOBJ.COPYFN 'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ) ""] (GLOBALVARS EVALOBJ.IMAGEFNS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PARAMS) (NLAML) (LAMA]) (DEFINEQ (EVALOBJ.BUTTONEVENTINFN [LAMBDA (OBJ STREAM) (* ; "Edited 19-Aug-97 14:03 by rmk:") (* jtm%: " 5-Aug-88 15:40") (* ;  "the user has pressed a button inside the eval OBJ") (CL:WHEN [MENU (CREATE MENU ITEMS _ '((|Edit evaulation form| T " Opens a window to edit the evaluation form"] (* ;;; "SEDIT always forks a process. We hang in that process until it closes (CLOSE-ON-COMPLETION)") (ALLOW.BUTTON.EVENTS) [IMAGEOBJPROP OBJ 'OBJECTDATUM (LET ((*READTABLE* FILERDTBL)) (DECLARE (SPECVARS *READTABLE*)) (EDITE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM)) NIL 'Evaluation% Form NIL NIL '(:CLOSE-ON-COMPLETION] (IMAGEOBJPROP OBJ 'EVALUATED NIL) 'CHANGED)]) (EVALOBJ.DISPLAYFN [LAMBDA (OBJ IMAGESTREAM) (* ; "Edited 19-Aug-97 13:46 by rmk:") (* fsg "17-Sep-87 11:14") (* ;; "Display an Eval imageobject. If the stream-type is display, then shows the form. Otherwise the stream-type is hardcopy and the form is executed.") (DECLARE (SPECVARS OBJ IMAGESTREAM) (USEDFREE TEXTSTREAM)) (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (LET ((FONT (DSPFONT '(TERMINAL 10) IMAGESTREAM))) (PRIN3 "{Eval: " IMAGESTREAM) (PRIN4 (IMAGEOBJPROP OBJ 'OBJECTDATUM) IMAGESTREAM) (PRIN3 "}" IMAGESTREAM) (DSPFONT FONT IMAGESTREAM))) (CL:WHEN (EQMEMB (IMAGEOBJPROP OBJ 'WHEN) '(NIL HARDCOPY)) (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM] (IF (LITATOM FORM/FN) THEN (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ) ELSE (EVAL FORM/FN))))]) (EVALOBJ.IMAGEBOXFN [LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 19-Aug-97 13:43 by rmk:") (* ss%: "27-Jun-87 15:50") (* ;; "Return the ImageBox for an EVALOBJ. Evaluates a CREATE/LOAD form that hasn't yet been evaluated (presumably came from the COPYFN).") (DECLARE (SPECVARS OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (USEDFREE TEXTSTREAM)) (CL:WHEN [AND (EQ (IMAGEOBJPROP OBJ 'WHEN) 'CREATE/LOAD) (NOT (IMAGEOBJPROP OBJ 'EVALUATED] (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM] (IF (LITATOM FORM/FN) THEN (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ) ELSE (EVAL FORM/FN)) (IMAGEOBJPROP OBJ 'EVALUATED T))) (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (LET [(FONT (FONTCREATE '(TERMINAL 10] (CREATE IMAGEBOX XSIZE _ (PLUS (STRINGWIDTH "{Eval: }" FONT) (STRINGWIDTH (IMAGEOBJPROP OBJ 'OBJECTDATUM) FONT T (FIND-READTABLE "INTERLISP"))) YSIZE _ (FONTPROP FONT 'HEIGHT) YDESC _ (FONTPROP FONT 'DESCENT) XKERN _ 0))) (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (EVALOBJ.COPYFN [LAMBDA (OBJ) (* ; "Edited 19-Aug-97 13:30 by rmk:") (EVALOBJ.CREATE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM)) (IMAGEOBJPROP OBJ 'WHEN]) (EVALOBJ.CREATE [LAMBDA (FORM WHEN TEXTSTREAM) (* ; "Edited 6-May-2000 09:24 by rmk:") (DECLARE (SPECVARS TEXTSTREAM)) (* ;; "For EVAL at CREATE/LOAD. TEXTSTREAM is NIL on call from COPYFN, since the destination stream isn't known. The object is not marked as evaluated, so that the imagebox fn will do it the first time it is displayed/printed. Hopefully it won't be copied to place where it isn't initially displayed--that's the best we can do. ") (IF (AND FORM (OR (LISTP FORM) (LITATOM FORM))) THEN (LET ((OBJ (IMAGEOBJCREATE FORM EVALOBJ.IMAGEFNS))) (IMAGEOBJPROP OBJ 'DISMANTLEFN (FUNCTION EVALOBJ.DISMANTLEFN)) (IMAGEOBJPROP OBJ 'TEDIT-TO-TEX-FN (FUNCTION TRUE)) (IMAGEOBJPROP OBJ 'WHEN WHEN) (CL:WHEN (AND TEXTSTREAM (EQ WHEN 'CREATE/LOAD)) (IF (LITATOM FORM) THEN (* ;;  "NIL is image stream. It should be an error if a CREATE/LOAD form accesses an image stream!") (APPLY* FORM NIL TEXTSTREAM OBJ) ELSE (EVAL FORM)) (IMAGEOBJPROP OBJ 'EVALUATED T)) OBJ) ELSE (ERROR!]) (EVALOBJ.GETFN [LAMBDA (FILESTREAM TEXTSTREAM) (* ; "Edited 19-Aug-97 13:25 by rmk:") (LET ((DATA (HREAD FILESTREAM)) FORM WHEN) (IF (LITATOM (CAR (LISTP DATA))) THEN (SETQ FORM DATA) ELSE (SETQ FORM (CAR DATA)) (SETQ WHEN (CADR DATA))) (EVALOBJ.CREATE FORM WHEN TEXTSTREAM]) (EVALOBJ.PUTFN [LAMBDA (OBJ STREAM) (* ; "Edited 19-Aug-97 13:28 by rmk:") (* ;; "Put a description of an eval object into the file.") (HPRINT (LIST (IMAGEOBJPROP OBJ 'OBJECTDATUM) (IMAGEOBJPROP OBJ 'WHEN)) STREAM]) ) (DEFINEQ (PARAMS [NLAMBDA PARAMS (* ; "Edited 7-Nov-97 08:41 by rmk:") (DECLARE (USEDFREE TEXTSTREAM)) (* ;; "Each P is either") (* ;; " a list of the form (name value), in which case value becomes the (new) value of parameter name;") (* ;;  " a list of the form (name v1 v2 ...) in which case it is treated as (name (v1 v2 ...))") (* ;; " a list of the form (name), in which case the value for name (even NIL) is removed)") (* ;; " a litatom, in which case it is treated as a list (atom T).") (* ;; "The form (name) is different from (name NIL)--the disinction allows the client to distinguish between no value (hence use a default) and a value of NIL.") (FOR P PCELL [PROP _ (APPEND (STREAMPROP TEXTSTREAM 'PARAMETERS] IN PARAMS DO (IF (LISTP P) THEN [IF (CDDR P) THEN (SETQ P (LIST (CAR P) (CDR P] ELSEIF (LITATOM P) THEN (SETQ P (LIST P T)) ELSE (PROMPTPRINT P " is not a valid text parameter")) (SETQ PCELL (ASSOC (CAR P) PROP)) (IF (CDR P) THEN [IF PCELL THEN (RPLACA (CDR PCELL) (CADR P)) ELSE (PUSH PROP (LIST (CAR P) (CADR P] ELSEIF PCELL THEN (SETQ PROP (DREMOVE PCELL PROP))) FINALLY (STREAMPROP TEXTSTREAM 'PARAMETERS PROP) (RETURN PROP]) (TEXTSTREAMPARAM [LAMBDA (PARAMNAME DEFAULTVALUE) (DECLARE (USEDFREE TEXTSTREAM)) (* ; "Edited 3-Aug-98 13:48 by rmk:") (* ;; "Returns the value of the parameter PARAMNAME on a higher-bound TEXTSTREAM, or DEFAULTVALUE if the parameter is not set.") (IF (AND (BOUNDP 'TEXTSTREAM) (STREAMP TEXTSTREAM)) THEN (LET [(PCELL (ASSOC PARAMNAME (STREAMPROP TEXTSTREAM 'PARAMETERS] (IF PCELL THEN (CADR PCELL) ELSE DEFAULTVALUE)) ELSE DEFAULTVALUE]) ) (DEFINEQ (EVALOBJ.DISMANTLEFN [LAMBDA (TEXTSTREAM OBJ CHAR#) (* ; "Edited 27-Jan-97 18:03 by rmk:") (SETFILEPTR TEXTSTREAM (SUB1 CHAR#)) (RESETLST (RESETSAVE %#RPARS) (PRINTOUT TEXTSTREAM 2 .PPV (IMAGEOBJPROP OBJ 'OBJECTDATUM)))]) (EVALOBJ.SELTOOBJ [LAMBDA (TEXTSTREAM SELECTION WHEN) (* ; "Edited 19-Aug-97 13:23 by rmk:") (IF (COLLECTIMOBJSINSEL TEXTSTREAM SELECTION) THEN (TEDIT.PROMPTPRINT TEXTSTREAM "Evaluation form can't contain image object" T) ELSE (* ; "Pack on ]]] to avoid eof errors") (LET ((OBJ (EVALOBJ.CREATE (READ (OPENSTRINGSTREAM (CONCAT (TEDIT.SEL.AS.STRING TEXTSTREAM SELECTION) "]]]]]")) (FIND-READTABLE "INTERLISP")) WHEN TEXTSTREAM))) (REPLACESELWITHOBJ OBJ TEXTSTREAM SELECTION]) ) [AND (GETD 'ADDTOIMOBJAPPLICATIONMENU) (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ "Converts current selection to an evaluation object" (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA ( TEXTSTREAM SELECTION ) (  EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'CREATE/LOAD] (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'HARDCOPY] (RPAQ? EVALOBJ.IMAGEFNS [IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN 'EVALOBJ.COPYFN 'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ) ""]) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EVALOBJ.IMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PARAMS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS EVALOBJ COPYRIGHT ("Xerox Corporation" 1997 1998 1999 2000)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2788 9069 (EVALOBJ.BUTTONEVENTINFN 2798 . 3991) (EVALOBJ.DISPLAYFN 3993 . 5168) ( EVALOBJ.IMAGEBOXFN 5170 . 6713) (EVALOBJ.COPYFN 6715 . 6938) (EVALOBJ.CREATE 6940 . 8356) ( EVALOBJ.GETFN 8358 . 8759) (EVALOBJ.PUTFN 8761 . 9067)) (9070 11635 (PARAMS 9080 . 11011) ( TEXTSTREAMPARAM 11013 . 11633)) (11636 12781 (EVALOBJ.DISMANTLEFN 11646 . 11929) (EVALOBJ.SELTOOBJ 11931 . 12779))))) STOP \ No newline at end of file diff --git a/lispusers/EVALOBJ.~2~ b/lispusers/EVALOBJ.~2~ deleted file mode 100644 index a15a5c09..00000000 --- a/lispusers/EVALOBJ.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-May-2018 08:22:13"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>EVALOBJ.;2 15206 changes to%: (VARS EVALOBJCOMS) previous date%: " 6-May-2000 09:24:45" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>EVALOBJ.;1) (* ; " Copyright (c) 1997, 1998, 1999, 2000, 2018 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EVALOBJCOMS) (RPAQQ EVALOBJCOMS [(FILES IMOBJAPPLICATION) (DECLARE%: DOEVAL@LOAD DONTCOPY (FILES EXPORTS.ALL)) (FNS EVALOBJ.BUTTONEVENTINFN EVALOBJ.DISPLAYFN EVALOBJ.IMAGEBOXFN EVALOBJ.COPYFN EVALOBJ.CREATE EVALOBJ.GETFN EVALOBJ.PUTFN) (FNS PARAMS TEXTSTREAMPARAM) [COMS (FNS EVALOBJ.DISMANTLEFN EVALOBJ.SELTOOBJ) (P (AND (GETD 'ADDTOIMOBJAPPLICATIONMENU) (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ "Converts current selection to an evaluation object" (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'CREATE/LOAD] (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'HARDCOPY] [INITVARS (EVALOBJ.IMAGEFNS (IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN 'EVALOBJ.COPYFN 'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ) ""] (GLOBALVARS EVALOBJ.IMAGEFNS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PARAMS) (NLAML) (LAMA]) (FILESLOAD IMOBJAPPLICATION) (DECLARE%: DOEVAL@LOAD DONTCOPY (FILESLOAD EXPORTS.ALL) ) (DEFINEQ (EVALOBJ.BUTTONEVENTINFN [LAMBDA (OBJ STREAM) (* ; "Edited 19-Aug-97 14:03 by rmk:") (* jtm%: " 5-Aug-88 15:40") (* ;  "the user has pressed a button inside the eval OBJ") (CL:WHEN [MENU (CREATE MENU ITEMS _ '((|Edit evaulation form| T " Opens a window to edit the evaluation form"] (* ;;; "SEDIT always forks a process. We hang in that process until it closes (CLOSE-ON-COMPLETION)") (ALLOW.BUTTON.EVENTS) [IMAGEOBJPROP OBJ 'OBJECTDATUM (LET ((*READTABLE* FILERDTBL)) (DECLARE (SPECVARS *READTABLE*)) (EDITE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM)) NIL 'Evaluation% Form NIL NIL '(:CLOSE-ON-COMPLETION] (IMAGEOBJPROP OBJ 'EVALUATED NIL) 'CHANGED)]) (EVALOBJ.DISPLAYFN [LAMBDA (OBJ IMAGESTREAM) (* ; "Edited 19-Aug-97 13:46 by rmk:") (* fsg "17-Sep-87 11:14") (* ;; "Display an Eval imageobject. If the stream-type is display, then shows the form. Otherwise the stream-type is hardcopy and the form is executed.") (DECLARE (SPECVARS OBJ IMAGESTREAM) (USEDFREE TEXTSTREAM)) (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (LET ((FONT (DSPFONT '(TERMINAL 10) IMAGESTREAM))) (PRIN3 "{Eval: " IMAGESTREAM) (PRIN4 (IMAGEOBJPROP OBJ 'OBJECTDATUM) IMAGESTREAM) (PRIN3 "}" IMAGESTREAM) (DSPFONT FONT IMAGESTREAM))) (CL:WHEN (EQMEMB (IMAGEOBJPROP OBJ 'WHEN) '(NIL HARDCOPY)) (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM] (IF (LITATOM FORM/FN) THEN (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ) ELSE (EVAL FORM/FN))))]) (EVALOBJ.IMAGEBOXFN [LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 19-Aug-97 13:43 by rmk:") (* ss%: "27-Jun-87 15:50") (* ;; "Return the ImageBox for an EVALOBJ. Evaluates a CREATE/LOAD form that hasn't yet been evaluated (presumably came from the COPYFN).") (DECLARE (SPECVARS OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (USEDFREE TEXTSTREAM)) (CL:WHEN [AND (EQ (IMAGEOBJPROP OBJ 'WHEN) 'CREATE/LOAD) (NOT (IMAGEOBJPROP OBJ 'EVALUATED] (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM] (IF (LITATOM FORM/FN) THEN (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ) ELSE (EVAL FORM/FN)) (IMAGEOBJPROP OBJ 'EVALUATED T))) (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (LET [(FONT (FONTCREATE '(TERMINAL 10] (CREATE IMAGEBOX XSIZE _ (PLUS (STRINGWIDTH "{Eval: }" FONT) (STRINGWIDTH (IMAGEOBJPROP OBJ 'OBJECTDATUM) FONT T (FIND-READTABLE "INTERLISP"))) YSIZE _ (FONTPROP FONT 'HEIGHT) YDESC _ (FONTPROP FONT 'DESCENT) XKERN _ 0))) (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (EVALOBJ.COPYFN [LAMBDA (OBJ) (* ; "Edited 19-Aug-97 13:30 by rmk:") (EVALOBJ.CREATE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM)) (IMAGEOBJPROP OBJ 'WHEN]) (EVALOBJ.CREATE [LAMBDA (FORM WHEN TEXTSTREAM) (* ; "Edited 6-May-2000 09:24 by rmk:") (DECLARE (SPECVARS TEXTSTREAM)) (* ;; "For EVAL at CREATE/LOAD. TEXTSTREAM is NIL on call from COPYFN, since the destination stream isn't known. The object is not marked as evaluated, so that the imagebox fn will do it the first time it is displayed/printed. Hopefully it won't be copied to place where it isn't initially displayed--that's the best we can do. ") (IF (AND FORM (OR (LISTP FORM) (LITATOM FORM))) THEN (LET ((OBJ (IMAGEOBJCREATE FORM EVALOBJ.IMAGEFNS))) (IMAGEOBJPROP OBJ 'DISMANTLEFN (FUNCTION EVALOBJ.DISMANTLEFN)) (IMAGEOBJPROP OBJ 'TEDIT-TO-TEX-FN (FUNCTION TRUE)) (IMAGEOBJPROP OBJ 'WHEN WHEN) (CL:WHEN (AND TEXTSTREAM (EQ WHEN 'CREATE/LOAD)) (IF (LITATOM FORM) THEN (* ;;  "NIL is image stream. It should be an error if a CREATE/LOAD form accesses an image stream!") (APPLY* FORM NIL TEXTSTREAM OBJ) ELSE (EVAL FORM)) (IMAGEOBJPROP OBJ 'EVALUATED T)) OBJ) ELSE (ERROR!]) (EVALOBJ.GETFN [LAMBDA (FILESTREAM TEXTSTREAM) (* ; "Edited 19-Aug-97 13:25 by rmk:") (LET ((DATA (HREAD FILESTREAM)) FORM WHEN) (IF (LITATOM (CAR (LISTP DATA))) THEN (SETQ FORM DATA) ELSE (SETQ FORM (CAR DATA)) (SETQ WHEN (CADR DATA))) (EVALOBJ.CREATE FORM WHEN TEXTSTREAM]) (EVALOBJ.PUTFN [LAMBDA (OBJ STREAM) (* ; "Edited 19-Aug-97 13:28 by rmk:") (* ;; "Put a description of an eval object into the file.") (HPRINT (LIST (IMAGEOBJPROP OBJ 'OBJECTDATUM) (IMAGEOBJPROP OBJ 'WHEN)) STREAM]) ) (DEFINEQ (PARAMS [NLAMBDA PARAMS (* ; "Edited 7-Nov-97 08:41 by rmk:") (DECLARE (USEDFREE TEXTSTREAM)) (* ;; "Each P is either") (* ;; " a list of the form (name value), in which case value becomes the (new) value of parameter name;") (* ;;  " a list of the form (name v1 v2 ...) in which case it is treated as (name (v1 v2 ...))") (* ;; " a list of the form (name), in which case the value for name (even NIL) is removed)") (* ;; " a litatom, in which case it is treated as a list (atom T).") (* ;; "The form (name) is different from (name NIL)--the disinction allows the client to distinguish between no value (hence use a default) and a value of NIL.") (FOR P PCELL [PROP _ (APPEND (STREAMPROP TEXTSTREAM 'PARAMETERS] IN PARAMS DO (IF (LISTP P) THEN [IF (CDDR P) THEN (SETQ P (LIST (CAR P) (CDR P] ELSEIF (LITATOM P) THEN (SETQ P (LIST P T)) ELSE (PROMPTPRINT P " is not a valid text parameter")) (SETQ PCELL (ASSOC (CAR P) PROP)) (IF (CDR P) THEN [IF PCELL THEN (RPLACA (CDR PCELL) (CADR P)) ELSE (PUSH PROP (LIST (CAR P) (CADR P] ELSEIF PCELL THEN (SETQ PROP (DREMOVE PCELL PROP))) FINALLY (STREAMPROP TEXTSTREAM 'PARAMETERS PROP) (RETURN PROP]) (TEXTSTREAMPARAM [LAMBDA (PARAMNAME DEFAULTVALUE) (DECLARE (USEDFREE TEXTSTREAM)) (* ; "Edited 3-Aug-98 13:48 by rmk:") (* ;; "Returns the value of the parameter PARAMNAME on a higher-bound TEXTSTREAM, or DEFAULTVALUE if the parameter is not set.") (IF (AND (BOUNDP 'TEXTSTREAM) (STREAMP TEXTSTREAM)) THEN (LET [(PCELL (ASSOC PARAMNAME (STREAMPROP TEXTSTREAM 'PARAMETERS] (IF PCELL THEN (CADR PCELL) ELSE DEFAULTVALUE)) ELSE DEFAULTVALUE]) ) (DEFINEQ (EVALOBJ.DISMANTLEFN [LAMBDA (TEXTSTREAM OBJ CHAR#) (* ; "Edited 27-Jan-97 18:03 by rmk:") (SETFILEPTR TEXTSTREAM (SUB1 CHAR#)) (RESETLST (RESETSAVE %#RPARS) (PRINTOUT TEXTSTREAM 2 .PPV (IMAGEOBJPROP OBJ 'OBJECTDATUM)))]) (EVALOBJ.SELTOOBJ [LAMBDA (TEXTSTREAM SELECTION WHEN) (* ; "Edited 19-Aug-97 13:23 by rmk:") (IF (COLLECTIMOBJSINSEL TEXTSTREAM SELECTION) THEN (TEDIT.PROMPTPRINT TEXTSTREAM "Evaluation form can't contain image object" T) ELSE (* ; "Pack on ]]] to avoid eof errors") (LET ((OBJ (EVALOBJ.CREATE (READ (OPENSTRINGSTREAM (CONCAT (TEDIT.SEL.AS.STRING TEXTSTREAM SELECTION) "]]]]]")) (FIND-READTABLE "INTERLISP")) WHEN TEXTSTREAM))) (REPLACESELWITHOBJ OBJ TEXTSTREAM SELECTION]) ) [AND (GETD 'ADDTOIMOBJAPPLICATIONMENU) (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ "Converts current selection to an evaluation object" (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA ( TEXTSTREAM SELECTION ) (  EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'CREATE/LOAD] (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM SELECTION) (EVALOBJ.SELTOOBJ TEXTSTREAM SELECTION 'HARDCOPY] (RPAQ? EVALOBJ.IMAGEFNS [IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN 'EVALOBJ.COPYFN 'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ) ""]) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EVALOBJ.IMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PARAMS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS EVALOBJ COPYRIGHT ("Xerox Corporation" 1997 1998 1999 2000 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3038 9319 (EVALOBJ.BUTTONEVENTINFN 3048 . 4241) (EVALOBJ.DISPLAYFN 4243 . 5418) ( EVALOBJ.IMAGEBOXFN 5420 . 6963) (EVALOBJ.COPYFN 6965 . 7188) (EVALOBJ.CREATE 7190 . 8606) ( EVALOBJ.GETFN 8608 . 9009) (EVALOBJ.PUTFN 9011 . 9317)) (9320 11885 (PARAMS 9330 . 11261) ( TEXTSTREAMPARAM 11263 . 11883)) (11886 13031 (EVALOBJ.DISMANTLEFN 11896 . 12179) (EVALOBJ.SELTOOBJ 12181 . 13029))))) STOP \ No newline at end of file diff --git a/lispusers/FILEWATCH.LCOM.~2~ b/lispusers/FILEWATCH.LCOM.~2~ deleted file mode 100644 index 8c697521dac8b4edf5f0b3178e14e38602ccbfc1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 24656 zcmd6PZE%~{btVAHmZF*rNKvZHIL-}P+oacI`2yglw-F%%6hH!aVE`0GTd7PDumFhy zwEVE+-F9}m_3rF+ns%CL6ldH_w(e}wW}7WUiaU+t7_*c9sPbbwnND}4_}6x}vp;rb zhnn?H_s4Fv&pGGb_XD7!xSP&YqXFOhecyY}Js;0G_Z?2A7BczN=t3r&8qMSvZ1r?8 zl}MHoXR|34$>htaVm4DMMAXxT#Qaj?Tu0{FL@A}L@sZwP>R=vC%c-P_SmUGl=If&~ z(<*As#-?Yj@rW9ZtT(UUsBcs&s@YHx_0N)}rC<5SH#VDBtLxjJyI!qqRNst_S)bde zZ{670s%~z5j=Ee)l;_i9FGfdHZzMWCnyjvm&cu~9HEUV3OJ5 zvbK$BM%-L0IvbmsjZZ~7-!y8C=GHc;p%tHc(dE^?Gw>izkSBv?OMD%rHJ1ortL3!&mkpaBazq9Gb1)DHUJ2meC+Md?7?`WX<_^9&$I08Dl)s#~9H?-`gPZO2 z?l0C_XLRzL`tR?y)3^T-*SH*LMWpIiYnKCUe*De3-%Ed)pWfnM-Dvk2DXtB1ZpTmW zV>GF-uKSgC?Pod7wGMVao!&dak37BhF)C}<=8n_fbT}{^wfL=>;uG^_6&;VNvsrt7 zNm(w5Q!2NVDBC#|i>l?(c{&i$xB}s2^5+U_22Jx$ZBUOj zV<|hYtm$!;OXZhA%5hrl;!dMcZ(KQ}tjP&wFDxi)BC67fVzQVjrOF_#DTSwUq9`ZR zibvG~&eF=-_Ij8o#aFbGL-dODGbWEj+MZ2gbV+x$CTv#sSJ*Ie-iq%Y`zI{ebV1q&Mo6Q^5 z&Fy-1OU12@3=8|{t${Ao)Rc-ibTO+^U$_BAhCNi4YHnf$);6zfsnJmdo`JT0hNKS~ z_GclRLJxw;%E_V)+VJ^M#$;ox`XGLO@H-U%G+4(rEL zyHCp#)A`^~+vE$$r$ZN7e;OFZKF??EQffs_D6mKw81FO5?@aRn<5326T(#2fHWrvqRJ_%8Cp>##O-)n5O1)8OzHzp>z1_SHzQKKZ^ODt# z?KO=H!G(yx2Pp8S6iK)nPqspfU!WT`z?#jz01u@4bNUvBibuI&TrcY3m zDGa=h+22YgSx$rffVU3Z&n#p}=H(Re7c~=gs1@rUjq%PV8tXM; zUe>fai}P>iMvIwqX-GpzN1c&PEs%8N>Ruw#)Hl;beWrkk$lC%!&_gikYW+%Wn+0Ph z5m{4~D%%A;7Ym%6QallBg2&VICZXBUSdR{>Upd>{tgx)~oF+4>yuN>SQSQ3X+^TQa zp|V=?&R9F*&1%{qdlDuNznpNg<8hbZCxzg7U|M{LWI0FN6*pPj+1jqZRH^L1B>pjx+lI$(@7^o9;N1@vLnb49?_w@=_flW`YX1J-={)y(|JzsXzWaY*_etue z$owyIuX(#~hzY+ICQfeNuFKCsm-U(gUy*k$n+e zp`)~OcO1^7H->EcB#YQ0OV_hDNm(ebsTEW;n}tVg)jiTnJAh^|;;jdnC1y;m|4D#LOfBajR7Dh*U;#|{g|h`7 z1VMr|a+c8|JHx(wig0Ae0j+5P`#l)ViDb%18tC|evfZ;HU(YjuMsep;&Hc|4wGWnd6vN}s6NIADFz-0ZcVfWiFt^agazSJqy@voFDJ#k zC(3gzc?XaoMbRY~q7o}Ut|F!C2Cyl$wY^zgyAFt1t#359szfIwiX26ARyCRmAXr1a z2HkTDKsZiEWFB=1))Fh6Uu+agkx!M=?2YlB5fxYm#v|r->jD|Wo$$`r4T>WSqGf60 zcW>A{e8xPS5>BPznISQ@$*BHA+A*xU1Gzv?=gF<$wQ=rb85Av-Yn-_lM0|!#vY2D8 zVaxGWz*S63Q^H6b353Z z=sR`rbvY&66zE>-hjdEr@G=k=@fs~t(4?KW2I8j|1K72G0;9oGvAR`-6+>V$Xcrq# zq_Cx+M*GqZP{UjZ_>e;}FsI{PmI>CMZ4q$?G1$QLkpTxG=B=?#vP%}0vst#YRNx&f zP)Hx*#9*LZnHvnX=QxA8MSm!mu4Hhi2NJx3H|5W-CwM))Rh~u_H}iH+T{nH49!ZSdB@&GLs(uv-hook>vBvbZ6 zp&9L6VQq*PlLpPl$Hs(Cd@gLrw2gR*;M`<&@O=d*sO&nRKz&33fj4a zq$t(hJ26Tqtl|2YEo&p#e!UOO<=s8PQU35~Kp$mTJFw{cPV|pI#=CMWa5K2dTk$gg z?mfLIX2;%1{lL|PoZCdJ-zQ%1cwXxY`h@?n{%eq|FSqlxq1G60;KA+*U0WDMyVer) z)$}3kVBnRWo7w#rmOg*64aV@hxdA>wmD^A91Yj1q)W9VoLM|>n+4>>rAyGCEfoWN) zWEX+m;+QyGg)DwyD@vdp4^=zH`)KL{mbG+7pByY8^o>-Ky{gFc&^eGc5Q*%OoF?)v z0UO4^qhutBzEJ|`vjE5mULtQ@!ZUb#0X#TI*@AO|ITv;89C|QzqpW~Q65Q(Hi3W7w z8Ngikj6uKy55Z-^0}W#kc@lpV8)Pr=Vd4R9B0_c9B}>>6Qrg(l$_41{{Ue|^mg&5C z{Z>(_(Ckw%K0f{pTNX75%+rfWmJ*I1fGn zJrPG#-VA&h?=}fF(4Pa+>Bzx`cI3cO;Lm~Q+n)h;kSrAzZ0H|QXfI~+rR5?pZvwcq z<3^|zSUZcgPNxGn1~%IVtYeS0OETd>5D7)_r3H315|3D;^9+R}pUGw!D+9A6rw0+X zfIBWqM0&F)C8xpyXTBXh= zmt>#HkPL$G)mw_m%4*O%xqcZ~IQos9bFJN(RL@-nSI-fD6qTB$W*s{Cm;)|IKI{KR zaA0|+91X{HQ?7=@!@fI|3C_7(n5FgaWcGXN4AuT+U>LG6nJK2`%XV>fEJr~f>~DnJ zB=uk+0|<#WuA>en3V14QL!>b!LoeAzPjFK^3~Iptf%kL!N3&@B ztJ!D22RU~qKS1!`Bdnb7R+fyFvkIr{gSyO0%hLpzUk{cu;;XvAsdM~ht|iq!{&>3e zB?wB`-o+H5xDb^vg~f?X@eFJ;VF$&O)%K99j7OnQ`fV5ruFzC!0en2n2=bcc#3}@^ zgH&^=+sHT3%V;N2Pl`!+feH|b0XtY*KV;L8?eki5^GbD_j32UY995Q$pLGqkQC-+S ztj1>Yh>9TE2Uk;pPY3Xi<&*m(eh{s(-q%?bMu zv1|MahJdNnD6KBMpc0w`KFjo)DW`G-68#k+(oA>8tNDGJ;NJOH>5sdKUT}HPK*@dW zO8Qas^Bw5i$J?wnN$?GKd=N+Sq{-JkgOg-@FbNO=XK| z)nD5wvf!*lr@WS+9nd7UokMEae=j6w#V0lKktc|BV~$CKcysc_dG2-#Wb0ugj)Owo zLF5=@8em#$>)ZS$B+|Q}bB@_C&^y%7RSGfkA1Uy24PDR?@ODY(zycy0Ng}dtW9>~K z$rZH@d!gRgK`hzEn`-9<1-z*Za%(nU^B@3Rm8x&oP~0>S=xda&Z!$`tZZzvO|E)+b zmJl$ztQyAy%0lTJI}hwzLGKwJwbU4*-bPdm5UaBqvjD9Kq+j6U$*bf5@xrV}aFn+J z(!W7LPlQNp*MMlzQAI^(ADtd@YmGO#o2`z1MhU*^>TIj}I(A`0ppOX6bvRP2uCF0T zkml(00U?#hX1V#==C(VTHD)Xb&d~6QTD!7VZ}?}X`#WT2(yKc&U)Rpmur%%fTY3bU zYJ`+770EY8n>QjfcY}P2Sv@sO@s{dx^^LX7>Sss%QDlX2bz6xm#pw%d zSG)A6$L3}O?*^(S5;mPe3S6#&xGC77TH)oQj*P3{*Oddgs)#A4?o3z1o7D}>4)26c zrNo?ELzAqaYPI0fq4P|#?>mq zXYe$GhYV#+s|%7dg$K@=R1{|ez#hNEk0@$@nt+G0@jIeIW2C$?H)r<#TiPZjd$qUH!S~XkKglfe zVBc7zSlQj@CG|4DEWi2wQCT8(Rb=hol;2R--Q zQ|%>0QoL*T@yz$;G4Iwdx`pPo?7{5)y=U#gi!H@71|nnHQPCfwI36O)rW1_RV&LJD_S5@X;R%OGM%D(6zUvyjje5<91Hp9#VO zfe7I|P6)o|2~M4mP_9yKtx{DJcomq~Nd#F)c#@}LTw<{tt`&#B!Rw2L0|8o-gn4l= zRUAgR8)p?mgp+9W8c~P=RrY591@LDOtl@Ry$AGW5}vv&Q(KsUOYh(^zf*y~U$EW8m%wje|rESBLI?+Bs_GH5~JmIUd*zwMs}0ydBV zZG`kK3TPHyTY@sxQ4?qoYUE? zwqD%Iq*lhDm_}6nN`u5Gxr@-ZN260DqcB&vl@Px`?k5&un`-OL>zA7w9N_>OjXaN* z&xhXL5_iG2wdV`h3eM4`v;Yfkr-wl?T> z`t9~yomr)cue>QY1x)fQ?K=13raxZ$cf^MB_3_9&VZ1l>eFhd537I6J*CuR6%x+8k zkX^A>mPEXF=L@9VoiFzYy7MJ+QItPgX|c%Nw4lsdouvwL(mWXwi>&b%sv$l&PX>+( zZ6uj`<6=uYw<90~_?7~Nj(X1@%qG(Nd}$wV2hhJ2In|KsU|=*lL3OHzdGlzGufm=a^4pB_2BkVu0pyNOOr#x$mB%o zBKN@XM*4y#F;O6Fo`ZnymW3(U=!-KX`n9yzTn8{XpI!J)blOM8E#31aVm zn1{a>^T70`FDg=Uh@Oi$U^jkSxvgy0?{(1K67n=s z(24_1kk4H1E?a=QPsM;3ebpE!|86HWXYu5-O2B=giok@dIFEJ?=W{r!*U(ELQ} zeDDKq`$yvX{=pN0s|R~0G5}MLXDaCZ$#!Tpf4ZFueZKX>%F;$p_LF_B&k! z$K^f$v*WrzQlGeX_eb~KD*RO8+IQvmC&_t8P4_*ox+CaG)VK{ZShoxa0Vqo5t*<|w z=1%lgDV--3xB%`2!8C~8{*;jXn1oSy!f0X;lVUB4H5UVU7`HZ?hkUgnv!Kn;C3c^}Ox4^=ijv*}yDymnW62cY2?dV8GE90CU$*axQdDlPN?yL1 z2O79SU?AKBlWxB<|HS%wb!$r(3+t4u^4ev-ZiK0psy8-u4N-#%)y;LluR2eFhlP4| zqhfNH@#fidF7e4JJuy0Ahqm0;kE0{)c;D5N~f#yf311Hu0AX@XPp%KZ%4`3m((U zk#a<;B*S!>B(ax9tQ$W#U8F>)FZkqh5F5cm-QNG3c^^v^NV0#>Zf~vq$i3sQWyI7M zll-^bw~!1(Sc*rtJ;!eG=X_3b2`%gJuac+y)`Ls1$`N~ET;qjshl@6m2p2>QR{=fj4&h8Ohh_ zi9H4{6K@`5y>3UR#}J7puEdlZwJS>Z6FdCwFmvHdW6%dA?uChf5>-`gZ40gsIM3F} zaYbknYzc2I#3qyL-s1q%4th6=NYl4b+$Hk%#Y5s!oa^(rllUo36{nemZ~s?A7Oi^} zvxo>mIi}q^2EJ<4V^=H)-=rnxjlqLgl@X&gm(Aeur>hjj*De@=Ll9u9$7s}-yPH?oE&_@Q>G0c6IS}RpdrClTo*VO ztxxC@J;d>Qzt!nU8GPK+@8B^{0uzY%lRxiIKI=~oOR^>!98a2q9tNMEBW)Wh1z*>u zqb~TdU!GBz0}i53B1I{rz}UI`=!$i^RBy^8L`*kju`6E{AWE<#MBF2i30yXuf*(Di z*R{YjF7DGw^c7j|Rt|%Pp*85u1>>SO7&sn$$&2n%IGc+Bi|BWtdmuVqR2W3;;Kl;K z7}VRLR>56ll3FqF&^I5`ZVgJl_(793%gfRiVHTkDhh58Nb47pVf$7{09^C%_!8wF# zKb(;#TcEyR-n%$IP)J^$D-2X+-3jcDlL8 zL9lY#dn|~LFriO+iBE*DZtuocx|V_VX~{4aorweh&oF?prt{ZTQkr;4uNzpmFaMms+Q$^GSQa%raOJDYfDuNFKm|pnv zK29&NoU=)%7c8d>j`3wvC&ZiBI);~vVpvVY1gJjjzTUjk`mbi_cg&_ft@D-s`~0>3 zH+m(`n-sC&f05@)eY$+?-KEx`ejbNI`(Ntvu-#XQsoj%p{Jw){JA8llQUZqEOW|L)!!d;*fJ+F?w8MN}E)67hU)NuN(S3#_II^vi!~Wz8W)_!*+Luo6p0tN< zvL@Mj(mwrVe)^(4BoA+K($`#z^mgLk+I@>3?LDtMi|9(+!0waCIXwZpZ}2IqAI1le zO#Pqt)ermYhX!=fM%sO0lx{Fi%^r^UK#&1gCIc3arW$5G$E zNv8pDiBaG6mo&Pjr{ns&^07SbXKDyBanyZyOi0g%n0NMbLU4L#2RiJRM}KmLeQAz* zkFA5af8SlFQ{Huw*dGD~|GRh*D}rPG1N+7D!&YSvB{`RTA1w0XZFJ`c#O%{CEwQw` z%JGl+LYJss=H8c%2I3GOOYBcCAjGH1i5;hp|6y=_nbQJlz$y8*orz2_sy5vgL$TKm zkYnXzBql&b;6H<=iSFb&KmGWooNP~wjPM=DlPc$(zPjn+l-{d4e5T<5=inB(yyAh` zB%;N&P~^LGu2mwR?9+OksA8^1!ewS1M2$TKe=e6-@sUgB_N>it+%j@XC@vNfFTLc? zMU*mNnF64(B}A&>yQ!)C`ApHyBW9uO)YG)H@1#K0EkwNTZ25z+$CS!!Bl@$BaM*f-Ix;b+6wHk*35mux zL;wSKv_V|Cl+LfxhytX+O>2=-(9~{8;;03A_ z7W+OIjRHi|aQws@F{nFEyi;Rl~{Dd=?V@nOT(t1UqjRR(sVj@JJ}6C8AK` zAE-=Fe0T2QpGTDmITza8&k<6TI05mMTurYC(*7LQ%hj_2Q%%P+~7ZVsb4CcYG6^5(L3BB}U^cmb%IGzPf+5pHfT z!vU!l5Voj#;oL3Y!&XH^+mu#IsU(6%G?kuD6j2!y!-}xO2fjxXQAVd{lg>cCL=92u z+#4}hCwgVuSXyKEIFd-#%;5E$C80<{Xq>?zOP(+$U$he?{LxXp91*T3;l}l;;j`un z2hOD$K9>M_D=1N(P(ZqB;3(k37hk~pFc~^|p4iJ?HI6ZKpq0;f$huad? zU1t{AbX|FejR2FPyW$~ZP&9LAhh%cPR$op;zEFrK?B9x@1!V^h!F{Rtd%(X-AF=l60?Z}!7@sHaXBC;cfg(%wgK zQq4#`Gx_^tr)sv57lb4d|1JF?DWC<;K)fvk7%B U0&gNf1pG|lXJ#6ENU=8m53~$aYXATM diff --git a/lispusers/FILEWATCH.~1~ b/lispusers/FILEWATCH.~1~ deleted file mode 100644 index 339ed340..00000000 --- a/lispusers/FILEWATCH.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) (FILECREATED "20-Oct-89 17:00:03" {ICE}LISPUSERS>MEDLEY>FILEWATCH.;2 63422 changes to%: (VARS FILEWATCHCOMS) (FNS FILEWATCH FW-CLOSE-CMD FW-INIT-MENUS) previous date%: "19-Oct-87 12:36:56" {ICE}LISPUSERS>MEDLEY>FILEWATCH.;1) (* " Copyright (c) 1986, 1987, 1989 by Johannes A. G. M. Koomen. All rights reserved. ") (PRETTYCOMPRINT FILEWATCHCOMS) (RPAQQ FILEWATCHCOMS [(PROP MAKEFILE-ENVIRONMENT FILEWATCH) (* ;;; "FILEWATCH is a facility for keeping an eye on the status of open files. It maintains a display containing the names of open files and their file pointer positions including a percentage bar.") (* ;;; "Interface") (FNS FILEWATCH FILEWATCHPROP) (* ;;; "Implementation") (COMS (DECLARE%: DONTCOPY (RECORDS FW-OFD)) (INITRECORDS FW-OFD)) (FNS FW-ADJUST-PLACEMENT FW-ADJUST-REGION FW-AFTERMOVEFN FW-BUTTONEVENTFN FW-CHANGE-ANCHOR FW-CHANGE-JUSTIFICATION FW-CHANGE-POSITION FW-CLOSE-CMD FW-CLOSE-OLD-OFD-WINDOWS FW-CLOSEFN FW-CREATE-OFD FW-CREATE-OFD-LIST FW-CREATE-OFD-WINDOWS FW-CREATEW FW-FILTERED-FILE? FW-FORGET-CMD FW-INIT FW-INIT-MENUS FW-INIT-PROPS FW-INTERACT FW-LOOP FW-MOVE-OFD-WINDOWS FW-MOVEW FW-OFD-EXISTS? FW-OPENP FW-PERCENTAGE FW-RE-INIT FW-RECALL-CMD FW-REPAINTFN FW-RESET FW-RESIZE-OFD FW-SHAPEW FW-SORT-FN FW-UPDATE-OFD-WINDOW FW-UPDATE-OFD-WINDOWS FW-WIPE) [DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (* FILES (SOURCE FROM LISPUSERS) SYSEDIT) (P [OR (HASDEF 'FDEV 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'FDEV] (OR (HASDEF 'STREAM 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'STREAM] [INITVARS (FW-OFDList NIL) (FW-OpenP-ScratchList (CONS)) [FW-Commands (COPY '(FORGET FORGET-MANY RECALL RECALL-MANY CLOSE CLOSE-MANY MOVE SET-ANCHOR SET-POSITION SET-JUSTIFICATION QUIT] (FW-Properties (COPY `(FONT (GACHA 8) ALL-FILES? T POSITION ,(CREATEPOSITION SCREENWIDTH 0) ANCHOR BOTTOM-RIGHT SHADE ,GRAYSHADE INTERVAL 1000] (P (FW-INIT-MENUS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FILEWATCHPROP]) (PUTPROPS FILEWATCH MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) (* ;;; "FILEWATCH is a facility for keeping an eye on the status of open files. It maintains a display containing the names of open files and their file pointer positions including a percentage bar." ) (* ;;; "Interface") (DEFINEQ (FILEWATCH [LAMBDA (COMMAND) (* ; "Edited 20-Oct-89 16:43 by koomen") (DECLARE (GLOBALVARS FW-Running?)) (PROG [(FW-PROC (FIND.PROCESS 'FileWatcher] (if (OR (NOT (PROCESSP FW-PROC)) (PROCESS.FINISHEDP FW-PROC)) then (SETQ FW-PROC NIL)) (SELECTQ (SELECTQ [if (OR (LITATOM COMMAND) (STRINGP COMMAND)) then (SETQ COMMAND (MKATOM (U-CASE COMMAND] (ON (if (NULL FW-PROC) then 'ON)) ((OFF QUIT) (if FW-PROC then (SETQ COMMAND 'OFF))) (MENU (SETQ COMMAND NIL) 'MENU) (if (OR COMMAND FW-PROC) then 'MENU else 'ON)) (ON (SETQ FW-PROC (ADD.PROCESS (LIST (FUNCTION FW-LOOP)) 'NAME 'FileWatcher 'RESTARTABLE 'HARDRESET))) (OFF (SETQ FW-PROC (SETQ FW-Running? NIL))) (MENU (if (NULL FW-PROC) then (FILEWATCH 'ON) (BLOCK)) (FW-INTERACT NIL COMMAND)) NIL) (RETURN FW-PROC]) (FILEWATCHPROP [LAMBDA FILEWATCH#ARGS (* Koomen "12-Jan-87 21:31") (DECLARE (GLOBALVARS FW-Properties FW-ReInit?)) (if (EQ FILEWATCH#ARGS 1) then (LET ((PROPNAME (ARG FILEWATCH#ARGS 1))) (LISTGET FW-Properties PROPNAME)) elseif (EQ FILEWATCH#ARGS 2) then (LET* ((PROPNAME (ARG FILEWATCH#ARGS 1)) (PROPVALUE (ARG FILEWATCH#ARGS 2)) (OLDPROPVALUE (LISTGET FW-Properties PROPNAME))) (if (NOT (EQUAL PROPVALUE OLDPROPVALUE)) then (LISTPUT FW-Properties PROPNAME PROPVALUE) (SETQ FW-ReInit? T)) OLDPROPVALUE) else (ERROR "FILEWATCH: Expecting 1 or 2 args -- " FILEWATCH#ARGS]) ) (* ;;; "Implementation") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE FW-OFD (FILESTREAM FULLNAME NAMEWIDTH LEFT BOTTOM WIDTH HEIGHT OFDLEFT OFDBOTTOM OFDWIDTH OFDHEIGHT OFDWINDOW OFDSTREAM OFDSTATUS CURPOS EOFPOS PCTPOS CURPOSXOFFSET EOFPOSXOFFSET PCTPOSXOFFSET ACCESSXOFFSET PCTREGION READING? WRITING? RANDOM?)) ) (/DECLAREDATATYPE 'FW-OFD '(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) '((FW-OFD 0 POINTER) (FW-OFD 2 POINTER) (FW-OFD 4 POINTER) (FW-OFD 6 POINTER) (FW-OFD 8 POINTER) (FW-OFD 10 POINTER) (FW-OFD 12 POINTER) (FW-OFD 14 POINTER) (FW-OFD 16 POINTER) (FW-OFD 18 POINTER) (FW-OFD 20 POINTER) (FW-OFD 22 POINTER) (FW-OFD 24 POINTER) (FW-OFD 26 POINTER) (FW-OFD 28 POINTER) (FW-OFD 30 POINTER) (FW-OFD 32 POINTER) (FW-OFD 34 POINTER) (FW-OFD 36 POINTER) (FW-OFD 38 POINTER) (FW-OFD 40 POINTER) (FW-OFD 42 POINTER) (FW-OFD 44 POINTER) (FW-OFD 46 POINTER) (FW-OFD 48 POINTER)) '50) ) (/DECLAREDATATYPE 'FW-OFD '(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) '((FW-OFD 0 POINTER) (FW-OFD 2 POINTER) (FW-OFD 4 POINTER) (FW-OFD 6 POINTER) (FW-OFD 8 POINTER) (FW-OFD 10 POINTER) (FW-OFD 12 POINTER) (FW-OFD 14 POINTER) (FW-OFD 16 POINTER) (FW-OFD 18 POINTER) (FW-OFD 20 POINTER) (FW-OFD 22 POINTER) (FW-OFD 24 POINTER) (FW-OFD 26 POINTER) (FW-OFD 28 POINTER) (FW-OFD 30 POINTER) (FW-OFD 32 POINTER) (FW-OFD 34 POINTER) (FW-OFD 36 POINTER) (FW-OFD 38 POINTER) (FW-OFD 40 POINTER) (FW-OFD 42 POINTER) (FW-OFD 44 POINTER) (FW-OFD 46 POINTER) (FW-OFD 48 POINTER)) '50) (DEFINEQ (FW-ADJUST-PLACEMENT [LAMBDA (OFDLIST) (* Koomen "12-Jan-87 21:19") (* * Recursively (post-order) position each window, so that the first element  ends up on top of the display. Note that, for downward-growing lists, the  sorter actually forces reverse sort.) (DECLARE (GLOBALVARS FW-WindowBottom FW-WindowBottomDelta)) (if OFDLIST then (FW-ADJUST-PLACEMENT (CDR OFDLIST)) (PROG ((OFD (CAR OFDLIST))) (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) ((NEW CURRENT) (replace (FW-OFD BOTTOM) of OFD with FW-WindowBottom) (if (OR (NEQ (fetch (FW-OFD OFDWIDTH) of OFD) (fetch (FW-OFD WIDTH) of OFD)) (NEQ (fetch (FW-OFD OFDHEIGHT) of OFD) (fetch (FW-OFD HEIGHT) of OFD))) then (FW-SHAPEW OFD) (replace (FW-OFD OFDSTATUS) of OFD with 'NEW) elseif (OR (NEQ (fetch (FW-OFD LEFT) of OFD) (fetch (FW-OFD OFDLEFT) of OFD)) (NEQ (fetch (FW-OFD BOTTOM) of OFD) (fetch (FW-OFD OFDBOTTOM) of OFD))) then (FW-MOVEW OFD)) (SETQ FW-WindowBottom (IPLUS FW-WindowBottom FW-WindowBottomDelta))) (FORGOTTEN) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-ADJUST-REGION [LAMBDA NIL (* Koomen "12-Jan-87 21:29") (DECLARE (GLOBALVARS FW-Anchor FW-Justified? FW-OFDList FW-Position FW-WindowBottom FW-WindowBottomDelta FW-WindowHeight WBorder)) [if FW-Justified? then (* Recompute maximum name field  width) (PROG (NAMEWIDTH (MAXNAMEWIDTH 0)) [for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) ((NEW CURRENT) (SETQ NAMEWIDTH (fetch (FW-OFD NAMEWIDTH) of OFD)) (if (IGREATERP NAMEWIDTH MAXNAMEWIDTH) then (SETQ MAXNAMEWIDTH NAMEWIDTH))) (FORGOTTEN) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS ) of OFD] (for OFD in FW-OFDList do (FW-RESIZE-OFD OFD MAXNAMEWIDTH] (SETQ FW-WindowBottom (fetch (POSITION YCOORD) of FW-Position)) (SETQ FW-WindowBottomDelta (IDIFFERENCE FW-WindowHeight (IQUOTIENT WBorder 2))) (SELECTQ FW-Anchor ((TOP-LEFT TOP-RIGHT) (SETQ FW-WindowBottom (IDIFFERENCE FW-WindowBottom FW-WindowHeight)) (SETQ FW-WindowBottomDelta (IMINUS FW-WindowBottomDelta))) ((BOTTOM-LEFT BOTTOM-RIGHT)) (ERROR "Unsupported anchor spec: " FW-Anchor]) (FW-AFTERMOVEFN [LAMBDA (W) (* ; "Edited 30-Sep-87 11:53 by Koomen") (* ;; "[30-Sep-87] Added FW-Dormant? flag: If moving a FileWatch window causes the FileWatch anchor position to move off the screen, then go to sleep. This is to accomodate the Rooms package.") (DECLARE (GLOBALVARS FW-Dormant? FW-OFDList SCREENHEIGHT SCREENWIDTH)) (SETQ FW-Dormant? NIL) (if (NEQ 'FileWatcher (PROCESS.NAME (THIS.PROCESS))) then (for OFD in FW-OFDList when (EQ W (fetch (FW-OFD OFDWINDOW) of OFD)) bind REGION DELTAX DELTAY OLDPOS NEWX NEWY do (SETQ OLDPOS (FILEWATCHPROP 'POSITION)) (SETQ REGION (WINDOWREGION W)) (SETQ DELTAX (IDIFFERENCE (fetch (REGION LEFT) of REGION) (fetch (FW-OFD OFDLEFT) of OFD))) (SETQ NEWX (IPLUS DELTAX (fetch (POSITION XCOORD) of OLDPOS))) (SETQ DELTAY (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) (fetch (FW-OFD OFDBOTTOM) of OFD))) (SETQ NEWY (IPLUS DELTAY (fetch (POSITION YCOORD) of OLDPOS))) (if (OR (ILESSP NEWX 0) (IGREATERP NEWX SCREENWIDTH) (ILESSP NEWY 0) (IGREATERP NEWY SCREENHEIGHT)) then (SETQ FW-Dormant? T) else (FILEWATCHPROP 'POSITION (create POSITION XCOORD _ NEWX YCOORD _ NEWY))) (RETURN]) (FW-BUTTONEVENTFN [LAMBDA (W) (* Koomen "16-Apr-87 15:28") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS)) (if (MOUSESTATE (ONLY RIGHT)) then (FW-INTERACT W) elseif (MOUSESTATE (ONLY MIDDLE)) then (FW-MOVE-OFD-WINDOWS 'POSITION) elseif (MOUSESTATE (ONLY LEFT)) then (FW-REPAINTFN W)) NIL]) (FW-CHANGE-ANCHOR [LAMBDA NIL (* Koomen "16-Apr-87 15:55") (DECLARE (GLOBALVARS PROMPTWINDOW)) (PROG [NEWANCHOR (OLDANCHOR (FILEWATCHPROP 'ANCHOR] (CLRPROMPT) (printout PROMPTWINDOW "Current anchor is " OLDANCHOR T T) (printout PROMPTWINDOW "Indicate new anchor: ") [SETQ NEWANCHOR (MENU (create MENU CENTERFLG _ T TITLE _ "Anchor: " ITEMS _ '(("Top Left" 'TOP-LEFT) ("Top Right" 'TOP-RIGHT) ("Bottom Left" 'BOTTOM-LEFT) ("Bottom Right" 'BOTTOM-RIGHT] (if (AND NEWANCHOR (NEQ NEWANCHOR OLDANCHOR)) then (FILEWATCHPROP 'ANCHOR NEWANCHOR]) (FW-CHANGE-JUSTIFICATION [LAMBDA NIL (* Koomen "16-Apr-87 15:55") (DECLARE (GLOBALVARS PROMPTWINDOW)) (PROG [NEWJUST? (OLDJUST? (FILEWATCHPROP 'JUSTIFIED?] (CLRPROMPT) (printout PROMPTWINDOW "Window justification is " OLDJUST? T T) (SETQ NEWJUST? (MOUSECONFIRM "Turn justification on?")) (if (NEQ NEWJUST? OLDJUST?) then (FILEWATCHPROP 'JUSTIFIED? NEWJUST?]) (FW-CHANGE-POSITION [LAMBDA NIL (* Koomen "16-Apr-87 15:48") (DECLARE (GLOBALVARS FW-OFDList PROMPTWINDOW)) (PROG ((OLDPOS (FILEWATCHPROP 'POSITION)) NEWPOS BOX R) (for OFD in FW-OFDList when (EQ (fetch (FW-OFD OFDSTATUS) of OFD) 'CURRENT) do (SETQ R (WINDOWREGION (fetch (FW-OFD OFDWINDOW) of OFD))) (SETQ BOX (if BOX then (UNIONREGIONS BOX R) else R))) (if BOX then (SETQ NEWPOS (GETBOXPOSITION (fetch (REGION WIDTH) of BOX) (fetch (REGION HEIGHT) of BOX) (fetch (REGION LEFT) of BOX) (fetch (REGION BOTTOM) of BOX))) (* ;; "Now translate since anchor may not have been bottom-left") [SETQ NEWPOS (create POSITION XCOORD _ (IPLUS (fetch (POSITION XCOORD) of OLDPOS) (IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (REGION LEFT) of BOX))) YCOORD _ (IPLUS (fetch (POSITION YCOORD) of OLDPOS) (IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (REGION BOTTOM) of BOX] else (CLRPROMPT) (printout PROMPTWINDOW "Current position is " OLDPOS T T) (printout PROMPTWINDOW "Indicate new position: ") (SETQ NEWPOS (GETPOSITION))) (if (NOT (EQUAL NEWPOS OLDPOS)) then (FILEWATCHPROP 'POSITION NEWPOS]) (FW-CLOSE-CMD [LAMBDA (W MANY?) (* ; "Edited 20-Oct-89 16:38 by koomen") (DECLARE (GLOBALVARS FW-OFDList)) (if (AND W (NOT MANY?)) then (for OFD in FW-OFDList bind STREAM when (EQ (fetch (FW-OFD OFDWINDOW) of OFD) W) do (SETQ STREAM (fetch (FW-OFD FILESTREAM) of OFD)) (if (NOT (OPENP STREAM)) then (* ;;  "The process owning the stream beat us to it!") elseif (NOT (fetch (STREAM USERCLOSEABLE) of STREAM)) then (PROMPTPRINT "FileWatch: stream not user closable.") elseif (MOUSECONFIRM (CONCAT "Closing " STREAM)) then (CLOSEF? STREAM)) (RETURN)) else (bind OPEN-STREAMS STREAM-TO-CLOSE do (SETQ OPEN-STREAMS (FW-OPENP)) (if (NULL OPEN-STREAMS) then (if (NULL STREAM-TO-CLOSE) then (* ;; "First time around, and no appropriate files") (PROMPTPRINT "FileWatch: no open files.")) (RETURN)) (SETQ OPEN-STREAMS (for STREAM in OPEN-STREAMS when (fetch (STREAM USERCLOSEABLE) of STREAM) collect STREAM)) (if (NULL OPEN-STREAMS) then (if (NULL STREAM-TO-CLOSE) then (* ;; "First time around, and no appropriate files") (PROMPTPRINT "FileWatch: no user closable files.")) (RETURN)) (SETQ STREAM-TO-CLOSE (MENU (create MENU TITLE _ "Select stream to close: " ITEMS _ OPEN-STREAMS))) (if (NULL STREAM-TO-CLOSE) then (RETURN)) (CLOSEF? STREAM-TO-CLOSE) (BLOCK) (* ; "Give FileWatch a chance") (if (NOT MANY?) then (RETURN]) (FW-CLOSE-OLD-OFD-WINDOWS [LAMBDA NIL (* Koomen " 1-Oct-86 23:48") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (OLD (CLOSEW (fetch (FW-OFD OFDWINDOW) of OFD))) ((NEW CURRENT FORGOTTEN)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-CLOSEFN [LAMBDA (W) (* Koomen " 2-Oct-86 00:17") (DECLARE (GLOBALVARS FW-OFDList FW-OpenFiles FW-Reset?)) (if (NEQ (PROCESS.NAME (THIS.PROCESS)) 'FileWatcher) then (for OFD in FW-OFDList when (EQ W (fetch (FW-OFD OFDWINDOW) of OFD)) do (replace (FW-OFD OFDSTATUS) of OFD with 'FORGOTTEN) (RETURN)) (* Force recomputing OFDList) (push FW-OpenFiles T) (SETQ FW-Reset? T]) (FW-CREATE-OFD [LAMBDA (FULLNAME FILESTREAM) (* ; "Edited 22-Sep-87 13:04 by Koomen") (DECLARE (GLOBALVARS FW-Font)) (FW-RESIZE-OFD (create FW-OFD FILESTREAM _ FILESTREAM FULLNAME _ FULLNAME NAMEWIDTH _ (STRINGWIDTH FULLNAME FW-Font) EOFPOS _ (if (RANDACCESSP FILESTREAM) then (GETEOFPTR FILESTREAM) else (GETFILEINFO FILESTREAM 'LENGTH)) READING? _ (if (OPENP FILESTREAM 'INPUT) then T) WRITING? _ (if (OPENP FILESTREAM 'OUTPUT) then T) RANDOM? _ (if (RANDACCESSP FILESTREAM) then T) OFDSTATUS _ 'NEW]) (FW-CREATE-OFD-LIST [LAMBDA NIL (* ; "Edited 22-Sep-87 13:34 by Koomen") (DECLARE (GLOBALVARS FW-OFDList FW-OpenFiles FW-SortFn)) (for FILESTREAM in FW-OpenFiles bind FULLNAME eachtime (SETQ FULLNAME (FULLNAME FILESTREAM)) unless (OR (FW-FILTERED-FILE? FULLNAME) (FW-OFD-EXISTS? FULLNAME FILESTREAM)) do (push FW-OFDList (FW-CREATE-OFD FULLNAME FILESTREAM))) [SETQ FW-OFDList (for OFD in FW-OFDList join (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) ((NEW CURRENT FORGOTTEN) (LIST OFD)) (OLD (CLOSEW (fetch (FW-OFD OFDWINDOW) of OFD)) NIL) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD] (if (AND FW-OFDList FW-SortFn) then (SETQ FW-OFDList (SORT FW-OFDList (FUNCTION FW-SORT-FN]) (FW-CREATE-OFD-WINDOWS [LAMBDA NIL (* Koomen "16-Apr-87 15:29") (DECLARE (GLOBALVARS FW-Font FW-OFDList)) (FW-ADJUST-REGION) (for OFD in FW-OFDList bind OFDWINDOW OFDSTREAM unless (fetch (FW-OFD OFDWINDOW ) of OFD) do (SETQ OFDWINDOW (FW-CREATEW OFD)) (SETQ OFDSTREAM (WINDOWPROP OFDWINDOW 'DSP)) (replace (FW-OFD OFDSTREAM) of OFD with OFDSTREAM) (DSPFONT FW-Font OFDSTREAM) (WINDOWPROP OFDWINDOW 'RIGHTBUTTONFN (FUNCTION FW-BUTTONEVENTFN)) (WINDOWPROP OFDWINDOW 'BUTTONEVENTFN (FUNCTION FW-BUTTONEVENTFN)) (WINDOWPROP OFDWINDOW 'REPAINTFN (FUNCTION FW-REPAINTFN)) (WINDOWPROP OFDWINDOW 'RESHAPEFN (FUNCTION NILL)) (WINDOWPROP OFDWINDOW 'CLOSEFN (FUNCTION FW-CLOSEFN)) (WINDOWPROP OFDWINDOW 'AFTERMOVEFN (FUNCTION FW-AFTERMOVEFN))) (FW-ADJUST-PLACEMENT FW-OFDList]) (FW-CREATEW [LAMBDA (OFD) (* Koomen "29-Sep-86 23:16") (replace (FW-OFD OFDWINDOW) of OFD with (CREATEW (create REGION LEFT _ (replace (FW-OFD OFDLEFT ) of OFD with (fetch (FW-OFD LEFT) of OFD)) BOTTOM _ (replace (FW-OFD OFDBOTTOM) of OFD with (fetch (FW-OFD BOTTOM) of OFD)) WIDTH _ (replace (FW-OFD OFDWIDTH ) of OFD with (fetch (FW-OFD WIDTH) of OFD)) HEIGHT _ (replace (FW-OFD OFDHEIGHT) of OFD with (fetch (FW-OFD HEIGHT) of OFD))) NIL NIL T]) (FW-FILTERED-FILE? [LAMBDA (FULLNAME) (* ; "Edited 22-Sep-87 13:31 by Koomen") (DECLARE (GLOBALVARS FW-Filters)) (* ;; "filters are precompiled for matching. Note that the system function DIRECTORY.MATCH.SETUP has stripped off the host, so we have to match it seperatedly.") (for FILTER in FW-Filters thereis (AND (DIRECTORY.MATCH (CDR FILTER) FULLNAME) (DIRECTORY.MATCH (CAR FILTER) (FILENAMEFIELD FULLNAME 'HOST]) (FW-FORGET-CMD [LAMBDA (W MANY?) (* Koomen "27-May-87 15:27") (DECLARE (GLOBALVARS FW-OFDList)) (if (AND W (NOT MANY?)) then (CLOSEW W) else (PROG (CURRENT-OFDS FORGET-OFD) (SETQ CURRENT-OFDS (for OFD in FW-OFDList when (EQ (fetch (FW-OFD OFDSTATUS) of OFD) 'CURRENT) collect OFD)) (if (NULL CURRENT-OFDS) then (PROMPTPRINT "FileWatch: no current files.") (RETURN)) FORGET-ANOTHER [SETQ FORGET-OFD (MENU (create MENU TITLE _ "Select file to forget: " ITEMS _ (for OFD in CURRENT-OFDS collect (LIST (fetch (FW-OFD FULLNAME) of OFD) (KWOTE OFD] (if (NULL FORGET-OFD) then (RETURN)) (CLOSEW (fetch (FW-OFD OFDWINDOW) of FORGET-OFD)) (if (AND MANY? (SETQ CURRENT-OFDS (REMOVE FORGET-OFD CURRENT-OFDS))) then (GO FORGET-ANOTHER]) (FW-INIT [LAMBDA NIL (* ; "Edited 30-Sep-87 11:53 by Koomen") (DECLARE (GLOBALVARS FW-Dormant? FW-Running?)) (* * Clean up possible left-overs from a previously killed FileWatch process,  then initialize the world) (FW-WIPE) (FW-RE-INIT) (FW-RESET) (SETQ FW-Dormant? NIL) (SETQ FW-Running? T]) (FW-INIT-MENUS [LAMBDA NIL (* ; "Edited 20-Oct-89 16:57 by koomen") (DECLARE (GLOBALVARS BackgroundMenu BackgroundMenuCommands FW-Commands FW-InteractMenu)) (* * When changing the list of control menu items, do  (SETQ FW-InteractMenu)) (PROG [(ITEMS '(("Forget File" 'FORGET "Stop watching this file" (SUBITEMS ("Forget Many Files" 'FORGET-MANY "Stop watching several files" ))) ("Recall File" 'RECALL "Start watching a forgotten file again" (SUBITEMS ("Recall Many Files" 'RECALL-MANY "Start watching several forgotten files again"))) ("" NIL "No-op") ("Close File" 'CLOSE "Close this file (user beware!)" (SUBITEMS ("Close Many Files" 'CLOSE-MANY "Close several files"))) ("" NIL "No-op") ("Move Display" 'MOVE "Change the display orientation specs" (SUBITEMS ("Set Anchor" 'SET-ANCHOR "Corner of the display to be anchored" ) ("Set Position" 'SET-POSITION "Position of display (relative to anchor)") ("Set Justification" 'SET-JUSTIFICATION "Windows to be shrunk or grown depending on maximum filename width" ))) ("Quit File Watcher" 'QUIT ""] [if (NOT (type? MENU FW-InteractMenu)) then (SETQ FW-InteractMenu (create MENU TITLE _ "FileWatch:" CENTERFLG _ T MENUOFFSET _ (CONS -1 58) CHANGEOFFSETFLG _ 'Y ITEMS _ (COPY ITEMS] (if (NULL (CDDDR (FASSOC 'FileWatch BackgroundMenuCommands))) then (* ;; "Not there, or no subitems (older version)") (for C in FW-Commands do (SETQ ITEMS (SUBST `'(FILEWATCH ',C) `',C ITEMS))) [push BackgroundMenuCommands (COPY `(FileWatch '(FILEWATCH 'ON) "Display and continuously update list of open files and and the location of their file pointers" (SUBITEMS ,@ITEMS] (SETQ BackgroundMenu]) (FW-INIT-PROPS [LAMBDA NIL (* ; "Edited 22-Sep-87 14:30 by Koomen") (DECLARE (GLOBALVARS FW-AllFiles? FW-Anchor FW-Filters FW-Font FW-Interval FW-Justified? FW-Position FW-Properties FW-Shade FW-SortFn)) [SETQ FW-AllFiles? (NOT (NULL (LISTGET FW-Properties 'ALL-FILES?] (SETQ FW-Anchor (OR [CAR (MEMB (LISTGET FW-Properties 'ANCHOR) '(TOP-LEFT TOP-RIGHT BOTTOM-LEFT BOTTOM-RIGHT] 'BOTTOM-LEFT)) (* ;; "precompile filters for matching. Note that the system function DIRECTORY.MATCH.SETUP strips off the host, so we have to match it seperatedly.") (SETQ FW-Filters (for FILTER inside (LISTGET FW-Properties 'FILTERS) join (if (OR (STRINGP FILTER) (LITATOM FILTER)) then (SETQ FILTER (DIRECTORY.FILL.PATTERN FILTER)) (LIST (CONS (DIRECTORY.MATCH.SETUP (OR (FILENAMEFIELD FILTER 'HOST) "*")) (DIRECTORY.MATCH.SETUP FILTER))) else (printout PROMPTWINDOW 0 "FileWatch: filter not a string or symbol: " T FILTER " ignored." T) NIL))) [SETQ FW-Font (FONTCREATE (LISTGET FW-Properties 'FONT] [SETQ FW-Interval (FIXP (LISTGET FW-Properties 'INTERVAL] [SETQ FW-Justified? (NOT (NULL (LISTGET FW-Properties 'JUSTIFIED?] (SETQ FW-Position (OR (POSITIONP (LISTGET FW-Properties 'POSITION)) (create POSITION XCOORD _ 0 YCOORD _ 0))) (LET ((X (fetch (POSITION XCOORD) of FW-Position)) (Y (fetch (POSITION YCOORD) of FW-Position)) (W SCREENWIDTH) (H SCREENHEIGHT) (XMIN 100) (XMAX (IDIFFERENCE SCREENWIDTH 100)) (YMIN 100) (YMAX (IDIFFERENCE SCREENHEIGHT 100))) (SELECTQ FW-Anchor (TOP-LEFT (if (IGEQ X XMAX) then (SETQ X XMAX)) (if (ILEQ Y YMIN) then (SETQ Y YMIN))) (TOP-RIGHT (if (ILEQ X XMIN) then (SETQ X XMIN)) (if (ILEQ Y YMIN) then (SETQ Y YMIN))) (BOTTOM-LEFT (if (IGEQ X XMAX) then (SETQ X XMAX)) (if (IGEQ Y YMAX) then (SETQ Y YMAX))) (BOTTOM-RIGHT (if (ILEQ X XMIN) then (SETQ X XMIN)) (if (IGEQ Y YMAX) then (SETQ Y YMAX))) (SHOULDNT)) (SETQ FW-Position (create POSITION XCOORD _ X YCOORD _ Y))) [SETQ FW-Shade (SMALLP (LISTGET FW-Properties 'SHADE] (SETQ FW-SortFn (LET [(FN (LISTGET FW-Properties 'SORTFN] (if (AND (LITATOM FN) (GETD FN)) then FN]) (FW-INTERACT [LAMBDA (W MENUCMD) (* Koomen "15-May-87 01:03") (DECLARE (GLOBALVARS FW-InteractMenu FW-Running?)) (SELECTQ (OR MENUCMD (SETQ MENUCMD (MENU FW-InteractMenu))) (NIL NIL) (FORGET (FW-FORGET-CMD W)) (FORGET-MANY (FW-FORGET-CMD W T)) (RECALL (FW-RECALL-CMD)) (RECALL-MANY (FW-RECALL-CMD T)) (CLOSE (FW-CLOSE-CMD W)) (CLOSE-MANY (FW-CLOSE-CMD W T)) (MOVE (FW-MOVE-OFD-WINDOWS)) (SET-ANCHOR (FW-MOVE-OFD-WINDOWS 'ANCHOR)) (SET-POSITION (FW-MOVE-OFD-WINDOWS 'POSITION)) (SET-JUSTIFICATION (FW-MOVE-OFD-WINDOWS 'JUSTIFIED?)) (QUIT (SETQ FW-Running? NIL)) (PROMPTPRINT "Unrecognized FileWatch Control Menu command: " MENUCMD]) (FW-LOOP [LAMBDA NIL (* ; "Edited 30-Sep-87 11:53 by Koomen") (DECLARE (GLOBALVARS FW-Dormant? FW-Interval FW-OpenFiles FW-ReInit? FW-Reset? FW-Running?)) (bind OPENFILES first (FW-INIT) while FW-Running? do (if (NOT FW-Dormant?) then (SETQ OPENFILES (FW-OPENP)) (if (OR FW-Reset? FW-ReInit? (NOT (EQUAL OPENFILES FW-OpenFiles))) then (if FW-ReInit? then (FW-RE-INIT)) (FW-RESET) (if (SETQ FW-OpenFiles (APPEND OPENFILES)) then (FW-CREATE-OFD-LIST) (FW-CREATE-OFD-WINDOWS) else (FW-CLOSE-OLD-OFD-WINDOWS)) (SETQ FW-ReInit?)) (FW-UPDATE-OFD-WINDOWS)) (BLOCK FW-Interval) finally (FW-WIPE]) (FW-MOVE-OFD-WINDOWS [LAMBDA (WHAT) (* Koomen "16-Apr-87 15:55") (if (OR (NULL WHAT) (EQ WHAT 'ANCHOR)) then (FW-CHANGE-ANCHOR)) (if (OR (NULL WHAT) (EQ WHAT 'POSITION)) then (FW-CHANGE-POSITION)) (if (OR (NULL WHAT) (EQ WHAT 'JUSTIFIED?)) then (FW-CHANGE-JUSTIFICATION]) (FW-MOVEW [LAMBDA (OFD) (* Koomen "29-Sep-86 23:10") (MOVEW (fetch (FW-OFD OFDWINDOW) of OFD) (replace (FW-OFD OFDLEFT) of OFD with (fetch (FW-OFD LEFT) of OFD)) (replace (FW-OFD OFDBOTTOM) of OFD with (fetch (FW-OFD BOTTOM) of OFD]) (FW-OFD-EXISTS? [LAMBDA (FULLNAME FILESTREAM) (* ; "Edited 22-Sep-87 13:27 by Koomen") (DECLARE (GLOBALVARS FW-OFDList FW-ReInit?)) (for OFD in FW-OFDList when (AND (EQ (fetch (FW-OFD FULLNAME) of OFD) FULLNAME) (EQ (fetch (FW-OFD FILESTREAM) of OFD) FILESTREAM) (EQ (fetch (FW-OFD READING?) of OFD) (if (OPENP FILESTREAM 'INPUT) then T)) (EQ (fetch (FW-OFD WRITING?) of OFD) (if (OPENP FILESTREAM 'OUTPUT) then T))) do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (OLD (replace (FW-OFD OFDSTATUS) of OFD with (if FW-ReInit? then 'NEW else 'CURRENT)) (RETURN T)) ((NEW CURRENT FORGOTTEN) (RETURN T)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-OPENP [LAMBDA NIL (* ; "Edited 22-Sep-87 11:32 by Koomen") (* ;; "Computes the list of currently open files (actually, streams). If the globalvar FW-AllFiles? is non-NIL, streams with flag USERVISIBLE=NIL are included as well.") (* ;;  "Note: Uses a scratchlist, so be sure to copy result if you need it across calls to FW-OPENP") (DECLARE (GLOBALVARS FW-AllFiles? FW-OpenP-ScratchList \FILEDEVICES)) (SCRATCHLIST FW-OpenP-ScratchList (for FD in \FILEDEVICES bind OPENPFN do (SETQ OPENPFN (fetch (FDEV OPENP) of FD)) (if (EQ OPENPFN '\GENERIC.OPENP) then (for S in (fetch (FDEV OPENFILELST) of FD) when (OR FW-AllFiles? (fetch (STREAM USERVISIBLE) of S)) do (ADDTOSCRATCHLIST S)) else (for FNAME in (APPLY* OPENPFN NIL NIL FD) do (ADDTOSCRATCHLIST (\GETSTREAM FNAME]) (FW-PERCENTAGE [LAMBDA (X Y) (* ; "Edited 30-Sep-87 01:00 by Koomen") (if (IGEQ X Y) then 100 elseif (IGREATERP X 0) then (IQUOTIENT (ITIMES X 100) Y) else 0]) (FW-RE-INIT [LAMBDA NIL (* ; "Edited 22-Sep-87 13:05 by Koomen") (* * Called from FW-INIT, or from FW-LOOP because a prop has changed.) (DECLARE (GLOBALVARS FW-AccessTab FW-AccessWidth FW-CurPosTab FW-EofPosTab FW-FieldWidth FW-Font FW-OFDList FW-PercentHeight FW-PercentTab FW-PercentWidth FW-SeprWidth FW-WindowBottom FW-WindowHeight FW-WindowNoNameWidth WBorder)) (FW-INIT-PROPS) (SETQ FW-SeprWidth (STRINGWIDTH "AA" FW-Font)) (SETQ FW-AccessWidth (IMAX (STRINGWIDTH "b " FW-Font) (STRINGWIDTH "r " FW-Font) (STRINGWIDTH "w " FW-Font))) (SETQ FW-FieldWidth (STRINGWIDTH "99999999" FW-Font)) (SETQ FW-PercentWidth (ITIMES 2 FW-FieldWidth)) [SETQ FW-PercentHeight (IDIFFERENCE (FONTHEIGHT FW-Font) (ITIMES 2 (ADD1 (FONTPROP FW-Font 'DESCENT] (SETQ FW-CurPosTab FW-SeprWidth) (SETQ FW-EofPosTab (IPLUS FW-CurPosTab FW-FieldWidth FW-SeprWidth)) (SETQ FW-PercentTab (IPLUS FW-EofPosTab FW-FieldWidth FW-SeprWidth)) (SETQ FW-AccessTab (IPLUS FW-PercentTab FW-FieldWidth FW-PercentWidth FW-SeprWidth)) (SETQ FW-WindowNoNameWidth (WIDTHIFWINDOW (IPLUS FW-AccessTab FW-AccessWidth) WBorder)) (SETQ FW-WindowBottom 0) (SETQ FW-WindowHeight (HEIGHTIFWINDOW (FONTHEIGHT FW-Font) NIL WBorder)) (for OFD in FW-OFDList do (DSPFONT FW-Font (fetch (FW-OFD OFDSTREAM) of OFD)) (replace (FW-OFD NAMEWIDTH) of OFD with (STRINGWIDTH (fetch (FW-OFD FULLNAME) of OFD) FW-Font)) (FW-RESIZE-OFD OFD]) (FW-RECALL-CMD [LAMBDA (MANY?) (* Koomen "14-May-87 23:46") (DECLARE (GLOBALVARS FW-OFDList FW-Reset?)) (PROG (FORGOTTEN-OFDS RECALL-OFD) (SETQ FORGOTTEN-OFDS (for OFD in FW-OFDList when (EQ (fetch (FW-OFD OFDSTATUS ) of OFD) 'FORGOTTEN) collect OFD)) (if (NULL FORGOTTEN-OFDS) then (PROMPTPRINT "FileWatch: no forgotten files.") (RETURN)) RECALL-ANOTHER [SETQ RECALL-OFD (MENU (create MENU TITLE _ "Select file to recall: " CENTERFLG _ T ITEMS _ (for OFD in FORGOTTEN-OFDS collect (LIST (fetch (FW-OFD FULLNAME) of OFD) (KWOTE OFD] (if (NULL RECALL-OFD) then (RETURN)) (replace (FW-OFD OFDSTATUS) of RECALL-OFD with (if (OPENP (fetch (FW-OFD FULLNAME) of RECALL-OFD)) then (FW-UPDATE-OFD-WINDOW RECALL-OFD T) 'CURRENT else (PROMPTPRINT "FileWatch: file has been closed.") 'OLD)) (SETQ FW-Reset? T) (if (AND MANY? (SETQ FORGOTTEN-OFDS (REMOVE RECALL-OFD FORGOTTEN-OFDS))) then (GO RECALL-ANOTHER]) (FW-REPAINTFN [LAMBDA (W) (* Koomen "25-Sep-86 00:44") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList when (EQ W (fetch (FW-OFD OFDWINDOW) of OFD)) do (if (OPENP (fetch (FW-OFD OFDSTREAM) of OFD)) then (FW-UPDATE-OFD-WINDOW OFD T)) (RETURN]) (FW-RESET [LAMBDA NIL (* Koomen "29-Sep-86 23:20") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (CURRENT (replace (FW-OFD OFDSTATUS) of OFD with 'OLD)) ((OLD FORGOTTEN)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-RESIZE-OFD [LAMBDA (OFD MAXNAMEWIDTH) (* ; "Edited 22-Sep-87 12:56 by Koomen") (* * If MAXNAMEWIDTH=NIL, uses OFD's own NAMEWIDTH) (DECLARE (GLOBALVARS FW-AccessTab FW-Anchor FW-CurPosTab FW-EofPosTab FW-PercentHeight FW-PercentTab FW-PercentWidth FW-Position FW-WindowBottom FW-WindowHeight FW-WindowNoNameWidth)) (PROG [(NAMEWIDTH (OR MAXNAMEWIDTH (fetch (FW-OFD NAMEWIDTH) of OFD] (replace (FW-OFD WIDTH) of OFD with (IPLUS FW-WindowNoNameWidth NAMEWIDTH)) (replace (FW-OFD HEIGHT) of OFD with FW-WindowHeight) (replace (FW-OFD LEFT) of OFD with (SELECTQ FW-Anchor ((TOP-LEFT BOTTOM-LEFT) (fetch (POSITION XCOORD) of FW-Position)) ((TOP-RIGHT BOTTOM-RIGHT) (IDIFFERENCE (fetch (POSITION XCOORD) of FW-Position) (fetch (FW-OFD WIDTH) of OFD))) (ERROR "Unsupported anchor spec: " FW-Anchor))) (replace (FW-OFD BOTTOM) of OFD with FW-WindowBottom) (replace (FW-OFD CURPOSXOFFSET) of OFD with (IPLUS FW-CurPosTab NAMEWIDTH)) (replace (FW-OFD EOFPOSXOFFSET) of OFD with (IPLUS FW-EofPosTab NAMEWIDTH)) (replace (FW-OFD PCTPOSXOFFSET) of OFD with (IPLUS FW-PercentTab NAMEWIDTH)) (replace (FW-OFD ACCESSXOFFSET) of OFD with (IPLUS FW-AccessTab NAMEWIDTH)) (replace (FW-OFD PCTREGION) of OFD with (create REGION LEFT _ NIL BOTTOM _ NIL WIDTH _ FW-PercentWidth HEIGHT _ FW-PercentHeight)) (RETURN OFD]) (FW-SHAPEW [LAMBDA (OFD) (* Koomen "29-Sep-86 23:09") (SHAPEW (fetch (FW-OFD OFDWINDOW) of OFD) (create REGION LEFT _ (replace (FW-OFD OFDLEFT) of OFD with (fetch (FW-OFD LEFT) of OFD)) BOTTOM _ (replace (FW-OFD OFDBOTTOM) of OFD with (fetch (FW-OFD BOTTOM) of OFD)) WIDTH _ (replace (FW-OFD OFDWIDTH) of OFD with (fetch (FW-OFD WIDTH) of OFD)) HEIGHT _ (replace (FW-OFD OFDHEIGHT) of OFD with (fetch (FW-OFD HEIGHT) of OFD]) (FW-SORT-FN [LAMBDA (OFD1 OFD2) (* Koomen "24-Sep-86 23:24") (DECLARE (GLOBALVARS FW-Anchor FW-SortFn)) (SELECTQ FW-Anchor ((TOP-LEFT TOP-RIGHT) (* growing downwards *) (APPLY* FW-SortFn (fetch (FW-OFD FULLNAME) of OFD2) (fetch (FW-OFD FULLNAME) of OFD1))) ((BOTTOM-LEFT BOTTOM-RIGHT) (* growing upwards *) (APPLY* FW-SortFn (fetch (FW-OFD FULLNAME) of OFD1) (fetch (FW-OFD FULLNAME) of OFD2))) (ERROR "Unsupported anchor spec: " FW-Anchor]) (FW-UPDATE-OFD-WINDOW [LAMBDA (OFD NEW?) (* ; "Edited 22-Sep-87 12:43 by Koomen") (DECLARE (GLOBALVARS FW-PercentHeight FW-PercentWidth FW-Shade)) (PROG ((OFDSTREAM (fetch (FW-OFD OFDSTREAM) of OFD)) (FILESTREAM (fetch (FW-OFD FILESTREAM) of OFD)) (OLDCURPOS (fetch (FW-OFD CURPOS) of OFD)) (OLDEOFPOS (fetch (FW-OFD EOFPOS) of OFD)) (OLDPCTPOS (fetch (FW-OFD PCTPOS) of OFD)) (PCTREGION (fetch (FW-OFD PCTREGION) of OFD)) (BOXBORDER 1) NEWCURPOS NEWEOFPOS NEWPCTPOS X Y) (if (NOT (OPENP FILESTREAM)) then (* * May just have created some windows, in which case there may have been a  BLOCK underneath during which this file was closed, so make sure file is still  open) (RETURN)) (SETQ NEWCURPOS (GETFILEPTR FILESTREAM)) (SETQ NEWEOFPOS (if (NOT (fetch (FW-OFD WRITING?) of OFD)) then OLDEOFPOS elseif (NOT (fetch (FW-OFD RANDOM?) of OFD)) then NEWCURPOS else (GETEOFPTR FILESTREAM))) (if (AND (FIXP NEWCURPOS) (FIXP NEWEOFPOS)) then (if (ILESSP NEWEOFPOS NEWCURPOS) then (SETQ NEWEOFPOS NEWCURPOS)) elseif (FIXP NEWCURPOS) then (SETQ NEWEOFPOS NEWCURPOS) elseif (FIXP NEWEOFPOS) then (SETQ NEWCURPOS NEWEOFPOS) else (SETQ NEWCURPOS (SETQ NEWEOFPOS 0))) (SETQ NEWPCTPOS (FW-PERCENTAGE NEWCURPOS NEWEOFPOS)) (if NEW? then (DSPRESET OFDSTREAM) (printout OFDSTREAM (fetch (FW-OFD FULLNAME) of OFD)) (DSPXPOSITION (fetch (FW-OFD ACCESSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM (LET ((R (fetch (FW-OFD READING?) of OFD)) (W (fetch (FW-OFD WRITING?) of OFD))) (if (AND R W) then "b" elseif R then "r" elseif W then "w" else "*"))) (replace (FW-OFD OFDSTATUS) of OFD with 'CURRENT)) (if (OR NEW? (NOT (EQUAL NEWCURPOS OLDCURPOS))) then (DSPXPOSITION (fetch (FW-OFD CURPOSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM |.I8| NEWCURPOS) (replace (FW-OFD CURPOS) of OFD with NEWCURPOS)) (if (OR NEW? (NOT (EQUAL NEWEOFPOS OLDEOFPOS))) then (DSPXPOSITION (fetch (FW-OFD EOFPOSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM |.I8| NEWEOFPOS) (replace (FW-OFD EOFPOS) of OFD with NEWEOFPOS)) (if (OR NEW? (NOT (EQUAL NEWPCTPOS OLDPCTPOS))) then (DSPXPOSITION (fetch (FW-OFD PCTPOSXOFFSET) of OFD) OFDSTREAM) (printout OFDSTREAM |.I5| NEWPCTPOS) (printout OFDSTREAM " %% ") [SETQ X (OR (fetch (REGION LEFT) of PCTREGION) (replace (REGION LEFT) of PCTREGION with (IPLUS BOXBORDER (DSPXPOSITION NIL OFDSTREAM] [SETQ Y (OR (fetch (REGION BOTTOM) of PCTREGION) (replace (REGION BOTTOM) of PCTREGION with (ADD1 (DSPYPOSITION NIL OFDSTREAM] (if (OR NEW? (ILESSP NEWPCTPOS (OR OLDPCTPOS 100))) then (GRAYBOXAREA X Y FW-PercentWidth FW-PercentHeight BOXBORDER BLACKSHADE OFDSTREAM)) (replace (REGION WIDTH) of PCTREGION with (IQUOTIENT (ITIMES NEWPCTPOS FW-PercentWidth ) 100)) (DSPFILL PCTREGION FW-Shade NIL OFDSTREAM) (replace (FW-OFD PCTPOS) of OFD with NEWPCTPOS]) (FW-UPDATE-OFD-WINDOWS [LAMBDA NIL (* Koomen " 9-Oct-86 17:18") (DECLARE (GLOBALVARS FW-OFDList)) (for OFD in FW-OFDList do (SELECTQ (fetch (FW-OFD OFDSTATUS) of OFD) (NEW (FW-UPDATE-OFD-WINDOW OFD T)) (CURRENT (FW-UPDATE-OFD-WINDOW OFD)) ((OLD FORGOTTEN)) (SHOULDNT (CONS "Unexpected OFDSTATUS : " (fetch (FW-OFD OFDSTATUS) of OFD]) (FW-WIPE [LAMBDA NIL (* Koomen "15-May-87 01:49") (DECLARE (GLOBALVARS FW-AllFiles? FW-Anchor FW-CurPosTab FW-EofPosTab FW-FieldWidth FW-Filters FW-Font FW-FullNameWidth FW-Interval FW-Justified? FW-OFDList FW-OpenFiles FW-PercentHeight FW-PercentTab FW-PercentWidth FW-Position FW-ReInit? FW-Reset? FW-Running? FW-SeprWidth FW-Shade FW-SortFn FW-WindowBottom FW-WindowBottomDelta FW-WindowHeight FW-WindowNoNameWidth)) (* * Clean up possible left-overs, then set all private vars to NIL) (for OFD in FW-OFDList do (CLOSEW (fetch (FW-OFD OFDWINDOW) of OFD))) (SETQ FW-AllFiles?) (SETQ FW-Anchor) (SETQ FW-CurPosTab) (SETQ FW-EofPosTab) (SETQ FW-FieldWidth) (SETQ FW-Filters) (SETQ FW-Font) (SETQ FW-FullNameWidth) (SETQ FW-Interval) (SETQ FW-Justified?) (SETQ FW-OFDList) (SETQ FW-OpenFiles) (SETQ FW-PercentHeight) (SETQ FW-PercentWidth) (SETQ FW-PercentTab) (SETQ FW-Position) (SETQ FW-ReInit?) (SETQ FW-Reset?) (SETQ FW-Running?) (SETQ FW-SeprWidth) (SETQ FW-Shade) (SETQ FW-SortFn) (SETQ FW-WindowBottom) (SETQ FW-WindowBottomDelta) (SETQ FW-WindowHeight) (SETQ FW-WindowNoNameWidth]) ) (DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE [OR (HASDEF 'FDEV 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'FDEV] [OR (HASDEF 'STREAM 'RECORDS 'CURRENT) (EVAL (SYSRECLOOK1 'STREAM] ) (RPAQ? FW-OFDList NIL) (RPAQ? FW-OpenP-ScratchList (CONS)) (RPAQ? FW-Commands (COPY '(FORGET FORGET-MANY RECALL RECALL-MANY CLOSE CLOSE-MANY MOVE SET-ANCHOR SET-POSITION SET-JUSTIFICATION QUIT))) (RPAQ? FW-Properties (COPY `(FONT (GACHA 8) ALL-FILES? T POSITION ,(CREATEPOSITION SCREENWIDTH 0) ANCHOR BOTTOM-RIGHT SHADE ,GRAYSHADE INTERVAL 1000))) (FW-INIT-MENUS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FILEWATCHPROP) ) (PUTPROPS FILEWATCH COPYRIGHT ("Johannes A. G. M. Koomen" 1986 1987 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3178 5622 (FILEWATCH 3188 . 4757) (FILEWATCHPROP 4759 . 5620)) (8016 62486 ( FW-ADJUST-PLACEMENT 8026 . 10093) (FW-ADJUST-REGION 10095 . 12049) (FW-AFTERMOVEFN 12051 . 14076) ( FW-BUTTONEVENTFN 14078 . 14504) (FW-CHANGE-ANCHOR 14506 . 15460) (FW-CHANGE-JUSTIFICATION 15462 . 15959) (FW-CHANGE-POSITION 15961 . 18279) (FW-CLOSE-CMD 18281 . 21446) (FW-CLOSE-OLD-OFD-WINDOWS 21448 . 22228) (FW-CLOSEFN 22230 . 22914) (FW-CREATE-OFD 22916 . 23971) (FW-CREATE-OFD-LIST 23973 . 25490) (FW-CREATE-OFD-WINDOWS 25492 . 26775) (FW-CREATEW 26777 . 29749) (FW-FILTERED-FILE? 29751 . 30429) ( FW-FORGET-CMD 30431 . 32080) (FW-INIT 32082 . 32497) (FW-INIT-MENUS 32499 . 35781) (FW-INIT-PROPS 35783 . 39386) (FW-INTERACT 39388 . 40238) (FW-LOOP 40240 . 41363) (FW-MOVE-OFD-WINDOWS 41365 . 41810) (FW-MOVEW 41812 . 42240) (FW-OFD-EXISTS? 42242 . 43870) (FW-OPENP 43872 . 45128) (FW-PERCENTAGE 45130 . 45419) (FW-RE-INIT 45421 . 47543) (FW-RECALL-CMD 47545 . 49616) (FW-REPAINTFN 49618 . 50020) ( FW-RESET 50022 . 50758) (FW-RESIZE-OFD 50760 . 53318) (FW-SHAPEW 53320 . 54550) (FW-SORT-FN 54552 . 55240) (FW-UPDATE-OFD-WINDOW 55242 . 60335) (FW-UPDATE-OFD-WINDOWS 60337 . 61086) (FW-WIPE 61088 . 62484))))) STOP \ No newline at end of file diff --git a/lispusers/FILEWATCH.~2~ b/lispusers/FILEWATCH.~2~ deleted file mode 100644 index 2b3350c3235015797c7bb3acfa97acaceb907285..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 59273 zcmeHw{c;;QlIOK|LVs+8Utt5MiwTuFOsz;!wxqco56usm-4scaRLffL#0@RcHm4<0 zK~nAY-QGjpqumqi{W9^5LKTaWdTw@OI%ce56_7|IG82hJB9Szjt#-FrYPCDfQoGyg ziGLV0YmHIuO{Xcg+uc!f&}k3*+u|Skwfc{>)8OTs+OR3g`@7G#zDo#19hFDThS;u@ zOK0On>G(*Lt0#w*lS*Y(K> zj?nnot}c7GnEW!G-!H}Wcr`)s?aIDEsd92qJ*gaSi;WOE0PN?<_u_YA`+0qS_iZu# z{ADGQt6fn(K6?3r{(VLNqSGJ0i67=bb_Qf?d*XCYob8Dp=kwdiY)^>V&5hv7OR<=s z+rLb%_nvP9deR>>N2AMn@2o!n?S-KR-VEvcpkI6UPHa8%K5Tub$Rj=gK(8;(YCmFB zF`&)vPwhdkd)9Pe?dsAX>(<{M4Pke?^w<9M;Ry$dQt zJJu#3=+4A1BAG{Xo24`nFixTN?cL1;1Bh+|n*bUOkVqQMdZ#vMg4-Is?x^1DUy5YV ztoH^DX4GD*v1?&VmQLE;HW)XfOa_a~s#XGOjUUd3qf)<9t2gCfUzF6lLG!fT>ynt% zS`g;5-cQXI|9o>k8uhx(pTHaPMg489d)h43y7jlcfiSe>woqMtriR+BcD*)IVAcD6 zZ`d}kI=x}DR6lD_vvvN_>oiK}e(9p!ZS*dN5%5$@A;L<8igSJQs{~C1nE*)pO2ad6 zFVdjF+UR++!AkBm0ZK8!N>RhhV>-AIQA;Nk+1VDOs zL6E8E&G*25$j$fq&2FFG_nU({=uc`DzXqg%fl3NC*rV3zXo3!!{Th^mq}8A~Y%)@K zX#X=~K%jX(LBi}C8}3ztmlz3$L~r|_b}_4(~BbktJpB$9!I;-j-#_fp6~ zQh!SPidkPs0pJ(J5CQ|Hgsf2Kskjj?`r%99yK}Gm4!ZpX^zvdgg`WKr5XKacoYo+% z;wVLmIPr<+c<^2m{e(f{MIr^zycptlvwP8QjNS^^0&!@;Tcu{+^q_^#N`v<4+mQg* zHk#ta>7aHgAKCr@TfxNG-~Xclob-8ct-Lzp6>z6z%0|y)OQWC_pAIC?)EW)>(CyUD zY6bfebS?8|LO|1um|4EihlCLI=dVAqDRDlM+RL#PU{P&7i&+QwkeooPMhw4`nBjNA zhMyUbLWnwrU@?*{^?d6$%KUi#AKw0W&IX9vr|rP<0B4e^{SIc_)^Citwe{WK3-JMC z_@+@4P(Ei+6ph`jEsRLv|F*V3MrmD&?eZba+;63$S7N_>Qhh~s3R-}zu=PxtCp6fn zo!*;Thglt(ZE!!E!K`|{yDN)=aZX`O;tQVYq{6$6J$h^ohhnD%OYedd=4A0lE-w*H zhD|I0M(?2N)x(FaXVXvA8tjRr(;n3z>OyzXshQo;1V(+kd)ha(B!bx$1Q;APOq!2lBCya z3D({smlPTaH5j>N3AAb6@Ba>(+s#3T?4E#RG->8Hw?nlu%V^AL_!YSe5z+L3!DnNz z^=xvpoM5D5gy!*M4lrB{-ENo|>0#SiH+o+TYkjCXxc8ymF$TWxSUEUc1! zZCok+FrJY%u9Qy>%7wJCW4NKOgGqZfT^ZG^N1^%7&iRa=DBJE^;&-q*NZ2bt{3;Uk zBwa5`YnBlBRaj)LDM?f!P^ONQLa8UyNL4bB`n~{GQ8wYez$846ccx_jyG^$spNa;ozCO}XuupCqu#*)#Io zdFh(wu#d1Zt&J}GO^^!`fJGbx-7z-hl9JthqJ^oMS)2ZmOOQ^pH4<`RA>^C4Oq8;4AE*h8^1jJb0N7t7yd9R^@ZO8zG6TA%$**0Fi;pG4Mu zzmeIzkcJ5F{TcU>+5+ABJJ?Ib{*xPkV!L@gT}`gBNHKe))e|T+>|-u&e?GCBU24Nn zY}aq*OL&%PFYoJgc0K?gWY6@%T8gEu#gha+xm8Pn)pAuN#>QNyr6&$VadIO*j zQw!E#yNgFTN3(Z+>)FNICcR5w_K*#(S|L|WtBGx6`lRM`c3rDI;bO$dEVcEl*OE9n zp61Nb;fDxrYFncW6%nPW5Kj z%oq}%g!dsXVw8$v!-jpxd*Mc-w_b*ap+O6)M|m&Z^>X>xte0gUoRtl)vcDID$<_U0 zIsIjF^Gzh!DPEQ4i|ff^*X$aL$@uDvV$m03IS0p%SIoAbrVH#0P2`@g_uAp8NF>iE1zE?e#@7$DPUd%;roX1-d@Z%IVl-;K%5YOEH5 zfWeD%H8_TZb|uP-tn|pj8{HU?9P*e3t4dmipJEM<&nQ=O$^``#^J$kbu=zBB>o|*{ z=j1O2&?ppwl_XtkY+}(hz{ctBTG#1fg6M-QauRB_AXk1QJi0ABlEOlnfQ*?)aHlk3 z*}DzDK1o)jZ@j*Ao6CnP>81XSKum)x1`lM*!cZ=ApAN+cytq@s>ubP|atC`2Gk5@q z{^{WcFTstf)Ma|acfd{S2h@9@iM)M!kHvhG7EgrTK-R~%(PcK2mtaXYWT$qd$XN(vmM(NJ5hs+ zGpDTD?CJ}gi5Q9>?w70Sr|INc#>0TkDM|w$`YPBfRK;;c9~)F#^X-HK^e)~=lR%EO z-jno@Fk@hpkkjo#k4zgFBlFw4dzc2d@}tBPIQRW1<`Tq+4UT6ARlT&Haan-)nc?Qr`gEk zCev}Gx_Tug*>*dk3eCp{Aeq&$m6|x2v+6nTfvMd3XrFRW+Mq8CrijC|L-`oA4OdD! zxnON;=^Z}@&8)`)YA&nl1`067!r5SBUm^@)RP19YYumEC5Df_+1PVwTo6_zPM)<@%%(fz zr)Kyhk@ktiT|G?VGWGkP{!G38txuY%Qa{1)&fP6AC)@RM)n4-Ern96??wd-qi2G}>|3&b(5UW-pR zjK4Zx} z7t0&OkRv*L^abJN_#a-4uP|HADLS9m$pb{kFU8&X>Sx4sb3FI@HL&RkdZi~n8H}j5 z?wrU(%h`wua;adV1dJ{x1K$nV5Hw5EhTI0BT0<4>p>eQSH6pKbL|weX$vdCC+>L=hDb9vl&;{h5~4! zN`nd}@PT%>0enX*qX-6oB4txykjSl4_3I+9hC0)kku%y>wmDSdJ+l*Fd;j+m=g2og_XuS zMuT9k%BO+0oM=f+A>u=rPQ0b*#L|jnWNPs^eNONBvA`uUQeA)#~vl0LRb9{z$1b`0+t+a3+pnAi)7@L zoiM$_Cr>bC3V&_-vQ)cU@QitQQaLj7Bq$kQn|5l$(OC~C5+q)T|7W70yfp6l8?Be1 z{CnLFg8eC;#L;bb@Yw=%;?s?IX(}f2<{ce2Y7SbRQzf#aq7_H&5svamov|$! z1VFTC?e?gN({Zvk_UN}q*iq?BKCQOJj$TW+eKzRkKS($O^6@A@QYwpLWuYhAY7wH4 za@GkC!b?HZsJTlGkKwd>p}kCJh{^o4KMhkk+Cif339&xO2rgxlO);W@lagic7|~z3 zNE5EFp?W)f&Jj-$fmZ!#HeP!)-bkqB`ceE@dM6>7IOs{M6&7uYL@3!>J{5|r+2Iau zwFhTndvw2;1<>ZR*W2Dmnn^|ty9A`W8uDN6m|GGM|1hA`uxktA*B$X{fl1d{v$?9( z)92V=lxvvSi0iI+0(?t6R*|j@h%c?pdt5VElS3 zrg+n`$mW{Ow7&MiCDq!(g$h`YT833v1d3cK(O`lwY>eUgY3N`@>AZ`x%yL~7VVojp zM#~uUe&7=zyC)VUtyYMYDOLu(*6i+WC#f~EzblNwg@@DSHw7%%zkMV$Z~6X6Si!QD zpzV6TM~5?{7Y#nJE@G2bi}7rELzdPONdzX^YP&^Zg4ui}zKr3$`Uszu_{i}Tr5mzN zOc+Kmy2d8s!Fj~$%v*{n7lS(4I)&+T0Y|HJaLW%DI-K0FDY)cYCdAe>PD0y;}~!{ ztA=N~B^TIc>|Va!Y@;FAVyINyEr$JIi-CC%Vi)(FSTjyrZtk)M-fbd_MA3@AOMx7# zEXDoWbka>^#xyD40Qk;$&r`r088KcO=be0XF?F0l+Qg^O59C6T@vyXq5{>q7LQ(Uu zNHw1I!s%6txzcrP7dQm8#p|cgzI9M^iM9s3I#Ou`!pb>pdIShksuPu&X{cg#OQW7l z3S-&9;4IBOuM!xKSd3DpY<(9)2L%~(<6br);NMl8r z$7BjAxhv@bFdRsZ99DH|fL-#i)52lowVglhsnjuwi^7=zlM8Kn>Xb^}tnd_GSy3+a zu2!X^m!fiTve|-OjTq>Xque2fdiU|^!<5KxfVe!GGB?>^%@`DawA~0~P5~t21Pj&u zD~cI(I%VgRfXP}oYXR+L4wyVBp26Ro5f#l=`}-&5V);q*-abtP$k;@JxuiY(0kY?% zkH&L+E>wHwj=iss-JO0rhIW!z$Hb1`XcJcRk-%VRad=1+vpw{Y0t?7yj&g=P{>b{T zMMn~FB0&Z-l2N1RpN?MKdWO7>DstYAjJNke?Xw|m#!HMGE;Fgzd`2_Jx*fY@ZOp3H z-uf_;wQ3Je_N$v(wXOMVWfd7=Z&Ivbn+&?mY{3v)wi+?YD=OPgV3cX!)xOB9rH{6& zI_hUm4I6qWtEluj@`$@7DbA2l-*Nz{)9eb0Hn8ZdxjdPU>~*wdFHcwH!11`uiWD4L z)WT@6IT&kT0tg|&NlPs@VyDyWo{rwej0S^^IYu9JkgZGyC$ZD+B1c0Wr3_5@VEUL_ z$(-I_+kOvOynY1)RMr5+jmCa?c59FQ)g-#pM9&ZLZnEB`_)W9;M?0uldu&dXTT9Me~e zzVs&0TFzl1E8&JHM%x+t2BRVQjk2z~wY@}RDkW=Fb;w9? zI$>2CXyIiShF?b0E=SCuG?cOfnPflZIVsG>XZUEfS5(MyJbGFiv9`3pT}5;ODGp^t z4jbM|J4SEBV&%}MvI@nW#?Vg-2e28(45=d~P#+M`DRr>aG~&uh0?3?~74&3U$4f~( zLaaE}MTV;(yRXMzUT~eK9n@BH2+OPRNLVJ6%!gxM7r_UHHsvq&`UM@+DNanFj24H}*AvvMqb_w1%AzjTA= zqHLO$Bg>{Lu`e%U&FV&OvKg&sRcG-h+Mq)#wDQT49^S)yR3jE0tJ9whpps)?AI|?z ziMZ~9?SRL!`g8HWa$9Z<>DAud6VZws8G6s<2|;ELz*D2IscXCO$U%_H?|k-`0US?7 zFN^xqLChY2r^Wrr$*+zA<u!U?4VMU*0IV8rM2;4P8&QiFguQ?ygEoH}s z;}i$pOr{t<x`wHtVK$cYvo4 z)qO#78%|*Jbt2=H=+qsxBc|Ben;_Lc!keydzWGPzj2D9PrCASz>LlL4VY8S_*=ay4 zo+Q9XCV`Pd_7Daz1L}~_8M^pm1PNrAc{mcBFO+)zVwF4BQ@l_THXP~EHf4Q-xBmXE5U z85j;fa0!)xjCC7eEO4SE8h(JRR(!k!S_Zc&JtP7_jcR5Hf^w3Xv45iIgIM4Jb%MeU zz%`#Is|Um#xFH8I?sKXB2&Tf8ju~y0AUH z#bb1QuFcf|RNnIJx{!>5TcA#h5kea5!hi~QplMr^FVwNHbY3vlYkHN={dNDbok56& zFD7=mPM6Dg)4-GLJ(%P8(X;%_y6Ai6-h(+&3I~JE*`I5ud@t%Z6I|PdOm>KMTuwhi z5Gl5~gyZ^)rTDZ!?zl0TFML%V($W1qg}OtQ07xuf@qur1$mHr&iM zzM1|{d4&J#d~tJaqNdRiph~=TaTCl z{6>QAEh$Ii_(tAz`1F0q(pSkg@=76Bq^7;PXbi}W7b{DA+}VgB!tn+01y8u+&$xmy z7fpANR2$A9i5+$C97VJh-IbCA3~@7*^DxBqkc?t>$G3Uyh!Y&8`CWz$l*ml9nmBCu zs_e9uA4P&JCJUVKK$6bMf8BN1^T~Jx9oMKhG<-_%Vuw5T#5_&|rbuW;iEK_BQjAQ@ z+{;3vaz+VZ8uIc_C=8ycx9fa=D{Cu#FX((R)mLf?%CM8K99)haPF6x5MFxD#7$tS& zb-O-a%rM%1&Q`KNKk9=&lj~f$Aewmp#VO$x!RQl0eU-mXp=5&ji!;Ku20I-+}WCQxBQGW1&e#0e%zq*1% zdPsMYQd#Wb=H((xZ@}<_%n~7?*(3uy>AXXJwe&A{y~oc!JJ_*BFbjF88c0-}v}(g4 zE~~TQoEb)!4~rT%!|kwv^JrXt@a2*2T1;LL+vAYH^8OD#A0N7sH-Qq=w!nP zG+ZA}4nzb| zZYIvkVk8g2u`4X&0#UcS(`ybt%pkoiIn1X0mI<8GUTX?SM3@cV<++g~AH$ElOSm^w)yi(v2)0q@ zinBNb(%snrsLo!$hD#FYHbDODji-SWc~E{q&iEYeQ|y7Z*uLTDOMq>fEeD4|A|N+@ zB~gB2pu8DUfV!JtyZybN>!fJi48rQ6T8pLK?uZ{K-rs0B>z)i$!pvC%#=J>K2Jb>F zzukVE-@vtvK%nZabq*qVb*ys|u;tLIDf|+!M^}^#N zXV_m~-peF_yxnpX6L|qAr!O&)LmCMYOlOVJDMOK!?{zWeB6~BzZxXgf|;xwp9xA#!uS*eIw4(!|x8p$ov z_9@PVzZZn8i%v@W1QUg-ky*vU?*RU#px$K`rp5yJs)pM+D#ab(a84R!)dOmQ@LAJB z*o3N*jg{X*fj)#SWOc%^jht>29Edcn){OW~h-cRv`r+bZ1$DN3cqfC|NT7D>+JsY;VG)XYS3v5^eVuu{lY{Rk0m zG=u3wp25M~g$q@2eLbRpGiEUg!EbeCZIC|wpJ6TziZM25zPu|il&=XA;uC|Z~oBRWpl+ripDSigfs$jq>CQTtJ}`qP_k zij9nFrrBB{NM~h`*3A5(2de6Va``h+5n@(l@tp*8ZM8hW2RkXCYGZ>VeH@Wcg2$9ymLRb9 zb!Qb9dU@=Sm8u!jA-ke361JGSnl!HUbu2>%N+@ z;e%V3s+oX=Xg^GC*=HPHv5^esTkxQfGBRMggqtn=NY0SpkfXD`(e+I+kX zDA@t0wmd5W59m4ocEQa`TdKWOf|4~oF~m?DA1^MEJn!R*^QNEw#49hez7S(+!6MH8 zgzMOG>!Ohf8J%LaL|XBBv+rk7iSw*D;ap2PD~T^nIY*nN6Ijd`p}*PYVah;k1Z z;BBpY+EkN-kw3$9?q15SJ8;a|?rN zF$U37SzZc5R3a@c@1#Tx<2WGQhi_qFkMT*{N1IURWB^$o&&h2hUEIFx+{<1@Hc-z)MEAq#~qv&j!xi%?$o&pqYo3#n12u?JJ# zlj~SXen$cyL&DP58O%-4umB!~h)$#NKx&|CO6O5>H-}|5PrE_nGCIS(m?4w4^dW=3 zIy=YHcWdKp9)zXaFEhy6PSeh@2%A6<)?e`_69Z&ujC6HRWANZvF)PMO)T8)+rk|7# zCx~;+*1qMF1HJ*i z@NHuVWT4wG<*o2~^Ix50KvaMe29W6cuW_P@vl1?MaaIa9kx?M)=bQP*@y#z|zA4mh zEhDycHlLNSZZnk-R)mY@=^8VE%UcFNwTJCDo#sE0OM#AMA=UHEJzaW+^Hg6aH#hQV zl;r@2$s`qi=R`SgZ6WS(g)E8UoNhqFX3rH)SY3Uge(^ahih;UED~QOtn%{jx!mQ=} z%}Pu^iEs0J+~|RJ5ver3S|IRRPyi=KPSF%jBWFWIAiD7oVidK#r+NsZ=$D2P4W8rv zg{Ij?^QSgao#|N)4tY9CMvgDCep8j4PV?l#Qz9E2oa)2{3BJ=A8wllA*R2aOS|vo+ zhsh%TgazE>2ct{l`AW=GfEiB%+WD8$X16(L*Z25MRDvDtNE(p)LMvaHwZ*lZG$ur` z4(_PeG8H}aWLbn7(8rnNI@Jz|t8-Nf35N?!3wmT+px(14W3AB`_1xjhsA;sD>2izj zrPJNU0g2eY`u3yhfYT0kEFtC{NsY|Po|%^ zc?mlf>RWUE$^K~3Ma!lfZ-zVg+fI>Mw5x>v1nCZED|IU>zNr_g1@+5-#a)~W`6COq zdkZNcEPq@0@^^RMMPRIiEoXk~NKg#G>FO_}i}4_;yn2xS0*e84qYK z4U;zSz{+qOnVewzBYdVP##N*JveeUoJgVm6!8N}+HA8%zq4fKBtp2m;2E_5kOUqw{ zJ7?HKwPtpld=~Kbw>g?ZZA}*?5NKr^PM~Ycv|G`|Nl%D|0wQ)A%^~T(U<=FRZZpt9 zA1&A0+wQ%J4*AfY1rxw=INbuWzzJ1DGeSHQkYq2C7z@V%o&w|zQXb&6tRRO`0~fHi zRC*@cp2YzG9e$U6cKA2rF%UxD#sVZynw7dYlIV$cBH6^EMq|D)>(F!^prS1sC@pQ< z05Pq?wD}NblXA@yS=^@EGR6sjC}GH;3h{Dmd1z9Nx}eBdQeG=ZyR6eE*)98DA|2Y$ zq2j~K_+|ZLML8z}kbMpEJ4)HU51*vw_wvkQfLwEcHZe=73^>3Pa@44`8NJO;3h$OjLgv;f(Rl2^fA27hx@rI+&%7|ko-NG9O-}qj{6vd98e!7> zq#4NLF^2^UjlLW$JL)P9*j-|>N;cU=!l5qQidXPSl~Ft+fX}a%FTxI3UXA1c0FdaW zLm-D1x-(U1dEsTg??3o8NDBHYs# zGYPexkU$xauiF32Auhh86HCH@V;5j+H`vklz(4A^|0*YkFE?=iVUNaboc3B?2xM1S z(&BOlN7HZ=+(Av}6UpIPf8EZPpp&n`^JjQI3Ex{2okvjLcRz#<2NUy*lHLm6{8s+D zEbuAEgjRvP_W6()8t`#2mt-*u$CP$gEN*ym)V`95Hy!4&LS)?{DMX#&aU~|&g7jXv zNZBR=O09(zMy*&#m~V5Bc;v{l`IOjmAkI+)eN@>LEBZh)nNIYt1DuK;*D2VB#8{p& za1R_j9OrhU-D=^shi<*;FiY~?CX{)IK z^rSf$VE1nOe73y5yTe5tv?nYz4doo6fMK*J&ma2@M5Q7f8fAIeNW~kzN!X=G6c%Pm z49|O+G$Af%R+g}uzxzY#dvaV#RA|>Uwk^;j6C{Td3PSA^t^G*`}9cQH^^2 z5*sSJ>zIh~q=ZnE2zaWwU_2?v%Lcr(m~6W7+>-xRVW#; z+GTfoPZB9S=_DXI{q%ZxfA{45D?h4#6|a9Am_3$jBhE|6i1uwHU|qVJe6#JQyya*0 zAXt8~L_%OQ_np*?XCo@yDUkQ6DP4`XAcL=fHigI~lrgEukM88}Ya&h}o(;hXcz2jJ z00Bp%wD)2-$S*kvptib~F`~`nm;Bn&PK&iIzvR?5)=@_7wCNOd{Y~%vo8F*-Ec8Bu zgOwCX@T9tjCxt4-f;kEr{Z?CRl+;b`7dV7>i;|);{yhhT^TIcwbvIt=+!r!#>=bI7%SHC}SATf}|dq8?XaxAxcx9i^tX-gJ8P9|iKi zPLPdojL@a)`voaQ3CE;LMFLO6M$vuT*Bn)PJN{Y4m9pC$L9fdda`J}IDVEkmQUyvm z+zF)5(xq*QO=pyea={&(E(J{$%XAL$)5@v7D&f>BrjaOdWcn49Q4$>%G88kA=`_c% zPfFR!k5VRC-LOD7%q3RUZ`UP!ekTfm_OOaUR$ceXIpS4vABON3>|{U`M;vX0R@Z13y`sCye@jj z+v9386!7nnw0Wn-t(Y3i%e9Z?(3rlhl?y5I5hql%i)!FEmJ9K3d+notvnnPEJW4-_ zpF8te;u%tGL_MV-&E)(T>Pc9CIqJnH5gwH&^;CI~OfNM(>Z#A}XsqKsHGhD5^64?u zlMwzA)H`I}Qy9loPehl)f&Sayig-q98E=NPVRY==(dTl>;2&m2t7;_?YuKn#JorPH z3(F3p@}!%!$ht<{28%rV8iXQwpSlHwg;6T*9-+ZdQXEO+;uH@YjE|&w7Bq+IG6Eh} z$EC44enr|?b1F)lw9s1nSu#D-%?Pc`YUhf*p))<$+2eFjy98&|V4&c<&n5XGLcfIX zxG-!e-gIj9A332_A%-!d@9A=bR#Y^6KdTvYXO!CS&U>RaP9&Ja3z#z$MV^|C1KMO# z*Yv5#17{A5VagXRBj>BI-6ppq=QJipwDgSDj+rWwE}2uU{G8)cdy1^me!!48F7>Wf z6unh`by7aETPZn?G<1BE=&fHdUL>W(7}WIEM7w)U;)a|pW&iX z9EpcJ6F!Y!a9^pwDSti|59TxOOz469C{n41ILTCWRgdwDY!NHurSk{9HGC&$AN!sI zLxPuv8-w?TF@yJ(M^hi<^|DMo)22OlXD3y7pX$hY2!m80A1Lo^@RwxR zJI7&p(LzQ}M zlHH)7zMTZ$cT~cJ5zD$I$WJ!v1AG-_a&#cgcDX}Boi9(m>!~cRMadL=!cj2 zOHlgA5KVhu1rYrcAGd{jzJ@Dl#E~IXR(rzUNx?UcnYLdfG8>+G;ikLZF95e&e~U$! z+Gduqe$vi=LCXdCs8g!bN&~KF$^>f;fKwhz%D)$~kL8+1&*K}zTZ)keKh*|9;wDb{ zfFEFuZl`uu1DU9);B_bcS`{X4j)0!BO5z2A1<^A&UA+>9YC`SZ+c=a3r%a#4(sw&Y!&IpnO z|cyPddN655H z`{xS_zE_D1<-?}&vfq+{^ zyN%w(kiQZ?RI1goMuAIR(5nie@VxS}QdR^5<6=yjjS_M2Yk@BnB30$((UC$!aS0KE z-ZBP9)q?|x0p(~A75qM=TKG(GiMcp=1IsSGenmhJD*I(Mk~XyizolV3IDDnMr87YD zJL=5A%fnZyCMVaR-^Vl}2d`f0p$`*R(l;LVgQNXdiV`wyAzmC29S$(&FJ(6{Pv~@h z{Q8JKA0OcgFo9VJ^9ZH(p*Jt7Vzs>gO7Vf+6XUlu_|>vuSe3klUr`?+qzC)5MRmA| z$VzW3)SK#I^+@rCIpf4Hi8ZQ+M@Ne2a?gxj5Y?+MtIh{?V1nQB*Q1xO2quk*3Ms7O z6+=9(9xI3{PD@nrifSG1lgeNQPOV1yBlYI+u*{-Mpi`xW{F&%+h_O<6epq2LL$NdWJA}|@>z3iFilrCUGqW)MP8MU+f9+Lp?m@veg*vY z^>SO45BaM09`kjPznDG4D>l3BewSA}uUOvYMem!Tf+U-|7UV0<8GvEAhT-bSST}^l zmo;pVZ`=|9GC)R{57E9TfWPd@eGTS7qpP~H)9dwQSTAcdft;tZVY+?G9ayp|DSroX zv?#yRYzuV99a?VRM&py&>tzyMd8orf=B43WcnKMW33>&`zJP6&KX1zYu2phT35MDY zNj19s4Ch+enC;;UA@sqI~d_)^WPue8#(Ngg9GLNtY8bLB4ac=MhBl}3l?8p g3p^|HyefZ!Usl_)TGpHLNe07d_K#y*n4wv^-`tMEDLEY>LAFITETIMEDDELETE.;3 9944 changes to%: (VARS LAFITETIMEDDELETECOMS) previous date%: "21-Sep-88 16:47:01" {ERINYES}MEDLEY>LAFITETIMEDDELETE.;2) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LAFITETIMEDDELETECOMS) (RPAQQ LAFITETIMEDDELETECOMS ((DECLARE%: DONTCOPY EVAL@COMPILE (FILES LAFITEDECLS)) (FILES LAFITEFIND) (FNS \LAFITE.TIMEDDELETE \LAFITE.SETEXPIRATIONS \LAFITE.DELETEEXPIRED) (FNS LTD.INIT MESSAGEAGE) (INITVARS EXPIRATIONMENU) (VARS EXPIRATIONMENUITEMS MARKDURATIONS) (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) (P (LTD.INIT)))) (DECLARE%: DONTCOPY EVAL@COMPILE (FILESLOAD LAFITEDECLS) ) (FILESLOAD LAFITEFIND) (DEFINEQ (\LAFITE.TIMEDDELETE [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* jtm%: "30-Sep-87 14:25") (COND ((EQ KEY 'MIDDLE) (\LAFITE.SETEXPIRATIONS WINDOW MAILFOLDER ITEM MENU)) (T (\LAFITE.DELETE WINDOW MAILFOLDER ITEM MENU]) (\LAFITE.SETEXPIRATIONS [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 21-Sep-88 16:36 by jtm:") (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) [LET (EXPIRATION DURATION MSGDURATION MSGEXPIRATION TODAY YEAR ONEDAY MESSAGEAGE (N 0) (NODATE 0)) (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) (COND [[SETQ EXPIRATION (MENU (OR EXPIRATIONMENU (SETQ EXPIRATIONMENU (create MENU MENUFONT _ LAFITEMENUFONT TITLE _ "Expiration date" CENTERFLG _ T ITEMS _ EXPIRATIONMENUITEMS] (SETQ DURATION (CADR (FASSOC EXPIRATION MARKDURATIONS))) [AND DURATION (add DURATION (IMINUS (IQUOTIENT DURATION 10] (* this is so yesterday's messages won't be marked as 4 months when you ask for  2.0) [COND ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"))) (SETQ TODAY (IPLUS (IDATE (DATE)) (IQUOTIENT ONEDAY 2))) (* treat "now" as being after noon  for the purposes of counting days.) (SETQ YEAR (SUBSTRING (DATE) 8 9)) (for MSG selectedin MAILFOLDER when (OR (EQ EXPIRATION 0) (NOT (fetch (LAFITEMSG DELETED?) of MSG))) do (COND ((EQ EXPIRATION T) (DELETEMESSAGE MSG MAILFOLDER)) ((EQ EXPIRATION 0) (* equivalent to undelete.) (UNDELETEMESSAGE MSG MAILFOLDER) (MARKMESSAGE MSG MAILFOLDER 32)) ((SETQ MESSAGEAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) (SETQ MSGDURATION (IPLUS DURATION MESSAGEAGE)) (SETQ MSGEXPIRATION (OR [CAR (for ITEM in MARKDURATIONS thereis (ILEQ MSGDURATION (CADR ITEM] 9)) (MARKMESSAGE MSG MAILFOLDER (IPLUS 48 MSGEXPIRATION))) (T (* the message didn't have a date.  Flag the message with a ?) (add NODATE 1) (MARKMESSAGE MSG MAILFOLDER 63))) (add N 1] (COND ((EQ NODATE 0) (LAB.PROMPTPRINT MAILFOLDER T "Marked " N " " (COND ((EQ N 1) "message") (T "messages")) " to expire after " [CAR (for I in EXPIRATIONMENUITEMS thereis (EQ EXPIRATION (CADR I] ".")) (T (LAB.PROMPTPRINT MAILFOLDER T "Error: " NODATE " " (COND ((EQ NODATE 1) "message") (T "messages")) " had a bad date."] (T (LAB.PROMPTPRINT MAILFOLDER T "No expiration date selected."])]) (\LAFITE.DELETEEXPIRED [LAMBDA (MAILFOLDER) (* ; "Edited 21-Sep-88 16:39 by jtm:") (LET (MESSAGES LASTMSG# YEAR TODAY ONEDAY (N 0)) (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) (SETQ TODAY (IDATE (DATE))) (SETQ YEAR (SUBSTRING (DATE) 8 9)) (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"))) [for I MSG MARK MSGAGE DURATION from 1 to LASTMSG# do (SETQ MSG (NTHMESSAGE MESSAGES I)) (SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG)) (COND ((AND (IGREATERP MARK 48) (ILESSP MARK 58) (NOT (fetch (LAFITEMSG DELETED?) of MSG))) (SETQ MSGAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) (SETQ DURATION (CADR (FASSOC (IDIFFERENCE MARK 48) MARKDURATIONS))) (COND ((AND DURATION (IGEQ MSGAGE DURATION)) (DELETEMESSAGE MSG MAILFOLDER) (add N 1] (LAB.PROMPTPRINT MAILFOLDER T N " expired " (COND ((EQ N 1) "message") (T "messages")) " deleted."]) ) (DEFINEQ (LTD.INIT [LAMBDA NIL (* jtm%: "30-Sep-87 16:44") (LET (DELETEMENUITEM) (COND ((SETQ DELETEMENUITEM (SASSOC "Delete" LAFITEBROWSERMENUITEMS)) (RPLACA (CDR DELETEMENUITEM) ''\LAFITE.TIMEDDELETE) (COND ((NOT (SASSOC "Delete Expired Msgs" LAFITEEXTRAMENUITEMS)) (push LAFITEEXTRAMENUITEMS '("Delete Expired Msgs" (FUNCTION \LAFITE.DELETEEXPIRED) "Mark as deleted all of the messages that have passed their expiration dates." )) (SETQ LAFITEEXTRAMENU NIL) (SETQ LAFITEEXTRAMENUFLG T]) (MESSAGEAGE [LAMBDA (MSG TODAY YEAR ONEDAY) (* ; "Edited 21-Sep-88 16:25 by jtm:") (LET (MSGDATE MSGTIME) (SETQ MSGDATE (fetch (LAFITEMSG DATE) of MSG)) [OR TODAY (SETQ TODAY (IDATE (DATE] (OR YEAR (SETQ YEAR (SUBSTRING (DATE) 8 9))) [OR ONEDAY (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") (IDATE "1-Jan-80 12:00"] (COND ((SETQ MSGTIME (IDATE (CONCAT MSGDATE " " YEAR " 12:00"))) [COND ((IGREATERP (IDIFFERENCE MSGTIME TODAY) ONEDAY) (* a message from last year.) (SETQ MSGTIME (IDATE (CONCAT MSGDATE " " (SUB1 (MKATOM YEAR)) " 12:00"] (QUOTIENT (IDIFFERENCE TODAY MSGTIME) ONEDAY]) ) (RPAQ? EXPIRATIONMENU NIL) (RPAQQ EXPIRATIONMENUITEMS (("now" T) ("one day" 1) ("two days" 2) ("four days" 3) ("one week" 4) ("two weeks" 5) ("one month" 6) ("two months" 7) ("four months" 8) ("eight months" 9) ("forever" 0))) (RPAQQ MARKDURATIONS ((1 1) (2 2) (3 4) (4 7) (5 14) (6 30) (7 61) (8 122) (9 244))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) ) (LTD.INIT) (PUTPROPS LAFITETIMEDDELETE COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (920 7257 (\LAFITE.TIMEDDELETE 930 . 1204) (\LAFITE.SETEXPIRATIONS 1206 . 5586) ( \LAFITE.DELETEEXPIRED 5588 . 7255)) (7258 9112 (LTD.INIT 7268 . 8157) (MESSAGEAGE 8159 . 9110))))) STOP \ No newline at end of file diff --git a/lispusers/LAFITETIMEDDELETE.~2~ b/lispusers/LAFITETIMEDDELETE.~2~ deleted file mode 100644 index 7b557f7c..00000000 --- a/lispusers/LAFITETIMEDDELETE.~2~ +++ /dev/null @@ -1,228 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "28-Jun-89 08:53:23" {POOH/N}MAXWELL>LISP>LAFITETIMEDDELETE;1 11153 - - changes to%: (FNS \LAFITE.DELETEEXPIRED MESSAGEAGE) - - previous date%: "13-Oct-88 11:05:53" {PHYLUM}MEDLEY>LAFITETIMEDDELETE.;1) - - -(* " -Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LAFITETIMEDDELETECOMS) - -(RPAQQ LAFITETIMEDDELETECOMS - ((DECLARE%: DONTCOPY EVAL@COMPILE (FILES LAFITEDECLS)) - (FILES LAFITEFIND) - (FNS \LAFITE.TIMEDDELETE \LAFITE.SETEXPIRATIONS \LAFITE.DELETEEXPIRED) - (FNS LTD.INIT MESSAGEAGE) - (INITVARS EXPIRATIONMENU) - (VARS EXPIRATIONMENUITEMS MARKDURATIONS) - (GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) - (P (LTD.INIT)))) -(DECLARE%: DONTCOPY EVAL@COMPILE - -(FILESLOAD LAFITEDECLS) -) - -(FILESLOAD LAFITEFIND) -(DEFINEQ - -(\LAFITE.TIMEDDELETE - [LAMBDA (WINDOW MAILFOLDER ITEM MENU KEY) (* jtm%: "30-Sep-87 14:25") - (COND - ((EQ KEY 'MIDDLE) - (\LAFITE.SETEXPIRATIONS WINDOW MAILFOLDER ITEM MENU)) - (T (\LAFITE.DELETE WINDOW MAILFOLDER ITEM MENU]) - -(\LAFITE.SETEXPIRATIONS - [LAMBDA (WINDOW MAILFOLDER ITEM MENU) (* ; "Edited 21-Sep-88 16:36 by jtm:") - (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of MAILFOLDER) - [LET (EXPIRATION DURATION MSGDURATION MSGEXPIRATION TODAY YEAR ONEDAY MESSAGEAGE (N 0) - (NODATE 0)) - (\LAFITE.MAYBE.CLEAR.PROMPT MAILFOLDER) - (COND - [[SETQ EXPIRATION - (MENU (OR EXPIRATIONMENU - (SETQ EXPIRATIONMENU - (create MENU - MENUFONT _ LAFITEMENUFONT - TITLE _ "Expiration date" - CENTERFLG _ T - ITEMS _ EXPIRATIONMENUITEMS] - (SETQ DURATION (CADR (FASSOC EXPIRATION MARKDURATIONS))) - [AND DURATION (add DURATION (IMINUS (IQUOTIENT DURATION 10] - - (* this is so yesterday's messages won't be marked as 4 months when you ask for - 2.0) - - [COND - ((NOT (LAB.ASSURE.SELECTIONS MAILFOLDER)) - (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") - (IDATE "1-Jan-80 12:00"))) - (SETQ TODAY (IPLUS (IDATE (DATE)) - (IQUOTIENT ONEDAY 2))) - (* treat "now" as being after noon - for the purposes of counting days.) - (SETQ YEAR (SUBSTRING (DATE) - 8 9)) - (for MSG selectedin MAILFOLDER - when (OR (EQ EXPIRATION 0) - (NOT (fetch (LAFITEMSG DELETED?) of MSG))) - do (COND - ((EQ EXPIRATION T) - (DELETEMESSAGE MSG MAILFOLDER)) - ((EQ EXPIRATION 0) (* equivalent to undelete.) - (UNDELETEMESSAGE MSG MAILFOLDER) - (MARKMESSAGE MSG MAILFOLDER 32)) - ((SETQ MESSAGEAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) - (SETQ MSGDURATION (IPLUS DURATION MESSAGEAGE)) - (SETQ MSGEXPIRATION (OR [CAR (for ITEM in MARKDURATIONS - thereis (ILEQ MSGDURATION - (CADR ITEM] - 9)) - (MARKMESSAGE MSG MAILFOLDER (IPLUS 48 MSGEXPIRATION))) - (T (* the message didn't have a date. - Flag the message with a ?) - (add NODATE 1) - (MARKMESSAGE MSG MAILFOLDER 63))) - (add N 1] - (COND - ((EQ NODATE 0) - (LAB.PROMPTPRINT MAILFOLDER T "Marked " N " " (COND - ((EQ N 1) - "message") - (T "messages")) - " to expire after " - [CAR (for I in EXPIRATIONMENUITEMS - thereis (EQ EXPIRATION (CADR I] - ".")) - (T (LAB.PROMPTPRINT MAILFOLDER T "Error: " NODATE " " (COND - ((EQ NODATE 1) - "message") - (T "messages")) - " had a bad date."] - (T (LAB.PROMPTPRINT MAILFOLDER T "No expiration date selected."])]) - -(\LAFITE.DELETEEXPIRED - [LAMBDA (MAILFOLDER) (* ; "Edited 22-Jun-89 09:39 by jtm:") - (* ; "Edited 22-Jun-89 09:39 by jtm:") - (* ; "Edited 22-Jun-89 09:37 by jtm:") - (* ; "Edited 22-Jun-89 09:36 by jtm:") - (* ; "Edited 22-Jun-89 09:22 by jtm:") - (* ; "Edited 21-Sep-88 16:39 by jtm:") - (LET (MESSAGES LASTMSG# YEAR TODAY ONEDAY MISSING (N 0)) - (SETQ MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of MAILFOLDER)) - (SETQ LASTMSG# (fetch (MAILFOLDER %#OFMESSAGES) of MAILFOLDER)) - (SETQ TODAY (IDATE (DATE))) - (SETQ YEAR (SUBSTRING (DATE) - 8 9)) - (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") - (IDATE "1-Jan-80 12:00"))) - [for I MSG MARK MSGAGE DURATION from 1 to LASTMSG# - do (SETQ MSG (NTHMESSAGE MESSAGES I)) - (SETQ MARK (fetch (LAFITEMSG MARKCHAR) of MSG)) - (COND - ((AND (IGREATERP MARK 48) - (ILESSP MARK 58) - (NOT (fetch (LAFITEMSG DELETED?) of MSG))) - (SETQ MSGAGE (MESSAGEAGE MSG TODAY YEAR ONEDAY)) - (SETQ DURATION (CADR (FASSOC (IDIFFERENCE MARK 48) - MARKDURATIONS))) - (COND - ((NULL MSGAGE) - (push MISSING I)) - ((AND DURATION (IGEQ MSGAGE DURATION)) - (DELETEMESSAGE MSG MAILFOLDER) - (add N 1] - (COND - (MISSING (SETQ MISSING (DREVERSE MISSING)) - (LAB.PROMPTPRINT MAILFOLDER T "The dates for " MISSING " cannot be parsed.")) - (T (LAB.PROMPTPRINT MAILFOLDER T N " expired " (COND - ((EQ N 1) - "message") - (T "messages")) - " deleted."]) -) -(DEFINEQ - -(LTD.INIT - [LAMBDA NIL (* jtm%: "30-Sep-87 16:44") - (LET (DELETEMENUITEM) - (COND - ((SETQ DELETEMENUITEM (SASSOC "Delete" LAFITEBROWSERMENUITEMS)) - (RPLACA (CDR DELETEMENUITEM) - ''\LAFITE.TIMEDDELETE) - (COND - ((NOT (SASSOC "Delete Expired Msgs" LAFITEEXTRAMENUITEMS)) - (push LAFITEEXTRAMENUITEMS '("Delete Expired Msgs" (FUNCTION - \LAFITE.DELETEEXPIRED) - - "Mark as deleted all of the messages that have passed their expiration dates." - )) - (SETQ LAFITEEXTRAMENU NIL) - (SETQ LAFITEEXTRAMENUFLG T]) - -(MESSAGEAGE - [LAMBDA (MSG TODAY YEAR ONEDAY) (* ; "Edited 22-Jun-89 11:46 by jtm:") - (* ; "Edited 21-Sep-88 16:25 by jtm:") - (LET (MSGDATE MSGTIME) - [COND - ((AND (fetch (LAFITEMSG DATEKNOWN?) of MSG) - (SETQ MSGTIME (fetch (LAFITEMSG IDATE) of MSG))) - - (* ;; "new format: date already parsed.") - - NIL) - ((SETQ MSGDATE (fetch (LAFITEMSG DATE) of MSG)) - [OR TODAY (SETQ TODAY (IDATE (DATE] - (OR YEAR (SETQ YEAR (SUBSTRING (DATE) - 8 9))) - [OR ONEDAY (SETQ ONEDAY (IDIFFERENCE (IDATE "2-Jan-80 12:00") - (IDATE "1-Jan-80 12:00"] - (SETQ MSGTIME (IDATE (CONCAT MSGDATE " " YEAR " 12:00"))) - (COND - ((AND MSGTIME (IGREATERP (IDIFFERENCE MSGTIME TODAY) - ONEDAY)) (* a message from last year.) - (SETQ MSGTIME (IDATE (CONCAT MSGDATE " " (SUB1 (MKATOM YEAR)) - " 12:00"] - (AND MSGTIME (QUOTIENT (IDIFFERENCE TODAY MSGTIME) - ONEDAY]) -) - -(RPAQ? EXPIRATIONMENU NIL) - -(RPAQQ EXPIRATIONMENUITEMS - (("now" T) - ("one day" 1) - ("two days" 2) - ("four days" 3) - ("one week" 4) - ("two weeks" 5) - ("one month" 6) - ("two months" 7) - ("four months" 8) - ("eight months" 9) - ("forever" 0))) - -(RPAQQ MARKDURATIONS ((1 1) - (2 2) - (3 4) - (4 7) - (5 14) - (6 30) - (7 61) - (8 122) - (9 244))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS EXPIRATIONMENU EXPIRATIONMENUITEMS MARKDURATIONS) -) - -(LTD.INIT) -(PUTPROPS LAFITETIMEDDELETE COPYRIGHT ("Xerox Corporation" 1987 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (934 8084 (\LAFITE.TIMEDDELETE 944 . 1218) (\LAFITE.SETEXPIRATIONS 1220 . 5600) ( -\LAFITE.DELETEEXPIRED 5602 . 8082)) (8085 10316 (LTD.INIT 8095 . 8984) (MESSAGEAGE 8986 . 10314))))) -STOP diff --git a/lispusers/LAMBDATRAN.LCOM.~2~ b/lispusers/LAMBDATRAN.LCOM.~2~ deleted file mode 100644 index 2c586bd0bbf8cbc1491c1889865d00245ca82547..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3900 zcmb7HTW{mm5!S`nwrS<1H$jlNNiY?#31vVAFS;jiMDrriqDY#gEU5|7dL<>+TDA@;wV(YH@|=I+e~`>Mhm`0G7O7!?)H!ozzWL^IhPGO*_y%%k3TPQ?>}u0d85^7i!O ze6<3SR1?ZIv77}yJD46EjVGfaOb;OopK5;Vvv-bW)5oL1$;QEGI2k>a*2Rs<`1t6_ z@o09uG1)zMG~7Lz?H;bbE#@GTm4v)D8sw`55K*UC6G~Y)AzCMI4PlH*+f)mn8gLa) z1>?zN0{+wE>5~(X3VCO6LNKkbuV(=jBNEg(UlygBT&@+$*<0RJ^Ty~=zETEJs1@*E zM)cb|pS@!ljSaNp>)wW~_ks;eX>V#u;3@X{+Y(fZ#S#qmb`L)q9mC1=VGVf0_Q9}& zzAHk;3bd}-?%-j=1}pG`maVjPuobW2=iq2I`glBja!hgJ(X2QJAyjL{QcbM<0uUm) zvSWG;jHeC!cE<^HK>ZlVAO`_%ww)dA-CH}Mq+@B3@Ev+WptrPy>kA!h;SLR`9I4Rn zM#6R$S|Z__pl#E#a*+pdPII|Th#qQMCBs|53rK!02Z^IpB9W~BCV_t|E6FB(dG=;A zeU@z|haZvUtM9_+f5YeJm*c-)?tRG)aepQgK&({rH+DoSYRVx9scKIE_&OK-aenC zI7ZL;(j?6#cu{8QjL4ZkG-?^XPz6Kpx!xMcRbVetxCA0wp|HYQSj4AC!t-7dL9K8J zO6XU0`d}=}^@!!+Sv8gHg$SRmhA%gx_9aJS%l(I<=IZ;+`^yNsTnu3&mM|oQbBRKQ zQaJ)&j4&6)(2GJSGiR3+JBbg*FczP3><4u;o|r5ME{I?#9V@`fbU|RI4XCii9vFbe z$-d&cR^PB1xFXKQ#KmD;mO@GF97IZH*43tBH?X>rnP1;aB)TtkUtW=xx?K9=)$W7y zN|zhT^{aEC%k?Qoz0-$`+tD7e2%NzvFBAkHaVc$@kCGfBQahJ|3)Y z?OXSk-%Hcq|K2jGx~uQDh9+g5M(*nC%T_9#TKU7T+8?AZUVCw?MVGq|&Kgvx)qUl+ zn2HHBk^Iv#%du~q`f;I{mg4)$RYnBWJ(A+(N)t zUw64wm)jc-%?y%&G;mxCGe9ayK-#Zq^o4gp!ssbMpr}m{OGWT>Mmh$y!l)!sMw*Kx zTQG1K2U4d{lG#%h=@TO@$>l`_V#-IwC=_BXUaXctb=qy+4oFd!>v6FgV+$W3LBG(HkuZPJ*l9boMPn63sW%hT3 zoL-%B${OMx(j?1B2I_2qR0dz4Us4DKuX?g!2Te367Gcxr*qW<#+U-7O?%X~_LvH{@ z5Cn0N`@UJLt*J_&HuK1L$FuW>=d{;oEzmuxDsMPmo=UA@W=lZoLI$#LTZm^nzoS?k z%<;r4*mo1-`bsM4(fk`M?X3>(Q3pw%66V()#t2c^j@MSK1-J;83~Q=mYi3|Nb{^|T zvve=NY2u3A@Ci7H8ee194NGZ|MG@9q&rx+bM9Y9NJ?7HUt+kI#lrUFxyAd=&F0fgH z#f3I-c2i^f79xf)3FCgmy+rarl7UyPn(ldy2kSA(kUG4Bc^AVQ^fBLE52wgj>f(}* z`<|<8Z{Ju3o?n9i2fyRV?#UR(#e?0!-uQ4ddkP;;XK*70OlQMmy#FmnRjeJH z#SjM0Hhfq_SW<@R`9TJF7oIl?!7m?$ZtG#Zk%8)lns8$=#jpj$cgIu~%|bVHM1xN> z<78qtEh@S;!98af!pf)PXEYOqYNK)V+65JBACU)&rcrkJ`Ou0L@hJ|p zg1yVMTajGX@hpvETqK8%{i9BD6TeEM+&(qy>7?H&JGjj52_i+>bwIQ?EN3&! zw@mEbN13RrGY@G;jwLr46=I!|s9Jzo*!OhR@iad?h`@0syd_GpTaKb3@Vos89rIY^ z<{=~_qJrwk)4E1CiHm|1k-A0kz`>K$fBKnnSH!WtI{}G#1U4Foq7(Egkq#W z%+JrS7nTQn51WgFgvD6J`H&rLYRIC>LISPNERD.;3 10439 changes to%: (VARS LISPNERDCOMS) previous date%: "25-Jan-88 11:18:03" {ERINYES}LYRIC>LISPNERD.;2) (* " Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LISPNERDCOMS) (RPAQQ LISPNERDCOMS ((COMS * LISPNERDDEPENDENCIES) (* must come before any FILES) (FILES ANALYZER DINFO HELPSYS (FROM {QV}LISP>) DICTCLIENT) (FNS LISPNERD.INIT IRMNERD.PRINTSEARCH) (INITVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST (IRMNERD.MAXWORDS 50)) (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS) (FNS IRMDICT.PRINTENTRY) (P (LISPNERD.INIT)))) (RPAQQ LISPNERDDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'LISPNERD 'DEPENDENCIES (for FILE in (FILECOMSLST 'LISPNERD 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES LISPNERD) (P (for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS LISPNERD DEPENDENCIES ((ANALYZER . " 3-Jun-88 17:03:38") (DINFO . " 1-Oct-87 10:11:04") (HELPSYS . " 1-Oct-87 13:40:16") (DICTCLIENT . " 8-Oct-87 15:15:08"))) [for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD  to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL] (* must come before any FILES) (FILESLOAD ANALYZER DINFO HELPSYS (FROM {QV}LISP>) DICTCLIENT) (DEFINEQ (LISPNERD.INIT [LAMBDA NIL (* jtm%: "18-Nov-87 14:36") (COND ((NULL IRMDICT) [Dict.Establish (SETQ IRMDICT (create Dict dictName _ 'IRMDict printEntryFn _ (FUNCTION IRMDICT.PRINTENTRY] (PUTASSOC 'Search% IRM '((IRMNERD.PRINTSEARCH) "Searches the Interlisp Reference Manual for entries given a list of keywords." ) BackgroundMenuCommands) (SETQ BackgroundMenu NIL]) (IRMNERD.PRINTSEARCH [LAMBDA (SYNONYMCLASSES) (* jtm%: " 7-Apr-87 12:33") (PROG (VENNDIAGRAM SELECTION MENUITEMS (MINWORD 0) (MAXWORD IRMNERD.MAXWORDS)) [COND ((NULL SYNONYMCLASSES) (CLRPROMPT) (PROMPTPRINT (CHARACTER (CHARCODE CR))) (SETQ SYNONYMCLASSES (PROMPTFORWORD "keywords to search on:" IRMNERD.LASTREQUEST NIL PROMPTWINDOW NIL NIL (CHARCODE EOL ESCAPE LF))) (COND ((NULL SYNONYMCLASSES) (PROMPTPRINT "Aborted") (RETURN)) (T (CLRPROMPT))) (COND ((NOT (STREQUAL SYNONYMCLASSES IRMNERD.LASTREQUEST)) (SETQ IRMNERD.LASTREQUEST SYNONYMCLASSES) (SETQ IRMNERD.LASTSEARCH NIL] [do [SETQ VENNDIAGRAM (COND ((AND IRMNERD.LASTSEARCH (EQ MINWORD 0)) IRMNERD.LASTSEARCH) (T (PROMPTPRINT " Searching . . . ") (DICTCLIENT.SEARCHFORWORD SYNONYMCLASSES 2 MINWORD MAXWORD 'IRMNerd] (COND ((EQ MINWORD 0) (* cache the results in case the use  calls again.) (SETQ IRMNERD.LASTSEARCH VENNDIAGRAM))) [COND ((NULL VENNDIAGRAM) (PROMPTPRINT "Sorry, no results.") (FLASHWINDOW PROMPTWINDOW) (RETURN)) ((NULL (CDR VENNDIAGRAM)) (SETQ MENUITEMS (CADAR VENNDIAGRAM))) (T (SETQ MENUITEMS (for SET in VENNDIAGRAM collect (LIST [CONCATLIST (for ELEMENT on (CAR SET) collect (COND ((CDR ELEMENT) (CONCAT (CAR ELEMENT) " ")) (T (CAR ELEMENT] (LIST 'QUOTE (CAR SET)) NIL (CONS 'SUBITEMS (CADR SET] (CLRPROMPT) (SETQ SELECTION (MENU (create MENU TITLE _ "IRM Entries" ITEMS _ MENUITEMS CENTERFLG _ T))) (COND ((NULL SELECTION) (PROMPTPRINT " No selection made.") (RETURN)) ((LISTP SELECTION) [for TAIL CLASSNAME on SELECTION do (COND ((EQ (NTHCHARCODE (CAR TAIL) -1) (CHARCODE +)) (SETQ CLASSNAME (SUBSTRING (CAR TAIL) 1 -2)) (RPLACA TAIL (for CLASS in SYNONYMCLASSES thereis (STREQUAL (CAR CLASS) CLASSNAME] (SETQ SYNONYMCLASSES SELECTION) (PROMPTPRINT "Seaching for: " SYNONYMCLASSES) (SETQ MINWORD 0) (SETQ MAXWORD IRMNERD.MAXWORDS)) ((AND (EQ 1 (STRPOS ". . .+" SELECTION)) (STRPOS "more" SELECTION)) (* the user asked for the next chunk.) (SETQ MINWORD (ADD1 MAXWORD)) (SETQ MAXWORD (IPLUS MAXWORD IRMNERD.MAXWORDS))) ((EQ 1 (STRPOS "No more" SELECTION)) (RETURN)) (T (PROMPTPRINT " Fetching definition . . . ") (IRMDICT.PRINTENTRY NIL SELECTION) (CLRPROMPT) (RETURN] (RETURN T]) ) (RPAQ? IRMDICT NIL) (RPAQ? IRMNERD.LASTSEARCH NIL) (RPAQ? IRMNERD.LASTREQUEST NIL) (RPAQ? IRMNERD.MAXWORDS 50) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS) ) (DEFINEQ (IRMDICT.PRINTENTRY [LAMBDA (DICT LEMMA) (* ; "Edited 25-Jan-88 11:10 by jtm:") (LET (FIRSTCHAR SECTION# GRAPH NODE) (SETQ FIRSTCHAR (NTHCHAR LEMMA 1)) [COND ((NUMBERP FIRSTCHAR) [SETQ SECTION# (SUBSTRING LEMMA 1 (SUB1 (OR (STRPOS " " LEMMA) 0] [COND ((EQ (NTHCHARCODE SECTION# -1) (CHARCODE %.)) (* sometimes there is a trailing  period.) (SETQ SECTION# (SUBSTRING SECTION# 1 -2] [for I from 1 to (NCHARS SECTION#) do (COND ((EQ (NTHCHARCODE SECTION# I) (CHARCODE %.)) (* DINFO uses dashes instead of  periods) (RPLCHARCODE SECTION# I (CHARCODE -] (SETQ SECTION# (MKATOM SECTION#)) (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH)) [COND ((NULL GRAPH) (DINFO.INIT) (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH] (SETQ NODE (FASSOC SECTION# (fetch (DINFOGRAPH NODELST) of GRAPH))) (AND NODE (DINFO.UPDATE NODE))) (T (IRM.SMART.LOOKUP (SUBSTRING LEMMA (COND ((EQ FIRSTCHAR '%() 2) (T 1)) (SUB1 (OR (STRPOS " " LEMMA) 0] T]) ) (LISPNERD.INIT) (PUTPROPS LISPNERD COPYRIGHT ("Xerox Corporation" 1987 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2875 8096 (LISPNERD.INIT 2885 . 3532) (IRMNERD.PRINTSEARCH 3534 . 8094)) (8344 10333 ( IRMDICT.PRINTENTRY 8354 . 10331))))) STOP \ No newline at end of file diff --git a/lispusers/LISPNERD.~2~ b/lispusers/LISPNERD.~2~ deleted file mode 100644 index 2dece7fb..00000000 --- a/lispusers/LISPNERD.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "30-Aug-2020 20:52:22"  {DSK}kaplan>Local>medley3.5>lispcore>lispusers>LISPNERD.;2 10365 changes to%: (VARS LISPNERDCOMS LISPNERDDEPENDENCIES) (PROPS (LISPNERD DEPENDENCIES)) previous date%: " 3-Aug-88 16:16:39" {DSK}kaplan>Local>medley3.5>lispcore>lispusers>LISPNERD.;1) (PRETTYCOMPRINT LISPNERDCOMS) (RPAQQ LISPNERDCOMS ((COMS * LISPNERDDEPENDENCIES) (* must come before any FILES) (FILES ANALYZER DINFO HELPSYS DICTCLIENT) (FNS LISPNERD.INIT IRMNERD.PRINTSEARCH) (INITVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST (IRMNERD.MAXWORDS 50)) (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS) (FNS IRMDICT.PRINTENTRY) (P (LISPNERD.INIT)))) (RPAQQ LISPNERDDEPENDENCIES [(* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) [E (PUTPROP 'LISPNERD 'DEPENDENCIES (for FILE in (FILECOMSLST 'LISPNERD 'FILES) collect (CONS FILE (CAAR (GETPROP FILE 'FILEDATES] (PROP DEPENDENCIES LISPNERD) (P (for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force FILESLOAD to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL]) (* * code to make sure that the right versions of everything are loaded. The P must be executed before any FILES commands.) (PUTPROPS LISPNERD DEPENDENCIES ((ANALYZER . " 9-Mar-89 15:24:58") (DINFO . " 1-Oct-87 10:11:04") (HELPSYS . " 1-Oct-87 13:40:16") (DICTCLIENT))) [for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES) do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE) 'FILEDATES] (COND ([AND FILEDATE (CDR FILE) (ILESSP (IDATE FILEDATE) (IDATE (CDR FILE] (* clear FILEDATES to force  FILESLOAD to reload the file.) (PUTPROP (CAR FILE) 'FILEDATES NIL] (* must come before any FILES) (FILESLOAD ANALYZER DINFO HELPSYS DICTCLIENT) (DEFINEQ (LISPNERD.INIT [LAMBDA NIL (* jtm%: "18-Nov-87 14:36") (COND ((NULL IRMDICT) [Dict.Establish (SETQ IRMDICT (create Dict dictName _ 'IRMDict printEntryFn _ (FUNCTION IRMDICT.PRINTENTRY] (PUTASSOC 'Search% IRM '((IRMNERD.PRINTSEARCH) "Searches the Interlisp Reference Manual for entries given a list of keywords." ) BackgroundMenuCommands) (SETQ BackgroundMenu NIL]) (IRMNERD.PRINTSEARCH [LAMBDA (SYNONYMCLASSES) (* jtm%: " 7-Apr-87 12:33") (PROG (VENNDIAGRAM SELECTION MENUITEMS (MINWORD 0) (MAXWORD IRMNERD.MAXWORDS)) [COND ((NULL SYNONYMCLASSES) (CLRPROMPT) (PROMPTPRINT (CHARACTER (CHARCODE CR))) (SETQ SYNONYMCLASSES (PROMPTFORWORD "keywords to search on:" IRMNERD.LASTREQUEST NIL PROMPTWINDOW NIL NIL (CHARCODE EOL ESCAPE LF))) (COND ((NULL SYNONYMCLASSES) (PROMPTPRINT "Aborted") (RETURN)) (T (CLRPROMPT))) (COND ((NOT (STREQUAL SYNONYMCLASSES IRMNERD.LASTREQUEST)) (SETQ IRMNERD.LASTREQUEST SYNONYMCLASSES) (SETQ IRMNERD.LASTSEARCH NIL] [do [SETQ VENNDIAGRAM (COND ((AND IRMNERD.LASTSEARCH (EQ MINWORD 0)) IRMNERD.LASTSEARCH) (T (PROMPTPRINT " Searching . . . ") (DICTCLIENT.SEARCHFORWORD SYNONYMCLASSES 2 MINWORD MAXWORD 'IRMNerd] (COND ((EQ MINWORD 0) (* cache the results in case the use  calls again.) (SETQ IRMNERD.LASTSEARCH VENNDIAGRAM))) [COND ((NULL VENNDIAGRAM) (PROMPTPRINT "Sorry, no results.") (FLASHWINDOW PROMPTWINDOW) (RETURN)) ((NULL (CDR VENNDIAGRAM)) (SETQ MENUITEMS (CADAR VENNDIAGRAM))) (T (SETQ MENUITEMS (for SET in VENNDIAGRAM collect (LIST [CONCATLIST (for ELEMENT on (CAR SET) collect (COND ((CDR ELEMENT) (CONCAT (CAR ELEMENT) " ")) (T (CAR ELEMENT] (LIST 'QUOTE (CAR SET)) NIL (CONS 'SUBITEMS (CADR SET] (CLRPROMPT) (SETQ SELECTION (MENU (create MENU TITLE _ "IRM Entries" ITEMS _ MENUITEMS CENTERFLG _ T))) (COND ((NULL SELECTION) (PROMPTPRINT " No selection made.") (RETURN)) ((LISTP SELECTION) [for TAIL CLASSNAME on SELECTION do (COND ((EQ (NTHCHARCODE (CAR TAIL) -1) (CHARCODE +)) (SETQ CLASSNAME (SUBSTRING (CAR TAIL) 1 -2)) (RPLACA TAIL (for CLASS in SYNONYMCLASSES thereis (STREQUAL (CAR CLASS) CLASSNAME] (SETQ SYNONYMCLASSES SELECTION) (PROMPTPRINT "Seaching for: " SYNONYMCLASSES) (SETQ MINWORD 0) (SETQ MAXWORD IRMNERD.MAXWORDS)) ((AND (EQ 1 (STRPOS ". . .+" SELECTION)) (STRPOS "more" SELECTION)) (* the user asked for the next chunk.) (SETQ MINWORD (ADD1 MAXWORD)) (SETQ MAXWORD (IPLUS MAXWORD IRMNERD.MAXWORDS))) ((EQ 1 (STRPOS "No more" SELECTION)) (RETURN)) (T (PROMPTPRINT " Fetching definition . . . ") (IRMDICT.PRINTENTRY NIL SELECTION) (CLRPROMPT) (RETURN] (RETURN T]) ) (RPAQ? IRMDICT NIL) (RPAQ? IRMNERD.LASTSEARCH NIL) (RPAQ? IRMNERD.LASTREQUEST NIL) (RPAQ? IRMNERD.MAXWORDS 50) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS) ) (DEFINEQ (IRMDICT.PRINTENTRY [LAMBDA (DICT LEMMA) (* ; "Edited 25-Jan-88 11:10 by jtm:") (LET (FIRSTCHAR SECTION# GRAPH NODE) (SETQ FIRSTCHAR (NTHCHAR LEMMA 1)) [COND ((NUMBERP FIRSTCHAR) [SETQ SECTION# (SUBSTRING LEMMA 1 (SUB1 (OR (STRPOS " " LEMMA) 0] [COND ((EQ (NTHCHARCODE SECTION# -1) (CHARCODE %.)) (* sometimes there is a trailing  period.) (SETQ SECTION# (SUBSTRING SECTION# 1 -2] [for I from 1 to (NCHARS SECTION#) do (COND ((EQ (NTHCHARCODE SECTION# I) (CHARCODE %.)) (* DINFO uses dashes instead of  periods) (RPLCHARCODE SECTION# I (CHARCODE -] (SETQ SECTION# (MKATOM SECTION#)) (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH)) [COND ((NULL GRAPH) (DINFO.INIT) (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH] (SETQ NODE (FASSOC SECTION# (fetch (DINFOGRAPH NODELST) of GRAPH))) (AND NODE (DINFO.UPDATE NODE))) (T (IRM.SMART.LOOKUP (SUBSTRING LEMMA (COND ((EQ FIRSTCHAR '%() 2) (T 1)) (SUB1 (OR (STRPOS " " LEMMA) 0] T]) ) (LISPNERD.INIT) (DECLARE%: DONTCOPY (FILEMAP (NIL (2864 8085 (LISPNERD.INIT 2874 . 3521) (IRMNERD.PRINTSEARCH 3523 . 8083)) (8332 10321 ( IRMDICT.PRINTENTRY 8342 . 10319))))) STOP \ No newline at end of file diff --git a/lispusers/NSDISPLAYSIZES.TEDIT.~2~ b/lispusers/NSDISPLAYSIZES.TEDIT.~2~ deleted file mode 100644 index ff7e2b08cfb6928204fce074d18c02b815b08553..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6436 zcmeHK%W@mn5gk&JZAF1ydAKUsbtz5>C?g07!<6i7G9-uOlt6$U3}rDXF9w4PVxqxZ zcpjvn{DHTr#~;gdtsc5gn^ARMf;$R-J|S>!&K# z&pW=Jw;JwD(O^VV9i=q&=0O;!gghLbc^8TjKUOM|-GtJam(nCi7NNH!EWO17W`enw zs&I*26~q+jc@TLaEpz~bN$^5-h}>C_&|G;@VFRkMBFH@QL!GFYd>x&~nTmWxW0hX= zow+^Sp}g4R4K1>j1JQ&+^p)W0|f+h_I$CVd*$HKSvmItblHX-er)^be58j=$x~r7cF(99wdk}s5XTWiBQQK zW(?`6$kYSATURd~+@5 z*dCaD8lJfJu}QA&nuFFVqZpu~Cio$$Y|d{y5L|;@anJXBXu%l{-&&p|fUd}=BpWB3 zP~ephO(`bpEM+`Z93%U6mPksa8A$EbE}9VBKv{?hToYC*ny9G)Kgl{+ns9BtV zB>_@a&lQZLBLK#NkO|_)^8AhqFAjurAm>XGl-mIaE^nVGw7+1HBCjRQ_yJ?ksYs1Z zW1yu_N1{d?F)+)G+UrMp&#<4)54`g4VloRCKRLbJMYB)<+ z$*>baV~)bly4-N2;G0N=rOprzG^m`PBvMxwQsJPRx^P>I4cHC35|JXX)9h%Pms6<7QM~pv4+=_ER>I;??VR(RWUFC^UyDX2vwaQ!mq8$Lzk-z zTdJ%S?@qv?FN+o>bHFrso{tRcnuPiX>o6`{NMlSKnlK)reAX`Fdht33NvEJ^s@Nh(o8Nz{}Yhm-Iu(h_7?9W z9Yat-!?|a9Gm_q~>gl3Udg6i^@C+2qr_BKKrx$a-=CK2T7fvnnU7qwV11_I3c)-LQ z$dz=+n+WJy7FIlSthfWpmqO`z zG?AwypEsIUNJLWq&xq%LtoJOkp1RgxWDf_eyT3gsOnudG6qi*dl@u}Qty0tK6>r^E zF_>`Dpo67o-0UM?1xTuUXr7@P@hfUws(3ZWzfv4AKswG#ILhOtqGu7R3V!qRC-~z4 za}CekML^1MNC3i6U*^3i#=M%K18^N4Gx5jzg8!i4AXPKL8cfx+)y3fDIP{?AU<-+s zqqE(Ene~&0=H8LXv&E|pqNm&W%$fw8Q9#7^fEzH$=WDbiq{r_VsJ;RiFs(z!0r=PCzd0m?JG2n7}IOt9@>M0AvI0M+{L_d z|33b;XylrXYYz_j?9XU>r`w|D7H!cEBJ%Jv{ss!;Y-!gq`@`Ym5jDR!HTP-H0s$Rs zzeNb5Q|ydR`SLx-K5=2l9z3x}_HN&z;lTlotiHA9p1>7XzMnWl7XoWP-{myh-YT=M z7^#L&ET?Y|3IncVKemRa`SH^MhWu*JdU|3?Zjxgip7u?LM*ZQ5Rek%?vJa13I=1%h z(_?nba>|=eN0uY-FnlBT4DMpp0&dQ+34E>r2Vk}z_NdpT?xRQa$xbWRZys6ZKH$vZ zD!#a9?8NC{fDIPm?4uq%?Dgo=Zv8ChvK*8cLglj^>V3LHJ6rf8hTUo5WEEsl`mcsc z2=n&vzXEJ_y!)uja6Rn4HCjC&wnF;zu5!mC1g;}(=RHoo1cc2|qqk#_CK&GuKv+Qvu5M=*a6qT8D{8LsPM4c#Az z?yc3v4Xd{Cjq%OKBjcSn(uGpx!%cXsE-3A?@Bq4>L`GUWRq}qB9k`M4-A_YFm=}jozJ919@RtHV@V6aj1VC8*b zD!+ac0P*qvhGn5 z1&sagOMyg#tvpzlZ0xT~3>iuIrs|ZiyLPwnhw@Ny(}uk!Fn(DIg3`OJl$2-wSqj)O zgFgnPq*U3e3z%OL2&SEQ!)L@vmIxVNBVp3YP1PyEy#BPGvI+}i=k2fhu(VV8#Ssz9 zl^1_1C2d}?;`^mU!p)K@8jK0My;rKp4y#mHvkD9T$SS;G0kcn@TfP#4_y25s_2O^; E2D?KZ=l}o! diff --git a/lispusers/NSDISPLAYSIZES.~2~ b/lispusers/NSDISPLAYSIZES.~2~ deleted file mode 100644 index eccdd5cd..00000000 --- a/lispusers/NSDISPLAYSIZES.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "14-Sep-96 09:32:32" {DSK}medley2.0>lispusers>NSDISPLAYSIZES.;13 8499 changes to%: (FNS NSDISPLAYSIZE PURGENSFONTS) (VARS NSDISPLAYSIZESCOMS) previous date%: "16-Nov-95 10:10:26" {DSK}medley2.0>lispusers>NSDISPLAYSIZES.;9) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1993, 1995, 1996 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSDISPLAYSIZESCOMS) (RPAQQ NSDISPLAYSIZESCOMS [(FNS NSDISPLAYSIZE NS\FONTFILENAME NS\FONTFILENAME.OLD PURGENSFONTS) (ADDVARS (NSFONTFAMILIES CLASSIC MODERN TERMINAL OPTIMA TITAN)) (INITVARS (*SMALLSCREEN* (ILESSP SCREENWIDTH 700))) [COMS (* ;  "VirtualKeyboard font needs adjusting so that real Classic 12 still appears") (FNS VKBD.FIX.FONT) (DECLARE%: EVAL@COMPILE DONTCOPY (P (OR (RECLOOK 'KEYBOARDCONFIGURATION) (LOADDEF 'KEYBOARDCONFIGURATION 'RECORDS 'VIRTUALKEYBOARDS] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? '\FONTFILENAME 'OLD\FONTFILENAME) (MOVD 'NS\FONTFILENAME '\FONTFILENAME) (MOVD? '\FONTFILENAME.OLD 'OLD\FONTFILENAME.OLD) (MOVD 'NS\FONTFILENAME.OLD '\FONTFILENAME.OLD) (PURGENSFONTS) (VKBD.FIX.FONT]) (DEFINEQ (NSDISPLAYSIZE [LAMBDA (FAMILY SIZE FACE EXTENSION) (* ; "Edited 14-Sep-96 09:32 by rmk:") (* ; "Edited 16-Nov-95 10:08 by ") (* ;  "Edited 5-Mar-93 18:12 by kaplan") (* ; "Edited 15-Jan-87 15:22 by bvm:") (* ;; "Returns size that we would prefer to see the font of requested family, size, face, extension. Used to make bigger ns display fonts than you would get by default. Don't do it for small screens, as on DOS and laptops.") (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS NSFONTFAMILIES)) (OR (AND (CL:MEMBER EXTENSION DISPLAYFONTEXTENSIONS :TEST 'STRING-EQUAL) (COND (*SMALLSCREEN* (CL:UNLESS (CL:MEMBER FAMILY NSFONTFAMILIES :TEST 'STRING-EQUAL) (* ;  " Small screen, shrink non-NS fonts ") (SELECTQ SIZE (12 10) (10 8) (8 6) NIL))) ((CL:MEMBER FAMILY NSFONTFAMILIES :TEST 'STRING-EQUAL) (* ; "Large screen, enlarge NS fonts") (AND (SELECTQ SIZE (12 (COND ((STRING-EQUAL FAMILY 'TERMINAL) (* ; "Until Terminal 14 exists") 12) (T 14))) (10 12) (8 10) (6 8) NIL))) ((AND NIL (CL:MEMBER EXTENSION INTERPRESSFONTEXTENSIONS :TEST 'STRING-EQUAL) (STRING-EQUAL FAMILY 'SYMBOL)) (* ;  "Fake NS size on Interpress printing, even tho display fonts don't exist") 10))) SIZE]) (NS\FONTFILENAME [LAMBDA (FAMILY SIZE FACE EXTENSION CHARACTERSET) (* ; "Edited 15-Jan-87 15:23 by bvm:") (OLD\FONTFILENAME FAMILY (NSDISPLAYSIZE FAMILY SIZE FACE EXTENSION) FACE EXTENSION CHARACTERSET]) (NS\FONTFILENAME.OLD [LAMBDA (FAMILY SIZE FACE EXTENSION CHARACTERSET) (* ; "Edited 15-Jan-87 15:29 by bvm:") (OLD\FONTFILENAME.OLD FAMILY (NSDISPLAYSIZE FAMILY SIZE FACE EXTENSION) FACE EXTENSION CHARACTERSET]) (PURGENSFONTS [LAMBDA (TYPES) (* ; "Edited 14-Sep-96 09:27 by rmk:") (* ; "Edited 14-Dec-87 14:53 by bvm:") (/SETTOPVAL '\FONTSINCORE (FOR ENTRY IN \FONTSINCORE BIND BADTYPES TMP COLLECT (SETQ BADTYPES (IF (AND (MEMB (CAR ENTRY) NSFONTFAMILIES) (OR (NULL TYPES) (EQMEMB 'NS TYPES))) THEN (CONS 'DISPLAY TYPES) ELSE (MKLIST TYPES))) (CONS (CAR ENTRY) (FOR SIZES IN (CDR ENTRY) WHEN [SETQ TMP (IF (AND (NULL TYPES) (> (CAR SIZES) 12)) THEN (* ;  "Only have to get rid of sizes smaller than 14") (CDR SIZES) ELSE (FOR FACE IN (CDR SIZES) WHEN (SETQ TMP (FOR ROT IN (CDR FACE) WHEN (SETQ TMP (FOR DEV IN (CDR ROT) COLLECT DEV UNLESS (MEMB (CAR DEV) BADTYPES))) COLLECT (CONS (CAR ROT) TMP))) COLLECT (CONS (CAR FACE) TMP] COLLECT (CONS (CAR SIZES) TMP]) ) (ADDTOVAR NSFONTFAMILIES CLASSIC MODERN TERMINAL OPTIMA TITAN) (RPAQ? *SMALLSCREEN* (ILESSP SCREENWIDTH 700)) (* ; "VirtualKeyboard font needs adjusting so that real Classic 12 still appears") (DEFINEQ (VKBD.FIX.FONT [LAMBDA (NEWFONT) (* ; "Edited 9-Mar-93 14:03 by rmk:") (* ; "Edited 1-Jul-88 16:55 by bvm") (* ;; "Change the VirtualKeyboard's configuration definitions to use NEWFONT (default Classic 10). The original font is Classic 12, but with NSDISPLAYSIZES loaded, that coerces to Classic 14, so we have to fool it by setting it back a notch.") [SETQ DEFAULTKEYBOARDDISPLAYFONT (OR NEWFONT (SETQ NEWFONT '(CLASSIC 10] (for X in (LISTP (EVALV 'VKBD.CONFIGURATIONS)) do (replace (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) of X with DEFAULTKEYBOARDDISPLAYFONT ]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (OR (RECLOOK 'KEYBOARDCONFIGURATION) (LOADDEF 'KEYBOARDCONFIGURATION 'RECORDS 'VIRTUALKEYBOARDS)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? '\FONTFILENAME 'OLD\FONTFILENAME) (MOVD 'NS\FONTFILENAME '\FONTFILENAME) (MOVD? '\FONTFILENAME.OLD 'OLD\FONTFILENAME.OLD) (MOVD 'NS\FONTFILENAME.OLD '\FONTFILENAME.OLD) (PURGENSFONTS) (VKBD.FIX.FONT) ) (PUTPROPS NSDISPLAYSIZES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1993 1995 1996)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1696 6738 (NSDISPLAYSIZE 1706 . 4036) (NS\FONTFILENAME 4038 . 4279) ( NS\FONTFILENAME.OLD 4281 . 4530) (PURGENSFONTS 4532 . 6736)) (6950 7988 (VKBD.FIX.FONT 6960 . 7986)))) ) STOP \ No newline at end of file diff --git a/lispusers/NSPROTECTION.LCOM.~2~ b/lispusers/NSPROTECTION.LCOM.~2~ deleted file mode 100644 index 8aa94ef4d1cde2cbc741a31e337104e79103cd56..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23527 zcmdUXZERatnx04{j+2c&lI_VP?reIN$vTt~F}fu6nII#IyfP_~ybMWMmhHr&h_p$Y z`luu)bq6szi?lPdZFiAr^D&do7VV!*F(@j_7TSF52xw7Y@~1$HY%vA;quu?tMGF<# z?vDjJ)8~EPbMHO(l5(=?{;7kA_nv$1`FuZ~_v74n&Ymrl?cv!%(H<_8XC3uqC6k@c zoU>J|P_En6Vxd-vsVA#;CRfkQ6hp-`nVPMvk)dO8Y9NbRbvvhG$%)}yb7gpPLRsTe z$@J9dNKD0JE9V3{Om= zjj5D1l}^W0>^mFnYn|ryb8DCdU%mL+^4e;%(`g!WSlhx3w=u)^`r7k&D`h3e(`u!) zymqa*rH*Z{|MrxM&z5USCYz|)^+ai*ST9tH_R!EVa|zT`ZsJ(HqDIw>Q_Rge<@%6{ zUOdv**LM{E_YGzqXg|yskq1ju+V_h`^7{9WKD^lzQY{XhJOZ~YfS zS9!iK_%-v7P#e-5x2aq8YlK?xZ@)}i(y;$d=LnCl#Jw7qfAksE^vBMN;=gw2l^#Q2 z{9a3cbSk-n;JBb2p!H zm;7gr3+7sRZtHTxUl*hCB44)#`r@PDmdZkXu~5!Ai(p5P-^5tBWNcEMv+HIwa-!S>C~v2t=e|UE-$Fm*oewHg7(7SV!q3nHs}x7Z*xsHIubf5?e@=UQ-rc zE@dvr&Rdw9p072Lma$mllg5HsknHHo0z2fOHH(=gT&JZwYc#F9vyvl5qgL8$bYwy| zIs)SM6rXGnxDYLa>fMI1Wju}X3Ek|dC2xbF%*mv9yD^s(HZVvhSleI;=nyP1qGC`- zvryEk;;AlGUtjM)dw~q%vTCthd-FM}H5HSQ&>q(6nQC2?>{^Wh1Ri%tD{r@&YHfM7 zsn)OZb)&h}-h}RL;P1-z`sOXQzNxOFEokLpp*&wxai$1R33Q-JrAJjs#AjVJw&{^{jw6UTba!`zH#b0VJ_`G2MPLol@r9lc2O%x%s*(V}e`CS?k=2 zDQk36#qa}R;VxIU)m*vZjt}cpw-vafe9o3@P0=XH743vDp(>PlNl~?{2XBqJU0&TS zT52C{sOH-CW*b9VzP8+6+uByyPIGy)y>_j&4tVvg7!g!9Z)fM-C3i{7lK?bzD>=dvYDHK91%p~?Z!Ckpyjj&+>#zId@ywQ5 zf8CthvqUhB=GEn!oo#g$*X`{sfGQc~w^V#(c}>0AL<3i^HZkt)A)YOFtm(_0Y>3fl z%3~9~s4YFD#xP%ZJ86J1RkHzlfp{Tf^#<1R&SGd9MExr_H)$N^_Gn(%+Gwt{ueMEY zcurVh$Xi_^FB`iF%IfYBf;(YDEHC-pW*QB(tk&>Wh#YRI_^tJuMDXCtZP3e5BIb9K z+1McB?d~E|sT9rTsU9W9E@-ATYC$p8ZT z^C>OgXnIXz)UD=z zwmu7$2}uTcFf7bi9i9RB0RX6-RTTy8UYMFX3zU$}4_EE_LbW_R3*bY~fE4IiZlP3K z8lH8k!(8jEnpI=`#BVtZvuU_kfO(ZELe{Erb>D7h)r887SWtYk3cAHUe}=5BTE&Ka z1M5qJnjzKq?2!kfeeLPN53{2RlNW>0D(H9FtySUmSkLy zyYdA~K#LccR{<+6SPj#916aO4!y_Mj>B0QHzaiHQrUwTfDo6OyMZvNM@9sOtpFR@V zIoFqjz2XlVkqp<`kM{5V zZ|Ml@WIeun9jL8kR?@@s}1r6ke+aD}`ysAPbLJE!t!3w7aoH9{{d}s-0u? zKBOYUwAIs@8QzXpAGp{5J9i>aPBXRguDs2cZ}Q*4oEKjxRH z#@=rhqmkVgb@}c$jru#!L?d_qL<)*KC*{I>vGJDfX}_>L?v;8MKmS9iUs{X&`j>z5 z$JfiBw+`+-T$Z~>iM02N5s+pQ=-Z_LA+sb%r(^p*wV=5o1) z{e$>Rz<_xU5}KVvz`~bxai$LQ2%K*xSib@qfaahv>~c;4+Us%Dol2r;pSOz@mG&qZ z_zvpRsV*gIOXYgzLPaIV$U+qQSg6@mA`1|SZp6M&0X|BQC8Q}lISTV@VFpGC7y^b$ zf=vQgX%m5B(D#_iWU~OKr~z4L!3+r86J{5+lL(e4gY{sA2tQdP$>7=~yoIPK7{6vK zDTr^QbFg=>zF_xa%ES86u)IN-Jc+@@Zl3|*)@XTUeQldCow}V<8_VQKx;=F%esitU zUTu?4Yq`@|hgycqY3TOzDxIJ|iwe^!`bg-nemVnEAQ5_lC(uPHQ&TKtxwtm#Ej;myXg>QxMn z`o8_L*Sl&h1GNH?Lz@F!ctFo+BaHc|UkiMI=`@W2t1ZB^H6E(lqhJN14&s4q)l!1&DN@P`eiF@1 znOx3QBE+ac56dWw(NaPz6fyW9FQ663J(7kc?miQ+4|#(Ua4vTNUNi1|^++BNt+jlm zH3L^nIgxcrC9pQA9R~A!*;yypG@Gk_xamk&&-!HU2zSzI_TkYM^u9|manKtYAot4PPqGvTE{9$Y7 zKg>mUe!))%2ah_(BfPvX`EW89OOy zAJc{KV-gm&-Yu<&lOsM%Ou`w|W4*Nwf``s!W-`$tdNpM;oG;c_1hbIy(1_XPwP&`cRBe5=`RaP(mRh|D z=gDT1G%mRznwx5QWu>{bMLGx4RO&-pZL8+$#`dkC=Ah@D_R0-av}fz2U7)+Kwl`O) z{x+O3TJLUcbe3;HbNgBcF{qwA>~X0$2^E}pt}PgX*N`LEp&}k&nx0|y_z{qGmW9WF zi?Le=dwCQZ5SyRx#sz#D<=OVZ+uYWh{8u-_*W5U$+yb?_WFt@%e%D|DJa*mG=3~*I zz)Cn}IGV?Myx|+GAy5cC?Dj})xv?}7wD992@IX3dtOwFk>12;m!e4N{8t{NN+TSLC z13<|b01HD6+`)f}ZPw1Im_qy@mRnzIJ}WrLby5Lgx&Eu$FZ<0g8QsnhX#sJZJ&Xu= zU0i4Zr?4Pbz-N)Y@DsQ+!DjUkNMVFXVWxes`&cIX!_KMic24rnP0KcBvZi4*qf7hZ z@Vxp40M?V*Wdk6Y>iq!g1@Yrc3$kT&3N3`))w#M%I4) z>%rfOo@eRLE5v_TntwPr@?e1Pi=1B=H+mqNxeF{6hZ?i%ML5V2 z_iA|TRpu5p>(EpiM|3c`gvnQaAA+|dTh-eFG> z261bF*#GO%NZ$j~yjAau9OE6?H?9{4u+5ACxElXCN|1UVdj7;vbzKU{xOx9>5UT_AI}$8zZCu-s2wSNxQ)$^LFXRXD{!3 zqkQADpX=sOH5w6eDn>8w{D@mFm9HPP4oc*De;L^o&q^4lG#XP4*# zuP?OD{x)(ifC#P8luMG(*NA=!_}#YD>N1&`Vu)^U zH#gUyO32K#*KV#hVfO+Y@JnP(#}~?Ksi2lR=QdeN{`cqL zeC0hAuYNRgNn2p^Aq&j1JZ$Pp6dh(IJ1HpF$i1nfA`lQgW-Im=(2+qR{yGZVK{mOq zeg!iLa@(_#0FV9P3*->Qh~bPvRQ{{lJBL~)o6Rl6HGDnazQr=OU55$aJeAj5rwS%fBN&`u&rlx((ao`wgK53d;PsJbmfl z-lN|pRmdz1-i2jRuP^DqF0j6xDIr^ixKQ7S-wJ+dNjI73#h}n9aF*#Ruq+8YRu>_; z(2TIVhKp=PT-MOGt6#X%QM=9o8ZfxWZ#uruo^lry`OMbCH8>t2ei`T!;2?jQ+#BtK z_x71n{&njgd>|L?HyOb&;ped;Foc6%J*)sCN(;pta&<7dE&)aAwU@BL{Cm5mf%Svg z0nlME$2~3OQ-{lQfvJ1M0dk0ADo;snx%4Un&-nal*=}z2B;hILBfp^^g0Hn zPBYUfGoy#i1#H!0;K7uPFSThahi;mvq95svYwwI>8{NCs&d}c1WFxuSj?DkyeWNV2 z!SHwoW~m^!zG#CX&^Xx(>_VCb-XHqG>TxNy-&Z^n{x#N*eBNDoDDV@<3h<5~umDd< z6L}Zy?HH*qLQ2oz5}Xjr0K9N|OgA}b5$rCjNf0mi1i=(9Yjr)10%5K8cu>vor;uDI_5+qC5h;dMCU1y6TBTQUNh^Rqh=u*Iq zY#uijY!E|ONoy8T1B})z;7(}!sam0gyzgPOhJfp^{nA3F2sa4@b7_Q>8zYZU2nEBa zLLR{ew^Y$_<`*i7at&GJRWKGjp&sPXQ@4;VT9&L#ww+vN(4&HgG)D!4$72_%fh963 z_z9{sEbW9q5~K@z#3+Ts*6otn4=XPQzlWXz$N`cjiOIkP0Tq>$EKYI=vxfs2`1Ana zntlMMsgz_>3N>JBQ4SwjW^3z|7j|>4K}HpXV(bn4lCAe0{33}l_9A|XMd=ru9D4!w z9eFp(>#BuBLiIX%^xV`eG(sU*Jo96eI%84t8bh^1j7~^EPBGNFVG(j3{^IMN=3}xq zaL?c$e=UFIRR12_2YU}W1Fh2ok=B(b_pf|&KY!)%{yoZ$C^}ExiTs_&mB;p5A32XP zmk(x6IqFKhfA2{rcH+|eb3YQsyZ-sz4d*fE_-VK(?nI8elH~4FTBO`PtuOwi{{2Az zBBLfAjkFH_KJ(+jKcc&j+IPS1#3NVE>^o2I4LWC9r>{JHB}NsaJAcDn1MePv+ZITgM0 zs~<@WVU5ddqnn)qkg<(TcPN;d>w(=NvaS zkXw-&QkvH-OWB=Y4MR-<&y< z1FvOw?L$<4dIH$NMevAtV?SOrYM)rby?kNKDb_`@473q+D`S`sb;pj~Tk z!O4UW6D4AkR3wRJ1{iz^?&A^itW3I+qUKk((cM z;s^Jh;qqy%(J$Ql1}^hA{xg&ObpFOKnJGv&LsuXnK*801bxqGYnj)>D{ zzn2zpA-QGm$kdVIqCA-bS-f3P7m`$Xzb-CxE z_fn@UEJa9LTkstk>cZ-4sVp&l*0_WKfl_?|IN2E(ZRWI3zlcAAo4)s0@H$;r$zofN+$^A;OIH1#m zdf!vR7?GED;?e^h!6l=W*4l-P!}N1R(={}$e6(ank@ZXT=A5}h2P#8Z4khmYsP zaWG_)j#gaTT)(+7L{}Tj9Gg(_vs1bCRir@R#K18={{e>}j&g4$?qPN@Z& zB%KhEQ@9d>@lHCCbDU3l=#FzunU&VYU#({}(xiMyuj|d`>iTO<9SP#o3lgK!8J;`{ z@R@ts1P3}~X@LX2+6d5s(ftY>Hb|_LKortidUWoe?OEJ}8wb=R;Nz=xzlZ}H?)+Dm zZ>iVm{yEuz=Nh~^JO~;QPad|IJNasJS!U0PfM2bDYD3STy2tbzD&D?|EK}-{DZQ!V zZcY8bGxdguBA{R5=HWA(B5`9VW*()hUo1nv0BaCvBt6r21}Y>vEpA+vymF~a1Q&5R zIWEG^Jpe!mFcFDfax}E33GX2YAOSrjNJ$p{&6tL$sN{`4e44b*eIBJpe@V_)`BS& z2`dKfgBaOcgMc1$7Xapty(p^9T#LU>JIKm<=Tsx2ozofZo5BkGk7?4HjJu>+X#!3{ zABmx3fwGiEf#g=?MT{$hbuXO7x3mHm^yl91h;iZZ?}GFjQf?x$1*+ zL%4f>ko(SIh~{vgDG1^o;N8GX0D!$ABe&KVBebP?OGBo}#ktL8oXKOQ2mduHNn)Sc zY+q|_Z;6eOYp&h$tAr|$2L0lB>#cM3(U;o3Pbq}JAh4BTfk5#w+049brX+al&3rGf ztL-1YTn}h(&QJC4z4qaCkKQYqopZ;3V3u6i5z{A7W|G%W^KBXU0HvxBPV$Ts%@Ocs z=rmTCfj)CEjxlc~)C0*NE_!g1yar?{7vTC(+lZL!rd^LCy^C!pN2^H*Fhj<*Ee+?s zWSYa04_1NPl_%hd;1lGh1`6P>Brb+iLs%MT%mdHiH3;0pj~TcRcaT;Lgur0P^gW!? z04iY=9ZHCb@&pcl3iIvor=I+wlW6AIHkXP+nvPGRlBRp(A<}e%R)0S7VIJ;6iS8G~ zhc|fQ$lOk<5xLZoFHO9%cZ`{Mo++p;h5PeNTnF!#i(E|l<=+dvNrjU92&I;$#kMKR z`G+DA9UMLySDHGS67K_wgCpu51!+e&l8k(BKlV{KWQbv?F7G8FX}H_-bi#?Y)qff8 zM^x|hGsn?b}H=Dkg?RE{gdxZfT z4xM9=u94~0U-RO2UOd2x!M#w=Lk(23P7bCxYblQc{FD_>dP{?J5S6z4G&RWkD2k@> zo|u@(TWeA4h%UH+06!Vm)r7F=y`DTX%^x^@@}@$ae49tT`xO25?VUeLKTH(-hehQ# zsBGZd^mlKRi#w0-B>4eL%wIgxdGzzQxr!Wx?L6w&z))d*k?ANOG{RR(%sYq!e&$s0 zeTOb<6PpMFPH!&00fECUY=k0KQo^EE%L-n}?#D1Zshas256?qmw1VB&tpJdAw*tAR z3u(QiW57YWAy3&Ne`&=(Pv=#_puNQxTi3`OV*;ccn6u&h+rv|AlYVAqN@c3&YS_86 zQKZ-McH9_@MyfUV4I}?2x)$v#-1z0v|N3dGlNL7L`_n@HIQ9UMYligDd?&ixKKSvRh^+li|93ml!Q|0Wqxkvm_E_UrIS`4J=b2;`rXzD9m%^_|G{l^sX~-2GN?GKkJK=_b!xc z2}1MIlsu=5xqtBDcc-R!qK9)^v~NSFgUHLWf>>lEFoyetBI;@qpO0Cn(4v|95@_9J zWI*;svWLj|M%?`71EeK*O?dN-%f0>^gR%bn-ov6f2BL+}cmKSQ(d_%5c=bLK^XdAW z4(Z74+F$f}1>#)&^vETAQHegP6q%zhD@DnZCe)TMJh8v?2c#@8SNgEcqMF31*MR#8 z&eEX57!NzKpx8s7F#>AQxkG=MumfVfu4@Sr!Tb7-NE|~rkk5>xtMKdC7pjPG)r|)j%qj3*q#_#RMn%40wZ9T2 zJ<{z~r0?{2{@jq>(qBGuhr-@wDhtE_{xXfBDTJ(Z|qmN3^gfbEQSvxlBLd37JR>>;(0?U z>m6Ti43+7xK*Y`Mf;5lSwwE_yPj9d*5AVRa95{`=jgLsdyN6yY_;gBr38#Kp;c7CI zeMcdk(W+K5FTK?D03YC?=Ws`>=kc*eI+FJ~K0q#Rd}R@*$Jg*J$;~bLvW@>` zMNL$ipvjt1t^=>@(-pdse~Mcd@QGuWCxQnidYAGs3bz~c5QJIX&l`42gZVJ#EE3xO zU@xfKa3DsghpOx8^g3PWRt%PgveDdDr5Jj}%U#i}7y(0F5{kNl6pURu7R&R7m=+5@ z&$9{!4s8(~Aon75x@n?VZ63L+6ZTlT0}i;a^y`MXrb|pGRIrlkpV6fugLmjyU{$GRk=iu+w3-g8L4OM{2Kh#BzsN$g=%m;x+J znuIQ>@;b*c6uBrDGo=g$NWVq=(ydDzLMqgsmX+V~p7=H=Z0qn-Z@-oQ&=s=@R`c)q*dW%^Hc#qGCu+3c)a&mHqD{&km4qfKeg zT!YzJDKpovSD8y6nI3E3YmcUT?B#T?JgD!ab9u}LISP>NSPROTECTION.;21 30480 changes to%: (FNS NSPROT.FETCH.PROTECTION NSPROT.SET.TO.DEFAULT NSPROT.TOP.LEVELP) (VARS NSPROTECTIONCOMS) previous date%: " 2-Sep-87 15:03:55" {ERIS}LISP>NSPROTECTION.;20) (* " Copyright (c) 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSPROTECTIONCOMS) (RPAQQ NSPROTECTIONCOMS ((COMS (* ; "Main window selection handlers") (FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND) (FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST NSPROT.EXPAND.FULLNAME)) (COMS (* ; "Handle protection submenus") (FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE)) (COMS (* ; "utilities") (FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN)) (INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT) (VARS NSPROT.ICON) (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) (LOCALVARS . T) (COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)))) (FNS ADD.NSPROTECTION) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION)))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NSPROT.PROMPT)))) ) (* ; "Main window selection handlers") (DEFINEQ (NSPROTECTION (LAMBDA NIL (* ; "Edited 1-Sep-87 10:31 by bvm:") (* ;; "Main entry--create the NS protection tool main window and prompt window.") (LET* ((PLAINFONT (NSPROT.GET.FONT)) (BOLDFONT (NSPROT.GET.FONT T)) (HEIGHTDIFFERENCE (- (FONTPROP BOLDFONT (QUOTE HEIGHT)) (FONTPROP PLAINFONT (QUOTE HEIGHT)))) (W (FREEMENU (BQUOTE ((PROPS COLUMNSPACE 14 FONT (\, BOLDFONT)) ((LABEL "Show" SELECTEDFN NSPROT.SHOW MESSAGE "Show the current protection of the specified directory/file.") (LABEL "New Entry" SELECTEDFN NSPROT.NEW.ENTRY MESSAGE "Add a new protection entry (you fill it in).") (LABEL "Apply" SELECTEDFN NSPROT.APPLY MESSAGE "Apply the indicated protections to the file.") (LABEL "Set to Default" SELECTEDFN NSPROT.SET.TO.DEFAULT MESSAGE "Make the file inherit protection from its parent (sub)directory." MAXWIDTH 275)) ((PROPS COLUMNSPACE 4) (LABEL "Type:" TYPE STATE CHANGESTATE NSPROT.HANDLE.TYPE INITSTATE "Principal" MESSAGE "Show directory's own protection, or default for its children? (can be different)" ID TYPE LINKS (DISPLAY PROTECTION-TYPE)) (LABEL "" TYPE DISPLAY ID PROTECTION-TYPE FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "Children Only " PLAINFONT))) (LABEL "Check:" TYPE STATE CHANGESTATE NSPROT.HANDLE.VERIFY INITSTATE "New Names Only" MESSAGE "Check names in protection entries against Clearinghouse?" ID CHECK LINKS (DISPLAY VERIFYFLG)) (LABEL "" TYPE DISPLAY ID VERIFYFLG FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "New Names Only" PLAINFONT)))) ((PROPS COLUMNSPACE (\, (+ 6 (- (STRINGWIDTH "Dir/File:" BOLDFONT) (STRINGWIDTH "Host:" BOLDFONT))))) (LABEL "Host:" TYPE EDITSTART MESSAGE "Fill in the name of the NS file server" LINKS (EDIT HOST)) (LABEL (\, (CONCAT)) TYPE EDIT ID HOST LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))) ((PROPS COLUMNSPACE 6) (LABEL "Dir/File:" TYPE EDITSTART MESSAGE "Fill in the name of the desired directory or file." LINKS (EDIT DIR)) (LABEL (\, (CONCAT)) TYPE EDIT ID DIR LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))))) "NS File Protection Tool")) (REG (WINDOWREGION W)) PW) (* ;; "The HEIGHTDIFFERENCE hacking is to get the baselines of the bold and plain fonts to line up (odd that they don't already). (CONCAT) instead of %"%" to ease my pain of debugging--otherwise, the edit items would all be fat, and Lyric's Courier doesn't handle that gracefully.") (WINDOWPROP W (QUOTE FM.DONTRESHAPE) T) (WINDOWPROP W (QUOTE MINSIZE) (CONS (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG))) (* ; "Don't let window shape any smaller than it is.") (WINDOWPROP W (QUOTE VERIFYFLG) :NEW) (WINDOWPROP W (QUOTE PROTECTION-TYPE) T) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION NSPROT.ICONFN)) (MOVEW W (GETBOXPOSITION (fetch (REGION WIDTH) of REG) (+ (fetch (REGION HEIGHT) of REG) (HEIGHTIFWINDOW (FONTPROP PLAINFONT (QUOTE HEIGHT)))))) (OPENW W) (SETQ PW (GETPROMPTWINDOW W NIL PLAINFONT)) (* ; "Arrange for prompt window to expand itself by one line at a time if it overflows") (WINDOWPROP PW (QUOTE PAGEFULLFN) (QUOTE NSPROT.PAGEFULLFN)) (WINDOWPROP W (QUOTE FM.PROMPTWINDOW) PW) NIL)) ) (NSPROT.SHOW (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 1-Sep-87 10:50 by bvm:") (LET ((DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) OLDWINDOWS) (if DEV&FILESPEC then (NSPROT.REMOVE.SUBMENUS WINDOW) (CL:MULTIPLE-VALUE-BIND (PROT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.FETCH.PROTECTION WINDOW DEV FILESPEC))) (if CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION) ELSE (for P in PROT do (NSPROT.SHOW.PROT.VALUE P WINDOW))) (NSPROT.RESTORE.VERIFY WINDOW))))) ) (NSPROT.FETCH.PROTECTION (LAMBDA (WINDOW DEV FILESPEC) (* ; "Edited 20-Nov-87 12:27 by bvm:") (* ;; "Return the access list of FILESPEC on DEV of the flavor requested by window (or implicitly by the filespec being a non-directory). This fn prints its own messages when the defaulting is interesting.") (if (SETQ FILESPEC (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) then (LET* ((TYPE (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE ACCESS.LIST))) (DIRP (NSPROT.DIRECTORY.SYNTAXP FILESPEC)) (DESIREDPROPS (if DIRP then (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)) (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST)))) else (LIST (\FILING.ATTRIBUTE.TYPE TYPE)))) (PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) PROT OTHER) (DECLARE (CL:SPECIAL DESIREDPROPS)) (* ; "Go thru internal filing interface in order to intercept errors and get more than one attribute at once. DESIREDPROPS is used free under \nsfiling.get/setinfo.") (if (EQ (CAR PROPS) (QUOTE ERROR)) then (NSPROT.PROMPT WINDOW "Failed: ~A" (CADDR PROPS)) elseif (NULL (SETQ PROT (CADR (ASSOC TYPE PROPS)))) then (NSPROT.PROMPT WINDOW "Failed to fetch protection.") else (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ OTHER (CADR (ASSOC (QUOTE DEFAULT.ACCESS.LIST) PROPS))) (NOT (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))) then (* ; "We're fetching the principal access list for a directory, but it has a non-defaulted DEFAULT.ACCESS.LIST, so warn user") (NSPROT.PROMPT WINDOW "Note: this ~:[~;protection is inherited, but the ~]directory has a separate default protection for its children." (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT)) elseif (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT) then (* ; "defaulted value, explain.") (if (EQ TYPE (QUOTE ACCESS.LIST)) then (NSPROT.PROMPT WINDOW "The protection shown is inherited from the parent.") else (NSPROT.PROMPT WINDOW "This is the directory's principal protection~:[~;, which is itself inherited~]." (AND (SETQ OTHER (CADR (ASSOC (QUOTE ACCESS.LIST) PROPS))) (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))))) (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (NSPROT.TOP.LEVELP FILESPEC)) then (* ; "Top-level directory, also give usage stats.") (SETQ DESIREDPROPS (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE)) (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE.LIMIT))))) (SETQ PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) (if (AND PROPS (NEQ (CAR PROPS) (QUOTE ERROR))) then (LET ((USED (CADR (ASSOC (QUOTE SUBTREE.SIZE) PROPS))) (LIMIT (CADR (ASSOC (QUOTE SUBTREE.SIZE.LIMIT) PROPS)))) (NSPROT.PROMPT WINDOW "~&Directory contains ~D pages ~:[(unlimited allocation)~;out of ~:*~D allocated~]" (FOLDHI USED BYTESPERPAGE) (AND (>= LIMIT 0) (FOLDHI LIMIT BYTESPERPAGE)))))) (COURIER.FETCH (FILING . ACCESS.LIST) ENTRIES of PROT))))) ) (NSPROT.NEW.ENTRY (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 16:14 by bvm:") (* ;; "Handles the NEW ENTRY button -- adds another protection entry and starts editing the name field of it") (NSPROT.BEGIN.COMMAND WINDOW) (LET* ((SUBW (NSPROT.GET.SUBMENU WINDOW)) (NAMEITEM (FM.GETITEM (QUOTE NAME) NIL SUBW))) (FM.CHANGESTATE (FM.GETITEM (QUOTE READ) NIL SUBW) T SUBW) (* ; "Initial protection = READ") (FM.CHANGELABEL NAMEITEM (CONCAT) SUBW) (* ; "Initial name is empty") (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) NIL) (* ; "erase any previous cache") (NSPROT.ADD.SUBMENU SUBW WINDOW) (FM.EDITITEM NAMEITEM SUBW))) ) (NSPROT.APPLY (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 14:38 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm setting the displayed protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) (SETQ PROT (NSPROT.PARSE.PROTECTIONS WINDOW))) then (if (AND (NULL (SETQ PROT (CAR PROT))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW "Can't set empty protection.") elseif (AND (for PAIR in PROT never (MEMB (QUOTE OWNER) (CADR PAIR))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW T "Can't: Somebody must retain owner access.") else (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC PROT))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION)))) (NSPROT.RESTORE.VERIFY WINDOW)))) ) (NSPROT.SET.PROTECTION (LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 31-Aug-87 18:22 by bvm:") (if (STRPOS "*" FILESPEC) then (NSPROT.SET.MULTIPLE WINDOW DEV FILESPEC PROT) elseif (NULL (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) elseif (NSPROT.SET.PROTECTION.ONE DEV FILESPEC PROT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) then (NSPROT.PROMPT WINDOW "Done, ~:[~;children's default ~]protection set ~A." (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (if (EQ PROT T) then "to default" else "as shown")) else (NSPROT.PROMPT WINDOW "Failed to set protection."))) ) (NSPROT.SET.PROTECTION.ONE (LAMBDA (DEV FILESPEC PROT DEFAULTP) (* ; "Edited 27-Aug-87 13:51 by bvm:") (* ;; "Performs the filing call that sets the protection of FILESPEC on DEV to be PROT. PROT=T means default protection. DEFAULTP = NIL means access, T means default access.") (if (EQ PROT T) then (* ; "Set to default protection. Can't do this in the obvious way, because the PROTECTION attribute hides the hair about defaulted") (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))) else (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)))) (CONSTANT (COURIER.WRITE.REP (COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T) (QUOTE FILING) (QUOTE ACCESS.LIST))) DEV) else (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE PROTECTION)) PROT DEV))) ) (NSPROT.SET.MULTIPLE (LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 27-Aug-87 15:29 by bvm:") (if (NSPROT.RESTORE.TYPE WINDOW) then (NSPROT.PROMPT WINDOW "(Will set Principal protection) ")) (NSPROT.PROMPT WINDOW "Enumerating...") (LET ((FILES (RESETLST (LET* ((FILING.ENUMERATION.DEPTH MAX.SMALLP) (GEN (\GENERATEFILES FILESPEC (QUOTE (FILE.ID)) (QUOTE (RESETLST)))) FILE) (DECLARE (CL:SPECIAL FILING.ENUMERATION.DEPTH)) (* ; "sets depth to infinity without telling the generator to filter out directories.") (while (SETQ FILE (\GENERATENEXTFILE GEN)) collect (NSPROT.PROMPT WINDOW T "~A" (SETQ FILE (CDR (NSPROT.STRIP.HOST FILE)))) (LIST (\GENERATEFILEINFO GEN (QUOTE FILE.ID)) (\GENERATEFILEINFO GEN (QUOTE IS.DIRECTORY)) FILE)))))) (if (NULL FILES) then (NSPROT.PROMPT WINDOW "no files match the pattern.") else (NSPROT.PROMPT WINDOW T "Setting...") (for F in FILES bind (OK _ 0) (FAILED _ 0) do (* ;; "Set explicit protection for file with this id. If it's a directory, also set its default access list to defaulted.") (if (AND (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) PROT) (OR (NULL (CADR F)) (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) T T))) then (add OK 1) else (add FAILED 1) (NSPROT.PROMPT WINDOW T "Failed on ~A" (CADDR F))) finally (NSPROT.PROMPT WINDOW T "Done, set ~A on ~D files~:[~; out of ~D~]." (if (EQ PROT T) then "default protection" else "the displayed protection") OK (NEQ FAILED 0) (+ OK FAILED)))))) ) (NSPROT.SET.TO.DEFAULT (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm restoring the file to inherited protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW))) then (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (if (AND (NSPROT.TOP.LEVELP FILESPEC) (NOT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) THEN (* ; "Dangerous operation!") (NSPROT.PROMPT WINDOW "Can't set top-level directory to default protection.") ELSE (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC T)))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION))) (NSPROT.RESTORE.VERIFY WINDOW)))) ) (NSPROT.BEGIN.COMMAND (LAMBDA (WINDOW) (* ; "Edited 20-Aug-87 17:35 by bvm:") (* ;; "Begin a new command. Clear old prompt window, if any, and stop any editing.") (LET ((PW (GETPROMPTWINDOW WINDOW NIL NIL T))) (AND PW (CLEARW PW))) (FM.ENDEDIT WINDOW) (for W in (WINDOWPROP WINDOW (QUOTE PROTMENUS)) do (FM.ENDEDIT W)) (if (EQ (GETSTREAM WINDOW) (TTYDISPLAYSTREAM)) then (* ; "Bug--freemenu leaves this guy being the ttydisplaystream") (TTYDISPLAYSTREAM \DEFAULTTTYDISPLAYSTREAM))) ) ) (DEFINEQ (NSPROT.HANDLE.TYPE (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 13:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) (SELECTQ (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (T (SETQ LABEL "Principal") NIL) (NIL (SETQ LABEL "Children Only") T) (SHOULDNT))) LABEL)) ) (NSPROT.RESTORE.TYPE (LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 13:56 by bvm:") (* ;; "Replace the %"children only%" state with %"Principal%"--do this when working on a non-directory. Returns T if it changed.") (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) NIL) then (FM.CHANGESTATE (FM.GETITEM (QUOTE TYPE) NIL WINDOW) "Principal" WINDOW) T)) ) (NSPROT.HANDLE.VERIFY (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 14:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) (SELECTQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) (:NEW (SETQ LABEL "All Names") T) (T (SETQ LABEL "Don't") NIL) (NIL (SETQ LABEL "I really mean it") :NO) (:NO (SETQ LABEL "New Names Only") :NEW) (SHOULDNT))) LABEL)) ) (NSPROT.RESTORE.VERIFY (LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 15:11 by bvm:") (* ;; "Replace the %"I really mean it%" state with a better one.") (if (EQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO) then (FM.CHANGESTATE (FM.GETITEM (QUOTE CHECK) NIL WINDOW) "New Names Only" WINDOW) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) :NEW))) ) (NSPROT.PARSE.FILENAME (LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (NSPROT.BEGIN.COMMAND WINDOW) (PROG ((STATE (FM.GETSTATE WINDOW)) HOST FILENAME FULLNAME HOST&FILE FULLHOST DEV) (for TL on STATE by (CDDR TL) do (SELECTQ (CAR TL) (HOST (SETQ HOST (CADR TL))) (DIR (SETQ FILENAME (CADR TL))) NIL)) (if (OR (NULL FILENAME) (EQ (NCHARS FILENAME) 0)) then (NSPROT.PROMPT WINDOW "No directory or file name was specified.") (RETURN NIL)) (if (SETQ HOST&FILE (NSPROT.STRIP.HOST FILENAME)) then (* ;; "User gave a full file name including host in the %"Dir/File%" field. Separate them out now.") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) (SETQ FILENAME (CDR HOST&FILE)) WINDOW) (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) (SETQ HOST (CAR HOST&FILE)) WINDOW)) (if (OR (NULL HOST) (EQ (NCHARS HOST) 0)) then (NSPROT.PROMPT WINDOW "No host was specified.") (RETURN NIL)) (SETQ FULLHOST (CAR (LOOKUP.NS.SERVER HOST NIL T))) (if (NOT (STRING-EQUAL HOST (SETQ HOST (NSNAME.TO.STRING (OR FULLHOST (PARSE.NSNAME HOST)) T)))) then (* ;; "Show fully-qualified name, either from lookup or from parse. In latter case, we may be reminding user of default domain.") (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) HOST WINDOW)) (if (NEQ (CHCON1 FILENAME) (CHARCODE "<")) then (SETQ FILENAME (CONCAT "<" FILENAME)) (if (NOT (STRPOS ">" FILENAME 2)) then (SETQ FILENAME (CONCAT FILENAME ">"))) (* ; "Show modified file name") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) FILENAME WINDOW)) (if (OR (NOT FULLHOST) (NULL (SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (CONCAT "{" HOST "}" FILENAME)) T)))) then (NSPROT.PROMPT WINDOW "Server ~A not found." HOST) (RETURN NIL)) (RETURN (CONS DEV FULLNAME)))) ) (NSPROT.PARSE.PROTECTIONS (LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (* ;; "Parse and as necessary validate the protection entries attached to WINDOW, returning a valid PROTECTION value, or NIL if something is wrong.") (LET ((PROTWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS))) (VERIFYFLG (WINDOWPROP WINDOW (QUOTE VERIFYFLG))) WHO HOW NSWHO OLDWHO FULLNAME DEADWINDOWS PROT VERIFIEDNAME) (for W in PROTWINDOWS do (SETQ WHO NIL) (SETQ HOW (for TAIL on (FM.GETSTATE W) by (CDDR TAIL) when (SELECTQ (CAR TAIL) ((READ WRITE ADD REMOVE OWNER) (CADR TAIL)) (NAME (SETQ WHO (CADR TAIL)) NIL) NIL) collect (CAR TAIL))) (if (NOT (AND HOW WHO (> (NCHARS WHO) 0))) then (* ; "No protection, remove this guy") (push DEADWINDOWS W) elseif (AND (NEQ VERIFYFLG T) (STREQUAL WHO (CAR (SETQ OLDWHO (WINDOWPROP W (QUOTE KNOWN-VALUE)))))) then (* ;; "This name hasn't been changed since we put it up, so use the parse that's there. We're assuming that not having to validate old protection names makes up for occasionally reinstalling a bogus name that just happened to be there.") (push PROT (LIST (CADR OLDWHO) HOW)) else (SETQ NSWHO (PARSE.NSNAME WHO)) (if (NOT (STREQUAL WHO (SETQ WHO (NSNAME.TO.STRING (OR (SETQ FULLNAME (if (SELECTQ VERIFYFLG ((NIL :NO) T) (STRPOS "*" WHO)) then (* ; "for now, accept any pattern") NSWHO else (* ; "get canonical name") (SETQ VERIFIEDNAME (CH.LOOKUP.OBJECT NSWHO)))) NSWHO) T)))) then (* ; "Show our parse or canonical name") (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL W) WHO W)) (if FULLNAME then (* ; "good name") (SETQ NSWHO FULLNAME) (if VERIFIEDNAME then (* ; "Remember this parse") (WINDOWPROP W (QUOTE KNOWN-VALUE) (LIST WHO VERIFIEDNAME HOW))) else (NSPROT.PROMPT WINDOW "~A not a registered name." WHO) (RETURN NIL)) (push PROT (LIST NSWHO HOW))) finally (if DEADWINDOWS then (* ; "Remove the windows showing no entry") (LET ((LASTDEAD (CAR DEADWINDOWS)) LOWERWINDOWS) (* ; "First detach everything up to the last dead one.") (for OLDW in PROTWINDOWS do (DETACHWINDOW OLDW) (if (MEMB OLDW DEADWINDOWS) then (CLOSEW OLDW) else (push LOWERWINDOWS OLDW)) repeatuntil (EQ OLDW LASTDEAD)) (* ; "Now reattach the good ones") (for OLDW in LOWERWINDOWS do (ATTACHWINDOW OLDW WINDOW (QUOTE BOTTOM))) (* ; "Add the dead ones to scratch heap") (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND DEADWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))) (WINDOWPROP WINDOW (QUOTE PROTMENUS) (CL:SET-DIFFERENCE PROTWINDOWS DEADWINDOWS)))) (RETURN (LIST PROT))))) ) (NSPROT.STRIP.HOST (LAMBDA (FILENAME) (* ; "Edited 20-Aug-87 14:17 by bvm:") (* ;; "Strips the host field off the front of FILENAME and returns a dotted pair (host . restOfName).") (PROG (I) (RETURN (AND (SETQ I (STRPOS (SELCHARQ (CHCON1 FILENAME) ({ "}") ("[" "]") ("(" ")") (RETURN NIL)) FILENAME 2)) (CONS (SUBSTRING FILENAME 2 (SUB1 I)) (SUBSTRING FILENAME (ADD1 I))))))) ) (NSPROT.EXPAND.FULLNAME (LAMBDA (WINDOW DEV FILENAME) (* ; "Edited 27-Aug-87 15:19 by bvm:") (* ;; "Looks up FILENAME on DEV, returning the full name (sans host). WINDOW is the window in which FILENAME is the DIR item--we will change it if appropriate. Returns NIL on file not found.") (LET ((FULLNAME (\NSFILING.GETFILE DEV FILENAME (QUOTE NONE) (QUOTE OLD) (QUOTE HANDLE) (FUNCTION \NSFILING.FULLNAME) T)) STRIPPED-NAME) (if (NULL FULLNAME) then (NSPROT.PROMPT WINDOW "~A not found." (if (NSPROT.DIRECTORY.SYNTAXP FILENAME) then "Directory" elseif (STRPOS ">" FILENAME) then (* ; "Looks like a file") "File" else (* ; "Could be either if they were sloppy") "Directory/file")) NIL else (SETQ STRIPPED-NAME (CDR (NSPROT.STRIP.HOST FULLNAME))) (if (NOT (STREQUAL STRIPPED-NAME FILENAME)) then (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) STRIPPED-NAME WINDOW)) (if (NOT (NSPROT.DIRECTORY.SYNTAXP FULLNAME)) then (* ; "Force Principal protection, since non-directories don't have a default access list.") (NSPROT.RESTORE.TYPE WINDOW)) FULLNAME))) ) ) (* ; "Handle protection submenus") (DEFINEQ (NSPROT.GET.SUBMENU (LAMBDA (MAINWINDOW) (* ; "Edited 26-Aug-87 18:03 by bvm:") (LET ((SUBW (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS))) HEIGHT) (if SUBW then (* ; "Return a cached window to avoid overhead of creating a whole new freemenu. Don't forget to clear the old one out!") (PROG1 (NSPROT.CHANGE.STATE (CAR SUBW) NIL) (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS) (CDR SUBW))) else (SETQ SUBW (FREEMENU (BQUOTE ((PROPS FONT (\, (NSPROT.GET.FONT)) COLUMNSPACE 5) ((LABEL "Read" ID READ TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Read: User may read (if a file) or enumerate (if a directory)") (LABEL "Wrt" ID WRITE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Write: User may write/change/delete the file.") (LABEL "Add" ID ADD TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Add: User can create files in the directory.") (LABEL "Del" ID REMOVE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Delete: User can remove files from the directory.") (LABEL "Own" ID OWNER TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Owner: User can change the protection.") (LABEL "All" ID ALL TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.ALL MESSAGE NSPROT.MESSAGE.ALL) (LABEL " to:" ID TO TYPE EDITSTART MESSAGE "Fill in name (user or group) or pattern (*:Domain)." FONT (\, (NSPROT.GET.FONT T)) LINKS (EDIT NAME)) (LABEL (\, (CONCAT)) TYPE EDIT ID NAME)))) NIL NIL 3)) (WINDOWPROP SUBW (QUOTE FM.DONTRESHAPE) T) (* ; "Don't want any extra space added between columns when the window gets wider--add it all on the right.") (WINDOWPROP SUBW (QUOTE MINSIZE) (CONS 0 (SETQ HEIGHT (fetch (REGION HEIGHT) of (WINDOWPROP SUBW (QUOTE REGION)))))) (WINDOWPROP SUBW (QUOTE MAXSIZE) (CONS MAX.SMALLP HEIGHT)) (WINDOWPROP SUBW (QUOTE FM.PROMPTWINDOW) (GETPROMPTWINDOW MAINWINDOW)) SUBW))) ) (NSPROT.ADD.SUBMENU (LAMBDA (MENUW MAINWINDOW) (* ; "Edited 20-Aug-87 10:13 by bvm:") (* ;; "Appends MENUW to MAINWINDOW's set of protection value entries") (ATTACHWINDOW MENUW MAINWINDOW (QUOTE BOTTOM)) (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS) (CONS MENUW (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS))))) ) (NSPROT.REMOVE.SUBMENUS (LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 12:34 by bvm:") (* ;; "Removes all the submenus (protection entries) from WINDOW, adding them to the scratch list for the window.") (LET ((OLDWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS) NIL))) (for W in OLDWINDOWS do (DETACHWINDOW W) (CLOSEW W)) (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND OLDWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))))) ) (NSPROT.CHANGE.STATE (LAMBDA (WINDOW NEWSTATE) (* ; "Edited 19-Aug-87 16:15 by bvm:") (* ;; "Change all the protection buttons to the specified state") (for ID in (QUOTE (READ WRITE ADD REMOVE OWNER ALL)) do (FM.CHANGESTATE (FM.GETITEM ID NIL WINDOW) NEWSTATE WINDOW)) WINDOW) ) (NSPROT.HANDLE.ALL (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 16:16 by bvm:") (* ;; "Called when ALL is selected--turn all protection bits to the specified state") (NSPROT.CHANGE.STATE WINDOW (FM.ITEMPROP ITEM (QUOTE STATE)))) ) (NSPROT.MESSAGE.ALL (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Aug-87 14:15 by bvm:") (* ;; "Called when ALL is held--return appropriate help message") (if (FM.ITEMPROP ITEM (QUOTE STATE)) then "Deny user all access rights" else "Grant user all 5 access rights")) ) (NSPROT.HANDLE.SUBTYPE (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 14:46 by bvm:") (LET ((OTHER (FM.GETITEM (QUOTE ALL) NIL WINDOW))) (if (FM.ITEMPROP OTHER (QUOTE STATE)) then (* ; "If the ALL button was on, turn it off") (FM.CHANGESTATE OTHER NIL WINDOW)) (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) ((WRITE ADD) (* ; "these accesses really need READ as well") (if (AND (FM.ITEMPROP ITEM (QUOTE STATE)) (NOT (FM.ITEMPROP (SETQ OTHER (FM.GETITEM (QUOTE READ) NIL WINDOW)) (QUOTE STATE)))) then (FM.CHANGESTATE OTHER T WINDOW))) NIL))) ) (NSPROT.SHOW.PROT.VALUE (LAMBDA (ENTRY MAINWINDOW) (* ; "Edited 24-Aug-87 16:16 by bvm:") (DESTRUCTURING-BIND (NAME TYPES) ENTRY (LET ((SUBW (NSPROT.GET.SUBMENU MAINWINDOW)) (STRINGNAME (NSNAME.TO.STRING NAME T)) ITEM) (for P in TYPES do (FM.CHANGESTATE (OR (SETQ ITEM (FM.GETITEM P NIL SUBW)) (HELP "Bad protection value" P)) T SUBW) (if (EQ P (QUOTE ALL)) then (NSPROT.HANDLE.ALL ITEM SUBW))) (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL SUBW) STRINGNAME SUBW) (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) (CONS STRINGNAME ENTRY)) (* ; "Save the parse of this value so we can avoid worrying about it later.") (NSPROT.ADD.SUBMENU SUBW MAINWINDOW) SUBW))) ) ) (* ; "utilities") (DEFINEQ (NSPROT.DIRECTORY.SYNTAXP (LAMBDA (FILENAME) (* ; "Edited 27-Aug-87 14:53 by bvm:") (* ; "True if FILENAME looks like a directory") (EQ (NTHCHARCODE FILENAME -1) (CHARCODE ">"))) ) (NSPROT.TOP.LEVELP (LAMBDA (FILESPEC) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (I) (NOT (AND (SETQ I (STRPOS ">" FILESPEC)) (NEQ I (NCHARS FILESPEC)))))) ) (NSPROT.GET.FONT (LAMBDA (BOLDP) (* ; "Edited 1-Sep-87 17:23 by bvm:") (if BOLDP then (OR NSPROT.BOLD.FONT (SETQ NSPROT.BOLD.FONT (FONTCOPY (NSPROT.GET.FONT) (QUOTE WEIGHT) (QUOTE BOLD)))) elseif NSPROT.PLAIN.FONT elseif (> (FONTHEIGHT (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 10))) 12) then (* ; "Yes, this is the one I had in mind (10 pt coerced to 12)") NSPROT.PLAIN.FONT else (* ; "The %"real%" 12 pt display font is about the right size.") (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 12)))) ) (NSPROT.PROMPT (LAMBDA WINDOW&ARGS (* ; "Edited 2-Sep-87 14:12 by bvm:") (LET* ((*PRINT-CASE* :UPCASE) (WINDOW (GETPROMPTWINDOW (ARG WINDOW&ARGS 1))) (ARGS (for J from (if (EQ (ARG WINDOW&ARGS 2) T) then (* ; "First arg of T means clear window first.") (CLEARW WINDOW) 3 else 2) to WINDOW&ARGS collect (ARG WINDOW&ARGS J)))) (RESETFORM (TTYDISPLAYSTREAM WINDOW) (* ; "Unfortunately, have to make it the tty to get pagefullfn action.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW ARGS)) NIL)) ) (NSPROT.LIMITCHARS (LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Aug-87 12:00 by bvm:") (SELECTQ CHAR ((% Â) (FM.SKIPNEXT WINDOW) NIL) T))) (NSPROT.PAGEFULLFN (LAMBDA (PW) (* ; "Edited 27-Aug-87 17:11 by bvm:") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (GETPROMPTWINDOW (MAINWINDOW PW) (+ 2 \CURRENTDISPLAYLINE)) (* ; "\Currentdisplayline is the line we're on when window fills, origin zero")))) ) (NSPROT.ICONFN (LAMBDA (WINDOW OLDICON) (* ; "Edited 1-Sep-87 10:29 by bvm:") (LET ((HOST (FM.ITEMPROP (FM.GETITEM (QUOTE HOST) NIL WINDOW) (QUOTE LABEL)))) (SETQ HOST (if (AND HOST (NEQ (NCHARS HOST) 0) (SETQ HOST (PARSE.NSNAME HOST))) then (fetch NSOBJECT of HOST) else "")) (* ; "show host's main name") (if OLDICON then (ICONW.TITLE OLDICON HOST) OLDICON else (TITLEDICONW NSPROT.ICON HOST (NSPROT.GET.FONT))))) ) ) (RPAQ? NSPROT.PLAIN.FONT NIL) (RPAQ? NSPROT.BOLD.FONT NIL) (RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO NIL (4 22 51 14)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) ) (DEFINEQ (ADD.NSPROTECTION (LAMBDA (LST) (* ; "Edited 2-Sep-87 11:53 by bvm:") (* ;; "Add an entry for the NSPROTECTION tool to the background menu") (for X in (if LST then (* ; "Mumbling thru sub items") (CDR LST) else (SETQ LST BackgroundMenuCommands)) bind (COM _ (QUOTE ("NS Protection" (QUOTE (NSPROTECTION)) "Start up the NS File protection tool."))) do (if (STRING-EQUAL (CAR X) "NS Protection") then (RETURN (RPLACD X (CDR COM))) elseif (AND (STRING-EQUAL (CAR X) "System") (CADDDR X)) then (RETURN (ADD.NSPROTECTION (CADDDR X)))) finally (NCONC1 LST COM)) (SETQ BackgroundMenu NIL) (* ; "also, load fonts") (NSPROT.GET.FONT T) (COND ((CCODEP (QUOTE ADD.NSPROTECTION)) (* ; "self destruct") (AND (PUTD (QUOTE ADD.NSPROTECTION)))))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADD.NSPROTECTION) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA NSPROT.PROMPT) ) (PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1808 14263 (NSPROTECTION 1818 . 5004) (NSPROT.SHOW 5006 . 5524) ( NSPROT.FETCH.PROTECTION 5526 . 8468) (NSPROT.NEW.ENTRY 8470 . 9093) (NSPROT.APPLY 9095 . 10024) ( NSPROT.SET.PROTECTION 10026 . 10602) (NSPROT.SET.PROTECTION.ONE 10604 . 11480) (NSPROT.SET.MULTIPLE 11482 . 12957) (NSPROT.SET.TO.DEFAULT 12959 . 13771) (NSPROT.BEGIN.COMMAND 13773 . 14261)) (14264 21296 (NSPROT.HANDLE.TYPE 14274 . 14574) (NSPROT.RESTORE.TYPE 14576 . 14927) (NSPROT.HANDLE.VERIFY 14929 . 15289) (NSPROT.RESTORE.VERIFY 15291 . 15622) (NSPROT.PARSE.FILENAME 15624 . 17353) ( NSPROT.PARSE.PROTECTIONS 17355 . 19850) (NSPROT.STRIP.HOST 19852 . 20233) (NSPROT.EXPAND.FULLNAME 20235 . 21294)) (21340 25891 (NSPROT.GET.SUBMENU 21350 . 23154) (NSPROT.ADD.SUBMENU 23156 . 23463) ( NSPROT.REMOVE.SUBMENUS 23465 . 23885) (NSPROT.CHANGE.STATE 23887 . 24169) (NSPROT.HANDLE.ALL 24171 . 24413) (NSPROT.MESSAGE.ALL 24415 . 24687) (NSPROT.HANDLE.SUBTYPE 24689 . 25234) ( NSPROT.SHOW.PROT.VALUE 25236 . 25889)) (25918 28228 (NSPROT.DIRECTORY.SYNTAXP 25928 . 26112) ( NSPROT.TOP.LEVELP 26114 . 26276) (NSPROT.GET.FONT 26278 . 26797) (NSPROT.PROMPT 26799 . 27291) ( NSPROT.LIMITCHARS 27293 . 27434) (NSPROT.PAGEFULLFN 27436 . 27802) (NSPROT.ICONFN 27804 . 28226)) ( 29447 30196 (ADD.NSPROTECTION 29457 . 30194))))) STOP \ No newline at end of file diff --git a/lispusers/NSPROTECTION.~2~ b/lispusers/NSPROTECTION.~2~ deleted file mode 100644 index b935d63b..00000000 --- a/lispusers/NSPROTECTION.~2~ +++ /dev/null @@ -1,225 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Sep-89 12:31:44" "{piglet/n}vanmelle>lispusers>nsprotection;4" 31274 - - changes to%: (FNS NSPROT.SET.MULTIPLE)) - - -(* " -Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT NSPROTECTIONCOMS) - -(RPAQQ NSPROTECTIONCOMS ((COMS (* ; "Main window selection handlers") (FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND) (FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST NSPROT.EXPAND.FULLNAME)) (COMS (* ; "Handle protection submenus") (FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE)) (COMS (* ; "utilities") (FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT NSPROT.CLEAR.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN)) (INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT) (VARS NSPROT.ICON) (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) (LOCALVARS . T) (COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)))) (FNS ADD.NSPROTECTION) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION)))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NSPROT.PROMPT))))) - - - -(* ; "Main window selection handlers") - -(DEFINEQ - -(NSPROTECTION -(LAMBDA NIL (* ; "Edited 1-Sep-87 10:31 by bvm:") (* ;; "Main entry--create the NS protection tool main window and prompt window.") (LET* ((PLAINFONT (NSPROT.GET.FONT)) (BOLDFONT (NSPROT.GET.FONT T)) (HEIGHTDIFFERENCE (- (FONTPROP BOLDFONT (QUOTE HEIGHT)) (FONTPROP PLAINFONT (QUOTE HEIGHT)))) (W (FREEMENU (BQUOTE ((PROPS COLUMNSPACE 14 FONT (\, BOLDFONT)) ((LABEL "Show" SELECTEDFN NSPROT.SHOW MESSAGE "Show the current protection of the specified directory/file.") (LABEL "New Entry" SELECTEDFN NSPROT.NEW.ENTRY MESSAGE "Add a new protection entry (you fill it in).") (LABEL "Apply" SELECTEDFN NSPROT.APPLY MESSAGE "Apply the indicated protections to the file.") (LABEL "Set to Default" SELECTEDFN NSPROT.SET.TO.DEFAULT MESSAGE "Make the file inherit protection from its parent (sub)directory." MAXWIDTH 275)) ((PROPS COLUMNSPACE 4) (LABEL "Type:" TYPE STATE CHANGESTATE NSPROT.HANDLE.TYPE INITSTATE "Principal" MESSAGE "Show directory's own protection, or default for its children? (can be different)" ID TYPE LINKS (DISPLAY PROTECTION-TYPE)) (LABEL "" TYPE DISPLAY ID PROTECTION-TYPE FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "Children Only " PLAINFONT))) (LABEL "Check:" TYPE STATE CHANGESTATE NSPROT.HANDLE.VERIFY INITSTATE "New Names Only" MESSAGE "Check names in protection entries against Clearinghouse?" ID CHECK LINKS (DISPLAY VERIFYFLG)) (LABEL "" TYPE DISPLAY ID VERIFYFLG FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "New Names Only" PLAINFONT)))) ((PROPS COLUMNSPACE (\, (+ 6 (- (STRINGWIDTH "Dir/File:" BOLDFONT) (STRINGWIDTH "Host:" BOLDFONT))))) (LABEL "Host:" TYPE EDITSTART MESSAGE "Fill in the name of the NS file server" LINKS (EDIT HOST)) (LABEL (\, (CONCAT)) TYPE EDIT ID HOST LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))) ((PROPS COLUMNSPACE 6) (LABEL "Dir/File:" TYPE EDITSTART MESSAGE "Fill in the name of the desired directory or file." LINKS (EDIT DIR)) (LABEL (\, (CONCAT)) TYPE EDIT ID DIR LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))))) "NS File Protection Tool")) (REG (WINDOWREGION W)) PW) (* ;; "The HEIGHTDIFFERENCE hacking is to get the baselines of the bold and plain fonts to line up (odd that they don't already). (CONCAT) instead of %"%" to ease my pain of debugging--otherwise, the edit items would all be fat, and Lyric's Courier doesn't handle that gracefully.") (WINDOWPROP W (QUOTE FM.DONTRESHAPE) T) (WINDOWPROP W (QUOTE MINSIZE) (CONS (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG))) (* ; "Don't let window shape any smaller than it is.") (WINDOWPROP W (QUOTE VERIFYFLG) :NEW) (WINDOWPROP W (QUOTE PROTECTION-TYPE) T) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION NSPROT.ICONFN)) (MOVEW W (GETBOXPOSITION (fetch (REGION WIDTH) of REG) (+ (fetch (REGION HEIGHT) of REG) (HEIGHTIFWINDOW (FONTPROP PLAINFONT (QUOTE HEIGHT)))))) (OPENW W) (SETQ PW (GETPROMPTWINDOW W NIL PLAINFONT)) (* ; "Arrange for prompt window to expand itself by one line at a time if it overflows") (WINDOWPROP PW (QUOTE PAGEFULLFN) (QUOTE NSPROT.PAGEFULLFN)) (WINDOWPROP W (QUOTE FM.PROMPTWINDOW) PW) NIL)) -) - -(NSPROT.SHOW -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 1-Sep-87 10:50 by bvm:") (LET ((DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) OLDWINDOWS) (if DEV&FILESPEC then (NSPROT.REMOVE.SUBMENUS WINDOW) (CL:MULTIPLE-VALUE-BIND (PROT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.FETCH.PROTECTION WINDOW DEV FILESPEC))) (if CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION) ELSE (for P in PROT do (NSPROT.SHOW.PROT.VALUE P WINDOW))) (NSPROT.RESTORE.VERIFY WINDOW))))) -) - -(NSPROT.FETCH.PROTECTION -(LAMBDA (WINDOW DEV FILESPEC) (* ; "Edited 3-Dec-87 17:09 by bvm:") (* ;; "Return the access list of FILESPEC on DEV of the flavor requested by window (or implicitly by the filespec being a non-directory). This fn prints its own messages when the defaulting is interesting.") (if (SETQ FILESPEC (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) then (LET* ((TYPE (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE ACCESS.LIST))) TOPLEVELP (DIRP (NSPROT.DIRECTORY.SYNTAXP FILESPEC)) (DESIREDPROPS (if DIRP then (* ; "Check both kinds of access list, and if top-level also get usage stats") (BQUOTE ((\,@ (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)) (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))))) (\,@ (AND (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ TOPLEVELP (NSPROT.TOP.LEVELP FILESPEC)) (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE)) (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE.LIMIT)))))))) else (LIST (\FILING.ATTRIBUTE.TYPE TYPE)))) (PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) PROT OTHER) (DECLARE (CL:SPECIAL DESIREDPROPS)) (* ; "Go thru internal filing interface in order to intercept errors and get more than one attribute at once. DESIREDPROPS is used free under \nsfiling.get/setinfo.") (if (OR (NULL PROPS) (EQ (CAR PROPS) (QUOTE ERROR))) then (NSPROT.PROMPT WINDOW "Failed: ~A" (CADDR PROPS)) elseif (NULL (SETQ PROT (CADR (ASSOC TYPE PROPS)))) then (NSPROT.PROMPT WINDOW "Failed to fetch protection.") else (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ OTHER (CADR (ASSOC (QUOTE DEFAULT.ACCESS.LIST) PROPS))) (NOT (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))) then (* ; "We're fetching the principal access list for a directory, but it has a non-defaulted DEFAULT.ACCESS.LIST, so warn user") (NSPROT.PROMPT WINDOW "Note: this ~:[~;protection is inherited, but the ~]directory has a separate default protection for its children." (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT)) elseif (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT) then (* ; "defaulted value, explain.") (if (EQ TYPE (QUOTE ACCESS.LIST)) then (NSPROT.PROMPT WINDOW "The protection shown is inherited from the parent.") else (NSPROT.PROMPT WINDOW "This is the directory's principal protection~:[~;, which is itself inherited~]." (AND (SETQ OTHER (CADR (ASSOC (QUOTE ACCESS.LIST) PROPS))) (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))))) (if TOPLEVELP then (* ; "Top-level directory, also give usage stats.") (LET ((USED (CADR (ASSOC (QUOTE SUBTREE.SIZE) PROPS))) (LIMIT (CADR (ASSOC (QUOTE SUBTREE.SIZE.LIMIT) PROPS)))) (NSPROT.PROMPT WINDOW "~&Directory contains ~D pages ~:[(unlimited allocation)~;out of ~:*~D allocated~]" (FOLDHI USED BYTESPERPAGE) (AND (>= LIMIT 0) (FOLDHI LIMIT BYTESPERPAGE))))) (COURIER.FETCH (FILING . ACCESS.LIST) ENTRIES of PROT))))) -) - -(NSPROT.NEW.ENTRY -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 16:14 by bvm:") (* ;; "Handles the NEW ENTRY button -- adds another protection entry and starts editing the name field of it") (NSPROT.BEGIN.COMMAND WINDOW) (LET* ((SUBW (NSPROT.GET.SUBMENU WINDOW)) (NAMEITEM (FM.GETITEM (QUOTE NAME) NIL SUBW))) (FM.CHANGESTATE (FM.GETITEM (QUOTE READ) NIL SUBW) T SUBW) (* ; "Initial protection = READ") (FM.CHANGELABEL NAMEITEM (CONCAT) SUBW) (* ; "Initial name is empty") (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) NIL) (* ; "erase any previous cache") (NSPROT.ADD.SUBMENU SUBW WINDOW) (FM.EDITITEM NAMEITEM SUBW))) -) - -(NSPROT.APPLY -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 14:38 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm setting the displayed protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) (SETQ PROT (NSPROT.PARSE.PROTECTIONS WINDOW))) then (if (AND (NULL (SETQ PROT (CAR PROT))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW "Can't set empty protection.") elseif (AND (for PAIR in PROT never (MEMB (QUOTE OWNER) (CADR PAIR))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW T "Can't: Somebody must retain owner access.") else (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC PROT))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION)))) (NSPROT.RESTORE.VERIFY WINDOW)))) -) - -(NSPROT.SET.PROTECTION -(LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 31-Aug-87 18:22 by bvm:") (if (STRPOS "*" FILESPEC) then (NSPROT.SET.MULTIPLE WINDOW DEV FILESPEC PROT) elseif (NULL (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) elseif (NSPROT.SET.PROTECTION.ONE DEV FILESPEC PROT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) then (NSPROT.PROMPT WINDOW "Done, ~:[~;children's default ~]protection set ~A." (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (if (EQ PROT T) then "to default" else "as shown")) else (NSPROT.PROMPT WINDOW "Failed to set protection."))) -) - -(NSPROT.SET.PROTECTION.ONE -(LAMBDA (DEV FILESPEC PROT DEFAULTP) (* ; "Edited 27-Aug-87 13:51 by bvm:") (* ;; "Performs the filing call that sets the protection of FILESPEC on DEV to be PROT. PROT=T means default protection. DEFAULTP = NIL means access, T means default access.") (if (EQ PROT T) then (* ; "Set to default protection. Can't do this in the obvious way, because the PROTECTION attribute hides the hair about defaulted") (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))) else (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)))) (CONSTANT (COURIER.WRITE.REP (COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T) (QUOTE FILING) (QUOTE ACCESS.LIST))) DEV) else (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE PROTECTION)) PROT DEV))) -) - -(NSPROT.SET.MULTIPLE -(LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 7-Sep-89 12:31 by bvm") (if (NSPROT.RESTORE.TYPE WINDOW) then (NSPROT.PROMPT WINDOW "(Will set Principal protection) ")) (NSPROT.PROMPT WINDOW "Enumerating...") (LET ((FILES (RESETLST (LET* ((FILING.ENUMERATION.DEPTH MAX.SMALLP) (GEN (\GENERATEFILES (DIRECTORY.FILL.PATTERN FILESPEC) (QUOTE (FILE.ID)) (QUOTE (RESETLST)))) FILE) (DECLARE (CL:SPECIAL FILING.ENUMERATION.DEPTH)) (* ; "sets depth to infinity without telling the generator to filter out directories.") (while (SETQ FILE (\GENERATENEXTFILE GEN)) collect (NSPROT.PROMPT WINDOW T "~A" (SETQ FILE (CDR (NSPROT.STRIP.HOST FILE)))) (LIST (\GENERATEFILEINFO GEN (QUOTE FILE.ID)) (\GENERATEFILEINFO GEN (QUOTE IS.DIRECTORY)) FILE)))))) (if (NULL FILES) then (NSPROT.PROMPT WINDOW "no files match the pattern.") else (NSPROT.PROMPT WINDOW T "Setting...") (for F in FILES bind (OK _ 0) (FAILED _ 0) do (* ;; "Set explicit protection for file with this id. If it's a directory, also set its default access list to defaulted.") (if (AND (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) PROT) (OR (NULL (CADR F)) (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) T T))) then (add OK 1) else (add FAILED 1) (NSPROT.PROMPT WINDOW T "Failed on ~A" (CADDR F))) finally (NSPROT.PROMPT WINDOW T "Done, set ~A on ~D files~:[~; out of ~D~]." (if (EQ PROT T) then "default protection" else "the displayed protection") OK (NEQ FAILED 0) (+ OK FAILED)))))) -) - -(NSPROT.SET.TO.DEFAULT -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm restoring the file to inherited protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW))) then (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (if (AND (NSPROT.TOP.LEVELP FILESPEC) (NOT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) THEN (* ; "Dangerous operation!") (NSPROT.PROMPT WINDOW "Can't set top-level directory to default protection.") ELSE (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC T)))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION))) (NSPROT.RESTORE.VERIFY WINDOW)))) -) - -(NSPROT.BEGIN.COMMAND -(LAMBDA (WINDOW) (* ; "Edited 20-Aug-87 17:35 by bvm:") (* ;; "Begin a new command. Clear old prompt window, if any, and stop any editing.") (LET ((PW (GETPROMPTWINDOW WINDOW NIL NIL T))) (AND PW (CLEARW PW))) (FM.ENDEDIT WINDOW) (for W in (WINDOWPROP WINDOW (QUOTE PROTMENUS)) do (FM.ENDEDIT W)) (if (EQ (GETSTREAM WINDOW) (TTYDISPLAYSTREAM)) then (* ; "Bug--freemenu leaves this guy being the ttydisplaystream") (TTYDISPLAYSTREAM \DEFAULTTTYDISPLAYSTREAM))) -) -) -(DEFINEQ - -(NSPROT.HANDLE.TYPE -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 13:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) (SELECTQ (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (T (SETQ LABEL "Principal") NIL) (NIL (SETQ LABEL "Children Only") T) (SHOULDNT))) LABEL)) -) - -(NSPROT.RESTORE.TYPE -(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 13:56 by bvm:") (* ;; "Replace the %"children only%" state with %"Principal%"--do this when working on a non-directory. Returns T if it changed.") (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) NIL) then (FM.CHANGESTATE (FM.GETITEM (QUOTE TYPE) NIL WINDOW) "Principal" WINDOW) T)) -) - -(NSPROT.HANDLE.VERIFY -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 14:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) (SELECTQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) (:NEW (SETQ LABEL "All Names") T) (T (SETQ LABEL "Don't") NIL) (NIL (SETQ LABEL "I really mean it") :NO) (:NO (SETQ LABEL "New Names Only") :NEW) (SHOULDNT))) LABEL)) -) - -(NSPROT.RESTORE.VERIFY -(LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 15:11 by bvm:") (* ;; "Replace the %"I really mean it%" state with a better one.") (if (EQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO) then (FM.CHANGESTATE (FM.GETITEM (QUOTE CHECK) NIL WINDOW) "New Names Only" WINDOW) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) :NEW))) -) - -(NSPROT.PARSE.FILENAME -(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (NSPROT.BEGIN.COMMAND WINDOW) (PROG ((STATE (FM.GETSTATE WINDOW)) HOST FILENAME FULLNAME HOST&FILE FULLHOST DEV) (for TL on STATE by (CDDR TL) do (SELECTQ (CAR TL) (HOST (SETQ HOST (CADR TL))) (DIR (SETQ FILENAME (CADR TL))) NIL)) (if (OR (NULL FILENAME) (EQ (NCHARS FILENAME) 0)) then (NSPROT.PROMPT WINDOW "No directory or file name was specified.") (RETURN NIL)) (if (SETQ HOST&FILE (NSPROT.STRIP.HOST FILENAME)) then (* ;; "User gave a full file name including host in the %"Dir/File%" field. Separate them out now.") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) (SETQ FILENAME (CDR HOST&FILE)) WINDOW) (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) (SETQ HOST (CAR HOST&FILE)) WINDOW)) (if (OR (NULL HOST) (EQ (NCHARS HOST) 0)) then (NSPROT.PROMPT WINDOW "No host was specified.") (RETURN NIL)) (SETQ FULLHOST (CAR (LOOKUP.NS.SERVER HOST NIL T))) (if (NOT (STRING-EQUAL HOST (SETQ HOST (NSNAME.TO.STRING (OR FULLHOST (PARSE.NSNAME HOST)) T)))) then (* ;; "Show fully-qualified name, either from lookup or from parse. In latter case, we may be reminding user of default domain.") (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) HOST WINDOW)) (if (NEQ (CHCON1 FILENAME) (CHARCODE "<")) then (SETQ FILENAME (CONCAT "<" FILENAME)) (if (NOT (STRPOS ">" FILENAME 2)) then (SETQ FILENAME (CONCAT FILENAME ">"))) (* ; "Show modified file name") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) FILENAME WINDOW)) (if (OR (NOT FULLHOST) (NULL (SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (CONCAT "{" HOST "}" FILENAME)) T)))) then (NSPROT.PROMPT WINDOW "Server ~A not found." HOST) (RETURN NIL)) (RETURN (CONS DEV FULLNAME)))) -) - -(NSPROT.PARSE.PROTECTIONS -(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (* ;; "Parse and as necessary validate the protection entries attached to WINDOW, returning a valid PROTECTION value, or NIL if something is wrong.") (LET ((PROTWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS))) (VERIFYFLG (WINDOWPROP WINDOW (QUOTE VERIFYFLG))) WHO HOW NSWHO OLDWHO FULLNAME DEADWINDOWS PROT VERIFIEDNAME) (for W in PROTWINDOWS do (SETQ WHO NIL) (SETQ HOW (for TAIL on (FM.GETSTATE W) by (CDDR TAIL) when (SELECTQ (CAR TAIL) ((READ WRITE ADD REMOVE OWNER) (CADR TAIL)) (NAME (SETQ WHO (CADR TAIL)) NIL) NIL) collect (CAR TAIL))) (if (NOT (AND HOW WHO (> (NCHARS WHO) 0))) then (* ; "No protection, remove this guy") (push DEADWINDOWS W) elseif (AND (NEQ VERIFYFLG T) (STREQUAL WHO (CAR (SETQ OLDWHO (WINDOWPROP W (QUOTE KNOWN-VALUE)))))) then (* ;; "This name hasn't been changed since we put it up, so use the parse that's there. We're assuming that not having to validate old protection names makes up for occasionally reinstalling a bogus name that just happened to be there.") (push PROT (LIST (CADR OLDWHO) HOW)) else (SETQ NSWHO (PARSE.NSNAME WHO)) (if (NOT (STREQUAL WHO (SETQ WHO (NSNAME.TO.STRING (OR (SETQ FULLNAME (if (SELECTQ VERIFYFLG ((NIL :NO) T) (STRPOS "*" WHO)) then (* ; "for now, accept any pattern") NSWHO else (* ; "get canonical name") (SETQ VERIFIEDNAME (CH.LOOKUP.OBJECT NSWHO)))) NSWHO) T)))) then (* ; "Show our parse or canonical name") (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL W) WHO W)) (if FULLNAME then (* ; "good name") (SETQ NSWHO FULLNAME) (if VERIFIEDNAME then (* ; "Remember this parse") (WINDOWPROP W (QUOTE KNOWN-VALUE) (LIST WHO VERIFIEDNAME HOW))) else (NSPROT.PROMPT WINDOW "~A not a registered name." WHO) (RETURN NIL)) (push PROT (LIST NSWHO HOW))) finally (if DEADWINDOWS then (* ; "Remove the windows showing no entry") (LET ((LASTDEAD (CAR DEADWINDOWS)) LOWERWINDOWS) (* ; "First detach everything up to the last dead one.") (for OLDW in PROTWINDOWS do (DETACHWINDOW OLDW) (if (MEMB OLDW DEADWINDOWS) then (CLOSEW OLDW) else (push LOWERWINDOWS OLDW)) repeatuntil (EQ OLDW LASTDEAD)) (* ; "Now reattach the good ones") (for OLDW in LOWERWINDOWS do (ATTACHWINDOW OLDW WINDOW (QUOTE BOTTOM))) (* ; "Add the dead ones to scratch heap") (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND DEADWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))) (WINDOWPROP WINDOW (QUOTE PROTMENUS) (CL:SET-DIFFERENCE PROTWINDOWS DEADWINDOWS)))) (RETURN (LIST PROT))))) -) - -(NSPROT.STRIP.HOST -(LAMBDA (FILENAME) (* ; "Edited 20-Aug-87 14:17 by bvm:") (* ;; "Strips the host field off the front of FILENAME and returns a dotted pair (host . restOfName).") (PROG (I) (RETURN (AND (SETQ I (STRPOS (SELCHARQ (CHCON1 FILENAME) ({ "}") ("[" "]") ("(" ")") (RETURN NIL)) FILENAME 2)) (CONS (SUBSTRING FILENAME 2 (SUB1 I)) (SUBSTRING FILENAME (ADD1 I))))))) -) - -(NSPROT.EXPAND.FULLNAME -(LAMBDA (WINDOW DEV FILENAME) (* ; "Edited 27-Aug-87 15:19 by bvm:") (* ;; "Looks up FILENAME on DEV, returning the full name (sans host). WINDOW is the window in which FILENAME is the DIR item--we will change it if appropriate. Returns NIL on file not found.") (LET ((FULLNAME (\NSFILING.GETFILE DEV FILENAME (QUOTE NONE) (QUOTE OLD) (QUOTE HANDLE) (FUNCTION \NSFILING.FULLNAME) T)) STRIPPED-NAME) (if (NULL FULLNAME) then (NSPROT.PROMPT WINDOW "~A not found." (if (NSPROT.DIRECTORY.SYNTAXP FILENAME) then "Directory" elseif (STRPOS ">" FILENAME) then (* ; "Looks like a file") "File" else (* ; "Could be either if they were sloppy") "Directory/file")) NIL else (SETQ STRIPPED-NAME (CDR (NSPROT.STRIP.HOST FULLNAME))) (if (NOT (STREQUAL STRIPPED-NAME FILENAME)) then (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) STRIPPED-NAME WINDOW)) (if (NOT (NSPROT.DIRECTORY.SYNTAXP FULLNAME)) then (* ; "Force Principal protection, since non-directories don't have a default access list.") (NSPROT.RESTORE.TYPE WINDOW)) FULLNAME))) -) -) - - - -(* ; "Handle protection submenus") - -(DEFINEQ - -(NSPROT.GET.SUBMENU -(LAMBDA (MAINWINDOW) (* ; "Edited 26-Aug-87 18:03 by bvm:") (LET ((SUBW (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS))) HEIGHT) (if SUBW then (* ; "Return a cached window to avoid overhead of creating a whole new freemenu. Don't forget to clear the old one out!") (PROG1 (NSPROT.CHANGE.STATE (CAR SUBW) NIL) (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS) (CDR SUBW))) else (SETQ SUBW (FREEMENU (BQUOTE ((PROPS FONT (\, (NSPROT.GET.FONT)) COLUMNSPACE 5) ((LABEL "Read" ID READ TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Read: User may read (if a file) or enumerate (if a directory)") (LABEL "Wrt" ID WRITE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Write: User may write/change/delete the file.") (LABEL "Add" ID ADD TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Add: User can create files in the directory.") (LABEL "Del" ID REMOVE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Delete: User can remove files from the directory.") (LABEL "Own" ID OWNER TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Owner: User can change the protection.") (LABEL "All" ID ALL TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.ALL MESSAGE NSPROT.MESSAGE.ALL) (LABEL " to:" ID TO TYPE EDITSTART MESSAGE "Fill in name (user or group) or pattern (*:Domain)." FONT (\, (NSPROT.GET.FONT T)) LINKS (EDIT NAME)) (LABEL (\, (CONCAT)) TYPE EDIT ID NAME)))) NIL NIL 3)) (WINDOWPROP SUBW (QUOTE FM.DONTRESHAPE) T) (* ; "Don't want any extra space added between columns when the window gets wider--add it all on the right.") (WINDOWPROP SUBW (QUOTE MINSIZE) (CONS 0 (SETQ HEIGHT (fetch (REGION HEIGHT) of (WINDOWPROP SUBW (QUOTE REGION)))))) (WINDOWPROP SUBW (QUOTE MAXSIZE) (CONS MAX.SMALLP HEIGHT)) (WINDOWPROP SUBW (QUOTE FM.PROMPTWINDOW) (GETPROMPTWINDOW MAINWINDOW)) SUBW))) -) - -(NSPROT.ADD.SUBMENU -(LAMBDA (MENUW MAINWINDOW) (* ; "Edited 20-Aug-87 10:13 by bvm:") (* ;; "Appends MENUW to MAINWINDOW's set of protection value entries") (ATTACHWINDOW MENUW MAINWINDOW (QUOTE BOTTOM)) (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS) (CONS MENUW (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS))))) -) - -(NSPROT.REMOVE.SUBMENUS -(LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 12:34 by bvm:") (* ;; "Removes all the submenus (protection entries) from WINDOW, adding them to the scratch list for the window.") (LET ((OLDWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS) NIL))) (for W in OLDWINDOWS do (DETACHWINDOW W) (CLOSEW W)) (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND OLDWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))))) -) - -(NSPROT.CHANGE.STATE -(LAMBDA (WINDOW NEWSTATE) (* ; "Edited 19-Aug-87 16:15 by bvm:") (* ;; "Change all the protection buttons to the specified state") (for ID in (QUOTE (READ WRITE ADD REMOVE OWNER ALL)) do (FM.CHANGESTATE (FM.GETITEM ID NIL WINDOW) NEWSTATE WINDOW)) WINDOW) -) - -(NSPROT.HANDLE.ALL -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 16:16 by bvm:") (* ;; "Called when ALL is selected--turn all protection bits to the specified state") (NSPROT.CHANGE.STATE WINDOW (FM.ITEMPROP ITEM (QUOTE STATE)))) -) - -(NSPROT.MESSAGE.ALL -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Aug-87 14:15 by bvm:") (* ;; "Called when ALL is held--return appropriate help message") (if (FM.ITEMPROP ITEM (QUOTE STATE)) then "Deny user all access rights" else "Grant user all 5 access rights")) -) - -(NSPROT.HANDLE.SUBTYPE -(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 14:46 by bvm:") (LET ((OTHER (FM.GETITEM (QUOTE ALL) NIL WINDOW))) (if (FM.ITEMPROP OTHER (QUOTE STATE)) then (* ; "If the ALL button was on, turn it off") (FM.CHANGESTATE OTHER NIL WINDOW)) (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) ((WRITE ADD) (* ; "these accesses really need READ as well") (if (AND (FM.ITEMPROP ITEM (QUOTE STATE)) (NOT (FM.ITEMPROP (SETQ OTHER (FM.GETITEM (QUOTE READ) NIL WINDOW)) (QUOTE STATE)))) then (FM.CHANGESTATE OTHER T WINDOW))) NIL))) -) - -(NSPROT.SHOW.PROT.VALUE -(LAMBDA (ENTRY MAINWINDOW) (* ; "Edited 24-Aug-87 16:16 by bvm:") (DESTRUCTURING-BIND (NAME TYPES) ENTRY (LET ((SUBW (NSPROT.GET.SUBMENU MAINWINDOW)) (STRINGNAME (NSNAME.TO.STRING NAME T)) ITEM) (for P in TYPES do (FM.CHANGESTATE (OR (SETQ ITEM (FM.GETITEM P NIL SUBW)) (HELP "Bad protection value" P)) T SUBW) (if (EQ P (QUOTE ALL)) then (NSPROT.HANDLE.ALL ITEM SUBW))) (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL SUBW) STRINGNAME SUBW) (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) (CONS STRINGNAME ENTRY)) (* ; "Save the parse of this value so we can avoid worrying about it later.") (NSPROT.ADD.SUBMENU SUBW MAINWINDOW) SUBW))) -) -) - - - -(* ; "utilities") - -(DEFINEQ - -(NSPROT.DIRECTORY.SYNTAXP -(LAMBDA (FILENAME) (* ; "Edited 27-Aug-87 14:53 by bvm:") (* ; "True if FILENAME looks like a directory") (EQ (NTHCHARCODE FILENAME -1) (CHARCODE ">"))) -) - -(NSPROT.TOP.LEVELP -(LAMBDA (FILESPEC) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (I) (NOT (AND (SETQ I (STRPOS ">" FILESPEC)) (NEQ I (NCHARS FILESPEC)))))) -) - -(NSPROT.GET.FONT -(LAMBDA (BOLDP) (* ; "Edited 1-Sep-87 17:23 by bvm:") (if BOLDP then (OR NSPROT.BOLD.FONT (SETQ NSPROT.BOLD.FONT (FONTCOPY (NSPROT.GET.FONT) (QUOTE WEIGHT) (QUOTE BOLD)))) elseif NSPROT.PLAIN.FONT elseif (> (FONTHEIGHT (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 10))) 12) then (* ; "Yes, this is the one I had in mind (10 pt coerced to 12)") NSPROT.PLAIN.FONT else (* ; "The %"real%" 12 pt display font is about the right size.") (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 12)))) -) - -(NSPROT.PROMPT -(LAMBDA WINDOW&ARGS (* ; "Edited 2-Aug-89 17:10 by bvm") (LET* ((*PRINT-CASE* :UPCASE) (MAINW (ARG WINDOW&ARGS 1)) (WINDOW (GETPROMPTWINDOW MAINW)) (ARGS (for J from (if (EQ (ARG WINDOW&ARGS 2) T) then (* ; "First arg of T means clear window first.") (NSPROT.CLEAR.PROMPT MAINW WINDOW) 3 else 2) to WINDOW&ARGS collect (ARG WINDOW&ARGS J)))) (RESETFORM (TTYDISPLAYSTREAM WINDOW) (* ; "Unfortunately, have to make it the tty to get pagefullfn action.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW ARGS)) NIL)) -) - -(NSPROT.CLEAR.PROMPT -(LAMBDA (MAINW PW) (* ; "Edited 2-Aug-89 17:14 by bvm") (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") (LET ((PROP (WINDOWPROP MAINW (QUOTE PROMPTWINDOW))) (IDEALHEIGHT (OR (WINDOWPROP MAINW (QUOTE PROMPTLINES)) 1)) HEIGHT) (* ;; "PROP = (promptwindow . #lines)") (if (AND PROP (> (CDR PROP) IDEALHEIGHT)) then (* ; "Window has grown, so shape it back down") (SETQ HEIGHT (HEIGHTIFWINDOW (TIMES IDEALHEIGHT (FONTPROP PW (QUOTE HEIGHT))))) (WINDOWPROP PW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (* ; "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") (WINDOWPROP PW (QUOTE MAXSIZE) (CONS 64000 HEIGHT)) (SHAPEW PW (create REGION using (WINDOWPROP PW (QUOTE REGION)) HEIGHT _ HEIGHT)) (RPLACD PROP IDEALHEIGHT) (* ; "Clear it last to get coordinates right.")) (CLEARW PW))) -) - -(NSPROT.LIMITCHARS -(LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Aug-87 12:00 by bvm:") (SELECTQ CHAR ((% - Â) (FM.SKIPNEXT WINDOW) NIL) T))) - -(NSPROT.PAGEFULLFN -(LAMBDA (PW) (* ; "Edited 2-Aug-89 16:19 by bvm") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (GETPROMPTWINDOW (MAINWINDOW PW) (+ 1 \#DISPLAYLINES)) (* ; "\Currentdisplayline is the line we're on when window fills, origin zero")))) -) - -(NSPROT.ICONFN -(LAMBDA (WINDOW OLDICON) (* ; "Edited 1-Sep-87 10:29 by bvm:") (LET ((HOST (FM.ITEMPROP (FM.GETITEM (QUOTE HOST) NIL WINDOW) (QUOTE LABEL)))) (SETQ HOST (if (AND HOST (NEQ (NCHARS HOST) 0) (SETQ HOST (PARSE.NSNAME HOST))) then (fetch NSOBJECT of HOST) else "")) (* ; "show host's main name") (if OLDICON then (ICONW.TITLE OLDICON HOST) OLDICON else (TITLEDICONW NSPROT.ICON HOST (NSPROT.GET.FONT))))) -) -) - -(RPAQ? NSPROT.PLAIN.FONT NIL) - -(RPAQ? NSPROT.BOLD.FONT NIL) - -(RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO NIL (4 22 51 14))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) -) -(DEFINEQ - -(ADD.NSPROTECTION -(LAMBDA (LST) (* ; "Edited 2-Sep-87 11:53 by bvm:") (* ;; "Add an entry for the NSPROTECTION tool to the background menu") (for X in (if LST then (* ; "Mumbling thru sub items") (CDR LST) else (SETQ LST BackgroundMenuCommands)) bind (COM _ (QUOTE ("NS Protection" (QUOTE (NSPROTECTION)) "Start up the NS File protection tool."))) do (if (STRING-EQUAL (CAR X) "NS Protection") then (RETURN (RPLACD X (CDR COM))) elseif (AND (STRING-EQUAL (CAR X) "System") (CADDDR X)) then (RETURN (ADD.NSPROTECTION (CADDDR X)))) finally (NCONC1 LST COM)) (SETQ BackgroundMenu NIL) (* ; "also, load fonts") (NSPROT.GET.FONT T) (COND ((CCODEP (QUOTE ADD.NSPROTECTION)) (* ; "self destruct") (AND (PUTD (QUOTE ADD.NSPROTECTION)))))) -) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(ADD.NSPROTECTION) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA) - -(ADDTOVAR NLAML) - -(ADDTOVAR LAMA NSPROT.PROMPT) -) -(PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1695 14166 (NSPROTECTION 1705 . 4891) (NSPROT.SHOW 4893 . 5411) ( -NSPROT.FETCH.PROTECTION 5413 . 8347) (NSPROT.NEW.ENTRY 8349 . 8972) (NSPROT.APPLY 8974 . 9903) ( -NSPROT.SET.PROTECTION 9905 . 10481) (NSPROT.SET.PROTECTION.ONE 10483 . 11359) (NSPROT.SET.MULTIPLE -11361 . 12860) (NSPROT.SET.TO.DEFAULT 12862 . 13674) (NSPROT.BEGIN.COMMAND 13676 . 14164)) (14167 -21199 (NSPROT.HANDLE.TYPE 14177 . 14477) (NSPROT.RESTORE.TYPE 14479 . 14830) (NSPROT.HANDLE.VERIFY -14832 . 15192) (NSPROT.RESTORE.VERIFY 15194 . 15525) (NSPROT.PARSE.FILENAME 15527 . 17256) ( -NSPROT.PARSE.PROTECTIONS 17258 . 19753) (NSPROT.STRIP.HOST 19755 . 20136) (NSPROT.EXPAND.FULLNAME -20138 . 21197)) (21243 25794 (NSPROT.GET.SUBMENU 21253 . 23057) (NSPROT.ADD.SUBMENU 23059 . 23366) ( -NSPROT.REMOVE.SUBMENUS 23368 . 23788) (NSPROT.CHANGE.STATE 23790 . 24072) (NSPROT.HANDLE.ALL 24074 . -24316) (NSPROT.MESSAGE.ALL 24318 . 24590) (NSPROT.HANDLE.SUBTYPE 24592 . 25137) ( -NSPROT.SHOW.PROT.VALUE 25139 . 25792)) (25821 29042 (NSPROT.DIRECTORY.SYNTAXP 25831 . 26015) ( -NSPROT.TOP.LEVELP 26017 . 26179) (NSPROT.GET.FONT 26181 . 26700) (NSPROT.PROMPT 26702 . 27226) ( -NSPROT.CLEAR.PROMPT 27228 . 28111) (NSPROT.LIMITCHARS 28113 . 28254) (NSPROT.PAGEFULLFN 28256 . 28616) - (NSPROT.ICONFN 28618 . 29040)) (30249 30998 (ADD.NSPROTECTION 30259 . 30996))))) -STOP diff --git a/lispusers/PLOT.~1~ b/lispusers/PLOT.~1~ deleted file mode 100644 index 022ccfa3..00000000 --- a/lispusers/PLOT.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Jun-92 15:42:27" |{PELE:MV:ENVOS}MEDLEY>PLOT.;3| 211578 changes to%: (FNS COPYMENU PLOTPROPMACRO ADDPLOTOBJECT ADJUSTSCALE? ADJUSTVIEWPORT APPLY.AFTERFN.MACRO ASKFORLABEL ASKFORSCALE BOXREGION CHOOSESCALE CHOOSETICS CLOSEPLOTWINDOW CLOSESTPLOTOBJECT COMPOUNDSUBTYPE COMPUTEBOTTOMMARGIN COMPUTELEFTMARGIN COMPUTERIGHTMARGIN COMPUTETOPMARGIN CREATEPLOT CREATEPLOTFNS CREATEPLOTOBJECT DEFAULTSCALEFN DEFAULTTICFN DEFAULTTICMETHOD DELETEPLOTOBJECT DESELECTPLOTOBJECT DISTANCETOPLOTOBJECT DRAWBOTTOMMARGIN DRAWLEFTMARGIN DRAWMARGIN DRAWPLOTOBJECT DRAWPLOT DRAWRIGHTMARGIN DRAWTOPMARGIN ERASEPLOTOBJECT EXTENDEDSCALEFN EXTENTOFPLOTOBJECT EXTENTOFPLOT GETPLOTWINDOW GETTICLIST HIGHLIGHTPLOTOBJECT LABELPLOTOBJECT LOWLIGHTPLOTOBJECT MANUALRESCALE MINSTREAMREGIONSIZE MOVEPLOTOBJECT OPENPLOTWINDOW PLOT.BUTTONEVENTFN PLOT.CLOSEFN PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOT.HARDCOPYFN PLOT.ICONFN PLOT.LABELTOWORLD PLOT.REPAINTFN PLOT.RESET PLOT.SETUP PLOT.SKETCH.CREATE PLOT.WHENSELECTEDFN PLOT.WORLDTOLABEL PLOTADDMENUITEMS PLOTADDPROP PLOTAXISINTERVAL PLOTDELMENUITEMS PLOTDELPROP PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTOBJECTADDPROP PLOTOBJECTDELPROP PLOTOBJECTLABEL PLOTOBJECTPROP PLOTOBJECTPROPMACRO PLOTOBJECTSUBTYPE PLOTOPERROR PLOTPROMPT PLOTPROP PLOTREMPROP PLOTSCALEFN PLOTTICFN PLOTTICINFO PLOTTICMETHOD PLOTTICS PRINTFONT PRINTMENU REDRAWPLOTWINDOW RELABELSELECTEDPLOTOBJECT RESCALEPLOT SCALE TOGGELLABEL TOGGLEEXTENDEDAXES TOGGLEFIXEDMENU TOGGLETICS TRANSLATEPLOTOBJECT UNDELETEPLOTOBJECT UNLABELPLOTOBJECT WHICHLABEL WHICHPLOT PLOT.PRINTNUM PLOT.FNUM-STRING PLOT.ENUM-STRING CREATETICLISTS NORMALIZE-TICLIST DRAW-TICS-LEFT-RIGHT DRAW-TICS-TOP-BOTTOM DRAW-LABEL-LEFT-RIGHT DRAW-LABEL-TOP-BOTTOM COPYPLOTOBJECT COPYPLOT PLOTOBJECTPRINT PRINTPLOTOBJECT PRINTPLOT READFONT READMENU READPLOTOBJECT READPLOT PRINT-VECTOR READ-VECTOR PLOT.EXP10 PLOT.LOG10 PLOT.FLOOR PLOT.CEILING SINEWAVE CREATEPLOTIMAGEOBJ CREATEPLOTBITMAPOBJ PLIO.BUTTONEVENTINFN PLIO.COPYFN PLIO.GETFN PLIO.PUTFN PLIO.REINSERTOBJ PLOT.COPYBUTTONEVENTFN PLIO.DISPLAYFN PLIO.IMAGEBOXFN PLIO.EDITCLOSEFN IMAGE.OBJECT.CHANGED) (FILEPKGCOMS PLOTS) (VARS PLOTCOMS) previous date%: "28-Sep-91 17:11:50" |{PELE:MV:ENVOS}MEDLEY>PLOT.;2|) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1991, 1992 by Venue. All rights reserved. ") (PRETTYCOMPRINT PLOTCOMS) (RPAQQ PLOTCOMS [ (* ;;; "PLOT manager fns") (FNS ADDPLOTOBJECT ADJUSTSCALE? ADJUSTVIEWPORT APPLY.AFTERFN.MACRO ASKFORLABEL ASKFORSCALE BOXREGION CHOOSESCALE CHOOSETICS CLOSEPLOTWINDOW CLOSESTPLOTOBJECT COMPOUNDSUBTYPE COMPUTEBOTTOMMARGIN COMPUTELEFTMARGIN COMPUTERIGHTMARGIN COMPUTETOPMARGIN COPYMENU CREATEPLOT CREATEPLOTFNS CREATEPLOTOBJECT DEFAULTSCALEFN DEFAULTTICFN DEFAULTTICMETHOD DELETEPLOTOBJECT DESELECTPLOTOBJECT DISTANCETOPLOTOBJECT DRAWBOTTOMMARGIN DRAWLEFTMARGIN DRAWMARGIN DRAWPLOTOBJECT DRAWPLOT DRAWRIGHTMARGIN DRAWTOPMARGIN ERASEPLOTOBJECT EXTENDEDSCALEFN EXTENTOFPLOTOBJECT EXTENTOFPLOT GETPLOTWINDOW GETTICLIST HIGHLIGHTPLOTOBJECT LABELPLOTOBJECT LOWLIGHTPLOTOBJECT MANUALRESCALE MINSTREAMREGIONSIZE MOVEPLOTOBJECT OPENPLOTWINDOW PLOT.BUTTONEVENTFN PLOT.CLOSEFN PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOT.HARDCOPYFN PLOT.ICONFN PLOT.LABELTOWORLD PLOT.REPAINTFN PLOT.RESET PLOT.SETUP PLOT.SKETCH.CREATE PLOT.WHENSELECTEDFN PLOT.WORLDTOLABEL PLOTADDMENUITEMS PLOTADDPROP PLOTAXISINTERVAL PLOTDELMENUITEMS PLOTDELPROP PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTOBJECTADDPROP PLOTOBJECTDELPROP PLOTOBJECTLABEL PLOTOBJECTPROP PLOTOBJECTPROPMACRO PLOTOBJECTSUBTYPE PLOTOPERROR PLOTPROMPT PLOTPROP PLOTPROPMACRO PLOTREMPROP PLOTSCALEFN PLOTTICFN PLOTTICINFO PLOTTICMETHOD PLOTTICS PRINTFONT PRINTMENU REDRAWPLOTWINDOW RELABELSELECTEDPLOTOBJECT RESCALEPLOT SCALE TOGGELLABEL TOGGLEEXTENDEDAXES TOGGLEFIXEDMENU TOGGLETICS TRANSLATEPLOTOBJECT UNDELETEPLOTOBJECT UNLABELPLOTOBJECT WHICHLABEL WHICHPLOT) (* ;; "Fns to do our own number printing") (FNS PLOT.PRINTNUM PLOT.FNUM-STRING PLOT.ENUM-STRING CREATETICLISTS NORMALIZE-TICLIST) (FNS DRAW-TICS-LEFT-RIGHT DRAW-TICS-TOP-BOTTOM DRAW-LABEL-LEFT-RIGHT DRAW-LABEL-TOP-BOTTOM) (VARS PLOT.DEFAULTMIDDLEMENUITEMS PLOT.DEFAULTRIGHTMENUITEMS OBJECTOPSTABLE) (RECORDS EXTENT MARGIN PLOT PLOTFNS PLOTOBJECT AXISINFO AXISINTERVAL PLOTSCALE TICINFO) (MACROS APPLY.AFTERFN PLOTOBJECTSUBTYPE? PLOTOBJECTPROP PLOTPROP) (PROP ARGNAMES PLOTOBJECTPROP PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTPRETTYFNS PLOTPROP PLOTSCALEFN PLOTTICFN PLOTTICS) [INITVARS (SMALLPLOTFONT '(GACHA 8 MRR)) (LARGEPLOTFONT '(GACHA 12 BRR] (* ;;; "PLOT I/O") (FNS COPYPLOTOBJECT COPYPLOT PLOTOBJECTPRINT PRINTPLOTOBJECT PRINTPLOT READFONT READMENU READPLOTOBJECT READPLOT) (FNS PRINT-VECTOR READ-VECTOR) (FILEPKGCOMS PLOTS) (ADDVARS (HPRINTMACROS (FONTDESCRIPTOR . PRINTFONT) (MENU . PRINTMENU) (PLOT . PRINTPLOT) (PLOTOBJECT . PRINTPLOTOBJECT) (ONED-ARRAY . PRINT-VECTOR))) (ADDVARS (HPRINTREADFNS READPLOT READPLOTOBJECT READFONT READMENU READ-VECTOR)) (P (DEFPRINT 'PLOTOBJECT (FUNCTION PLOTOBJECTPRINT))) (* ;;; "Numeric fns") (FNS PLOT.EXP10 PLOT.LOG10 PLOT.FLOOR PLOT.CEILING SINEWAVE) (* ;;; "PLOT image object FNS") (FNS CREATEPLOTIMAGEOBJ CREATEPLOTBITMAPOBJ PLIO.BUTTONEVENTINFN PLIO.COPYFN PLIO.GETFN PLIO.PUTFN PLIO.REINSERTOBJ PLOT.COPYBUTTONEVENTFN PLIO.DISPLAYFN PLIO.IMAGEBOXFN) (* ;; "additional fns to allow plot im. objs. to work in Sketch") (FNS PLIO.EDITCLOSEFN IMAGE.OBJECT.CHANGED) [INITVARS (PLOTIMAGEFNS (IMAGEFNSCREATE (FUNCTION PLIO.DISPLAYFN) (FUNCTION PLIO.IMAGEBOXFN) (FUNCTION PLIO.PUTFN) (FUNCTION PLIO.GETFN) (FUNCTION PLIO.COPYFN) (FUNCTION PLIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL] (GLOBALVARS PLOTIMAGEFNS) (* ;;; "Initialize") (P (PLOT.SETUP OBJECTOPSTABLE) (PLOT.DEFAULTMENU 'MIDDLE PLOT.DEFAULTMIDDLEMENUITEMS) (PLOT.DEFAULTMENU 'RIGHT PLOT.DEFAULTRIGHTMENUITEMS)) (* ;;; "Dependent files") (FILES TWODGRAPHICS PLOTOBJECTS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PLOTTICS PLOTTICFN PLOTSCALEFN PLOTPROP PLOTOBJECTPROP PLOTMENUITEMS PLOTMENU PLOTLABEL PLOT.FIXRIGHTMENU PLOT.DEFAULTMENU]) (* ;;; "PLOT manager fns") (DEFINEQ (ADDPLOTOBJECT [LAMBDA (OBJECT PLOT NODRAWFLG) (* ; "Edited 28-Sep-91 16:15 by jds") (PROG ((WHENADDEDFN (PLOTOBJECTPROP OBJECT 'WHENADDEDFN)) REDRAWFLG NEWSCALES) [COND ((NOT (MEMB OBJECT (fetch (PLOT PLOTOBJECTS) of PLOT))) (replace (PLOT PLOTOBJECTS) of PLOT with (CONS OBJECT (fetch (PLOT PLOTOBJECTS) of PLOT] (COND ((ADJUSTSCALE? (EXTENTOFPLOTOBJECT OBJECT PLOT) PLOT) (SETQ REDRAWFLG T))) [COND ((NULL NODRAWFLG) (COND ([OR REDRAWFLG (NOT (OPENWP (fetch (PLOT PLOTWINDOW) of PLOT] (REDRAWPLOTWINDOW PLOT)) (T (DRAWPLOTOBJECT OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT] (APPLY.AFTERFN WHENADDEDFN OBJECT PLOT NODRAWFLG) (RETURN OBJECT]) (ADJUSTSCALE? [LAMBDA (EXTENT PLOT) (* ; "Edited 28-Sep-91 16:03 by jds") (* ;; "Determines whether the plotting scale must be adjusted to included the extrema 'minx' , 'maxx' , etc. If so returns T. Side effects the PLOTSCALE of PLOT") (LET* ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (XAXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) (XTICINFO (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (YAXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) (YTICINFO (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) (MINX (fetch (EXTENT MINX) of EXTENT)) (MAXX (fetch (EXTENT MAXX) of EXTENT)) (MINY (fetch (EXTENT MINY) of EXTENT)) (MAXY (fetch (EXTENT MAXY) of EXTENT)) CHANGEDFLG) [COND ((OR (LESSP MINX (fetch (AXISINTERVAL MIN) of XINTERVAL)) (GREATERP MAXX (fetch (AXISINTERVAL MAX) of XINTERVAL))) (SETQ CHANGEDFLG T) (LET [(NEWMIN (FMIN MINX (fetch (AXISINTERVAL MIN) of XINTERVAL))) (NEWMAX (FMAX MAXX (fetch (AXISINTERVAL MAX) of XINTERVAL] (SETQ XTICINFO (CHOOSETICS NEWMIN NEWMAX XAXISINFO PLOT)) (SETQ XINTERVAL (CHOOSESCALE NEWMIN NEWMAX XAXISINFO XTICINFO PLOT] [COND ((OR (LESSP MINY (fetch (AXISINTERVAL MIN) of YINTERVAL)) (GREATERP MAXY (fetch (AXISINTERVAL MAX) of YINTERVAL))) (SETQ CHANGEDFLG T) (LET [(NEWMIN (FMIN MINY (fetch (AXISINTERVAL MIN) of YINTERVAL))) (NEWMAX (FMAX MAXY (fetch (AXISINTERVAL MAX) of YINTERVAL] (SETQ YTICINFO (CHOOSETICS NEWMIN NEWMAX YAXISINFO PLOT)) (SETQ YINTERVAL (CHOOSESCALE NEWMIN NEWMAX YAXISINFO YTICINFO PLOT] (COND (CHANGEDFLG (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with XINTERVAL) (replace (PLOTSCALE XTICINFO) of PLOTSCALE with XTICINFO) (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with YINTERVAL) (replace (PLOTSCALE YTICINFO) of PLOTSCALE with YTICINFO))) CHANGEDFLG]) (ADJUSTVIEWPORT [LAMBDA (VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 16:59 by jds") (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (PARENTSTREAM (fetch PARENTSTREAM of VIEWPORT)) BOTTOMMARGINSIZE LEFTMARGINSIZE RIGHTMARGINSIZE TOPMARGINSIZE) (SETQ BOTTOMMARGINSIZE (COMPUTEBOTTOMMARGIN PARENTSTREAM (fetch (PLOT BOTTOMMARGIN) of PLOT) PLOT)) (SETQ LEFTMARGINSIZE (COMPUTELEFTMARGIN PARENTSTREAM (fetch (PLOT LEFTMARGIN) of PLOT) PLOT)) (SETQ RIGHTMARGINSIZE (COMPUTERIGHTMARGIN PARENTSTREAM (fetch (PLOT RIGHTMARGIN) of PLOT) PLOT)) (SETQ TOPMARGINSIZE (COMPUTETOPMARGIN PARENTSTREAM (fetch (PLOT TOPMARGIN) of PLOT) PLOT)) [replace WORLDREGION of VIEWPORT with (CREATEREGION (fetch (AXISINTERVAL MIN) of (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (fetch (AXISINTERVAL MIN) of (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (fetch (AXISINTERVAL INTERVALLENGTH) of (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (fetch (AXISINTERVAL INTERVALLENGTH) of (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE] [replace STREAMSUBREGION of VIEWPORT with (CREATEREGION (PLUS (fetch (REGION LEFT) of STREAMREGION) (CAR LEFTMARGINSIZE)) (PLUS (fetch (REGION BOTTOM) of STREAMREGION) (CDR BOTTOMMARGINSIZE)) (IDIFFERENCE (fetch (REGION WIDTH) of STREAMREGION) (IPLUS (CAR LEFTMARGINSIZE) (CAR RIGHTMARGINSIZE)) ) (IDIFFERENCE (fetch (REGION HEIGHT) of STREAMREGION) (IPLUS (CDR BOTTOMMARGINSIZE) (CDR TOPMARGINSIZE] (COMPUTETRANSFORM VIEWPORT) (RETURN VIEWPORT]) (APPLY.AFTERFN.MACRO [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:16 by jop") (PROG ((FNS (CAR ARGS)) (ARGLST (CDR ARGS))) (RETURN `(if ,FNS then (if (AND (LISTP ,FNS) (NEQ (CAR ,FNS) 'LAMBDA)) then (for FN in ,FNS do (CL:FUNCALL FN ,@ARGLST)) else (CL:FUNCALL ,FNS ,@ARGLST]) (ASKFORLABEL [LAMBDA (PLOT MARGINNAME) (* ; "Edited 28-Sep-91 16:16 by jds") (* ;; "Prompt for new label and make the required call to LABELPLOT") [COND ((EQ MARGINNAME 'TITLE) (SETQ MARGINNAME 'TOP] (PROG ((PLOTPROMPT (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) (MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "ILLEGAL MARGIN NAME" MARGINNAME))) (PROMPT (SELECTQ MARGINNAME (BOTTOM "BOTTOM MARGIN LABEL?") (LEFT "LEFT MARGIN LABEL?") (TOP "TITLE?") (RIGHT "RIGHT MARGIN LABEL?") (HELP "ILLEGAL MARGIN NAME" MARGINNAME))) LABEL NEWLABEL) (SETQ LABEL (fetch (MARGIN LABEL) of MARGIN)) (TERPRI PLOTPROMPT) [SETQ NEWLABEL (PROMPTFORWORD PROMPT LABEL "Type a label" PLOTPROMPT NIL NIL (CHARCODE (EOL LF ESCAPE TAB] (COND ((AND (NEQ NEWLABEL LABEL) (NOT (STREQUAL NEWLABEL LABEL))) (PLOTLABEL PLOT MARGINNAME NEWLABEL]) (ASKFORSCALE [LAMBDA (PLOT AXIS) (* ; "Edited 28-Sep-91 16:16 by jds") (PROG ((PLOTPROMPT (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) (LOWER (PLOT.WORLDTOLABEL (SELECTQ AXIS (X (fetch (PLOT XLOWER) of PLOT)) (Y (fetch (PLOT YLOWER) of PLOT)) (HELP "Illegal axis" AXIS)) PLOT AXIS)) (UPPER (PLOT.WORLDTOLABEL (SELECTQ AXIS (X (fetch (PLOT XUPPER) of PLOT)) (Y (fetch (PLOT YUPPER) of PLOT)) (HELP "Illegal axis" AXIS)) PLOT AXIS))) (TERPRI PLOTPROMPT) (SETQ LOWER (PLOT.LABELTOWORLD [READ (OPENSTRINGSTREAM (PROMPTFORWORD (CONCAT AXIS " axis: From ") LOWER "Type a number" PLOTPROMPT NIL NIL (CHARCODE (EOL LF ESCAPE TAB] PLOT AXIS)) (SETQ UPPER (PLOT.LABELTOWORLD [READ (OPENSTRINGSTREAM (PROMPTFORWORD " to " UPPER "Type a number" PLOTPROMPT NIL NIL (CHARCODE (EOL LF ESCAPE TAB] PLOT AXIS)) (RETURN (CONS LOWER UPPER]) (BOXREGION [LAMBDA (REGION STREAM) (* ; "Edited 28-Sep-91 17:00 by jds") (* ;; "Draw a box around a region in STREAM") (PROG ((RLEFT (fetch (REGION LEFT) of REGION)) (RBOTTOM (fetch (REGION BOTTOM) of REGION)) (RRIGHT (fetch (REGION RIGHT) of REGION)) (RTOP (fetch (REGION TOP) of REGION)) (LINEWIDTH (DSPSCALE NIL STREAM))) (DRAWLINE RLEFT RBOTTOM RRIGHT RBOTTOM LINEWIDTH 'REPLACE STREAM) (DRAWLINE RRIGHT RBOTTOM RRIGHT RTOP LINEWIDTH 'REPLACE STREAM) (DRAWLINE RRIGHT RTOP RLEFT RTOP LINEWIDTH 'REPLACE STREAM) (DRAWLINE RLEFT RTOP RLEFT RBOTTOM LINEWIDTH 'REPLACE STREAM]) (CHOOSESCALE [LAMBDA (MIN MAX AXISINFO TICINFO PLOT) (* ; "Edited 5-May-87 18:25 by jop") (PROG ((SCALEFN (fetch (AXISINFO SCALEFN) of AXISINFO)) NEWINTERVAL) [SETQ NEWINTERVAL (COND (SCALEFN (CL:FUNCALL SCALEFN MIN MAX TICINFO PLOT)) (T (DEFAULTSCALEFN MIN MAX TICINFO] (AND (NOT (type? AXISINTERVAL NEWINTERVAL)) (HELP "Not an AXISINTERVAL" NEWINTERVAL)) (RETURN NEWINTERVAL]) (CHOOSETICS [LAMBDA (MIN MAX AXISINFO PLOT) (* ; "Edited 5-May-87 18:25 by jop") (PROG ((TICFN (fetch (AXISINFO TICFN) of AXISINFO)) NEWTICINFO) [SETQ NEWTICINFO (COND (TICFN (CL:FUNCALL TICFN MIN MAX PLOT)) (T (DEFAULTTICFN MIN MAX] (AND (NOT (type? TICINFO NEWTICINFO)) (HELP "Not a TICINFO" NEWTICINFO)) (RETURN NEWTICINFO]) (CLOSEPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:17 by jop") (LET [(PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (WHENCLOSEDFN (PLOTPROP PLOT 'WHENCLOSEDFN] (* ;; "Unfix the right menu") (PLOT.FIXRIGHTMENU PLOT NIL) (* ;; "Cleanup Window Props") (COND ((WINDOWP PLOTWINDOW) (WINDOWPROP PLOTWINDOW 'PLOT NIL) (WINDOWDELPROP PLOTWINDOW 'REPAINTFN (FUNCTION PLOT.REPAINTFN)) (WINDOWDELPROP PLOTWINDOW 'RESHAPEFN (FUNCTION PLOT.REPAINTFN)) (WINDOWDELPROP PLOTWINDOW 'CLOSEFN (FUNCTION PLOT.CLOSEFN)) (WINDOWPROP PLOTWINDOW 'BUTTONEVENTFN (FUNCTION TOTOPW)) (WINDOWPROP PLOTWINDOW 'RIGHTBUTTONFN NIL) (WINDOWPROP PLOTWINDOW 'COPYBUTTONEVENTFN NIL) (WINDOWPROP PLOTWINDOW 'HARDCOPYFN NIL) (WINDOWPROP PLOTWINDOW 'ICONFN NIL) (CLOSEW PLOTWINDOW) (DETACHALLWINDOWS PLOTWINDOW))) (* ;; "A user hook") (APPLY.AFTERFN WHENCLOSEDFN PLOT]) (CLOSESTPLOTOBJECT [LAMBDA (PLOT STREAMPOSITION) (* ; "Edited 28-Sep-91 16:16 by jds") (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) smallest (DISTANCETOPLOTOBJECT OBJECT STREAMPOSITION PLOT]) (COMPOUNDSUBTYPE [LAMBDA (COMPOUNDOBJECT) (* ; "Edited 28-Sep-91 16:28 by jds") (fetch COMPOUNDTYPE of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT]) (COMPUTEBOTTOMMARGIN [LAMBDA (STREAM BOTTOMMARGIN PLOT) (* ; "Edited 5-May-87 18:18 by jop") (* ;; "Returns a size cons pair (width . height) in streamcoordinates") (DECLARE (SPECVARS SMALLFONT LARGEFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of BOTTOMMARGIN)) (LABEL (fetch (MARGIN LABEL) of BOTTOMMARGIN)) (WIDTH 0) SMALLASCENT LARGEHEIGHT HEIGHT) (SETQ SMALLASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ LARGEHEIGHT (FONTPROP LARGEFONT 'HEIGHT)) (* ;  "margin of at least one LARGEHEIGHT") [SETQ HEIGHT (COND ((OR TICS? LABEL) LARGEHEIGHT) (T (ITIMES 2 LARGEHEIGHT] [COND (TICS? (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 3 SMALLASCENT] [COND (LABEL (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 2 LARGEHEIGHT))) (SETQ WIDTH (STRINGWIDTH LABEL LARGEFONT] (RETURN (CONS WIDTH HEIGHT]) (COMPUTELEFTMARGIN [LAMBDA (STREAM LEFTMARGIN PLOT) (* ; "Edited 13-May-87 13:36 by jop") (* ;; "Returns a (width . height) pair") (DECLARE (SPECVARS PRXFLG SMALLPLOTFONT LARGEPLOTFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of LEFTMARGIN)) (TICLIST (fetch (MARGIN TICLIST) of LEFTMARGIN)) (LABEL (fetch (MARGIN LABEL) of LEFTMARGIN)) (HEIGHT 0) LARGEWIDTH SMALLWIDTH WIDTH) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ LARGEWIDTH (STRINGWIDTH 'A LARGEFONT)) [SETQ WIDTH (COND ((OR TICS? LABEL) LARGEWIDTH) (T (ITIMES 2 LARGEWIDTH] [COND (TICS? (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 SMALLWIDTH) (bind TICWIDTH for TICPAIR in TICLIST largest (STRINGWIDTH (CDR TICPAIR) SMALLFONT) finally (RETURN $$EXTREME ] [COND (LABEL (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 LARGEWIDTH))) (SETQ HEIGHT (ITIMES (NCHARS LABEL) (FONTPROP LARGEFONT 'HEIGHT] (RETURN (CONS WIDTH HEIGHT]) (COMPUTERIGHTMARGIN [LAMBDA (STREAM RIGHTMARGIN PLOT) (* ; "Edited 13-May-87 13:37 by jop") (* ;; "Returns a (width . height) pair") (DECLARE (SPECVARS PRXFLG SMALLFONT LARGEFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of RIGHTMARGIN)) (TICLIST (fetch (MARGIN TICLIST) of RIGHTMARGIN)) (LABEL (fetch (MARGIN LABEL) of RIGHTMARGIN)) (HEIGHT 0) SMALLWIDTH LARGEWIDTH WIDTH) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ LARGEWIDTH (STRINGWIDTH 'A LARGEFONT)) [SETQ WIDTH (COND ((OR TICS? LABEL) LARGEWIDTH) (T (ITIMES 2 LARGEWIDTH] [COND (TICS? (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 SMALLWIDTH) (for TICPAIR in TICLIST largest (STRINGWIDTH (CDR TICPAIR) SMALLFONT) finally (RETURN $$EXTREME ] [COND (LABEL (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 LARGEWIDTH))) (SETQ HEIGHT (ITIMES (NCHARS LABEL) (FONTPROP LARGEFONT 'HEIGHT] (RETURN (CONS WIDTH HEIGHT]) (COMPUTETOPMARGIN [LAMBDA (STREAM TOPMARGIN PLOT) (* ; "Edited 5-May-87 18:19 by jop") (DECLARE (SPECVARS SMALLFONT LARGEFONT)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (TICS? (fetch (MARGIN TICS?) of TOPMARGIN)) (LABEL (fetch (MARGIN LABEL) of TOPMARGIN)) (WIDTH 0) SMALLASCENT LARGEHEIGHT HEIGHT) (SETQ SMALLASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ LARGEHEIGHT (FONTPROP LARGEFONT 'HEIGHT)) (* ;  "margin of at least one LARGEHEIGHT") [SETQ HEIGHT (COND ((OR TICS? LABEL) LARGEHEIGHT) (T (ITIMES 2 LARGEHEIGHT] [COND (TICS? (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 3 SMALLASCENT] [COND (LABEL (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 2 LARGEHEIGHT))) (SETQ WIDTH (IMAX WIDTH (STRINGWIDTH LABEL LARGEFONT] (RETURN (CONS WIDTH HEIGHT]) (COPYMENU [LAMBDA (MENU NEWITEMS) (* ; "Edited 1-Jun-92 13:59 by jds") (* ;; "Note that menu props are not copied") (create MENU ITEMS _ (OR NEWITEMS (fetch (MENU ITEMS) of MENU)) WHENSELECTEDFN _ (fetch (MENU WHENSELECTEDFN) of MENU) WHENHELDFN _ (fetch (MENU WHENHELDFN) of MENU) WHENUNHELDFN _ (fetch (MENU WHENUNHELDFN) of MENU) MENUPOSITION _ (fetch (MENU MENUPOSITION) of MENU) MENUOFFSET _ (fetch (MENU MENUOFFSET) of MENU) MENUFONT _ (fetch (MENU MENUFONT) of MENU) MENUTITLEFONT _ (fetch (MENU MENUTITLEFONT) of MENU) TITLE _ (fetch (MENU TITLE) of MENU) CENTERFLG _ (fetch (MENU CENTERFLG) of MENU) MENUBORDERSIZE _ (fetch (MENU MENUBORDERSIZE) of MENU) MENUOUTLINESIZE _ (fetch (MENU MENUOUTLINESIZE) of MENU) CHANGEOFFSETFLG _ (fetch (MENU CHANGEOFFSETFLG) of MENU]) (CREATEPLOT [LAMBDA (OPENFLG REGION TITLE BORDER) (* ; "Edited 5-May-87 18:19 by jop") (* ;; "Creates a PLOT. If OPENFLG is T then the PLOT's asssociated window is opened. The other arguments are passed to CREATEW") (PROG ((PLOT (create PLOT))) (replace (PLOT PLOTSCALE) of PLOT with (create PLOTSCALE XAXISINFO _ (create AXISINFO) XINTERVAL _ (create AXISINTERVAL MIN _ 0.0 MAX _ 1.0) XTICINFO _ (create TICINFO TICMIN _ 0.0 TICMAX _ 1.0 TICINC _ 1.0 NTICS _ 2) YAXISINFO _ (create AXISINFO) YINTERVAL _ (create AXISINTERVAL MIN _ 0.0 MAX _ 1.0) YTICINFO _ (create TICINFO TICMIN _ 0.0 TICMAX _ 1.0 TICINC _ 1.0 NTICS _ 2))) (PLOTMENU PLOT 'MIDDLE (PLOT.DEFAULTMENU 'MIDDLE)) (PLOTMENU PLOT 'RIGHT (PLOT.DEFAULTMENU 'RIGHT)) (* ;  "Compute size of margins in stream coordinates") (replace (PLOT BOTTOMMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (replace (PLOT LEFTMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (replace (PLOT TOPMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (replace (PLOT RIGHTMARGIN) of PLOT with (create MARGIN TICMETHOD _ 'DEFAULT)) (* ;  "Cache display parameters until OPENPLOTWINDOW is called") [COND ((OR REGION TITLE BORDER) (replace (PLOT PLOTWINDOW) of PLOT with (LIST REGION TITLE BORDER] (COND (OPENFLG (OPENPLOTWINDOW PLOT))) (RETURN PLOT]) (CREATEPLOTFNS [LAMBDA (DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN GETFN BORROWFROM) (* ; "Edited 28-Sep-91 16:22 by jds") (* ;; "Create an instance of PLOTFNS, a vector of functions that implement generic plot object operations. A DRAWFN , ERASEFN , and a EXTENTFN are required. If there is a DISTANCEFN then a HIGHLIGHTFN must also be supplied. Supplies defaults for some generic operations. If BORROWFROM then it must be another PLOTFNS, in which case NIL functions are inherited from USING.") (DECLARE (SPECVARS DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN GETFN)) [COND (BORROWFROM [COND ((AND (NULL LOWLIGHTFN) (NULL HIGHLIGHTFN)) (SETQ LOWLIGHTFN (fetch (PLOTFNS LOWLIGHTFN) of BORROWFROM] (for FN in '(DRAWFN ERASEFN EXTENTFN HIGHLIGHTFN LABELFN DISTANCEFN MOVEFN COPYFN PUTFN GETFN) do (COND ((NULL (EVAL FN)) (SET FN (RECORDACCESS FN BORROWFROM] (COND ((NOT (AND DRAWFN ERASEFN EXTENTFN)) (HELP "Attempt to create PLOTFNS without required FNS"))) (COND ((AND DISTANCEFN (NOT HIGHLIGHTFN)) (HELP "DISTANCEFN without a HIGHLIGHTFN"))) (create PLOTFNS DRAWFN _ DRAWFN ERASEFN _ ERASEFN HIGHLIGHTFN _ (OR HIGHLIGHTFN (FUNCTION PLOTOPERROR)) LOWLIGHTFN _ (OR LOWLIGHTFN HIGHLIGHTFN (FUNCTION PLOTOPERROR)) MOVEFN _ (OR MOVEFN (FUNCTION PLOTOPERROR)) LABELFN _ (OR LABELFN (FUNCTION LABELGENERIC)) EXTENTFN _ EXTENTFN DISTANCEFN _ [OR DISTANCEFN (FUNCTION (LAMBDA NIL MAX.SMALLP] COPYFN _ (OR COPYFN (FUNCTION COPYGENERIC)) PUTFN _ (OR PUTFN (FUNCTION PUTGENERIC)) GETFN _ (OR GETFN (FUNCTION GETGENERIC]) (CREATEPLOTOBJECT [LAMBDA (OBJECTFNS OBJECTSUBTYPE OBJECTLABEL OBJECTMENU OBJECTDATA) (* ; "Edited 5-May-87 18:20 by jop") (COND ((NOT (AND OBJECTFNS OBJECTDATA)) (HELP "Attempt to create a PLOTOBJECT without a FNS vector or OBJECTDATA"))) (PROG ((PLOTOBJECT (create PLOTOBJECT OBJECTFNS _ OBJECTFNS OBJECTSUBTYPE _ OBJECTSUBTYPE OBJECTLABEL _ OBJECTLABEL OBJECTDATA _ OBJECTDATA))) (* ;  "PLOTOBJECTPROP coerces OBJECTMENU to a menu if it is an item list") (PLOTOBJECTPROP PLOTOBJECT 'OBJECTMENU OBJECTMENU) (RETURN PLOTOBJECT]) (DEFAULTSCALEFN [LAMBDA (MIN MAX TICINFO) (* ; "Edited 5-May-87 18:20 by jop") (create AXISINTERVAL MIN _ (fetch (TICINFO TICMIN) of TICINFO) MAX _ (fetch (TICINFO TICMAX) of TICINFO]) (DEFAULTTICFN [LAMBDA (MIN MAX TICS ROUND POWER) (* ; "Edited 28-Sep-91 16:54 by jds") (* ;; "Computes an interval that includes (MIN,MAX) and can be exactly spanned by (NTICS-1) *some increment. If TICS is NIL tries a few values and chooses the one that yields the shortest interval.") (COND [(NULL TICS) (SETQ TICS '(3 4 5 6 7 8] ((FIXP TICS) (SETQ TICS (LIST TICS))) ((NLISTP TICS) (HELP "Not a list of FIXP's" TICS))) (bind (SHORTEST _ (SCALE MIN MAX (CAR TICS) ROUND POWER)) CURRENT for NTICS in (CDR TICS) do (SETQ CURRENT (SCALE MIN MAX NTICS ROUND POWER)) (COND ((LESSP (fetch (TICINFO TICINTERVALLENGTH ) of CURRENT ) (fetch (TICINFO TICINTERVALLENGTH ) of SHORTEST )) (SETQ SHORTEST CURRENT))) finally (RETURN SHORTEST]) (DEFAULTTICMETHOD [LAMBDA (MARGIN PLOTSCALE PLOT) (* ; "Edited 5-May-87 18:21 by jop") (* ;; "Return the default tic list based on the values of PLOTSCALE") (PROG ((TICINFO (SELECTQ MARGIN ((BOTTOM TOP) (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) ((RIGHT LEFT) (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) (HELP "MARGIN must be one of RIGHT, LEFT, TOP, BOTTOM" MARGIN))) TICINC) (SETQ TICINC (fetch (TICINFO TICINC) of TICINFO)) (RETURN (COND ((LISTP TICINC) TICINC) ((NUMBERP TICINC) (* ;  "Be carefull that min and max tics correspond to min and max of interval") (NCONC1 (for I from 1 to (SUB1 (fetch (TICINFO NTICS) of TICINFO)) as X from (fetch (TICINFO TICMIN) of TICINFO) by TICINC collect X) (fetch (TICINFO TICMAX) of TICINFO))) (T (HELP "Invalid TICINC" TICINC]) (DELETEPLOTOBJECT [LAMBDA (OBJECT PLOT NODRAWFLG NOSAVEFLG) (* ; "Edited 5-May-87 18:21 by jop") (* ;; "Delete object from display list of plot. If (NULL NODRAWFLG) then update the display (open it if necessary) if (NULL NOSAVEFLG) then intern the object on the save list.") (LET [(PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) (PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (WHENDELETEDFN (PLOTOBJECTPROP OBJECT 'WHENDELETEDFN] (if (MEMB OBJECT PLOTOBJECTS) then (if (EQ OBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) then (if (NULL NODRAWFLG) then (if (OPENWP PLOTWINDOW) then (LOWLIGHTPLOTOBJECT OBJECT PLOT))) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL)) (replace (PLOT PLOTOBJECTS) of PLOT with (DREMOVE OBJECT PLOTOBJECTS)) (if (NULL NOSAVEFLG) then (push (fetch (PLOT PLOTSAVELIST) of PLOT) OBJECT)) (if (NULL NODRAWFLG) then (if (NOT (OPENWP PLOTWINDOW)) then (OPENPLOTWINDOW PLOT) else (ERASEPLOTOBJECT OBJECT PLOT))) (APPLY.AFTERFN WHENDELETEDFN OBJECT PLOT NODRAWFLG NOSAVEFLG) OBJECT]) (DESELECTPLOTOBJECT [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:21 by jop") (if (fetch (PLOT SELECTEDOBJECT) of PLOT) then (LOWLIGHTPLOTOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT) PLOT) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL]) (DISTANCETOPLOTOBJECT [LAMBDA (OBJECT STREAMPOSITION PLOT) (* ; "Edited 5-May-87 18:25 by jop") (CL:FUNCALL (fetch (PLOTFNS DISTANCEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT STREAMPOSITION PLOT]) (DRAWBOTTOMMARGIN [LAMBDA (BOTTOMMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 16:40 by jds") (* ;; "DRAW the BOTTOM MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of BOTTOMMARGIN)) (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLPLOTFONTASCENT BOTTOM) (SETQ SMALLPLOTFONTASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ BOTTOM (fetch (REGION BOTTOM) of (fetch STREAMSUBREGION of VIEWPORT)) ) (if (fetch (MARGIN TICS?) of BOTTOMMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-TOP-BOTTOM (fetch (MARGIN TICLIST) of BOTTOMMARGIN) (fetch (AXISINTERVAL MIN) of XINTERVAL) (fetch (AXISINTERVAL MAX) of XINTERVAL) (IPLUS SMALLPLOTFONTASCENT BOTTOM) (IDIFFERENCE BOTTOM SMALLPLOTFONTASCENT) (ITIMES 2 SMALLPLOTFONTASCENT) SMALLFONT STREAM VIEWPORT T)) (if LABEL then (DRAW-LABEL-TOP-BOTTOM LABEL LARGEFONT [PLUS (fetch (REGION BOTTOM) of STREAMREGION) (IPLUS (FONTPROP STREAM 'DESCENT) (FONTPROP LARGEFONT 'HEIGHT] STREAMREGION STREAM]) (DRAWLEFTMARGIN [LAMBDA (LEFTMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 17:00 by jds") (* ;; "DRAW the BOTTOM MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of LEFTMARGIN)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLWIDTH LEFT) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ LEFT (fetch (REGION LEFT) of (fetch STREAMSUBREGION of VIEWPORT))) (if (fetch (MARGIN TICS?) of LEFTMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-LEFT-RIGHT (fetch (MARGIN TICLIST) of LEFTMARGIN) (fetch (AXISINTERVAL MIN) of YINTERVAL) (fetch (AXISINTERVAL MAX) of YINTERVAL) (IPLUS SMALLWIDTH LEFT) (IDIFFERENCE LEFT SMALLWIDTH) SMALLWIDTH SMALLFONT STREAM VIEWPORT T)) (if LABEL then (DRAW-LABEL-LEFT-RIGHT LABEL LARGEFONT (PLUS (fetch (REGION LEFT) of STREAMREGION) (STRINGWIDTH 'A LARGEFONT)) STREAMREGION STREAM]) (DRAWMARGIN [LAMBDA (MARGIN STREAM STREAMVIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (* ;; "Draws the margin MARGIN (one of RIGHT LEFT BOTTOM or TOP)") (SELECTQ MARGIN (RIGHT (DRAWRIGHTMARGIN (fetch (PLOT RIGHTMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (LEFT (DRAWLEFTMARGIN (fetch (PLOT LEFTMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (BOTTOM (DRAWBOTTOMMARGIN (fetch (PLOT BOTTOMMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (TOP (DRAWTOPMARGIN (fetch (PLOT TOPMARGIN) of PLOT) STREAM STREAMVIEWPORT STREAMREGION PLOT)) (HELP "MARGIN must be one of RIGHT, LEFT, BOTTOM, or TOP " MARGIN]) (DRAWPLOTOBJECT [LAMBDA (OBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 18:23 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENDRAWNFN (PLOTOBJECTPROP OBJECT 'WHENDRAWNFN] (CL:FUNCALL (fetch (PLOTFNS DRAWFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT VIEWPORT PLOT) (COND (TEXTOBJECT (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT))) (APPLY.AFTERFN WHENDRAWNFN OBJECT VIEWPORT PLOT]) (DRAWPLOT [LAMBDA (PLOT CURRENTSTREAM STREAMVIEWPORT STREAMREGION) (* ; "Edited 28-Sep-91 16:17 by jds") (* ;; "Draws a plot on CURRENTSTREAM. STREAMREGION is the region the PLOT will occupy. Does not blank the STREAMREGION before drawing") (COND ((NOT (type? PLOT PLOT)) (HELP "Not a PLOT " PLOT))) (* ;  "Will not check, for the moment, that the streamregion is large enough") (BOXREGION (fetch STREAMSUBREGION of STREAMVIEWPORT) CURRENTSTREAM) (for MARGIN in '(BOTTOM LEFT TOP RIGHT) do (DRAWMARGIN MARGIN CURRENTSTREAM STREAMVIEWPORT STREAMREGION PLOT)) (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (DRAWPLOTOBJECT OBJECT STREAMVIEWPORT PLOT]) (DRAWRIGHTMARGIN [LAMBDA (RIGHTMARGIN STREAM VIEWPORT STREAMREGION PLOT)(* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "DRAW the RIGHT MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of RIGHTMARGIN)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLWIDTH RIGHT) (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) (SETQ RIGHT (fetch (REGION RIGHT) of (fetch STREAMSUBREGION of VIEWPORT))) (if (fetch (MARGIN TICS?) of RIGHTMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-LEFT-RIGHT (fetch (MARGIN TICLIST) of RIGHTMARGIN) (fetch (AXISINTERVAL MIN) of YINTERVAL) (fetch (AXISINTERVAL MAX) of YINTERVAL) (IPLUS SMALLWIDTH RIGHT) (IDIFFERENCE RIGHT SMALLWIDTH) SMALLWIDTH SMALLFONT STREAM VIEWPORT)) (if LABEL then (DRAW-LABEL-LEFT-RIGHT LABEL LARGEFONT (DIFFERENCE (fetch (REGION RIGHT) of STREAMREGION) (ITIMES 2 (STRINGWIDTH 'A LARGEFONT))) STREAMREGION STREAM]) (DRAWTOPMARGIN [LAMBDA (TOPMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "DRAW the Top MARGIN") (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) (LABEL (fetch (MARGIN LABEL) of TOPMARGIN)) (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of (fetch (PLOT PLOTSCALE) of PLOT))) SMALLFONTASCENT TOP) (SETQ SMALLFONTASCENT (FONTPROP SMALLFONT 'ASCENT)) (SETQ TOP (fetch (REGION TOP) of (fetch STREAMSUBREGION of VIEWPORT))) (if (fetch (MARGIN TICS?) of TOPMARGIN) then (* ;; "DRAW TICS and TIC labels if necessary") (DRAW-TICS-TOP-BOTTOM (fetch (MARGIN TICLIST) of TOPMARGIN) (fetch (AXISINTERVAL MIN) of XINTERVAL) (fetch (AXISINTERVAL MAX) of XINTERVAL) (IPLUS SMALLFONTASCENT TOP) (IDIFFERENCE TOP SMALLFONTASCENT) SMALLFONTASCENT SMALLFONT STREAM VIEWPORT)) (if LABEL then (DRAW-LABEL-TOP-BOTTOM LABEL LARGEFONT [IDIFFERENCE (fetch (REGION TOP) of STREAMREGION) (IPLUS (FONTPROP LARGEFONT 'HEIGHT) (FONTPROP STREAM 'ASCENT] STREAMREGION STREAM]) (ERASEPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:24 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENERASEDFN (PLOTOBJECTPROP OBJECT 'WHENERASEDFN] (CL:FUNCALL (fetch (PLOTFNS ERASEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT) (COND (TEXTOBJECT (ERASEPLOTOBJECT TEXTOBJECT PLOT))) (APPLY.AFTERFN WHENERASEDFN OBJECT PLOT]) (EXTENDEDSCALEFN [LAMBDA (MIN MAX TICINFO) (* ; "Edited 5-May-87 18:28 by jop") (PROG ((NEWMIN (fetch (TICINFO TICMIN) of TICINFO)) (NEWMAX (fetch (TICINFO TICMAX) of TICINFO)) (EPISILON 0.05) DELTA) (SETQ DELTA (FTIMES EPISILON (FDIFFERENCE NEWMAX NEWMIN))) (RETURN (create AXISINTERVAL MIN _ (FDIFFERENCE NEWMIN DELTA) MAX _ (FPLUS NEWMAX DELTA]) (EXTENTOFPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:28 by jop") (CL:FUNCALL (fetch (PLOTFNS EXTENTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT) ) OBJECT PLOT]) (EXTENTOFPLOT [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (bind EXTENT (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (SETQ EXTENT (EXTENTOFPLOTOBJECT OBJECT)) [COND ((LESSP (fetch (EXTENT MINX) of EXTENT) MINX) (SETQ MINX (fetch (EXTENT MINX) of EXTENT] [COND ((GREATERP (fetch (EXTENT MAXX) of EXTENT) MAXX) (SETQ MAXX (fetch (EXTENT MAXX) of EXTENT] [COND ((LESSP (fetch (EXTENT MINY) of EXTENT) MINY) (SETQ MINY (fetch (EXTENT MINY) of EXTENT] [COND ((GREATERP (fetch (EXTENT MAXY) of EXTENT) MAXY) (SETQ MAXY (fetch (EXTENT MAXY) of EXTENT] finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY]) (GETPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:29 by jop") (WINDOWP (fetch (PLOT PLOTWINDOW) of PLOT]) (GETTICLIST [LAMBDA (MARGINNAME PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (LET* ((MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (SHOULDNT))) (TICMETHOD (fetch (MARGIN TICMETHOD) of MARGIN))) (COND ((EQ TICMETHOD 'DEFAULT) (DEFAULTTICMETHOD MARGINNAME (fetch (PLOT PLOTSCALE) of PLOT) PLOT)) ((LITATOM TICMETHOD) (CL:FUNCALL TICMETHOD MARGINNAME (fetch (PLOT PLOTSCALE) of PLOT) PLOT)) ((LISTP TICMETHOD) TICMETHOD) (T (HELP "Illegal ticmethod" TICMETHOD]) (HIGHLIGHTPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENHIGHLIGHTEDFN (PLOTOBJECTPROP OBJECT 'WHENHIGHLIGHTEDFN] (CL:FUNCALL (fetch (PLOTFNS HIGHLIGHTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT) (COND (TEXTOBJECT (HIGHLIGHTPLOTOBJECT TEXTOBJECT PLOT))) (APPLY.AFTERFN WHENHIGHLIGHTEDFN OBJECT PLOT]) (LABELPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") (PROG [(WHENLABELEDFN (PLOTOBJECTPROP OBJECT 'WHENLABELEDFN] (CL:FUNCALL (fetch (PLOTFNS LABELFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT PLOT) (APPLY.AFTERFN WHENLABELEDFN OBJECT PLOT]) (LOWLIGHTPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENLOWLIGHTEDFN (PLOTOBJECTPROP OBJECT 'WHENLOWLIGHTEDFN] (CL:FUNCALL (fetch (PLOTFNS LOWLIGHTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT) (COND (TEXTOBJECT (LOWLIGHTPLOTOBJECT TEXTOBJECT PLOT))) (APPLY.AFTERFN WHENLOWLIGHTEDFN OBJECT PLOT]) (MANUALRESCALE [LAMBDA (PLOT AXIS) (* ; "Edited 28-Sep-91 16:17 by jds") [COND ((NULL AXIS) (SETQ AXIS 'BOTH] (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) NEWSCALE) [COND ((OR (EQ AXIS 'BOTH) (EQ AXIS 'X)) (SETQ NEWSCALE (ASKFORSCALE PLOT 'X)) (COND ((GREATERP (CDR NEWSCALE) (CAR NEWSCALE)) (LET ((NEWMIN (CAR NEWSCALE)) (NEWMAX (CDR NEWSCALE)) (AXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE))) (replace (PLOTSCALE XTICINFO) of PLOTSCALE with (CHOOSETICS NEWMIN NEWMAX AXISINFO PLOT)) (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with (create AXISINTERVAL MIN _ NEWMIN MAX _ NEWMAX] [COND ((OR (EQ AXIS 'BOTH) (EQ AXIS 'Y)) (SETQ NEWSCALE (ASKFORSCALE PLOT 'Y)) (COND ((GREATERP (CDR NEWSCALE) (CAR NEWSCALE)) (LET ((NEWMIN (CAR NEWSCALE)) (NEWMAX (CDR NEWSCALE)) (AXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE))) (replace (PLOTSCALE YTICINFO) of PLOTSCALE with (CHOOSETICS NEWMIN NEWMAX AXISINFO PLOT)) (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with (create AXISINTERVAL MIN _ NEWMIN MAX _ NEWMAX] (REDRAWPLOTWINDOW PLOT]) (MINSTREAMREGIONSIZE [LAMBDA (STREAM PLOT) (* ; "Edited 28-Sep-91 16:17 by jds") (* ;; "Compute the minimun acceptable size for a plot STREAMREGION. In the case of PLOTWINDOWS, corresponds to the min exceptable interior size of the WINDOW. Returns a dotted pair (MINX . MINY)") (* ;  "Sizes are (width . height) pairs") (PROG ((BOTTOMMARGINSIZE (COMPUTEBOTTOMMARGIN STREAM (fetch (PLOT BOTTOMMARGIN) of PLOT) PLOT)) (LEFTMARGINSIZE (COMPUTELEFTMARGIN STREAM (fetch (PLOT LEFTMARGIN) of PLOT) PLOT)) (RIGHTMARGINSIZE (COMPUTERIGHTMARGIN STREAM (fetch (PLOT RIGHTMARGIN) of PLOT) PLOT)) (TOPMARGINSIZE (COMPUTETOPMARGIN STREAM (fetch (PLOT TOPMARGIN) of PLOT) PLOT)) MINX MINY) (* ; "The constant 100 is heuristic") (SETQ MINX (IPLUS (CAR LEFTMARGINSIZE) (IMAX (CAR BOTTOMMARGINSIZE) (CAR TOPMARGINSIZE) 100) (CAR RIGHTMARGINSIZE))) (SETQ MINY (IPLUS (CDR BOTTOMMARGINSIZE) (IMAX (CDR LEFTMARGINSIZE) (CDR RIGHTMARGINSIZE) 100) (CDR TOPMARGINSIZE))) (RETURN (CONS MINX MINY]) (MOVEPLOTOBJECT [LAMBDA (OBJECT DX DY PLOT) (* ; "Edited 5-May-87 18:30 by jop") (CL:FUNCALL (fetch (PLOTFNS MOVEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) OBJECT DX DY PLOT]) (OPENPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "Open window associated with PLOT. Creates circularities later broken by PLOT.CLOSEFN") (COND ((NOT (type? PLOT PLOT)) (HELP "Not a plot" PLOT))) (PROG ((WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) (WHENOPENEDFN (PLOTPROP PLOT 'WHENOPENEDFN)) MINSIZE WINDOWRESHAPEFLG PROMPTCREATEDFLG MINWINDOWEXTENT) (COND ((OPENWP WINDOW) (* ; "No need to continue") (RETURN WINDOW))) [COND ((NOT (WINDOWP WINDOW)) (LET (REGION TITLE BORDER) [COND ((LISTP WINDOW) (SETQ REGION (CAR WINDOW)) (SETQ TITLE (CADR WINDOW)) (SETQ BORDER (CADDR WINDOW] (SETQ WINDOW (CREATEW (OR REGION (CREATEREGION 0 0 100 100)) (OR TITLE "Plot Window") BORDER T)) (replace (PLOT PLOTWINDOW) of PLOT with WINDOW) (SETQ WINDOWRESHAPEFLG (NOT REGION] (* ;; "setup plot window props") (WINDOWPROP WINDOW 'PLOT PLOT) (WINDOWADDPROP WINDOW 'REPAINTFN (FUNCTION PLOT.REPAINTFN)) (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION PLOT.REPAINTFN)) (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION PLOT.CLOSEFN)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION PLOT.BUTTONEVENTFN)) (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION PLOT.BUTTONEVENTFN)) (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (FUNCTION PLOT.COPYBUTTONEVENTFN)) (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION PLOT.HARDCOPYFN)) (WINDOWPROP WINDOW 'ICONFN (FUNCTION PLOT.ICONFN)) (* ;  "Rest of VIEWPORT initializations in REDRAWPLOTWINDOW") [replace (PLOT PLOTWINDOWVIEWPORT) of PLOT with (CREATEVIEWPORT (WINDOWPROP WINDOW 'DSP] (* ;; "Get a prompt window, if none exists") (COND ((NULL PLOTPROMPTWINDOW) (SETQ PLOTPROMPTWINDOW (CREATEW [CREATEREGION 0 0 100 (HEIGHTIFWINDOW (FONTPROP (DEFAULTFONT 'DISPLAY) 'HEIGHT] NIL NIL T)) (WINDOWPROP PLOTPROMPTWINDOW 'PAGEFULLFN (FUNCTION NILL)) [WINDOWPROP PLOTPROMPTWINDOW 'MAXSIZE (CONS MAX.SMALLP (fetch (REGION HEIGHT) of (WINDOWPROP PLOTPROMPTWINDOW 'REGION] (DSPSCROLL 'ON PLOTPROMPTWINDOW) (replace (PLOT PLOTPROMPTWINDOW) of PLOT with PLOTPROMPTWINDOW) (SETQ PROMPTCREATEDFLG T))) (* ;  "Establish a min size for the window") (CREATETICLISTS PLOT) (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP WINDOW 'DSP) PLOT)) [WINDOWPROP WINDOW (COND ((NULL (ATTACHEDWINDOWS WINDOW)) 'MINSIZE) (T 'MAINWINDOWMINSIZE)) (CONS (WIDTHIFWINDOW (CAR MINSIZE) (WINDOWPROP WINDOW 'BORDER)) (HEIGHTIFWINDOW (CDR MINSIZE) (WINDOWPROP WINDOW 'TITLE) (WINDOWPROP WINDOW 'BORDER] (COND ([AND (NOT WINDOWRESHAPEFLG) (OR (ILESSP (WINDOWPROP WINDOW 'WIDTH) (CAR MINSIZE)) (ILESSP (WINDOWPROP WINDOW 'HEIGHT) (CDR MINSIZE] (SETQ WINDOWRESHAPEFLG T) (PROMPTPRINT "Window too small: reshape"))) [IF WINDOWRESHAPEFLG THEN (* ;  "Shaping window implies redrawing it") (SHAPEW WINDOW) ELSE (LET ((PLOTWINDOWVIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT))) (OPENW WINDOW) (ADJUSTVIEWPORT PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL WINDOW) PLOT) (DRAWPLOT PLOT (WINDOWPROP WINDOW 'DSP) PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL WINDOW)) (IF SELECTEDOBJECT THEN (HIGHLIGHTPLOTOBJECT SELECTEDOBJECT PLOT] (* ;  "Attach the promptwindow if necessary") (ATTACHWINDOW PLOTPROMPTWINDOW WINDOW 'TOP) (* ; "attach the fixed menu") (COND ((PLOTPROP PLOT 'FIXEDRIGHTMENU?) (PLOT.FIXRIGHTMENU PLOT T))) (* ; "A user hook") (APPLY.AFTERFN WHENOPENEDFN PLOT) (RETURN WINDOW]) (PLOT.BUTTONEVENTFN [LAMBDA (PLOTWINDOW) (* ; "Edited 7-May-87 10:14 by jop") (TOTOPW PLOTWINDOW) (LET* ((PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT))) (COND [(LASTMOUSESTATE LEFT) (LET ((OLDX 0) (OLDY 0) (PLOTSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of (fetch (PLOT PLOTWINDOWVIEWPORT ) of PLOT))) (POSITION (create POSITION)) NEWX NEWY NEWSELECTEDOBJECT) (while (MOUSESTATE LEFT) do (replace (POSITION XCOORD) of POSITION with (SETQ NEWX (LASTMOUSEX PLOTWINDOW))) (replace (POSITION YCOORD) of POSITION with (SETQ NEWY (LASTMOUSEY PLOTWINDOW))) [COND [(INSIDEP PLOTSUBREGION POSITION) (COND ((NOT (AND (EQ OLDX NEWX) (EQ OLDY NEWY))) (SETQ NEWSELECTEDOBJECT (CLOSESTPLOTOBJECT PLOT POSITION)) (COND ((AND NEWSELECTEDOBJECT (NEQ NEWSELECTEDOBJECT SELECTEDOBJECT) ) (COND (SELECTEDOBJECT (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT))) (HIGHLIGHTPLOTOBJECT NEWSELECTEDOBJECT PLOT) (replace (PLOT SELECTEDOBJECT) of PLOT with NEWSELECTEDOBJECT ) (SETQ SELECTEDOBJECT NEWSELECTEDOBJECT) (* ;  "Try to print a meaningfull message in the PLOTPROMPTWINDOW") (PLOTPROMPT (fetch (PLOTOBJECT OBJECTLABEL) of NEWSELECTEDOBJECT) PLOT] (T (COND (SELECTEDOBJECT (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT) (SETQ SELECTEDOBJECT NIL) (replace (PLOT SELECTEDOBJECT) of PLOT with SELECTEDOBJECT] (SETQ OLDX NEWX) (SETQ OLDY NEWY] [(AND SELECTEDOBJECT (LASTMOUSESTATE MIDDLE)) (LET ((MIDDLEMENU (fetch (PLOT MIDDLEMENU) of PLOT)) (OBJECTMENU (fetch (PLOTOBJECT OBJECTMENU) of SELECTEDOBJECT)) MIDMENU) (SETQ MIDMENU (COND (OBJECTMENU [COND ((LITATOM OBJECTMENU) (SETQ OBJECTMENU (LISTGET (fetch (PLOT OTHERMENUS ) of PLOT) OBJECTMENU] OBJECTMENU) (T MIDDLEMENU))) (COND (MIDMENU (PUTMENUPROP MIDMENU 'PLOT PLOT) (PUTMENUPROP MIDMENU 'MODE 'MIDDLE) (MENU MIDMENU) (PUTMENUPROP MIDMENU 'MODE NIL) (PUTMENUPROP MIDMENU 'PLOT NIL] ((LASTMOUSESTATE RIGHT) (LET [(RIGHTMENU (fetch (PLOT RIGHTMENU) of PLOT)) (FIXEDRIGHTMENU? (PLOTPROP PLOT 'FIXEDRIGHTMENU?] (COND ([OR FIXEDRIGHTMENU? (IGREATERP (fetch (POSITION YCOORD) of (CURSORPOSITION NIL PLOTWINDOW)) (WINDOWPROP PLOTWINDOW 'HEIGHT] (DOWINDOWCOM PLOTWINDOW)) (RIGHTMENU (PUTMENUPROP RIGHTMENU 'PLOT PLOT) (MENU RIGHTMENU) (PUTMENUPROP RIGHTMENU 'PLOT NIL]) (PLOT.CLOSEFN [LAMBDA (W) (* ; "Edited 5-May-87 18:38 by jop") (CLOSEPLOTWINDOW (WINDOWPROP W 'PLOT]) (PLOT.DEFAULTMENU [LAMBDA ARGS (* ; "Edited 5-May-87 18:38 by jop") (* ;; "If no third argument then simply return items list for given menu (middle or right), else replace the cached menu with the new list of items") (DECLARE (GLOBALVARS PLOT.DEFAULTMIDDLEMENU PLOT.DEFAULTRIGHTMENU)) (COND ((LESSP ARGS 1) (HELP "Must have at least one arg, MENUNAME"))) (PROG ((MENUNAME (ARG ARGS 1)) (NEWITEMS (AND (GREATERP ARGS 1) (ARG ARGS 2))) MENU) (COND ((AND (GREATERP ARGS 1) (NOT (LISTP NEWITEMS))) (HELP "Not a list" NEWITEMS))) (SETQ MENU (SELECTQ MENUNAME (MIDDLE (AND (BOUNDP 'PLOT.DEFAULTMIDDLEMENU) PLOT.DEFAULTMIDDLEMENU)) (RIGHT (AND (BOUNDP 'PLOT.DEFAULTRIGHTMENU) PLOT.DEFAULTRIGHTMENU)) (SHOULDNT))) [COND ((GREATERP ARGS 1) [SETQ MENU (AND NEWITEMS (COND (MENU (COPYMENU MENU NEWITEMS)) (T (create MENU ITEMS _ NEWITEMS] (SELECTQ MENUNAME (MIDDLE (SETQ PLOT.DEFAULTMIDDLEMENU MENU)) (RIGHT (SETQ PLOT.DEFAULTRIGHTMENU MENU)) (SHOULDNT] (RETURN MENU]) (PLOT.FIXRIGHTMENU [LAMBDA ARGS (* ; "Edited 5-May-87 18:39 by jop") (COND ((ILESSP ARGS 1) (HELP "Must have at least one arg"))) (LET* ((PLOT (ARG ARGS 1)) [FIXEDFLG (COND ((IGREATERP ARGS 1) (ARG ARGS 2] (OLDVALUE (PLOTPROP PLOT 'FIXEDRIGHTMENU?)) (PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT))) [COND ((IGREATERP ARGS 1) (LET [(FIXEDRIGHTMENU (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU] (PLOTPROP PLOT 'FIXEDRIGHTMENU? (NOT (NULL FIXEDFLG))) (COND [FIXEDFLG (COND ((AND (OPENWP PLOTWINDOW) (NULL FIXEDRIGHTMENU)) (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU (ATTACHMENU (fetch (PLOT RIGHTMENU ) of PLOT) PLOTWINDOW 'RIGHT 'TOP] (T (COND (FIXEDRIGHTMENU (CLOSEW FIXEDRIGHTMENU) (DETACHWINDOW FIXEDRIGHTMENU) (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU NIL] OLDVALUE]) (PLOT.HARDCOPYFN [LAMBDA (PLOTWINDOW PRINTERSTREAM) (* ; "Edited 28-Sep-91 17:01 by jds") (* ;; "Modified to allow hardcopy of plots on PRESS printers -- no landscape drawing") (* ;; "Modified to center plot on page") (PROG ((WINDOWREGION (DSPCLIPPINGREGION NIL PLOTWINDOW)) (PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) (VIEWPORT (CREATEVIEWPORT PRINTERSTREAM)) PRINTERCLIPREGION STREAMREGION K) [if (EQ (IMAGESTREAMTYPE PRINTERSTREAM) 'INTERPRESS) then (LET ((MICASPERINCH 2540)) (if (GREATERP (fetch (REGION WIDTH) of WINDOWREGION) (fetch (REGION HEIGHT) of WINDOWREGION)) then (* ; "Print in landscape mode") (ROTATE.IP PRINTERSTREAM 90) (CONCATT.IP PRINTERSTREAM) [TRANSLATE.IP PRINTERSTREAM 0 (FIX (MINUS (TIMES 8.5 MICASPERINCH] (CONCATT.IP PRINTERSTREAM) (* ;  "Make sure the clippingregion is rational") (DSPCLIPPINGREGION (CREATEREGION (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 10 MICASPERINCH)) (FIX (TIMES 7.5 MICASPERINCH))) PRINTERSTREAM) else (* ;  "Make sure the clippingregion is rational") (DSPCLIPPINGREGION (CREATEREGION (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 0.5 MICASPERINCH)) (FIX (TIMES 7.5 MICASPERINCH)) (FIX (TIMES 10 MICASPERINCH))) PRINTERSTREAM] (SETQ PRINTERCLIPREGION (DSPCLIPPINGREGION NIL PRINTERSTREAM)) (* ; "Reset the margins") (DSPLEFTMARGIN (fetch (REGION LEFT) of PRINTERCLIPREGION) PRINTERSTREAM) (DSPBOTTOMMARGIN (fetch (REGION BOTTOM) of PRINTERCLIPREGION) PRINTERSTREAM) (DSPRIGHTMARGIN (fetch (REGION RIGHT) of PRINTERCLIPREGION) PRINTERSTREAM) (DSPTOPMARGIN (fetch (REGION TOP) of PRINTERCLIPREGION) PRINTERSTREAM) (* ;  "maintain the PLOTWINDOW's aspect ratio") [SETQ K (MIN (QUOTIENT (fetch (REGION WIDTH) of PRINTERCLIPREGION) (fetch (REGION WIDTH) of WINDOWREGION)) (QUOTIENT (fetch (REGION HEIGHT) of PRINTERCLIPREGION) (fetch (REGION HEIGHT) of WINDOWREGION] (SETQ STREAMREGION (LET [(SWIDTH (TIMES K (fetch (REGION WIDTH) of WINDOWREGION))) (SHEIGHT (TIMES K (fetch (REGION HEIGHT) of WINDOWREGION] (* ;; "center plot on page") (CREATEREGION (PLUS (fetch (REGION LEFT) of PRINTERCLIPREGION ) (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PRINTERCLIPREGION ) SWIDTH) 2)) (PLUS (fetch (REGION BOTTOM) of PRINTERCLIPREGION) (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PRINTERCLIPREGION) SHEIGHT) 2)) SWIDTH SHEIGHT))) (CREATETICLISTS PLOT) (ADJUSTVIEWPORT VIEWPORT STREAMREGION PLOT) (DRAWPLOT PLOT PRINTERSTREAM VIEWPORT STREAMREGION]) (PLOT.ICONFN [LAMBDA (PLOTWINDOW OLDICON) (* ; "Edited 28-Sep-91 17:02 by jds") (PROG ((PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) (TITLEFONT (WINDOWTITLEFONT)) ICONWWIDTH ICONWHEIGHT SUBREGION ICONW VIEWPORT) (if (GREATERP (WINDOWPROP PLOTWINDOW 'WIDTH) (WINDOWPROP PLOTWINDOW 'HEIGHT)) then (SETQ ICONWWIDTH (WIDTHIFWINDOW 100)) [SETQ ICONWHEIGHT (HEIGHTIFWINDOW (FIXR (TIMES 100 (FQUOTIENT (WINDOWPROP PLOTWINDOW 'HEIGHT) (WINDOWPROP PLOTWINDOW 'WIDTH] else [SETQ ICONWWIDTH (WIDTHIFWINDOW (FIXR (TIMES 100 (FQUOTIENT (WINDOWPROP PLOTWINDOW 'WIDTH) (WINDOWPROP PLOTWINDOW 'HEIGHT] (SETQ ICONWHEIGHT (HEIGHTIFWINDOW 100))) (if OLDICON then (SHAPEW OLDICON (CREATEREGION (fetch (REGION LEFT) of (WINDOWPROP OLDICON 'REGION)) (fetch (REGION BOTTOM) of (WINDOWPROP OLDICON 'REGION)) ICONWWIDTH ICONWHEIGHT)) (SETQ ICONW OLDICON) else (SETQ ICONW (CREATEW (GETBOXREGION ICONWWIDTH ICONWHEIGHT))) (DSPFONT TITLEFONT ICONW)) (CLEARW ICONW) [SETQ SUBREGION (CREATEREGION [FIXR (TIMES 0.1 (WINDOWPROP ICONW 'WIDTH] [FIXR (TIMES 0.1 (WINDOWPROP ICONW 'HEIGHT] [FIXR (TIMES 0.8 (WINDOWPROP ICONW 'WIDTH] (FIXR (TIMES 0.8 (WINDOWPROP ICONW 'HEIGHT] [SETQ VIEWPORT (CREATEVIEWPORT (WINDOWPROP ICONW 'DSP) SUBREGION (fetch WORLDREGION of (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT] (BOXREGION SUBREGION ICONW) [LET ((OBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) TOBJECTS) (if (ILESSP (SETQ TOBJECTS (LENGTH OBJECTS)) 50) then (* ;  "few enough objects so that all of them may be drawn") (for OBJECT in OBJECTS do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT)) else (* ; "Sample the display list") (bind (SAMPLERATE _ (FIXR (FQUOTIENT TOBJECTS 50))) for OBJECT in OBJECTS as I from 1 when (IEQP 0 (IMOD I SAMPLERATE)) do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT] (CENTERPRINTINREGION (OR (PLOTLABEL PLOT 'TOP) (if (NOT (STREQUAL (WINDOWPROP PLOTWINDOW 'TITLE) "Plot Window")) then (WINDOWPROP PLOTWINDOW 'TITLE)) "Plot Icon") NIL ICONW) (RETURN ICONW]) (PLOT.LABELTOWORLD [LAMBDA (VALUE PLOT AXIS) (* ; "Edited 5-May-87 18:26 by jop") (* ;; "given label VALUE computes corresponding VALUE in world coords") (PROG [(FN (SELECTQ AXIS (X (PLOTPROP PLOT 'XWORLDFN)) (Y (PLOTPROP PLOT 'YWORLDFN)) (HELP "Illegal axis" AXIS] (RETURN (COND (FN (CL:FUNCALL FN VALUE PLOT AXIS)) (T (* ; "use identity transformation") VALUE]) (PLOT.REPAINTFN [LAMBDA (WINDOW) (* ; "Edited 5-May-87 18:40 by jop") (* ;; "Redraws a PLOT WINDOW based on data stored on property list of WINDOW") (REDRAWPLOTWINDOW (WINDOWPROP WINDOW 'PLOT]) (PLOT.RESET [LAMBDA (PLOT XSCALE YSCALE FLUSHMARGINS FLUSHPROPS NODRAWFLG) (* ; "Edited 5-May-87 18:40 by jop") (* ;; "Reset a PLOT for reuse. XSCALE must be an AXISINTERVAL, defaults to the current interval. Similarly for YSCALE. Non-NIL FLUSHMARGINS means flush all labels, ticmethods, etc. Non-NIL FLUSHPROPS means flush all PLOTPROPS and cached menus") (if (NOT (type? PLOT PLOT)) then (HELP "NOT A PLOT" PLOT)) (* ; "Flush display list") (replace (PLOT PLOTOBJECTS) of PLOT with NIL) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL) (replace (PLOT PLOTSAVELIST) of PLOT with NIL) (if FLUSHMARGINS then (for MARGIN in '(BOTTOM LEFT TOP RIGHT) do (PLOTLABEL PLOT MARGIN NIL T) (PLOTTICS PLOT MARGIN NIL T) (PLOTTICMETHOD PLOT MARGIN NIL T))) (if XSCALE then (PLOTAXISINTERVAL PLOT 'X XSCALE T)) (if YSCALE then (PLOTAXISINTERVAL PLOT 'Y YSCALE T)) (* ; "Flush PLOT PROPS") (if FLUSHPROPS then (replace (PLOT PLOTUSERDATA) of PLOT with NIL) (replace (PLOT OTHERMENUS) of PLOT with NIL)) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT]) (PLOT.SETUP [LAMBDA (OPSTABLE) (* ; "Edited 7-May-87 18:28 by jop") (* ;; "Assume opstable is a list of lists, one list for each PLOT object. The CAR of each sublist is the the name of the PLOT object, e.g. POINT. Then follows pairs of method-names and function-names, e.g. (ADDFN ADDPOINTOBJECT)") [bind ASSOCLST for OBJECTLST in OPSTABLE do (SET (PACK* (CAR OBJECTLST) 'FNS) (APPLY (FUNCTION CREATEPLOTFNS) (first (SETQ ASSOCLST (CDR OBJECTLST)) for FNNAME in '(DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN GETFN) collect (CADR (ASSOC FNNAME ASSOCLST] (SETQ LARGEPLOTFONT (FONTCREATE LARGEPLOTFONT)) (SETQ SMALLPLOTFONT (FONTCREATE SMALLPLOTFONT]) (PLOT.SKETCH.CREATE [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 17:02 by jds") (* ;; "Creates a SKETCH STREAM and dumps the contents of PLOT into it") (if (NOT (type? PLOT PLOT)) then (HELP "Not a PLOT " PLOT)) (if (NOT (CL:FBOUNDP 'OPENSKETCHSTREAM)) then (PLOTPROMPT "SKETCHSTREAM not loaded" PLOT) else (PROG ([SKETCHSTREAM (OPENSKETCHSTREAM "LAYOUT OF PLOT" (if (fetch (PLOT PLOTWINDOW) of PLOT) then (LET [(PLOTREGION (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'REGION] (LIST 'REGION (GETBOXREGION (fetch (REGION WIDTH) of PLOTREGION) (fetch (REGION HEIGHT) of PLOTREGION] SKETCHVIEWPORT) (SETQ SKETCHVIEWPORT (CREATEVIEWPORT SKETCHSTREAM)) (ADJUSTVIEWPORT SKETCHVIEWPORT (DSPCLIPPINGREGION NIL SKETCHSTREAM) PLOT) (DRAWPLOT PLOT SKETCHSTREAM SKETCHVIEWPORT (DSPCLIPPINGREGION NIL SKETCHSTREAM]) (PLOT.WHENSELECTEDFN [LAMBDA (ITEM MENU) (* ; "Edited 5-May-87 18:42 by jop") (LET* ([PLOT (OR (GETMENUPROP MENU 'PLOT) (WINDOWPROP (MAINWINDOW (WFROMMENU MENU)) 'PLOT] (MODE (GETMENUPROP MENU 'MODE)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) (SELECTEDFN (CADR ITEM)) EXTRAARGS ARGSTOPASS) [COND ((LISTP SELECTEDFN) (SETQ EXTRAARGS (CDR SELECTEDFN)) (SETQ SELECTEDFN (CAR SELECTEDFN] (SETQ ARGSTOPASS (for ARG in EXTRAARGS collect (EVAL ARG))) (COND ((EQ MODE 'MIDDLE) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL) (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT) (CL:APPLY SELECTEDFN SELECTEDOBJECT PLOT ARGSTOPASS)) (T (CL:APPLY SELECTEDFN PLOT ARGSTOPASS]) (PLOT.WORLDTOLABEL [LAMBDA (VALUE PLOT AXIS) (* ; "Edited 5-May-87 18:26 by jop") (* ;; "Given VALUE in world coords, computes corresponding label VALUE") (PROG [(FN (SELECTQ AXIS (X (PLOTPROP PLOT 'XLABELFN)) (Y (PLOTPROP PLOT 'YLABELFN)) (HELP "Illegal axis" AXIS] (RETURN (COND (FN (CL:FUNCALL FN VALUE PLOT AXIS)) (T (* ; "use identity transformation") VALUE]) (PLOTADDMENUITEMS [LAMBDA (PLOT MENUNAME ITEMSTOADD) (* ; "Edited 28-Sep-91 16:18 by jds") (* ;; "Add ITEMSTOADD to end of menu MENUNAME item list") (PROG ((MENU (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) (MENUITEMS (PLOTMENUITEMS PLOT MENUNAME))) (if ITEMSTOADD then (SETQ ITEMSTOADD (for ITEM in ITEMSTOADD unless (for ELEMENT in MENUITEMS thereis (EQUAL (CAR ELEMENT) (CAR ITEM))) collect ITEM)) (PLOTMENUITEMS PLOT MENUNAME (APPEND MENUITEMS ITEMSTOADD))) (RETURN MENUITEMS]) (PLOTADDPROP [LAMBDA (PLOT PROP ITEMTOADD FIRSTFLG) (* ; "Edited 5-May-87 18:42 by jop") (* ;; "As in WINDOWADDPROP.") (PROG [(PROPVAL (MKLIST (PLOTPROP PLOT PROP] [if (NOT (MEMB ITEMTOADD PROPVAL)) then (if FIRSTFLG then (SETQ PROPVAL (CONS ITEMTOADD PROPVAL)) else (SETQ PROPVAL (APPEND PROPVAL (LIST ITEMTOADD] (RETURN (PLOTPROP PLOT PROP PROPVAL]) (PLOTAXISINTERVAL [LAMBDA (PLOT AXIS INTERVAL NODRAWFLG) (* ; "Edited 28-Sep-91 16:18 by jds") (* ;; "If INTERVAL is NIL returns the current INTERVAL for AXIS of PLOT. If INTERVAL is non-NIL it must be an INTERVAL, in which case the interval for axis AXIS of PLOT is set to INTERVAL") (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) OLDVALUE) (SETQ OLDVALUE (SELECTQ AXIS (X (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (Y (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (SHOULDNT))) (if (type? AXISINTERVAL INTERVAL) then (SELECTQ AXIS (X (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with INTERVAL)) (Y (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with INTERVAL)) (SHOULDNT)) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT))) (RETURN OLDVALUE]) (PLOTDELMENUITEMS [LAMBDA (PLOT MENUNAME ITEMSTODELETE) (* ; "Edited 1-Jun-92 14:02 by jds") (* ;; "Delete ITEMSTODELETE from menu MENUNAME item list. RETURNS new item list if something deleted or else NIL. ITEMSTODELETE may be a list of lists or of atoms, in which case the atoms are compared to secessive CARS of MENUNAME's item list") (SETQ ITEMSTODELETE (MKLIST ITEMSTODELETE)) (PROG ((MENU (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) MENUITEMS SOMETHINGDELETED) (SETQ MENUITEMS (AND MENU (fetch (MENU ITEMS) of MENU))) [bind TARGET for ITEMTODELETE in ITEMSTODELETE do (if (LITATOM ITEMTODELETE) then (if [SETQ TARGET (for ITEM in MENUITEMS thereis (EQUAL ITEMTODELETE (CAR ITEM] then (SETQ SOMETHINGDELETED T) (SETQ MENUITEMS (REMOVE TARGET MENUITEMS))) elseif [AND (LISTP ITEMTODELETE) (SETQ TARGET (CAR (MEMBER ITEMTODELETE MENUITEMS] then (SETQ SOMETHINGDELETED T) (SETQ MENUITEMS (REMOVE TARGET MENUITEMS] (RETURN (if SOMETHINGDELETED then (PLOTMENUITEMS PLOT MENUNAME MENUITEMS) MENUITEMS]) (PLOTDELPROP [LAMBDA (PLOT PROP ITEMTODELETE) (* ; "Edited 5-May-87 18:43 by jop") (* ;; "As in WINDOWDELPROP") (PROG ((PROPVAL (PLOTPROP PLOT PROP))) (RETURN (if (EQ ITEMTODELETE PROPVAL) then (PLOTPROP PLOT PROP NIL) elseif (MEMB ITEMTODELETE PROPVAL) then (PLOTPROP PLOT PROP (REMOVE ITEMTODELETE PROPVAL]) (PLOTLABEL [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:18 by jds") (* ;; "IF NEWLABEL is not present then return current POSITION label of PLOT, else set the label to NEWLABEL and return the old value. NODRAWFLG T suppresses redrawing. POSITIOn may be one of X , Y , TITLE") (COND ((LESSP ARGS 2) (HELP "PLOTLABEL takes at least two args, plot and position"))) (PROG ((PLOT (ARG ARGS 1)) (POSITION (ARG ARGS 2)) (NEWLABEL (AND (GREATERP ARGS 2) (ARG ARGS 3))) (NODRAWFLG (AND (GREATERP ARGS 3) (ARG ARGS 4))) MARGIN OLDLABEL) (SETQ MARGIN (SELECTQ POSITION (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "Illegal margin" POSITION))) (SETQ OLDLABEL (fetch (MARGIN LABEL) of MARGIN)) [COND ((GREATERP ARGS 2) (replace (MARGIN LABEL) of MARGIN with (AND NEWLABEL (MKSTRING NEWLABEL))) (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT] (RETURN OLDLABEL]) (PLOTMENU [LAMBDA ARGS (* ; "Edited 1-Jun-92 14:02 by jds") (* * If no third argument then simply return items list for given menu  (middle or right)%, else replace the cached menu with the new list of items.  If the NEWMENU's whenselectedfn is NIL it is replaced with PLOT.WHENSELECTEDFN) (COND ((ILESSP ARGS 2) (HELP "Must have at least two args, PLOT and MENUNAME"))) (PROG ((PLOT (ARG ARGS 1)) (MENUNAME (ARG ARGS 2)) (NEWMENU (AND (IGREATERP ARGS 2) (ARG ARGS 3))) PLOTWINDOW OLDVALUE) (SETQ PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (SETQ OLDVALUE (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) [COND ((NOT (OR (NULL NEWMENU) (type? MENU NEWMENU))) (HELP "Not a menu" NEWMENU)) ((AND NEWMENU (NULL (fetch (MENU WHENSELECTEDFN) of NEWMENU))) (replace (MENU WHENSELECTEDFN) of NEWMENU with (FUNCTION PLOT.WHENSELECTEDFN] [COND ((IGREATERP ARGS 2) [SELECTQ MENUNAME (MIDDLE (replace (PLOT MIDDLEMENU) of PLOT with NEWMENU)) (RIGHT (replace (PLOT RIGHTMENU) of PLOT with NEWMENU)) (COND ((NULL (fetch (PLOT OTHERMENUS) of PLOT)) (replace (PLOT OTHERMENUS) of PLOT with (LIST MENUNAME NEWMENU)) NEWMENU) (T (LISTPUT (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME NEWMENU] (COND ((AND (OPENWP PLOTWINDOW) (EQ MENUNAME 'RIGHT) (PLOTPROP PLOT 'FIXEDRIGHTMENU?)) (* Update the fixed menu) (PLOT.FIXRIGHTMENU PLOT NIL) (PLOT.FIXRIGHTMENU PLOT T] (RETURN OLDVALUE]) (PLOTMENUITEMS [LAMBDA ARGS (* ; "Edited 1-Jun-92 14:02 by jds") (* * If no third argument then simply return items list for given menu  (middle or right)%, else replace the cached menu with the new list of items) (if (LESSP ARGS 2) then (HELP "Must have at least two args, PLOT and MENUNAME")) (PROG ((PLOT (ARG ARGS 1)) (MENUNAME (ARG ARGS 2)) (NEWITEMS (AND (GREATERP ARGS 2) (ARG ARGS 3))) MENU) (if (AND (GREATERP ARGS 2) (NOT (LISTP NEWITEMS))) then (HELP "Not a list" NEWITEMS)) (SETQ MENU (SELECTQ MENUNAME (MIDDLE (fetch (PLOT MIDDLEMENU) of PLOT)) (RIGHT (fetch (PLOT RIGHTMENU) of PLOT)) (LISTGET (fetch (PLOT OTHERMENUS) of PLOT) MENUNAME))) (if (GREATERP ARGS 2) then [SETQ MENU (AND NEWITEMS (if MENU then (COPYMENU MENU NEWITEMS) else (create MENU ITEMS _ NEWITEMS] (PLOTMENU PLOT MENUNAME MENU)) (RETURN (if (LESSP ARGS 3) then (if MENU then (fetch (MENU ITEMS) of MENU)) else NEWITEMS]) (PLOTOBJECTADDPROP [LAMBDA (OBJECT PROP ITEMTOADD FIRSTFLG) (* jop%: "20-Jan-86 16:03") (* * As in WINDOWADDPROP.) (PROG [(PROPVAL (MKLIST (PLOTOBJECTPROP OBJECT PROP] [if (NOT (MEMB ITEMTOADD PROPVAL)) then (if FIRSTFLG then (SETQ PROPVAL (CONS ITEMTOADD PROPVAL)) else (SETQ PROPVAL (APPEND PROPVAL (LIST ITEMTOADD] (RETURN (PLOTOBJECTPROP OBJECT PROP PROPVAL]) (PLOTOBJECTDELPROP [LAMBDA (OBJECT PROP ITEMTODELETE) (* jop%: "20-Jan-86 16:03") (* * As in WINDOWDELPROP) (PROG ((PROPVAL (PLOTOBJECTPROP OBJECT PROP))) (RETURN (if (EQ ITEMTODELETE PROPVAL) then (PLOTOBJECTPROP OBJECT PROP NIL) elseif (MEMB ITEMTODELETE PROPVAL) then (PLOTOBJECTPROP OBJECT PROP (REMOVE ITEMTODELETE PROPVAL]) (PLOTOBJECTLABEL [LAMBDA (OBJECT LABEL PLOT NODRAWFLG) (* edited%: "27-Mar-86 21:29") (* * IF LABEL is NIL then return current label of OBJECT, else set the label to  LABEL and return the old value. NODRAWFLG T suppresses drawing) (if (NOT (type? PLOTOBJECT OBJECT)) then (HELP "NOT A PLOTOBJECT" OBJECT)) (PROG ((OLDLABEL (fetch (PLOTOBJECT OBJECTLABEL) of OBJECT))) (if LABEL then (if (AND (NULL NODRAWFLG) (PLOTOBJECTPROP OBJECT 'LABEL) PLOT) then (UNLABELPLOTOBJECT OBJECT PLOT)) (replace (PLOTOBJECT OBJECTLABEL) of OBJECT with LABEL) (if (AND PLOT (NULL NODRAWFLG)) then (LABELPLOTOBJECT OBJECT PLOT))) (RETURN OLDLABEL]) (PLOTOBJECTPROP [LAMBDA ARGS (* ; "Edited 1-Jun-92 14:02 by jds") (* ;; "As in WINDOWPROP. Operates on field OBJECTUSERDATA of PLOTOBJECT. If PROP is (QUOTE MENU) then accesses the object menu") (COND ((LESSP ARGS 2) (HELP "OBJECTPROP takes at least two arguments, plotobject and prop"))) (PROG ((PLOTOBJECT (ARG ARGS 1)) (PROPNAME (ARG ARGS 2)) (NEWVALUE (AND (GREATERP ARGS 2) (ARG ARGS 3))) (FIELDNAMES '(OBJECTMENU OBJECTLABEL OBJECTDATA)) OLDVALUE OBJECTUSERDATA) (SETQ OBJECTUSERDATA (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT)) [SETQ OLDVALUE (COND ((MEMB PROPNAME FIELDNAMES) (SELECTQ PROPNAME (OBJECTMENU (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT)) (OBJECTLABEL (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) (SHOULDNT))) (T (LISTGET OBJECTUSERDATA PROPNAME] [COND ((GREATERP ARGS 2) (COND ((MEMB PROPNAME FIELDNAMES) (SELECTQ PROPNAME (OBJECTMENU (replace (PLOTOBJECT OBJECTMENU) of PLOTOBJECT with (OR [COND ((LISTP NEWVALUE) (COND ((type? MENU OLDVALUE) (LET ((NEWMENU (COPYMENU OLDVALUE NEWVALUE))) [COND ((NULL (fetch (MENU WHENSELECTEDFN ) of NEWMENU)) (replace (MENU WHENSELECTEDFN) of NEWMENU with (FUNCTION PLOT.WHENSELECTEDFN] NEWMENU)) (T (create MENU ITEMS _ NEWVALUE WHENSELECTEDFN _ (FUNCTION PLOT.WHENSELECTEDFN] NEWVALUE))) (OBJECTLABEL (replace (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT with NEWVALUE)) (OBJECTDATA (replace (PLOTOBJECT OBJECTDATA) of PLOTOBJECT with NEWVALUE)) (SHOULDNT))) (T (COND ((NULL OBJECTUSERDATA) (replace (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT with (LIST PROPNAME NEWVALUE))) (T (LISTPUT OBJECTUSERDATA PROPNAME NEWVALUE] (RETURN OLDVALUE]) (PLOTOBJECTPROPMACRO [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:44 by jop") (LET [(BPLOTOBJECT (CAR ARGS)) (BPROPNAME (CADR ARGS)) (FIELDNAMES '(OBJECTMENU OBJECTLABEL OBJECTDATA] (COND ((OR (NOT (EQLENGTH ARGS 2)) (NEQ (CAR BPROPNAME) 'QUOTE) (MEMB (CADR BPROPNAME) FIELDNAMES)) 'IGNOREMACRO) (T `(LISTGET (fetch (PLOTOBJECT OBJECTUSERDATA) of ,BPLOTOBJECT) ,BPROPNAME]) (PLOTOBJECTSUBTYPE [LAMBDA (PLOTOBJECT) (* jop%: "20-Jan-86 16:21") (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT]) (PLOTOPERROR [LAMBDA NIL (* edited%: "19-May-85 13:48") (HELP "ATTEMPT To APPLY a generic PLOT operation to a deficient PLOT OBJECT"]) (PLOTPROMPT [LAMBDA (TEXT PLOT) (* ; "Edited 28-Sep-91 16:19 by jds") (PROG ((PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT))) (printout PLOTPROMPTWINDOW T TEXT]) (PLOTPROP [LAMBDA ARGS (* ; "Edited 5-May-87 18:45 by jop") (* ;; "As in WINDOWPROP. See also PLOTPROPMACRO") (COND ((LESSP ARGS 2) (HELP "PLOTPROP TAKES AT LEAST TWO ARGUMENTS, PLOT and PROPNAME"))) (PROG ((PLOT (ARG ARGS 1)) (PROPNAME (ARG ARGS 2)) (NEWVALUE (AND (GREATERP ARGS 2) (ARG ARGS 3))) (FIELDS '(XLOWER XUPPER YLOWER YUPPER MIDDLEMENU RIGHTMENU OTHERMENUS LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST)) OLDVALUE USERDATA) (* ;; "FIELDS is given as an explicit LIST for efficiency reasons -- RECORDFIELDNAMES, although more robust, takes too long") (SETQ USERDATA (fetch (PLOT PLOTUSERDATA) of PLOT)) [SETQ OLDVALUE (COND ((MEMB PROPNAME FIELDS) (RECORDACCESS PROPNAME PLOT)) (T (LISTGET USERDATA PROPNAME] [COND ((GREATERP ARGS 2) (COND ((MEMB PROPNAME FIELDS) (RECORDACCESS PROPNAME PLOT NIL 'REPLACE NEWVALUE)) (T (COND ((NULL USERDATA) (replace (PLOT PLOTUSERDATA) of PLOT with (LIST PROPNAME NEWVALUE ))) (T (LISTPUT USERDATA PROPNAME NEWVALUE] (RETURN OLDVALUE]) (PLOTPROPMACRO [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:47 by jop") (LET [(BPLOT (CAR ARGS)) (BPROPNAME (CADR ARGS)) (BVALUE (CADDR ARGS)) (FIELDNAMES '(XLOWER XUPPER YLOWER YUPPER MIDDLEMENU RIGHTMENU OTHERMENUS LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST] (COND ((NEQ (CAR BPROPNAME) 'QUOTE) 'IGNOREMACRO) (T (COND [(MEMB (CADR BPROPNAME) FIELDNAMES) (COND [(EQLENGTH ARGS 3) `(PROG1 (fetch (PLOT ,(CADR BPROPNAME)) of ,BPLOT) (replace (PLOT ,(CADR BPROPNAME)) of ,BPLOT with ,BVALUE))] (T `(fetch (PLOT ,(CADR BPROPNAME)) of ,BPLOT] (T (COND ((NOT (EQLENGTH ARGS 2)) 'IGNOREMACRO) (T `(LISTGET (fetch (PLOT PLOTUSERDATA) of ,BPLOT) ,BPROPNAME]) (PLOTREMPROP [LAMBDA (PLOT PROPNAME) (* ; "Edited 5-May-87 18:47 by jop") (* ;; "Destructively removes PROPNAME from proplist of PLOT") (if (NOT (type? PLOT PLOT)) then (HELP "Not a plot" PLOT)) (PROG ((FIELDS (RECORDFIELDNAMES 'PLOT)) (USERDATA (fetch (PLOT PLOTUSERDATA) of PLOT)) LSTPTR OLDVALUE) (SETQ OLDVALUE (if (MEMB PROPNAME FIELDS) then (RECORDACCESS PROPNAME PLOT) else (LISTGET USERDATA PROPNAME))) [if (MEMB PROPNAME FIELDS) then (RECORDACCESS PROPNAME PLOT NIL 'REPLACE NIL) else (if (SETQ LSTPTR (MEMB PROPNAME USERDATA)) then (* ; "Splice out the offending links") (if (EQ LSTPTR USERDATA) then (replace (PLOT PLOTUSERDATA) of PLOT with (CDDR USERDATA)) else (RPLACD (NLEFT USERDATA 1 LSTPTR) (CDDR LSTPTR] (RETURN OLDVALUE]) (PLOTSCALEFN [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:19 by jds") (* *) (COND ((ILESSP ARGS 2) (HELP "Must have at least two args"))) (PROG ((PLOT (ARG ARGS 1)) (AXIS (ARG ARGS 2)) AXISINFO OLDVALUE) (SETQ AXISINFO (SELECTQ AXIS (X (fetch (PLOTSCALE XAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (Y (fetch (PLOTSCALE YAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (SHOULDNT))) (SETQ OLDVALUE (fetch (AXISINFO SCALEFN) of AXISINFO)) [COND ((IGREATERP ARGS 2) (LET [(NEWVALUE (ARG ARGS 3)) (NODRAWFLG (AND (IGREATERP ARGS 3) (ARG ARGS 4] (replace (AXISINFO SCALEFN) of AXISINFO with NEWVALUE) (RESCALEPLOT PLOT AXIS NODRAWFLG] (RETURN OLDVALUE]) (PLOTTICFN [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:19 by jds") (if (ILESSP ARGS 2) then (HELP "Must have at least two args")) (PROG ((PLOT (ARG ARGS 1)) (AXIS (ARG ARGS 2)) AXISINFO OLDVALUE) (SETQ AXISINFO (SELECTQ AXIS (X (fetch (PLOTSCALE XAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (Y (fetch (PLOTSCALE YAXISINFO) of (fetch (PLOT PLOTSCALE) of PLOT))) (SHOULDNT))) (SETQ OLDVALUE (fetch (AXISINFO TICFN) of AXISINFO)) (if (IGREATERP ARGS 2) then (LET [(NEWVALUE (ARG ARGS 3)) (NODRAWFLG (AND (IGREATERP ARGS 3) (ARG ARGS 4] (replace (AXISINFO TICFN) of AXISINFO with NEWVALUE) (RESCALEPLOT PLOT AXIS NODRAWFLG))) (RETURN OLDVALUE]) (PLOTTICINFO [LAMBDA (PLOT AXIS NEWTICINFO NODRAWFLG) (* ; "Edited 28-Sep-91 16:19 by jds") (PROG ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) OLDVALUE) (SETQ OLDVALUE (SELECTQ AXIS (X (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) (Y (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) (SHOULDNT))) (if (type? TICINFO NEWTICINFO) then (SELECTQ AXIS (X (replace (PLOTSCALE XTICINFO) of PLOTSCALE with NEWTICINFO)) (Y (replace (PLOTSCALE YTICINFO) of PLOTSCALE with NEWTICINFO)) (SHOULDNT)) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT))) (RETURN OLDVALUE]) (PLOTTICMETHOD [LAMBDA (PLOT MARGINNAME NEWMETHOD NODRAWFLG) (* ; "Edited 28-Sep-91 16:19 by jds") (* ;; "If NEWMETHOD not present then RETURNS current tic method for margin MARGIN , else replaces the method with NEWMETHOD, which may be a list of numbers, or a list of CONS pairs (VALUE . LABEL), or a function to be APPLIED to MARGIN PLOTSCALE PLOT, or the atom DEFAULT") (PROG (MARGIN OLDVALUE) (SETQ MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "ILLEGAL MARGIN" MARGIN))) (SETQ OLDVALUE (fetch (MARGIN TICMETHOD) of MARGIN)) (if NEWMETHOD then (replace (MARGIN TICMETHOD) of MARGIN with NEWMETHOD) (if (AND (NULL NODRAWFLG) (fetch (MARGIN TICS?) of MARGIN)) then (REDRAWPLOTWINDOW PLOT))) (RETURN OLDVALUE]) (PLOTTICS [LAMBDA ARGS (* ; "Edited 28-Sep-91 16:19 by jds") (COND ((ILESSP ARGS 2) (HELP "Must have at least two args"))) (PROG ((PLOT (ARG ARGS 1)) (MARGINNAME (ARG ARGS 2)) MARGIN OLDVALUE) (SETQ MARGIN (SELECTQ MARGINNAME (BOTTOM (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFT (fetch (PLOT LEFTMARGIN) of PLOT)) (TOP (fetch (PLOT TOPMARGIN) of PLOT)) (RIGHT (fetch (PLOT RIGHTMARGIN) of PLOT)) (HELP "Illegal margin" MARGINNAME))) (SETQ OLDVALUE (fetch (MARGIN TICS?) of MARGIN)) [COND ((IGREATERP ARGS 2) (LET [(NEWVALUE (ARG ARGS 3)) (NODRAWFLG (AND (IGREATERP ARGS 3) (ARG ARGS 4] (replace (MARGIN TICS?) of MARGIN with NEWVALUE) (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT] (RETURN OLDVALUE]) (PRINTFONT [LAMBDA (FONT STREAM) (* ; "Edited 6-May-87 09:25 by jop") (PRINTOUT STREAM "(READFONT)(FAMILY" %, .P2 (FONTPROP FONT 'FAMILY) %, "SIZE" %, .P2 (FONTPROP FONT 'SIZE) %, "FACE" %, (FONTPROP FONT 'FACE) %, "ROTATION" %, (FONTPROP FONT 'ROTATION) %, "DEVICE" %, (FONTPROP FONT 'DEVICE) ")") T]) (PRINTMENU [LAMBDA (MENU STREAM) (* ; "Edited 1-Jun-92 14:03 by jds") (* ;; "Function for dumping menus on file") (PRINTOUT STREAM "(READMENU)(ITEMS" %, .P2 (fetch (MENU ITEMS) of MENU) %, "WHENSELECTEDFN" %, .P2 (fetch (MENU WHENSELECTEDFN) of MENU) %, "WHENHELDFN" %, .P2 (fetch (MENU WHENHELDFN) of MENU) %, "WHENUNHELDFN" %, .P2 (fetch (MENU WHENUNHELDFN) of MENU) %, "MENUPOSITION" %, .P2 (fetch (MENU MENUPOSITION) of MENU) %, "MENUOFFSET" %, .P2 (fetch (MENU MENUOFFSET) of MENU) %,) (* ;  "use HPRINT here to avoid dumping the whole font") (PRINTOUT STREAM "MENUFONT" %,) (HPRINT (fetch (MENU MENUFONT) of MENU) STREAM T T) (PRINTOUT STREAM %,) (PRINTOUT STREAM "TITLE" %, .P2 (fetch (MENU TITLE) of MENU) %, "CENTERFLG" %, .P2 (fetch (MENU CENTERFLG) of MENU) %, "MENUROWS" %, .P2 (fetch (MENU MENUROWS) of MENU) %, "MENUCOLUMNS" %, .P2 (fetch (MENU MENUCOLUMNS) of MENU) %, "ITEMHEIGHT" %, .P2 (fetch (MENU ITEMHEIGHT) of MENU) %, "ITEMWIDTH" %, .P2 (fetch (MENU ITEMWIDTH) of MENU) %, "MENUBORDERSIZE" %, .P2 (fetch (MENU MENUBORDERSIZE) of MENU) %, "MENUOUTLINESIZE" %, .P2 (fetch (MENU MENUOUTLINESIZE) of MENU) %, "CHANGEOFFSETFLG" %, .P2 (fetch (MENU CHANGEOFFSETFLG) of MENU) ")") T]) (REDRAWPLOTWINDOW [LAMBDA (PLOT) (* ; "Edited 7-May-87 18:16 by jop") (* ;; "Redraws the PLOTWINDOW of a PLOT") (PROG ((PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (PLOTWINDOWVIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) MINSIZE) (COND ((NOT (OPENWP PLOTWINDOW)) (* ;  "Assumes OPENPLOTWINDOW will call REDRAWPLOTWINDOW") (OPENPLOTWINDOW PLOT)) (T (CREATETICLISTS PLOT) (* ; "Setup the tic lists ") (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP PLOTWINDOW 'DSP) PLOT)) (* ;  "Establish a min size for the WINDOW") (* ;  "Uses MAINWINDOWMINSIZE since PLOTWINDOW is the main window of a group") [WINDOWPROP PLOTWINDOW 'MAINWINDOWMINSIZE (CONS (WIDTHIFWINDOW (CAR MINSIZE) (WINDOWPROP PLOTWINDOW 'BORDER)) (HEIGHTIFWINDOW (CDR MINSIZE) (WINDOWPROP PLOTWINDOW 'TITLE) (WINDOWPROP PLOTWINDOW 'BORDER] (COND ((OR (LESSP (WINDOWPROP PLOTWINDOW 'WIDTH) (CAR MINSIZE)) (LESSP (WINDOWPROP PLOTWINDOW 'HEIGHT) (CDR MINSIZE))) (PROMPTPRINT "Plotwindow too small: reshape") (* ;  "Assumes SHAPEW will call REDRAWPLOTWINDOW") (SHAPEW PLOTWINDOW)) (T (ADJUSTVIEWPORT PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL PLOTWINDOW) PLOT) (CLEARW PLOTWINDOW) (DRAWPLOT PLOT (WINDOWPROP PLOTWINDOW 'DSP) PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL PLOTWINDOW)) (COND (SELECTEDOBJECT (HIGHLIGHTPLOTOBJECT SELECTEDOBJECT PLOT]) (RELABELSELECTEDPLOTOBJECT [LAMBDA (SELECTEDOBJECT PLOT) (* ; "Edited 6-May-87 09:26 by jop") (PROG ((PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) LABEL LABELFLG) (* ;  "If the object is labeled, delete the label.") (if (PLOTOBJECTPROP SELECTEDOBJECT 'LABEL) then (UNLABELPLOTOBJECT SELECTEDOBJECT PLOT) (SETQ LABELFLG T)) (SETQ LABEL (fetch (PLOTOBJECT OBJECTLABEL) of SELECTEDOBJECT)) (TERPRI PLOTPROMPTWINDOW) [SETQ LABEL (PROMPTFORWORD "TYPE NEW LABEL :" LABEL "ENTER NIL FOR NO LABEL" PLOTPROMPTWINDOW NIL NIL (CHARCODE (EOL LF ESCAPE TAB] (replace (PLOTOBJECT OBJECTLABEL) of SELECTEDOBJECT with LABEL) (LABELPLOTOBJECT SELECTEDOBJECT PLOT]) (RESCALEPLOT [LAMBDA (PLOT AXIS NODRAWFLG) (* ; "Edited 28-Sep-91 16:19 by jds") [COND ((NULL AXIS) (SETQ AXIS 'BOTH] (LET* ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) (PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) (PLOTEXTENT (EXTENTOFPLOT PLOT)) (MINX (fetch (EXTENT MINX) of PLOTEXTENT)) (MAXX (fetch (EXTENT MAXX) of PLOTEXTENT)) (MINY (fetch (EXTENT MINY) of PLOTEXTENT)) (MAXY (fetch (EXTENT MAXY) of PLOTEXTENT))) (COND (PLOTOBJECTS (LET ((XINTERVAL (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) (XAXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) (YAXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) TEMP) [COND ((AND (OR (EQ AXIS 'BOTH) (EQ AXIS 'X)) (GREATERP MAXX MINX)) (LET ((AXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE) ) TICINFO) (SETQ TICINFO (CHOOSETICS MINX MAXX AXISINFO PLOT)) (replace (PLOTSCALE XTICINFO) of PLOTSCALE with TICINFO) (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with (CHOOSESCALE MINX MAXX AXISINFO TICINFO PLOT] [COND ((AND (OR (EQ AXIS 'BOTH) (EQ AXIS 'Y)) (GREATERP MAXY MINY)) (LET ((AXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE) ) TICINFO) (SETQ TICINFO (CHOOSETICS MINY MAXY AXISINFO PLOT)) (replace (PLOTSCALE YTICINFO) of PLOTSCALE with TICINFO) (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with (CHOOSESCALE MINY MAXY AXISINFO TICINFO PLOT] (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT]) (SCALE [LAMBDA (MIN MAX NTICS ROUND POWER) (* ; "Edited 6-May-87 09:26 by jop") (* ;; "Scaling algorithm for plots. NTICS is the desired number of tics. Round is a list of acceptable scaling factors. POWER is the power of ten to use. Returns a TICINFO including NEWMAX, NEWMIN, INC, and NTICS") [COND ((NULL ROUND) (SETQ ROUND '(5.0 2.5 2.0 1.5 1.0] (* ;  "Rounding Constants. Notice that they are in decreasing order and end with 1.0") (PROG ((NUMINC (SUB1 NTICS)) RAWINC MANTISSA INDEX) (SETQ RAWINC (FQUOTIENT (DIFFERENCE MAX MIN) NUMINC)) (* ; "POWER is the power of ten") [SETQ POWER (EXPT 10.0 (OR POWER (PLOT.FLOOR (PLOT.LOG10 RAWINC] (* ; "MANTISSA is the scale factor") (SETQ MANTISSA (FQUOTIENT RAWINC POWER)) [COND ((GREATERP MANTISSA (CAR ROUND)) (SETQ POWER (TIMES 10 POWER)) (SETQ INDEX (LAST ROUND))) (T (SETQ INDEX (for MARK on ROUND as TEST in (CDR ROUND) until (GREATERP MANTISSA TEST) finally (RETURN MARK] (* ;; "Find new max and new min") (RETURN (bind (NEWMAX _ MIN) NEWMIN INC FACTOR LOWERMULT UPPERMULT while (LESSP NEWMAX MAX) do (SETQ INC (TIMES (CAR INDEX) POWER)) (SETQ FACTOR (FQUOTIENT (FDIFFERENCE (FPLUS MAX MIN) (FTIMES NUMINC INC)) (FTIMES 2.0 INC))) [SETQ NEWMIN (FTIMES INC (SETQ LOWERMULT (PLOT.CEILING FACTOR] [COND ((GREATERP NEWMIN MIN) (SETQ NEWMIN (FTIMES INC (SETQ LOWERMULT (SUB1 LOWERMULT] (COND ((AND (GEQ MIN 0.0) (MINUSP NEWMIN)) (SETQ LOWERMULT 0) (SETQ NEWMIN 0.0))) (SETQ UPPERMULT (IPLUS LOWERMULT NUMINC)) (SETQ NEWMAX (FTIMES INC UPPERMULT)) [COND ((AND (LEQ MAX 0.0) (GREATERP NEWMAX 0.0)) (SETQ UPPERMULT 0) (SETQ NEWMAX 0.0) (SETQ LOWERMULT (IMINUS NUMINC)) (SETQ NEWMIN (SETQ NEWMIN (FTIMES INC LOWERMULT] [COND ((NULL (SETQ INDEX (NLEFT ROUND 1 INDEX))) (SETQ INDEX (LAST ROUND)) (SETQ POWER (TIMES 10 POWER] finally (RETURN (create TICINFO TICMAX _ NEWMAX TICMIN _ NEWMIN TICINC _ INC NTICS _ NTICS]) (TOGGELLABEL [LAMBDA (SELECTEDOBJECT PLOT) (* ; "Edited 6-May-87 09:26 by jop") (COND ((PLOTOBJECTPROP SELECTEDOBJECT 'LABEL) (UNLABELPLOTOBJECT SELECTEDOBJECT PLOT)) (T (LABELPLOTOBJECT SELECTEDOBJECT PLOT]) (TOGGLEEXTENDEDAXES [LAMBDA (PLOT AXIS) (* jop%: "10-Dec-85 17:56") (* *) [COND ((NULL AXIS) (SETQ AXIS 'BOTH] [PROG [(XSCALEFN (PLOTSCALEFN PLOT 'X)) (YSCALEFN (PLOTSCALEFN PLOT 'Y] [COND ((OR (EQ AXIS 'X) (EQ AXIS 'BOTH)) (COND ((EQ XSCALEFN (FUNCTION EXTENDEDSCALEFN)) (* recover previous state) (PLOTSCALEFN PLOT 'X (PLOTPROP PLOT 'OLDXSCALEFN) T)) (T (* Remember the old fn for next time) (PLOTPROP PLOT 'OLDXSCALEFN (PLOTSCALEFN PLOT 'X)) (PLOTSCALEFN PLOT 'X (FUNCTION EXTENDEDSCALEFN) T] (COND ((OR (EQ AXIS 'Y) (EQ AXIS 'BOTH)) (COND ((EQ YSCALEFN (FUNCTION EXTENDEDSCALEFN)) (PLOTSCALEFN PLOT 'Y (PLOTPROP PLOT 'OLDYSCALEFN) T)) (T (PLOTPROP PLOT 'OLDYSCALEFN (PLOTSCALEFN PLOT 'Y)) (PLOTSCALEFN PLOT 'Y (FUNCTION EXTENDEDSCALEFN) T] (RESCALEPLOT PLOT AXIS]) (TOGGLEFIXEDMENU [LAMBDA (PLOT) (* jop%: "12-Dec-85 10:34") (* *) (PLOT.FIXRIGHTMENU PLOT (NOT (PLOT.FIXRIGHTMENU PLOT]) (TOGGLETICS [LAMBDA (PLOT MARGINNAME) (* jop%: "10-Dec-85 21:27") [COND [(NULL MARGINNAME) (for MARGIN in '(BOTTOM LEFT) do (COND ((PLOTTICS PLOT MARGIN) (PLOTTICS PLOT MARGIN NIL T)) (T (PLOTTICS PLOT MARGIN T T] (T (COND ((PLOTTICS PLOT MARGINNAME) (PLOTTICS PLOT MARGINNAME NIL T)) (T (PLOTTICS PLOT MARGINNAME T T] (REDRAWPLOTWINDOW PLOT]) (TRANSLATEPLOTOBJECT [LAMBDA (OBJECT DX DY PLOT NODRAWFLG) (* ; "Edited 6-May-87 09:27 by jop") (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENTRANSLATEDFN (PLOTOBJECTPROP OBJECT 'WHENTRANSLATEDFN] (if (NULL NODRAWFLG) then (if (EQ OBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) then (LOWLIGHTPLOTOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT) PLOT) (replace (PLOT SELECTEDOBJECT) of PLOT with NIL)) (ERASEPLOTOBJECT OBJECT PLOT)) (* ;  "Destructively modify the data structure for OBJECT") (MOVEPLOTOBJECT OBJECT DX DY PLOT) (if (NULL NODRAWFLG) then (DRAWPLOTOBJECT OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) PLOT)) (if TEXTOBJECT then (TRANSLATEPLOTOBJECT TEXTOBJECT DX DY PLOT NODRAWFLG)) (APPLY.AFTERFN WHENTRANSLATEDFN OBJECT DX DY PLOT NODRAWFLG]) (UNDELETEPLOTOBJECT [LAMBDA (PLOT MODE) (* ; "Edited 6-May-87 09:27 by jop") (* ;; "MODE MAY BE ONE OF TOP, SELECT, ABOVE, ALL,. NIL defaults to TOP. TOP means restore the top element of the save stack. SELECT means choose an object to restore from a menu. ABOVE means restore all objects above the selected object. ALL means restore all the objects on the save stack.") (if (NULL MODE) then (SETQ MODE 'TOP)) (PROG ((SAVELIST (fetch (PLOT PLOTSAVELIST) of PLOT)) SELECTION OBJECTSTORESTORE) (if (NULL SAVELIST) then (PLOTPROMPT "No object to undelete" PLOT) (RETURN NIL)) (SETQ OBJECTSTORESTORE (SELECTQ MODE (TOP (LIST (CAR SAVELIST))) (ALL SAVELIST) ((ABOVE SELECT) [SETQ SELECTION (MENU (create MENU ITEMS _ (bind OBJECTLABEL for OBJECT in SAVELIST as I from 1 collect (SETQ OBJECTLABEL (fetch (PLOTOBJECT OBJECTLABEL) of OBJECT)) (LIST (if OBJECTLABEL then (CONCAT (PLOTOBJECTSUBTYPE OBJECT) " " OBJECTLABEL) else (PLOTOBJECTSUBTYPE OBJECT)) I] (AND SELECTION (if (EQ MODE 'SELECT) then (LIST (CAR (NTH SAVELIST SELECTION))) else (for I from 1 to SELECTION as OBJECT in SAVELIST collect OBJECT)))) (SHOULDNT "Illegal mode"))) [if OBJECTSTORESTORE then (for OBJECT in OBJECTSTORESTORE do (ADDPLOTOBJECT OBJECT PLOT) ) (replace (PLOT PLOTSAVELIST) of PLOT with (SELECTQ MODE (TOP (CDR SAVELIST)) (ALL NIL) (ABOVE (CDR (NTH SAVELIST SELECTION))) (SELECT (DREMOVE (CAR OBJECTSTORESTORE) SAVELIST)) (SHOULDNT "ILLEGAL MODE"] (RETURN OBJECTSTORESTORE]) (UNLABELPLOTOBJECT [LAMBDA (OBJECT PLOT) (* ; "Edited 6-May-87 09:27 by jop") (* *) (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) (WHENUNLABELEDFN (PLOTOBJECTPROP OBJECT 'WHENUNLABELEDFN] (COND (TEXTOBJECT (ERASEPLOTOBJECT TEXTOBJECT PLOT) (PLOTOBJECTPROP OBJECT 'LABEL NIL) (APPLY.AFTERFN WHENUNLABELEDFN OBJECT PLOT)) (T (PLOTPROMPT "NOT A LABELED OBJECT" PLOT]) (WHICHLABEL [LAMBDA (PLOT) (* ; "Edited 6-May-87 09:27 by jop") (* ;; "Prompt for new label and make the required call to ASKFORLABEL") (PROG ([LMENU (CONSTANT (create MENU ITEMS _ '(TOP LEFT BOTTOM RIGHT] MARGIN) (PLOTPROMPT "Select a margin" PLOT) (SETQ MARGIN (MENU LMENU)) (AND MARGIN (ASKFORLABEL PLOT MARGIN]) (WHICHPLOT [LAMBDA (X Y) (* ; "Edited 6-May-87 09:27 by jop") (* ;; "like WHICHW but returns corresponding plot. First arg may be a window") (PROG ((W (OR (WINDOWP X) (WHICHW X Y))) PLOT) [SETQ PLOT (OR (WINDOWPROP W 'PLOT) (WINDOWPROP (WINDOWPROP W 'ICONFOR) 'PLOT] (RETURN (COND ((type? PLOT PLOT) PLOT]) ) (* ;; "Fns to do our own number printing") (DEFINEQ (PLOT.PRINTNUM [LAMBDA (F) (* ; "Edited 7-May-87 17:23 by jop") (SETQ F (FLOAT F)) (LET ((STR (CL:MAKE-ARRAY 14 :ELEMENT-TYPE 'CL:STRING-CHAR :FILL-POINTER 0)) [MINUSFLAG (AND (< F 0.0) (SETQ F (- F] (ROUND 5) NUMSTR INTEXP) (IF (AND (OR (< F 0.001) (>= F 1.0E+7)) (NOT (ZEROP F))) THEN (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) (FLTSTR F ROUND)) (PLOT.ENUM-STRING STR NUMSTR INTEXP MINUSFLAG) ELSE (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) (FLTSTR F ROUND)) (PLOT.FNUM-STRING STR NUMSTR INTEXP MINUSFLAG]) (PLOT.FNUM-STRING [LAMBDA (OUTSTR MANTSTR INTEXP MINUSP) (* ; "Edited 7-May-87 17:21 by jop") (LET* ((DIGITS (CL:LENGTH MANTSTR)) (POINTPLACE (+ DIGITS INTEXP)) (INDEX 0)) (COND (MINUSP (CL:SETF (CL:AREF OUTSTR 0) #\-) (SETQ INDEX 1))) [COND [(< POINTPLACE 0) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX)) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:DOTIMES (I (- POINTPLACE)) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX))) (CL:DOTIMES (I DIGITS) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX)))] [(< INTEXP 0) (CL:DOTIMES (I POINTPLACE) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:DO ((I POINTPLACE (CL:1+ I))) ((EQ I DIGITS)) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX)))] (T (CL:DOTIMES (I DIGITS) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (CL:DOTIMES (I INTEXP) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX))) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:SETF (CL:AREF OUTSTR INDEX) #\0) (SETQ INDEX (CL:1+ INDEX] [COND ((OR (< POINTPLACE 0) (< INTEXP 0)) (* ;; "Trim off extraneous zeros") (CL:DO ((I (CL:1- INDEX) (CL:1- I))) [(NOT (EQ (CL:AREF OUTSTR I) #\0)) (CL:IF (NOT (EQ (CL:AREF OUTSTR I) #\.)) (SETQ INDEX (CL:1+ I)) (SETQ INDEX (+ I 2)))])] (CL:SETF (CL:FILL-POINTER OUTSTR) INDEX) OUTSTR]) (PLOT.ENUM-STRING [LAMBDA (OUTSTR MANTSTR INTEXP MINUSP) (* ; "Edited 13-May-87 09:21 by jop") (* ;; "Prints exponential notation observing rounding & exponent spacing") (LET ((DIGITS (CL:LENGTH MANTSTR)) (INDEX 0) EXPOFFSET) (COND (MINUSP (CL:SETF (CL:AREF OUTSTR 0) #\-) (SETQ INDEX 1))) (* ;; "Print the mantissa") (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR 0)) (SETQ INDEX (CL:1+ INDEX)) (CL:SETF (CL:AREF OUTSTR INDEX) #\.) (SETQ INDEX (CL:1+ INDEX)) (CL:DO ((I 1 (CL:1+ I))) ((EQ I DIGITS)) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (* ;; "Trim off extraneous zeros") (CL:DO ((I (CL:1- INDEX) (CL:1- I))) [(NOT (EQ (CL:AREF OUTSTR I) #\0)) (CL:IF (NOT (EQ (CL:AREF OUTSTR I) #\.)) (SETQ INDEX (CL:1+ I)) (SETQ INDEX (+ I 2)))]) (* ;; "mantissa done - now for the exponent") (SETQ EXPOFFSET (- (+ INTEXP DIGITS) 1)) (SETQ MANTSTR (MKSTRING EXPOFFSET)) (SETQ DIGITS (CL:LENGTH MANTSTR)) (CL:SETF (CL:AREF OUTSTR INDEX) #\E) (SETQ INDEX (CL:1+ INDEX)) (CL:DOTIMES (I DIGITS) (CL:SETF (CL:AREF OUTSTR INDEX) (CL:AREF MANTSTR I)) (SETQ INDEX (CL:1+ INDEX))) (CL:SETF (CL:FILL-POINTER OUTSTR) INDEX) OUTSTR]) (CREATETICLISTS [LAMBDA (PLOT) (* ; "Edited 7-May-87 18:08 by jop") (LET ((BOTTOMMARGIN (fetch (PLOT BOTTOMMARGIN) of PLOT)) (LEFTMARGIN (fetch (PLOT LEFTMARGIN) of PLOT)) (RIGHTMARGIN (fetch (PLOT RIGHTMARGIN) of PLOT)) (TOPMARGIN (fetch (PLOT TOPMARGIN) of PLOT))) [IF (fetch (MARGIN TICS?) of BOTTOMMARGIN) THEN (replace (MARGIN TICLIST) of BOTTOMMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'BOTTOM PLOT] [IF (fetch (MARGIN TICS?) of LEFTMARGIN) THEN (replace (MARGIN TICLIST) of LEFTMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'LEFT PLOT] [IF (fetch (MARGIN TICS?) of RIGHTMARGIN) THEN (replace (MARGIN TICLIST) of RIGHTMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'RIGHT PLOT] [IF (fetch (MARGIN TICS?) of TOPMARGIN) THEN (replace (MARGIN TICLIST) of TOPMARGIN with (NORMALIZE-TICLIST (GETTICLIST 'TOP PLOT] NIL]) (NORMALIZE-TICLIST [LAMBDA (TICLIST) (* ; "Edited 27-May-87 18:19 by jop") (BIND VALUE LABEL FOR TIC IN TICLIST COLLECT (IF (LISTP TIC) THEN (SETQ VALUE (CAR TIC)) (SETQ LABEL (CDR TIC)) ELSE (SETQ VALUE (SETQ LABEL TIC))) (CONS VALUE (IF (FLOATP LABEL) THEN (PLOT.PRINTNUM LABEL) ELSE LABEL]) ) (DEFINEQ (DRAW-TICS-LEFT-RIGHT [LAMBDA (TICLIST MIN MAX RIGHTTIC LEFTTIC TICOFFSET TICFONT STREAM VIEWPORT LEFT-P) (* ; "Edited 13-May-87 16:56 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT TICFONT STREAM) [bind YWINDOWLOC TICVALUE TICLABEL for TICPAIR in TICLIST do (SETQ TICVALUE (CAR TICPAIR)) (SETQ TICLABEL (CDR TICPAIR)) (if (AND (GEQ TICVALUE MIN) (LEQ TICVALUE MAX)) then (SETQ YWINDOWLOC (WORLDTOSTREAMY TICVALUE VIEWPORT)) (MOVETO LEFTTIC YWINDOWLOC STREAM) (DRAWTO RIGHTTIC YWINDOWLOC (DSPSCALE NIL STREAM) 'REPLACE STREAM) (if TICLABEL then (IF LEFT-P THEN (MOVETO (DIFFERENCE LEFTTIC (PLUS TICOFFSET (STRINGWIDTH TICLABEL STREAM ))) YWINDOWLOC STREAM) ELSE (MOVETO (PLUS RIGHTTIC TICOFFSET) YWINDOWLOC STREAM)) (PRIN1 TICLABEL STREAM] (DSPFONT FONT STREAM]) (DRAW-TICS-TOP-BOTTOM [LAMBDA (TICLIST MIN MAX TOPOFTIC BOTTOMOFTIC TICOFFSET TICFONT STREAM VIEWPORT BOTTOM-P) (* ; "Edited 13-May-87 17:03 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT TICFONT STREAM) [bind XWINDOWLOC TICVALUE TICLABEL for TICPAIR in TICLIST do (SETQ TICVALUE (CAR TICPAIR)) (SETQ TICLABEL (CDR TICPAIR)) (if (AND (GEQ TICVALUE MIN) (LEQ TICVALUE MAX)) then (SETQ XWINDOWLOC (WORLDTOSTREAMX TICVALUE VIEWPORT)) (* ; "always draw the tic mark") (MOVETO XWINDOWLOC TOPOFTIC STREAM) (DRAWTO XWINDOWLOC BOTTOMOFTIC (DSPSCALE NIL STREAM) 'REPLACE STREAM) (if TICLABEL then (IF BOTTOM-P THEN (MOVETO XWINDOWLOC (DIFFERENCE BOTTOMOFTIC TICOFFSET) STREAM) ELSE (MOVETO XWINDOWLOC (PLUS TOPOFTIC TICOFFSET) STREAM)) (RELMOVETO (IMINUS (IQUOTIENT (STRINGWIDTH TICLABEL TICFONT) 2)) 0 STREAM) (PRIN1 TICLABEL STREAM] (DSPFONT FONT STREAM]) (DRAW-LABEL-LEFT-RIGHT [LAMBDA (LABEL LABELFONT XOFFSET STREAMREGION STREAM) (* ; "Edited 13-May-87 17:15 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT LABELFONT STREAM) (MOVETO XOFFSET (DIFFERENCE (fetch (REGION TOP) of STREAMREGION) (IQUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of STREAMREGION ) (ITIMES (FONTPROP STREAM 'HEIGHT) (NCHARS LABEL))) 2)) STREAM) (bind (LF _ (DSPLINEFEED NIL STREAM)) for I from 0 to (SUB1 (CL:LENGTH LABEL)) do (CL:PRINC (CL:AREF LABEL I) STREAM) (MOVETO XOFFSET (IPLUS (DSPYPOSITION NIL STREAM) LF) STREAM)) (DSPFONT FONT STREAM]) (DRAW-LABEL-TOP-BOTTOM [LAMBDA (LABEL LABELFONT YOFFSET STREAMREGION STREAM) (* ; "Edited 13-May-87 16:34 by jop") (LET ((FONT (DSPFONT NIL STREAM))) (DSPFONT LABELFONT STREAM) (MOVETO (PLUS (fetch (REGION LEFT) of STREAMREGION) (IMAX 0 (IQUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of STREAMREGION) (STRINGWIDTH LABEL STREAM)) 2))) YOFFSET STREAM) (PRIN1 LABEL STREAM) (DSPFONT FONT STREAM]) ) (RPAQQ PLOT.DEFAULTMIDDLEMENUITEMS ((Label TOGGELLABEL "Toggle label on/off" (SUBITEMS (Relabel RELABELSELECTEDPLOTOBJECT "Change label"))) (Delete DELETEPLOTOBJECT "Delete object"))) (RPAQQ PLOT.DEFAULTRIGHTMENUITEMS ((Layout PLOT.SKETCH.CREATE "Create a sketch of the PLOT") (Redraw REDRAWPLOTWINDOW "Redraw plot") [Rescale RESCALEPLOT "Rescale plot axes" (SUBITEMS (X% Axis (RESCALEPLOT 'X) "Rescale X axis" (SUBITEMS (Automatic (RESCALEPLOT 'X) "Rescale automatically") (Manual (MANUALRESCALE 'X) "Rescale manually"))) (Y% Axis (RESCALEPLOT 'Y) "Rescale Y axis" (SUBITEMS (Automatic (RESCALEPLOT 'Y) "Rescale automatically") (Manual (MANUALRESCALE 'Y) "Rescale manually"] (Extend TOGGLEEXTENDEDAXES "Extend plot axes on/off" (SUBITEMS (X% Axis (TOGGLEEXTENDEDAXES 'X) "Extend X axis on/off") (Y% Axis (TOGGLEEXTENDEDAXES 'Y) "Extend Y axis on/off"))) (Labels WHICHLABEL "Relabel plot" (SUBITEMS (Title (ASKFORLABEL 'TOP) "Title plot") (Left (ASKFORLABEL 'LEFT) "Label left of plot") (Bottom (ASKFORLABEL 'BOTTOM) "Label bottom of plot") (Right (ASKFORLABEL 'RIGHT) "Label right of plot"))) (Tics TOGGLETICS "Tics on or off" (SUBITEMS (Top (TOGGLETICS 'TOP) "Top tics on/off") (Left (TOGGLETICS 'LEFT) "Left tics on/off") (Bottom (TOGGLETICS 'BOTTOM) "Bottom tics on/off") (Right (TOGGLETICS 'RIGHT) "Right tics on/off"))) (Undelete UNDELETEPLOTOBJECT "Undelete last deleted object" (SUBITEMS (Top (UNDELETEPLOTOBJECT 'TOP) "Undelete last deleted object" ) (Select (UNDELETEPLOTOBJECT 'SELECT) "Select object to undelete" ) (Above (UNDELETEPLOTOBJECT 'ABOVE) "Undelete all objects above selected object" ) (All (UNDELETEPLOTOBJECT 'ALL) "Undelete all deleted objects" ))) (Fixed% Menu TOGGLEFIXEDMENU "Fix Plot menu"))) (RPAQQ OBJECTOPSTABLE ((POINT (DRAWFN DRAWPOINTOBJECT) (ERASEFN ERASEPOINTOBJECT) (HIGHLIGHTFN HIGHLIGHTPOINT) (MOVEFN MOVEPOINT) (LABELFN LABELPOINT) (EXTENTFN EXTENTOFPOINT) (DISTANCEFN DISTANCETOPOINT) (COPYFN COPYPOINT) (PUTFN PUTPOINT) (GETFN GETPOINT)) (CURVE (DRAWFN DRAWCURVEOBJECT) (ERASEFN ERASECURVEOBJECT) (HIGHLIGHTFN HIGHLIGHTCURVE) (MOVEFN MOVECURVE) (EXTENTFN EXTENTOFCURVE) (DISTANCEFN DISTANCETOCURVE) (COPYFN COPYCURVE) (PUTFN PUTCURVE) (GETFN GETCURVE)) (POLYGON (DRAWFN DRAWPOLYGONOBJECT) (ERASEFN ERASEPOLYGONOBJECT) (HIGHLIGHTFN HIGHLIGHTPOLYGON) (MOVEFN MOVEPOLYGON) (EXTENTFN EXTENTOFPOLYGON) (DISTANCEFN DISTANCETOPOLYGON) (COPYFN COPYPOLYGON) (PUTFN PUTPOLYGON) (GETFN GETPOLYGON)) (LINE (DRAWFN DRAWLINEOBJECT) (ERASEFN ERASELINEOBJECT) (HIGHLIGHTFN HIGHLIGHTLINE) (MOVEFN MOVELINE) (EXTENTFN EXTENTOFLINE) (DISTANCEFN DISTANCETOLINE) (COPYFN COPYLINE) (PUTFN PUTLINE) (GETFN GETLINE)) (GRAPH (DRAWFN DRAWGRAPHOBJECT) (ERASEFN ERASEGRAPHOBJECT) (HIGHLIGHTFN HIGHLIGHTGRAPH) (EXTENTFN EXTENTOFGRAPH) (DISTANCEFN DISTANCETOGRAPH) (COPYFN COPYGRAPHOBJECT) (PUTFN PUTGRAPH) (GETFN GETGRAPH)) (TEXT (DRAWFN DRAWTEXTOBJECT) (ERASEFN ERASETEXTOBJECT) (HIGHLIGHTFN HIGHLIGHTTEXT) (MOVEFN MOVETEXT) (LABELFN LABELTEXT) (EXTENTFN EXTENTOFTEXT) (DISTANCEFN DISTANCETOTEXT) (COPYFN COPYTEXT) (PUTFN PUTTEXT) (GETFN GETTEXT)) (COMPOUND (DRAWFN DRAWCOMPOUNDOBJECT) (ERASEFN ERASECOMPOUNDOBJECT) (HIGHLIGHTFN HIGHLIGHTCOMPOUND) (LOWLIGHTFN LOWLIGHTCOMPOUND) (MOVEFN MOVECOMPOUND) (EXTENTFN EXTENTOFCOMPOUND) (DISTANCEFN DISTANCETOCOMPOUND) (COPYFN COPYCOMPOUND) (PUTFN PUTCOMPOUND) (GETFN GETCOMPOUND)) (FILLEDRECTANGLE (DRAWFN DRAWFILLEDRECTANGLEOBJECT) (ERASEFN ERASEFILLEDRECTANGLEOBJECT) (HIGHLIGHTFN HIGHLIGHTFILLEDRECTANGLE) (MOVEFN MOVEFILLEDRECTANGLE) (EXTENTFN EXTENTOFFILLEDRECTANGLE) (DISTANCEFN DISTANCETOFILLEDRECTANGLE) (COPYFN COPYFILLEDRECTANGLE) (PUTFN PUTFILLEDRECTANGLE) (GETFN GETFILLEDRECTANGLE)))) (DECLARE%: EVAL@COMPILE (DATATYPE EXTENT ((MINX FLOATING) (MAXX FLOATING) (MINY FLOATING) (MAXY FLOATING))) (DATATYPE MARGIN (TICS? TICMETHOD LABEL TICLIST)) (DATATYPE PLOT (PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST) (* ;; "PLOTOBJECTS is a display list, PLOTSCALE describes the scale in world coordinates, USERDATA is a prop list, SAVELIST is for undelete") (* ;;  "WINDOWINFO descibes the associated PLOTWINDOW and its attached PLOTPROMPTWINDOW") (DATATYPE WINDOWINFO (PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW)) (* ;; "MARGININFO describes the size of the plot margins in stream coordinates") (DATATYPE MARGININFO (LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN)) (* ;; "MENUINFO decribes the PLOT's menus") (DATATYPE MENUINFO (MIDDLEMENU RIGHTMENU OTHERMENUS)) [ACCESSFNS PLOT ([XLOWER (fetch MIN of (fetch XINTERVAL of (fetch PLOTSCALE of DATUM] [XUPPER (fetch MAX of (fetch XINTERVAL of (fetch PLOTSCALE of DATUM] [YLOWER (fetch MIN of (fetch YINTERVAL of (fetch PLOTSCALE of DATUM] (YUPPER (fetch MAX of (fetch YINTERVAL of (fetch PLOTSCALE of DATUM]) (DATATYPE PLOTFNS (DRAWFN ERASEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN EXTENTFN DISTANCEFN COPYFN PUTFN GETFN)) (DATATYPE PLOTOBJECT (OBJECTFNS OBJECTSUBTYPE OBJECTUSERDATA OBJECTMENU OBJECTLABEL OBJECTDATA)) (DATATYPE AXISINFO (SCALEFN TICFN) (* ; "SCALEFN and TICFN are functions") ) (DATATYPE AXISINTERVAL ((MIN FLOATING) (MAX FLOATING)) [ACCESSFNS (INTERVALLENGTH (FDIFFERENCE (fetch MAX of DATUM) (fetch MIN of DATUM]) (DATATYPE PLOTSCALE (XINTERVAL XAXISINFO XTICINFO YINTERVAL YAXISINFO YTICINFO) (* ;; "XINTERVAL YINTERVAL are instances of AXISINTERVAL, XAXISINFO and YAXISINFO are instances of AXISINFO and XTICINFO and YTICINFO are instances of TICINFO") ) (DATATYPE TICINFO ((TICMIN FLOATING) (TICMAX FLOATING) TICINC NTICS) [ACCESSFNS (TICINTERVALLENGTH (FDIFFERENCE (fetch (TICINFO TICMAX) of DATUM) (fetch (TICINFO TICMIN) of DATUM]) ) (/DECLAREDATATYPE 'EXTENT '(FLOATP FLOATP FLOATP FLOATP) '((EXTENT 0 FLOATP) (EXTENT 2 FLOATP) (EXTENT 4 FLOATP) (EXTENT 6 FLOATP)) '8) (/DECLAREDATATYPE 'MARGIN '(POINTER POINTER POINTER POINTER) '((MARGIN 0 POINTER) (MARGIN 2 POINTER) (MARGIN 4 POINTER) (MARGIN 6 POINTER)) '8) (/DECLAREDATATYPE 'MENUINFO '(POINTER POINTER POINTER) '((MENUINFO 0 POINTER) (MENUINFO 2 POINTER) (MENUINFO 4 POINTER)) '6) (/DECLAREDATATYPE 'MARGININFO '(POINTER POINTER POINTER POINTER) '((MARGININFO 0 POINTER) (MARGININFO 2 POINTER) (MARGININFO 4 POINTER) (MARGININFO 6 POINTER)) '8) (/DECLAREDATATYPE 'WINDOWINFO '(POINTER POINTER POINTER) '((WINDOWINFO 0 POINTER) (WINDOWINFO 2 POINTER) (WINDOWINFO 4 POINTER)) '6) (/DECLAREDATATYPE 'PLOT '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOT 0 POINTER) (PLOT 2 POINTER) (PLOT 4 POINTER) (PLOT 6 POINTER) (PLOT 8 POINTER) (PLOT 10 POINTER) (PLOT 12 POINTER) (PLOT 14 POINTER)) '16) (/DECLAREDATATYPE 'PLOTFNS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTFNS 0 POINTER) (PLOTFNS 2 POINTER) (PLOTFNS 4 POINTER) (PLOTFNS 6 POINTER) (PLOTFNS 8 POINTER) (PLOTFNS 10 POINTER) (PLOTFNS 12 POINTER) (PLOTFNS 14 POINTER) (PLOTFNS 16 POINTER) (PLOTFNS 18 POINTER) (PLOTFNS 20 POINTER)) '22) (/DECLAREDATATYPE 'PLOTOBJECT '(POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTOBJECT 0 POINTER) (PLOTOBJECT 2 POINTER) (PLOTOBJECT 4 POINTER) (PLOTOBJECT 6 POINTER) (PLOTOBJECT 8 POINTER) (PLOTOBJECT 10 POINTER)) '12) (/DECLAREDATATYPE 'AXISINFO '(POINTER POINTER) '((AXISINFO 0 POINTER) (AXISINFO 2 POINTER)) '4) (/DECLAREDATATYPE 'AXISINTERVAL '(FLOATP FLOATP) '((AXISINTERVAL 0 FLOATP) (AXISINTERVAL 2 FLOATP)) '4) (/DECLAREDATATYPE 'PLOTSCALE '(POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTSCALE 0 POINTER) (PLOTSCALE 2 POINTER) (PLOTSCALE 4 POINTER) (PLOTSCALE 6 POINTER) (PLOTSCALE 8 POINTER) (PLOTSCALE 10 POINTER)) '12) (/DECLAREDATATYPE 'TICINFO '(FLOATP FLOATP POINTER POINTER) '((TICINFO 0 FLOATP) (TICINFO 2 FLOATP) (TICINFO 4 POINTER) (TICINFO 6 POINTER)) '8) (DECLARE%: EVAL@COMPILE (PUTPROPS APPLY.AFTERFN MACRO (ARGS (APPLY.AFTERFN.MACRO ARGS))) (PUTPROPS PLOTOBJECTSUBTYPE? MACRO [ARGS `(EQ ',(CAR ARGS) (fetch (PLOTOBJECT OBJECTSUBTYPE) of ,(CADR ARGS]) (PUTPROPS PLOTOBJECTPROP MACRO (ARGS (PLOTOBJECTPROPMACRO ARGS))) (PUTPROPS PLOTPROP MACRO (ARGS (PLOTPROPMACRO ARGS))) ) (PUTPROPS PLOTOBJECTPROP ARGNAMES (NIL (PLOTOBJECT PROP NEWVALUE) . PROPARGS)) (PUTPROPS PLOT.DEFAULTMENU ARGNAMES (NIL (MENUNAME NEWMENUITEMS) . MENUARGS)) (PUTPROPS PLOT.FIXRIGHTMENU ARGNAMES (NIL (PLOT FIXEDFLG) . PROPARGS)) (PUTPROPS PLOTLABEL ARGNAMES (NIL (PLOT MARGINNAME NEWLABEL NODRAWFLG) . LABELARGS)) (PUTPROPS PLOTMENU ARGNAMES (NIL (PLOT MENUNAME NEWMENU) . MENUARGS)) (PUTPROPS PLOTMENUITEMS ARGNAMES (NIL (PLOT MENUNAME NEWMENUITEMS) . MENUARGS)) (PUTPROPS PLOTPRETTYFNS ARGNAMES (NIL (PLOT AXIS NEWPRETTYSCALEFN NEWINVPRETTYSCALEFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTPROP ARGNAMES (NIL (PLOT PROP NEWVALUE) . PROPARGS)) (PUTPROPS PLOTSCALEFN ARGNAMES (NIL (PLOT AXIS NEWSCALEFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTTICFN ARGNAMES (NIL (PLOT AXIS NEWTICFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTTICS ARGNAMES (NIL (PLOT MARGINNAME NEWTICFLG NODRAWFLG) . LABELARGS)) (RPAQ? SMALLPLOTFONT '(GACHA 8 MRR)) (RPAQ? LARGEPLOTFONT '(GACHA 12 BRR)) (* ;;; "PLOT I/O") (DEFINEQ (COPYPLOTOBJECT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 28-Sep-91 16:32 by jds") (* ;; "Returns a copy of PLOTOBJECT. OBJECTPROPS are handled as follows. If the PLOTOBJECT has a COPYFN (which may be a list of fns) on its prop list, apply's it to NEWPLOTOBJECT PLOTOBJECT PLOT and expects it to copy the OBJECTPROPs, else calls COPYALL, except for PLOTOBJECTS or lists of PLOTOBJECTS which are COPYOBJECT'ed") (PROG ([OBJECTCOPYFN (MKLIST (PLOTOBJECTPROP PLOTOBJECT 'COPYFN] NEWPLOTOBJECT) (SETQ NEWPLOTOBJECT (CREATEPLOTOBJECT (fetch (PLOTOBJECT OBJECTFNS) of PLOTOBJECT ) (PLOTOBJECTSUBTYPE PLOTOBJECT) (COPYALL (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT)) (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT) (CL:FUNCALL (fetch (PLOTFNS COPYFN) of (fetch (PLOTOBJECT OBJECTFNS) of PLOTOBJECT)) PLOTOBJECT PLOT))) [for PROPNAME in (for PROP in (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT) by (CDDR PROP) collect PROP) do (PLOTOBJECTPROP NEWPLOTOBJECT PROPNAME (OR (AND OBJECTCOPYFN (bind PROPVALUE for FN in OBJECTCOPYFN until (SETQ PROPVALUE (CL:FUNCALL FN NEWPLOTOBJECT PLOTOBJECT PLOT PROPNAME)) finally (RETURN PROPVALUE))) (LET ((PROPVALUE (PLOTOBJECTPROP PLOTOBJECT PROPNAME))) (COND ((type? PLOTOBJECT PROPVALUE) (COPYPLOTOBJECT PROPVALUE)) [(LISTP PROPVALUE) (for ITEM in PROPVALUE collect (COND ((type? PLOTOBJECT ITEM) (COPYPLOTOBJECT ITEM PLOT)) (T (HCOPYALL ITEM] (T (HCOPYALL PROPVALUE] (COND ([OR (NOT (type? PLOTOBJECT NEWPLOTOBJECT)) (NOT (EQ (PLOTOBJECTSUBTYPE NEWPLOTOBJECT) (PLOTOBJECTSUBTYPE PLOTOBJECT] (HELP "Not a plotobject of correct type" NEWPLOTOBJECT))) (RETURN NEWPLOTOBJECT]) (COPYPLOT [LAMBDA (PLOT OPENFLG REGION TITLE BORDER) (* ; "Edited 5-May-87 18:27 by jop") (* ;; "Copies a PLOT. Copying of PLOTPROP's is handled as follows. If PLOT has a COPYPLOTFN, (which may be a list of fns) calls it with NEWPLOT PLOT as args, and expects it to copy the PLOTPROPS intelligently, else HCOPYALL's the PROPS, except for PLOTOBJECTS or lists of PLOTOBJECTS which are COPYOBJECT'ed") (PROG ([COPYFN (MKLIST (PLOTPROP PLOT 'COPYFN] (NEWPLOT (create PLOT))) (* ; "OK to share Menus") (replace (PLOT MIDDLEMENU) of NEWPLOT with (fetch (PLOT MIDDLEMENU) of PLOT)) (replace (PLOT RIGHTMENU) of NEWPLOT with (fetch (PLOT RIGHTMENU) of PLOT)) (* ;  "OTHERMENUS copied since it is a list in prop format and consists of MENU's or LITATOMS") (replace (PLOT OTHERMENUS) of NEWPLOT with (COPY (fetch (PLOT OTHERMENUS) of PLOT))) (replace (PLOT LEFTMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT LEFTMARGIN) of PLOT))) (replace (PLOT RIGHTMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT RIGHTMARGIN) of PLOT))) (replace (PLOT TOPMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT TOPMARGIN) of PLOT))) (replace (PLOT BOTTOMMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT BOTTOMMARGIN ) of PLOT))) (* ;  "Plot objects not shared since they can be distructively modified") (replace (PLOT PLOTOBJECTS) of NEWPLOT with (for OBJECT in (fetch (PLOT PLOTOBJECTS ) of PLOT) collect (COPYPLOTOBJECT OBJECT PLOT))) (replace (PLOT PLOTSCALE) of NEWPLOT with (create PLOTSCALE copying (fetch (PLOT PLOTSCALE) of PLOT))) (* ;  "Does a HCOPYALL since we don't know what's cached here") [for PROPNAME in (for PROP in (fetch (PLOT PLOTUSERDATA) of PLOT) by (CDDR PROP) collect PROP) do (PLOTPROP NEWPLOT PROPNAME (OR (AND COPYFN (bind PROPVALUE for FN in COPYFN until (SETQ PROPVALUE (CL:FUNCALL FN NEWPLOT PLOT PROPNAME)) finally (RETURN PROPVALUE))) (LET ((PROPVALUE (PLOTPROP PLOT PROPNAME))) (COND ((type? PLOTOBJECT PROPVALUE) (COPYPLOTOBJECT PROPVALUE)) [(LISTP PROPVALUE) (for ITEM in PROPVALUE collect (COND ((type? PLOTOBJECT ITEM) (COPYPLOTOBJECT ITEM PLOT)) (T (HCOPYALL ITEM] (T (HCOPYALL PROPVALUE] (* ; "Cache the display parameters") [COND ((OR REGION TITLE BORDER) (replace (PLOT PLOTWINDOW) of NEWPLOT with (LIST REGION TITLE BORDER] (COND (OPENFLG (OPENPLOTWINDOW NEWPLOT))) (RETURN NEWPLOT]) (PLOTOBJECTPRINT [LAMBDA (PLOTOBJECT STREAM) (* ; "Edited 28-Sep-91 16:32 by jds") (PRINTOUT STREAM "#<" (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT) " PLOTOBJECT>@") (\PRINTADDR PLOTOBJECT STREAM) T]) (PRINTPLOTOBJECT [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 28-Sep-91 16:32 by jds") (* ;; "Puts a plot object on STREAM") (PROG [(OBJECTPUTFN (MKLIST (PLOTOBJECTPROP PLOTOBJECT 'PUTFN] (PRINTOUT STREAM "(READPLOTOBJECT)(" %, "OBJECTSUBTYPE" %, .P2 (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT) %, "OBJECTDATA" %,) (CL:FUNCALL (fetch (PLOTFNS PUTFN) of (fetch (PLOTOBJECT OBJECTFNS) of PLOTOBJECT)) PLOTOBJECT PLOT STREAM) (PRINTOUT STREAM %, "OBJECTMENU" %,) (HPRINT (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT) STREAM T T) (PRINTOUT STREAM %, "OBJECTLABEL" %, .P2 (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT ) %,) (PRINTOUT STREAM "OBJECTUSERDATA (") (for PROPNAME in (for PROP in (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT) by (CDDR PROP) collect PROP) do (PRINTOUT STREAM PROPNAME %,) (if (NULL (for FN in OBJECTPUTFN thereis (CL:FUNCALL FN PLOTOBJECT PLOT PROPNAME STREAM))) then (HPRINT (PLOTOBJECTPROP PLOTOBJECT PROPNAME) STREAM NIL T))) (PRINTOUT STREAM "))") (RETURN T]) (PRINTPLOT [LAMBDA (PLOT STREAM) (* ; "Edited 5-May-87 18:27 by jop") (* ;; "Puts out a symbolic representation of PLOT on STREAM") (PROG ([PUTFN (MKLIST (PLOTPROP PLOT 'PUTFN] MENU) (PRINTOUT STREAM "(READPLOT)(") (PRINTOUT STREAM "RIGHTMENU" %,) (if (EQ (PLOT.DEFAULTMENU 'RIGHT) (fetch (PLOT RIGHTMENU) of PLOT)) then (PRINTOUT STREAM "DEFAULT" %,) else (HPRINT (fetch (PLOT RIGHTMENU) of PLOT) STREAM T T)) (PRINTOUT STREAM "MIDDLEMENU" %,) (if (EQ (PLOT.DEFAULTMENU 'MIDDLE) (fetch (PLOT MIDDLEMENU) of PLOT)) then (PRINTOUT STREAM "DEFAULT" %,) else (HPRINT (fetch (PLOT MIDDLEMENU) of PLOT) STREAM T T)) (for FIELDNAME in '((PLOT OTHERMENUS) (PLOT LEFTMARGIN) (PLOT TOPMARGIN) (PLOT RIGHTMARGIN) (PLOT BOTTOMMARGIN) (PLOT PLOTSCALE)) do (PRINTOUT STREAM (CADR FIELDNAME) %,) (HPRINT (RECORDACCESS FIELDNAME PLOT) STREAM T T)) (PRINTOUT STREAM %, "PLOTOBJECTS (") (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (HPRINT OBJECT STREAM T T)) (PRINTOUT STREAM ")" %,) (PRINTOUT STREAM %, "PLOTUSERDATA (") (for PROPNAME in (for PROP in (fetch (PLOT PLOTUSERDATA) of PLOT) by (CDDR PROP) collect PROP) do (PRINTOUT STREAM %, PROPNAME %,) (if (NULL (for FN in PUTFN thereis (CL:FUNCALL FN PLOT PROPNAME STREAM))) then (HPRINT (PLOTPROP PLOT PROPNAME) STREAM NIL T))) (PRINTOUT STREAM ")" %,) (PRINTOUT STREAM ")") (RETURN T]) (READFONT [LAMBDA (STREAM) (* jop%: "27-Aug-85 13:34") (PROG ((PROPLIST (READ STREAM))) (RETURN (FONTCREATE (LISTGET PROPLIST 'FAMILY) (LISTGET PROPLIST 'SIZE) (LISTGET PROPLIST 'FACE) (LISTGET PROPLIST 'ROTATION) (LISTGET PROPLIST 'DEVICE]) (READMENU [LAMBDA (STREAM) (* ; "Edited 6-May-87 09:31 by jop") (* ;; "Function For Reading Menus From File") (PROG ((PROPLIST (HREAD STREAM))) (RETURN (create MENU ITEMS _ (LISTGET PROPLIST 'ITEMS) WHENSELECTEDFN _ (LISTGET PROPLIST 'WHENSELECTEDFN) WHENHELDFN _ (LISTGET PROPLIST 'WHENHELDFN) WHENUNHELDFN _ (LISTGET PROPLIST 'WHENUNHELDFN) MENUPOSITION _ (LISTGET PROPLIST 'MENUPOSITION) MENUOFFSET _ (LISTGET PROPLIST 'MENUOFFSET) MENUFONT _ (LISTGET PROPLIST 'MENUFONT) TITLE _ (LISTGET PROPLIST 'TITLE) CENTERFLG _ (LISTGET PROPLIST 'CENTERFLG) MENUROWS _ (LISTGET PROPLIST 'MENUROWS) MENUCOLUMNS _ (LISTGET PROPLIST 'MENUCOLUMNS) ITEMHEIGHT _ (LISTGET PROPLIST 'ITEMHEIGHT) ITEMWIDTH _ (LISTGET PROPLIST 'ITEMWIDTH) MENUBORDERSIZE _ (LISTGET PROPLIST 'MENUBORDERSIZE) MENUOUTLINESIZE _ (LISTGET PROPLIST 'MENUOUTLINESIZE) CHANGEOFFSETFLG _ (LISTGET PROPLIST 'CHANGEOFFSETFLG]) (READPLOTOBJECT [LAMBDA (STREAM) (* ; "Edited 5-May-87 18:27 by jop") (* ;; "Reads a plot object from STREAM previously written out by PRINTOBJECT") (PROG ((PROPLST (HREAD STREAM)) OBJECTSUBTYPE OBJECTFNS OBJECTGETFN NEWOBJECT OBJECTUSERDATA) (SETQ OBJECTSUBTYPE (LISTGET PROPLST 'OBJECTSUBTYPE)) [SETQ OBJECTFNS (EVAL (PACK* OBJECTSUBTYPE 'FNS] (SETQ OBJECTGETFN (fetch (PLOTFNS GETFN) of OBJECTFNS)) [SETQ NEWOBJECT (CREATEPLOTOBJECT OBJECTFNS OBJECTSUBTYPE (LISTGET PROPLST 'OBJECTLABEL) (LISTGET PROPLST 'OBJECTMENU) (CL:FUNCALL OBJECTGETFN (LISTGET PROPLST 'OBJECTDATA] (SETQ OBJECTUSERDATA (LISTGET PROPLST 'OBJECTUSERDATA)) (for PROPNAME in OBJECTUSERDATA by (CDDR PROPNAME) as PROPVALUE in (CDR OBJECTUSERDATA) by (CDDR PROPVALUE) do (PLOTOBJECTPROP NEWOBJECT PROPNAME (if (AND (LISTP PROPVALUE) (EQ (CAR PROPVALUE) 'FUNCTION)) then (SETQ PROPVALUE (CL:FUNCALL (CADR PROPVALUE) NEWOBJECT PROPNAME)) else PROPVALUE))) (RETURN NEWOBJECT]) (READPLOT [LAMBDA (STREAM) (* ; "Edited 5-May-87 18:28 by jop") (* ;;  "Reads In a Symbolic Representation Of A PLOT From Stream Previously Written Out By PRINTPLOT") (LET* [(PROPLST (HREAD STREAM)) (RIGHTMENU (LISTGET PROPLST 'RIGHTMENU)) (MIDDLEMENU (LISTGET PROPLST 'MIDDLEMENU)) (USERDATA (LISTGET PROPLST 'PLOTUSERDATA)) (PLOT (create PLOT OTHERMENUS _ (LISTGET PROPLST 'OTHERMENUS) LEFTMARGIN _ (LISTGET PROPLST 'LEFTMARGIN) TOPMARGIN _ (LISTGET PROPLST 'TOPMARGIN) RIGHTMARGIN _ (LISTGET PROPLST 'RIGHTMARGIN) BOTTOMMARGIN _ (LISTGET PROPLST 'BOTTOMMARGIN) PLOTSCALE _ (LISTGET PROPLST 'PLOTSCALE) PLOTOBJECTS _ (LISTGET PROPLST 'PLOTOBJECTS] (PLOTMENU PLOT 'RIGHT (if (EQ RIGHTMENU 'DEFAULT) then (PLOT.DEFAULTMENU 'RIGHT) else RIGHTMENU)) (PLOTMENU PLOT 'MIDDLE (if (EQ MIDDLEMENU 'DEFAULT) then (PLOT.DEFAULTMENU 'MIDDLE) else MIDDLEMENU)) (for PROPNAME in USERDATA by (CDDR PROPNAME) as PROPVALUE in (CDR USERDATA) by (CDDR PROPVALUE) do (PLOTPROP PLOT PROPNAME (if [AND (LISTP PROPVALUE) (AND (LISTP (CAR PROPVALUE)) (EQ (CAAR PROPVALUE) 'FUNCTION] then (* ;  "Assumes Lists Of Form ((Function Foo) Bar)") (SETQ PROPVALUE (CL:FUNCALL (CADAR PROPVALUE ) PLOT PROPNAME (CADR PROPVALUE))) else PROPVALUE))) PLOT]) ) (DEFINEQ (PRINT-VECTOR [LAMBDA (VECTOR STREAM) (* ; "Edited 1-Jun-87 17:34 by jop") (PRINTOUT STREAM "(READ-VECTOR)") (PRIN2 (COERCE VECTOR 'LIST) STREAM]) (READ-VECTOR [LAMBDA (STREAM) (* ; "Edited 1-Jun-87 17:39 by jop") (LET ((LST (HREAD STREAM))) (CL:MAKE-ARRAY (LENGTH LST) :INITIAL-CONTENTS LST]) ) (PUTDEF (QUOTE PLOTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (PLTS (HORRIBLEVARS . PLTS]) (ADDTOVAR HPRINTMACROS (FONTDESCRIPTOR . PRINTFONT) (MENU . PRINTMENU) (PLOT . PRINTPLOT) (PLOTOBJECT . PRINTPLOTOBJECT) (ONED-ARRAY . PRINT-VECTOR)) (ADDTOVAR HPRINTREADFNS READPLOT READPLOTOBJECT READFONT READMENU READ-VECTOR) (DEFPRINT 'PLOTOBJECT (FUNCTION PLOTOBJECTPRINT)) (* ;;; "Numeric fns") (DEFINEQ (PLOT.EXP10 [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (* ;; "this procedure returns exact power of ten for integer args") (EXPT 10.0 X]) (PLOT.LOG10 [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (* ;; "Returns log base 10 of X") (PROG [(C (CONSTANT (FQUOTIENT 1.0 (LOG 10.0] (RETURN (FTIMES C (LOG X]) (PLOT.FLOOR [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (SETQ X (FLOAT X)) (PROG ((FIXX (FIX X))) (RETURN (COND [(MINUSP X) (COND ((EQP FIXX X) FIXX) (T (SUB1 FIXX] (T FIXX]) (PLOT.CEILING [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") (SETQ X (FLOAT X)) (PROG ((FIXX (FIX X))) (RETURN (COND ((MINUSP X) FIXX) (T (COND ((EQP FIXX X) FIXX) (T (ADD1 FIXX]) (SINEWAVE [LAMBDA (N FREQUENCY FROM TO AMPLITUDE) (* ; "Edited 6-May-87 09:33 by jop") (* ;; "produce N points on a sine wave") (PROG ((TWOPI (TIMES 2.0 3.14159)) (RANGE (FDIFFERENCE TO FROM))) (if (NULL FREQUENCY) then (SETQ FREQUENCY 1)) (if (NULL AMPLITUDE) then (SETQ AMPLITUDE 1)) (RETURN (bind (X _ FROM) (INC _ (FQUOTIENT RANGE N)) POINT for I from 1 to N collect [SETQ POINT (create POSITION XCOORD _ X YCOORD _ (TIMES AMPLITUDE (SIN (TIMES FREQUENCY X ) T] (SETQ X (PLUS X INC)) POINT]) ) (* ;;; "PLOT image object FNS") (DEFINEQ (CREATEPLOTIMAGEOBJ [LAMBDA (PLOT) (* ; "Edited 27-May-87 18:38 by jop") (* ;; "creates PLOT image object from PLOT") (LET* ((WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (REGION (IF (WINDOWP WINDOW) THEN (WINDOWPROP WINDOW 'REGION) ELSE (CAR WINDOW))) (OBJ (IMAGEOBJCREATE (COPYPLOT PLOT) PLOTIMAGEFNS))) (IMAGEOBJPROP OBJ 'WIDTH (FETCH (REGION WIDTH) OF REGION)) (IMAGEOBJPROP OBJ 'HEIGHT (FETCH (REGION HEIGHT) OF REGION)) OBJ]) (CREATEPLOTBITMAPOBJ [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:19 by jop") (LET* [(WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) (BITMAP (BITMAPCREATE (WINDOWPROP WINDOW 'WIDTH) (WINDOWPROP WINDOW 'HEIGHT] (BITBLT WINDOW NIL NIL BITMAP) (BITMAPTEDITOBJ BITMAP 1 0]) (PLIO.BUTTONEVENTINFN [LAMBDA (PLOTIMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) (* ; "Edited 28-Sep-91 17:05 by jds") (PROG ([CHOICEMENU (CONSTANT (create MENU CENTERFLG _ T ITEMS _ '(("Select" 'SELECT "Select the image object") ("Reshape" 'RESHAPE "Reshape the image objcet") ("Plot Window" 'EDIT "Open a window containing plot"] (PLOT (IMAGEOBJPROP PLOTIMAGEOBJ 'OBJECTDATUM)) (IMAGEWIDTH (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH)) (IMAGEHEIGHT (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT)) MINSIZE NEWREGION WIN NEWPLOT) (* ;; "consider selection if BUTTON=NIL to handle plots in Koto version of Sketch") (COND ((OR (NOT BUTTON) (EQ BUTTON 'LEFT)) (SELECTQ (MENU CHOICEMENU) (RESHAPE (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP (fetch (PLOT PLOTWINDOW ) of PLOT) 'DSP) PLOT)) (* ;  "Assumes the WINDOWSTREAM has been changed to fit the imageobj") (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE) (CREATEREGION (DSPXOFFSET NIL WINDOWSTREAM) (DSPYOFFSET NIL WINDOWSTREAM) IMAGEWIDTH IMAGEHEIGHT))) (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH (fetch (REGION WIDTH) of NEWREGION )) (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT (fetch (REGION HEIGHT) of NEWREGION)) (* ; "Redraw the Image object") (RETURN 'CHANGED)) (EDIT (SETQ NEWPLOT (COPYPLOT PLOT NIL (GETBOXREGION (WIDTHIFWINDOW IMAGEWIDTH) (HEIGHTIFWINDOW IMAGEHEIGHT T)) "Plot Edit Window")) (SETQ WIN (OPENPLOTWINDOW NEWPLOT)) (* ;; "Cache some info some that changes to NEWPLOT may be reinserted into TEXTSTREAM. Windowprops are used because they are not copied (HACK)") (* ;;  "sketch doesn't pass down anything for TEXTSTREAM arg so must use viewer window instead") (WINDOWPROP WIN 'SOURCEHOST (OR TEXTSTREAM WINDOW WINDOWSTREAM)) (WINDOWPROP WIN 'SOURCEIMAGEOBJ PLOTIMAGEOBJ) (WINDOWADDPROP WIN 'CLOSEFN 'PLIO.EDITCLOSEFN T) (* ;; "handle reinsert by a closefn rather than an new menu item -- similar to the behavior of Sketch image object edits (PLOTADDMENUITEMS NEWPLOT (QUOTE RIGHT) (QUOTE ((Reinsert PLIO.REINSERTOBJ 'Change source image object'))))") (RETURN T)) (RETURN NIL))) (T (RETURN NIL]) (PLIO.COPYFN [LAMBDA (PLOTIOBJ) (* ; "Edited 6-May-87 09:35 by jop") (* ; "simple copy") (PROG ((NEWOBJ (IMAGEOBJCREATE NIL PLOTIMAGEFNS))) [IMAGEOBJPROP NEWOBJ 'OBJECTDATUM (COPYPLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM] (IMAGEOBJPROP NEWOBJ 'WIDTH (IMAGEOBJPROP PLOTIOBJ 'WIDTH)) (IMAGEOBJPROP NEWOBJ 'HEIGHT (IMAGEOBJPROP PLOTIOBJ 'HEIGHT)) (RETURN NEWOBJ]) (PLIO.GETFN [LAMBDA (STREAM TEXTSTREAM) (* ; "Edited 6-May-87 09:35 by jop") (* ;; "PLOT IMAGEOBJECT GETFN") (PROG ((PROPLST (HREAD STREAM)) PLOTIMAGEOBJ) (SETQ PLOTIMAGEOBJ (IMAGEOBJCREATE (LISTGET PROPLST 'PLOT) PLOTIMAGEFNS)) (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH (LISTGET PROPLST 'WIDTH)) (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT (LISTGET PROPLST 'HEIGHT)) (RETURN PLOTIMAGEOBJ]) (PLIO.PUTFN [LAMBDA (PLOTIMAGEOBJ STREAM) (* ; "Edited 6-May-87 09:35 by jop") (* ;; "PLOT IMAGEOBJECT PUTFN") (PRINTOUT STREAM "(WIDTH" %, (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH) %, "HEIGHT" %, (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT) %, "PLOT" %,) (HPRINT (IMAGEOBJPROP PLOTIMAGEOBJ 'OBJECTDATUM) STREAM T T) (PRINTOUT STREAM ")"]) (PLIO.REINSERTOBJ [LAMBDA (PLOT) (* ; "Edited 28-Sep-91 16:21 by jds") (* ;; "allows modified plot to be reinserted in document") (* ;; "modified to work with Sketch as well as TEdit sources") (PROG ((PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) HOST OBJ) (SETQ HOST (WINDOWPROP PLOTWINDOW 'SOURCEHOST)) (SETQ OBJ (WINDOWPROP PLOTWINDOW 'SOURCEIMAGEOBJ)) (COND ((NOT (IMAGEOBJP OBJ)) (HELP "Not an IMAGEOBJ" OBJ))) (* ;  "Destructively change imageobj to retain EQ ness") (IMAGEOBJPROP OBJ 'OBJECTDATUM (COPYPLOT PLOT)) (IMAGEOBJPROP OBJ 'WIDTH (WINDOWPROP PLOTWINDOW 'WIDTH)) (IMAGEOBJPROP OBJ 'HEIGHT (WINDOWPROP PLOTWINDOW 'HEIGHT)) (IMAGE.OBJECT.CHANGED HOST OBJ]) (PLOT.COPYBUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-May-87 09:36 by jop") (* ;; "Allows plots to be copy selected") (PROG ((PLOT (WINDOWPROP WINDOW 'PLOT)) [IMAGETYPEMENU (CONSTANT (create MENU ITEMS _ '((Plot 'PLOT) (Bitmap 'BITMAP] IMAGEOBJ) (INVERTW WINDOW) (UNTILMOUSESTATE UP) (INVERTW WINDOW) (COND ((INSIDEP WINDOW (CURSORPOSITION NIL WINDOW)) (SELECTQ (MENU IMAGETYPEMENU) (PLOT (SETQ IMAGEOBJ (CREATEPLOTIMAGEOBJ PLOT))) (BITMAP (SETQ IMAGEOBJ (CREATEPLOTBITMAPOBJ PLOT))) NIL) (AND IMAGEOBJ (COPYINSERT IMAGEOBJ]) (PLIO.DISPLAYFN [LAMBDA (PLOTIOBJ IMAGESTREAM) (* ; "Edited 7-May-87 18:21 by jop") (* ;; "Displays plot image object") (PROG ((PLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM)) (VIEWPORT (IMAGEOBJPROP PLOTIOBJ 'VIEWPORT)) (SCALE (DSPSCALE NIL IMAGESTREAM)) STREAMREGION) (COND ((OR (NULL VIEWPORT) (NOT (EQ (fetch PARENTSTREAM of VIEWPORT) IMAGESTREAM))) (SETQ VIEWPORT (CREATEVIEWPORT IMAGESTREAM)) (IMAGEOBJPROP PLOTIOBJ 'VIEWPORT VIEWPORT))) [SETQ STREAMREGION (CREATEREGION (DSPXPOSITION NIL IMAGESTREAM) (DSPYPOSITION NIL IMAGESTREAM) [FIXR (TIMES SCALE (IMAGEOBJPROP PLOTIOBJ 'WIDTH] (FIXR (TIMES SCALE (IMAGEOBJPROP PLOTIOBJ 'HEIGHT] (CREATETICLISTS PLOT) (ADJUSTVIEWPORT VIEWPORT STREAMREGION PLOT) (DRAWPLOT PLOT IMAGESTREAM VIEWPORT STREAMREGION]) (PLIO.IMAGEBOXFN [LAMBDA (PLOTIOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 6-May-87 09:36 by jop") (* ;; "Determines size of plotimageobj") (PROG ((IMAGEWIDTH (IMAGEOBJPROP PLOTIOBJ 'WIDTH)) (IMAGEHEIGHT (IMAGEOBJPROP PLOTIOBJ 'HEIGHT)) (PLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM)) (SCALE (COND (IMAGESTREAM (DSPSCALE NIL IMAGESTREAM)) (T 1))) NEWREGION MINSIZE) (* ;; "(* this doesn't work with Sketch which has no rightmargin) (if (GREATERP (TIMES SCALE IMAGEWIDTH) (DIFFERENCE RIGHTMARGIN CURRENTX)) then (if (NOT (EQ (IMAGESTREAMTYPE IMAGESTREAM) (QUOTE DISPLAY))) then (HELP 'PLOT image object too big')) (PROMPTPRINT 'Image object too wide. Choose a smaller region') (SETQ MINSIZE (MINSTREAMREGIONSIZE IMAGESTREAM PLOT)) (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE))) (SETQ IMAGEWIDTH (fetch WIDTH of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE WIDTH) IMAGEWIDTH) (SETQ IMAGEHEIGHT (fetch HEIGHT of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE HEIGHT) IMAGEHEIGHT))") (RETURN (create IMAGEBOX XSIZE _ (TIMES SCALE IMAGEWIDTH) YSIZE _ (TIMES SCALE IMAGEHEIGHT) YDESC _ 0 XKERN _ 0]) ) (* ;; "additional fns to allow plot im. objs. to work in Sketch") (DEFINEQ (PLIO.EDITCLOSEFN [LAMBDA (W) (* ; "Edited 5-May-87 18:10 by jop") (* ;; "this plot window is from an image object. Reinsert plot if requested") (* ;; "later could test if plot has been changed -- if no changes don't ask to reinsert") (LET (RESULT) (SETQ RESULT (SELECTQ (MENU (CONSTANT (create MENU TITLE _ "Change source image object?" ITEMS _ '(("Yes" 'YES "This image used in the document instead of the one that is there." ) ("No" 'NO "The changes made to this image will not be put into the document." )) CENTERFLG _ T))) (YES (PLIO.REINSERTOBJ (WHICHPLOT W)) NIL) (NO NIL) (NIL (* ;  "user selected outside the menu -- abort the close") 'DON'T) NIL)) (OR RESULT (WINDOWDELPROP W 'CLOSEFN 'PLIO.EDITCLOSEFN)) (* ;  "clean up window prop -- required since currently PLOT.CLOSEFN calls CLOSEW!") RESULT]) (IMAGE.OBJECT.CHANGED [LAMBDA (HOST OBJECT) (* ; "Edited 5-May-87 18:11 by jop") (* ;; "notifies HOST that OBJECT has changed and needs to be redisplayed") (* ;; "currently assumes object is in TEdit or Sketch") (LET (CANONICALHOST) (COND ([SETQ CANONICALHOST (CAR (NLSETQ (TEXTSTREAM HOST] (TEDIT.OBJECT.CHANGED CANONICALHOST OBJECT)) ([SETQ CANONICALHOST (CAR (NLSETQ (INSURE.SKETCH HOST] (* ;  "INSURE.SKETCH noerrorflg doesn't work") (SK.MARK.DIRTY CANONICALHOST) (* ;  "this sets SKETCHCHANGED prop of all viewers on the sketch") (for SKW in (SKETCH.ALL.VIEWERS CANONICALHOST) do (REDISPLAYW SKW))) (T (HELP "Can't update image object in " HOST]) ) (RPAQ? PLOTIMAGEFNS (IMAGEFNSCREATE (FUNCTION PLIO.DISPLAYFN) (FUNCTION PLIO.IMAGEBOXFN) (FUNCTION PLIO.PUTFN) (FUNCTION PLIO.GETFN) (FUNCTION PLIO.COPYFN) (FUNCTION PLIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PLOTIMAGEFNS) ) (* ;;; "Initialize") (PLOT.SETUP OBJECTOPSTABLE) (PLOT.DEFAULTMENU 'MIDDLE PLOT.DEFAULTMIDDLEMENUITEMS) (PLOT.DEFAULTMENU 'RIGHT PLOT.DEFAULTRIGHTMENUITEMS) (* ;;; "Dependent files") (FILESLOAD TWODGRAPHICS PLOTOBJECTS) (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 PLOTTICS PLOTTICFN PLOTSCALEFN PLOTPROP PLOTOBJECTPROP PLOTMENUITEMS PLOTMENU PLOTLABEL PLOT.FIXRIGHTMENU PLOT.DEFAULTMENU) ) (PUTPROPS PLOT COPYRIGHT ("Venue" 1985 1986 1987 1988 1991 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8386 143842 (ADDPLOTOBJECT 8396 . 9560) (ADJUSTSCALE? 9562 . 12146) (ADJUSTVIEWPORT 12148 . 17120) (APPLY.AFTERFN.MACRO 17122 . 17776) (ASKFORLABEL 17778 . 19256) (ASKFORSCALE 19258 . 21120) (BOXREGION 21122 . 21874) (CHOOSESCALE 21876 . 22422) (CHOOSETICS 22424 . 22925) ( CLOSEPLOTWINDOW 22927 . 24074) (CLOSESTPLOTOBJECT 24076 . 24346) (COMPOUNDSUBTYPE 24348 . 24565) ( COMPUTEBOTTOMMARGIN 24567 . 25830) (COMPUTELEFTMARGIN 25832 . 27435) (COMPUTERIGHTMARGIN 27437 . 29018 ) (COMPUTETOPMARGIN 29020 . 30203) (COPYMENU 30205 . 31294) (CREATEPLOT 31296 . 34171) (CREATEPLOTFNS 34173 . 36425) (CREATEPLOTOBJECT 36427 . 37247) (DEFAULTSCALEFN 37249 . 37523) (DEFAULTTICFN 37525 . 39434) (DEFAULTTICMETHOD 39436 . 40822) (DELETEPLOTOBJECT 40824 . 42447) (DESELECTPLOTOBJECT 42449 . 42826) (DISTANCETOPLOTOBJECT 42828 . 43190) (DRAWBOTTOMMARGIN 43192 . 45380) (DRAWLEFTMARGIN 45382 . 47104) (DRAWMARGIN 47106 . 48024) (DRAWPLOTOBJECT 48026 . 48627) (DRAWPLOT 48629 . 49604) ( DRAWRIGHTMARGIN 49606 . 51487) (DRAWTOPMARGIN 51489 . 53557) (ERASEPLOTOBJECT 53559 . 54224) ( EXTENDEDSCALEFN 54226 . 54745) (EXTENTOFPLOTOBJECT 54747 . 55025) (EXTENTOFPLOT 55027 . 56364) ( GETPLOTWINDOW 56366 . 56543) (GETTICLIST 56545 . 57530) (HIGHLIGHTPLOTOBJECT 57532 . 58228) ( LABELPLOTOBJECT 58230 . 58674) (LOWLIGHTPLOTOBJECT 58676 . 59365) (MANUALRESCALE 59367 . 61388) ( MINSTREAMREGIONSIZE 61390 . 63259) (MOVEPLOTOBJECT 63261 . 63515) (OPENPLOTWINDOW 63517 . 69583) ( PLOT.BUTTONEVENTFN 69585 . 75343) (PLOT.CLOSEFN 75345 . 75512) (PLOT.DEFAULTMENU 75514 . 77093) ( PLOT.FIXRIGHTMENU 77095 . 78943) (PLOT.HARDCOPYFN 78945 . 84229) (PLOT.ICONFN 84231 . 88438) ( PLOT.LABELTOWORLD 88440 . 89043) (PLOT.REPAINTFN 89045 . 89309) (PLOT.RESET 89311 . 90787) (PLOT.SETUP 90789 . 91769) (PLOT.SKETCH.CREATE 91771 . 93622) (PLOT.WHENSELECTEDFN 93624 . 94613) ( PLOT.WORLDTOLABEL 94615 . 95219) (PLOTADDMENUITEMS 95221 . 96351) (PLOTADDPROP 96353 . 96863) ( PLOTAXISINTERVAL 96865 . 97993) (PLOTDELMENUITEMS 97995 . 99727) (PLOTDELPROP 99729 . 100191) ( PLOTLABEL 100193 . 101658) (PLOTMENU 101660 . 104063) (PLOTMENUITEMS 104065 . 105688) ( PLOTOBJECTADDPROP 105690 . 106214) (PLOTOBJECTDELPROP 106216 . 106700) (PLOTOBJECTLABEL 106702 . 107667) (PLOTOBJECTPROP 107669 . 111635) (PLOTOBJECTPROPMACRO 111637 . 112240) (PLOTOBJECTSUBTYPE 112242 . 112419) (PLOTOPERROR 112421 . 112616) (PLOTPROMPT 112618 . 112861) (PLOTPROP 112863 . 114619) (PLOTPROPMACRO 114621 . 115975) (PLOTREMPROP 115977 . 117251) (PLOTSCALEFN 117253 . 118469) ( PLOTTICFN 118471 . 119697) (PLOTTICINFO 119699 . 120618) (PLOTTICMETHOD 120620 . 121870) (PLOTTICS 121872 . 123069) (PRINTFONT 123071 . 123484) (PRINTMENU 123486 . 125176) (REDRAWPLOTWINDOW 125178 . 128081) (RELABELSELECTEDPLOTOBJECT 128083 . 129066) (RESCALEPLOT 129068 . 131981) (SCALE 131983 . 135390) (TOGGELLABEL 135392 . 135678) (TOGGLEEXTENDEDAXES 135680 . 137031) (TOGGLEFIXEDMENU 137033 . 137234) (TOGGLETICS 137236 . 137901) (TRANSLATEPLOTOBJECT 137903 . 139181) (UNDELETEPLOTOBJECT 139183 . 142289) (UNLABELPLOTOBJECT 142291 . 142834) (WHICHLABEL 142836 . 143308) (WHICHPLOT 143310 . 143840 )) (143894 151602 (PLOT.PRINTNUM 143904 . 144721) (PLOT.FNUM-STRING 144723 . 147445) (PLOT.ENUM-STRING 147447 . 149256) (CREATETICLISTS 149258 . 150534) (NORMALIZE-TICLIST 150536 . 151600)) (151603 156830 (DRAW-TICS-LEFT-RIGHT 151613 . 153270) (DRAW-TICS-TOP-BOTTOM 153272 . 155068) (DRAW-LABEL-LEFT-RIGHT 155070 . 156238) (DRAW-LABEL-TOP-BOTTOM 156240 . 156828)) (173375 193394 (COPYPLOTOBJECT 173385 . 176643) (COPYPLOT 176645 . 182624) (PLOTOBJECTPRINT 182626 . 182903) (PRINTPLOTOBJECT 182905 . 184809) (PRINTPLOT 184811 . 187281) (READFONT 187283 . 187690) (READMENU 187692 . 189056) (READPLOTOBJECT 189058 . 190803) (READPLOT 190805 . 193392)) (193395 193848 (PRINT-VECTOR 193405 . 193616) ( READ-VECTOR 193618 . 193846)) (194361 196693 (PLOT.EXP10 194371 . 194586) (PLOT.LOG10 194588 . 194837) (PLOT.FLOOR 194839 . 195234) (PLOT.CEILING 195236 . 195639) (SINEWAVE 195641 . 196691)) (196734 207524 (CREATEPLOTIMAGEOBJ 196744 . 197399) (CREATEPLOTBITMAPOBJ 197401 . 197784) ( PLIO.BUTTONEVENTINFN 197786 . 201790) (PLIO.COPYFN 201792 . 202315) (PLIO.GETFN 202317 . 202833) ( PLIO.PUTFN 202835 . 203253) (PLIO.REINSERTOBJ 203255 . 204199) (PLOT.COPYBUTTONEVENTFN 204201 . 205060 ) (PLIO.DISPLAYFN 205062 . 206167) (PLIO.IMAGEBOXFN 206169 . 207522)) (207599 210334 (PLIO.EDITCLOSEFN 207609 . 209318) (IMAGE.OBJECT.CHANGED 209320 . 210332))))) STOP \ No newline at end of file diff --git a/lispusers/PLOT.~2~ b/lispusers/PLOT.~2~ deleted file mode 100644 index 0dbc101c..00000000 --- a/lispusers/PLOT.~2~ +++ /dev/null @@ -1,2946 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-May-2000 10:22:28" {DSK}medley3.5>lispusers>PLOT.;3 198079 changes to%: (VARS PLOTCOMS) previous date%: " 4-Nov-93 14:56:28" {DSK}medley3.5>lispusers>PLOT.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1993, 2000 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PLOTCOMS) (RPAQQ PLOTCOMS [ (* ;;; "PLOT manager fns") (FNS ADDPLOTOBJECT ADJUSTSCALE? ADJUSTVIEWPORT APPLY.AFTERFN.MACRO ASKFORLABEL ASKFORSCALE BOXREGION CHOOSESCALE CHOOSETICS CLOSEPLOTWINDOW CLOSESTPLOTOBJECT COMPOUNDSUBTYPE COMPUTEBOTTOMMARGIN COMPUTELEFTMARGIN COMPUTERIGHTMARGIN COMPUTETOPMARGIN COPYMENU CREATEPLOT CREATEPLOTFNS CREATEPLOTOBJECT DEFAULTSCALEFN DEFAULTTICFN DEFAULTTICMETHOD DELETEPLOTOBJECT DESELECTPLOTOBJECT DISTANCETOPLOTOBJECT DRAWBOTTOMMARGIN DRAWLEFTMARGIN DRAWMARGIN DRAWPLOTOBJECT DRAWPLOT DRAWRIGHTMARGIN DRAWTOPMARGIN ERASEPLOTOBJECT EXTENDEDSCALEFN EXTENTOFPLOTOBJECT EXTENTOFPLOT GETPLOTWINDOW GETTICLIST HIGHLIGHTPLOTOBJECT LABELPLOTOBJECT LOWLIGHTPLOTOBJECT MANUALRESCALE MINSTREAMREGIONSIZE MOVEPLOTOBJECT OPENPLOTWINDOW PLOT.BUTTONEVENTFN PLOT.CLOSEFN PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOT.HARDCOPYFN PLOT.ICONFN PLOT.LABELTOWORLD PLOT.REPAINTFN PLOT.RESET PLOT.SETUP PLOT.SKETCH.CREATE PLOT.WHENSELECTEDFN PLOT.WORLDTOLABEL PLOTADDMENUITEMS PLOTADDPROP PLOTAXISINTERVAL PLOTDELMENUITEMS PLOTDELPROP PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTOBJECTADDPROP PLOTOBJECTDELPROP PLOTOBJECTLABEL PLOTOBJECTPROP PLOTOBJECTPROPMACRO PLOTOBJECTSUBTYPE PLOTOPERROR PLOTPROMPT PLOTPROP PLOTPROPMACRO PLOTREMPROP PLOTSCALEFN PLOTTICFN PLOTTICINFO PLOTTICMETHOD PLOTTICS PRINTFONT PRINTMENU REDRAWPLOTWINDOW RELABELSELECTEDPLOTOBJECT RESCALEPLOT SCALE TOGGELLABEL TOGGLEEXTENDEDAXES TOGGLEFIXEDMENU TOGGLETICS TRANSLATEPLOTOBJECT UNDELETEPLOTOBJECT UNLABELPLOTOBJECT WHICHLABEL WHICHPLOT) (* ;; "Fns to do our own number printing") (FNS PLOT.PRINTNUM PLOT.FNUM-STRING PLOT.ENUM-STRING CREATETICLISTS NORMALIZE-TICLIST) (FNS DRAW-TICS-LEFT-RIGHT DRAW-TICS-TOP-BOTTOM DRAW-LABEL-LEFT-RIGHT DRAW-LABEL-TOP-BOTTOM) (VARS PLOT.DEFAULTMIDDLEMENUITEMS PLOT.DEFAULTRIGHTMENUITEMS OBJECTOPSTABLE) (RECORDS EXTENT MARGIN PLOT PLOTFNS PLOTOBJECT AXISINFO AXISINTERVAL PLOTSCALE TICINFO) (MACROS APPLY.AFTERFN PLOTOBJECTSUBTYPE? PLOTOBJECTPROP PLOTPROP) (PROP ARGNAMES PLOTOBJECTPROP PLOT.DEFAULTMENU PLOT.FIXRIGHTMENU PLOTLABEL PLOTMENU PLOTMENUITEMS PLOTPRETTYFNS PLOTPROP PLOTSCALEFN PLOTTICFN PLOTTICS) [INITVARS (SMALLPLOTFONT '(GACHA 8 MRR)) (LARGEPLOTFONT '(GACHA 12 BRR] (* ;;; "PLOT I/O") (FNS COPYPLOTOBJECT COPYPLOT PLOTOBJECTPRINT PRINTPLOTOBJECT PRINTPLOT READFONT READMENU READPLOTOBJECT READPLOT) (FNS PRINT-VECTOR READ-VECTOR) (FILEPKGCOMS PLOTS) (ADDVARS (HPRINTMACROS (FONTDESCRIPTOR . PRINTFONT) (MENU . PRINTMENU) (PLOT . PRINTPLOT) (PLOTOBJECT . PRINTPLOTOBJECT) (ONED-ARRAY . PRINT-VECTOR))) (ADDVARS (HPRINTREADFNS READPLOT READPLOTOBJECT READFONT READMENU READ-VECTOR)) (P (DEFPRINT 'PLOTOBJECT (FUNCTION PLOTOBJECTPRINT))) (* ;;; "Numeric fns") (FNS PLOT.EXP10 PLOT.LOG10 PLOT.FLOOR PLOT.CEILING SINEWAVE) (* ;;; "PLOT image object FNS") (FNS CREATEPLOTIMAGEOBJ CREATEPLOTBITMAPOBJ PLIO.BUTTONEVENTINFN PLIO.COPYFN PLIO.GETFN PLIO.PUTFN PLIO.REINSERTOBJ PLOT.COPYBUTTONEVENTFN PLIO.DISPLAYFN PLIO.IMAGEBOXFN) (* ;; "additional fns to allow plot im. objs. to work in Sketch") (FNS PLIO.EDITCLOSEFN IMAGE.OBJECT.CHANGED) [INITVARS (PLOTIMAGEFNS (IMAGEFNSCREATE (FUNCTION PLIO.DISPLAYFN) (FUNCTION PLIO.IMAGEBOXFN) (FUNCTION PLIO.PUTFN) (FUNCTION PLIO.GETFN) (FUNCTION PLIO.COPYFN) (FUNCTION PLIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL] (GLOBALVARS PLOTIMAGEFNS) (* ;;; "Initialize") (P (PLOT.SETUP OBJECTOPSTABLE) (PLOT.DEFAULTMENU 'MIDDLE PLOT.DEFAULTMIDDLEMENUITEMS) (PLOT.DEFAULTMENU 'RIGHT PLOT.DEFAULTRIGHTMENUITEMS)) (* ;;; "Dependent files") (FILES TWODGRAPHICS PLOTOBJECTS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) TWODGRAPHICS UNBOXEDOPS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PLOTTICS PLOTTICFN PLOTSCALEFN PLOTPROP PLOTOBJECTPROP PLOTMENUITEMS PLOTMENU PLOTLABEL PLOT.FIXRIGHTMENU PLOT.DEFAULTMENU]) (* ;;; "PLOT manager fns") (DEFINEQ (ADDPLOTOBJECT - [LAMBDA (OBJECT PLOT NODRAWFLG) (* ; "Edited 5-May-87 18:11 by jop") - - (PROG ((WHENADDEDFN (PLOTOBJECTPROP OBJECT 'WHENADDEDFN)) - REDRAWFLG NEWSCALES) - [COND - ((NOT (MEMB OBJECT (fetch PLOTOBJECTS of PLOT))) - (replace PLOTOBJECTS of PLOT with (CONS OBJECT (fetch PLOTOBJECTS of PLOT] - (COND - ((ADJUSTSCALE? (EXTENTOFPLOTOBJECT OBJECT PLOT) - PLOT) - (SETQ REDRAWFLG T))) - [COND - ((NULL NODRAWFLG) - (COND - ([OR REDRAWFLG (NOT (OPENWP (fetch PLOTWINDOW of PLOT] - (REDRAWPLOTWINDOW PLOT)) - (T (DRAWPLOTOBJECT OBJECT (fetch PLOTWINDOWVIEWPORT of PLOT) - PLOT] - (APPLY.AFTERFN WHENADDEDFN OBJECT PLOT NODRAWFLG) - (RETURN OBJECT]) (ADJUSTSCALE? - [LAMBDA (EXTENT PLOT) (* ; "Edited 5-May-87 18:12 by jop") - - (* ;; "Determines whether the plotting scale must be adjusted to included the extrema 'minx' , 'maxx' , etc. If so returns T. Side effects the PLOTSCALE of PLOT") - - (LET* ((PLOTSCALE (fetch (PLOT PLOTSCALE) of PLOT)) - (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) - (XAXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) - (XTICINFO (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) - (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) - (YAXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) - (YTICINFO (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) - (MINX (fetch MINX of EXTENT)) - (MAXX (fetch MAXX of EXTENT)) - (MINY (fetch MINY of EXTENT)) - (MAXY (fetch MAXY of EXTENT)) - CHANGEDFLG) - [COND - ((OR (LESSP MINX (fetch (AXISINTERVAL MIN) of XINTERVAL)) - (GREATERP MAXX (fetch (AXISINTERVAL MAX) of XINTERVAL))) - (SETQ CHANGEDFLG T) - (LET [(NEWMIN (FMIN MINX (fetch (AXISINTERVAL MIN) of XINTERVAL))) - (NEWMAX (FMAX MAXX (fetch (AXISINTERVAL MAX) of XINTERVAL] - (SETQ XTICINFO (CHOOSETICS NEWMIN NEWMAX XAXISINFO PLOT)) - (SETQ XINTERVAL (CHOOSESCALE NEWMIN NEWMAX XAXISINFO XTICINFO PLOT] - [COND - ((OR (LESSP MINY (fetch (AXISINTERVAL MIN) of YINTERVAL)) - (GREATERP MAXY (fetch (AXISINTERVAL MAX) of YINTERVAL))) - (SETQ CHANGEDFLG T) - (LET [(NEWMIN (FMIN MINY (fetch (AXISINTERVAL MIN) of YINTERVAL))) - (NEWMAX (FMAX MAXY (fetch (AXISINTERVAL MAX) of YINTERVAL] - (SETQ YTICINFO (CHOOSETICS NEWMIN NEWMAX YAXISINFO PLOT)) - (SETQ YINTERVAL (CHOOSESCALE NEWMIN NEWMAX YAXISINFO YTICINFO PLOT] - (COND - (CHANGEDFLG (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with XINTERVAL) - (replace (PLOTSCALE XTICINFO) of PLOTSCALE with XTICINFO) - (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with YINTERVAL) - (replace (PLOTSCALE YTICINFO) of PLOTSCALE with YTICINFO))) - CHANGEDFLG]) (ADJUSTVIEWPORT - [LAMBDA (VIEWPORT STREAMREGION PLOT) (* ; "Edited 5-May-87 18:12 by jop") - - (PROG ((PLOTSCALE (fetch PLOTSCALE of PLOT)) - (PARENTSTREAM (fetch PARENTSTREAM of VIEWPORT)) - BOTTOMMARGINSIZE LEFTMARGINSIZE RIGHTMARGINSIZE TOPMARGINSIZE) - (SETQ BOTTOMMARGINSIZE (COMPUTEBOTTOMMARGIN PARENTSTREAM (fetch BOTTOMMARGIN of PLOT) - PLOT)) - (SETQ LEFTMARGINSIZE (COMPUTELEFTMARGIN PARENTSTREAM (fetch LEFTMARGIN of PLOT) - PLOT)) - (SETQ RIGHTMARGINSIZE (COMPUTERIGHTMARGIN PARENTSTREAM (fetch RIGHTMARGIN of PLOT) - PLOT)) - (SETQ TOPMARGINSIZE (COMPUTETOPMARGIN PARENTSTREAM (fetch TOPMARGIN of PLOT) - PLOT)) - [replace WORLDREGION of VIEWPORT with (CREATEREGION (fetch MIN of (fetch XINTERVAL - of PLOTSCALE)) - (fetch MIN of (fetch YINTERVAL of PLOTSCALE)) - (fetch INTERVALLENGTH - of (fetch XINTERVAL of PLOTSCALE)) - (fetch INTERVALLENGTH - of (fetch YINTERVAL of PLOTSCALE] - [replace STREAMSUBREGION of VIEWPORT with (CREATEREGION (PLUS (fetch LEFT of STREAMREGION) - (CAR LEFTMARGINSIZE)) - (PLUS (fetch BOTTOM of STREAMREGION) - (CDR BOTTOMMARGINSIZE)) - (IDIFFERENCE (fetch WIDTH of STREAMREGION) - (IPLUS (CAR LEFTMARGINSIZE) - (CAR RIGHTMARGINSIZE))) - (IDIFFERENCE (fetch HEIGHT of STREAMREGION - ) - (IPLUS (CDR BOTTOMMARGINSIZE) - (CDR TOPMARGINSIZE] - (COMPUTETRANSFORM VIEWPORT) - (RETURN VIEWPORT]) (APPLY.AFTERFN.MACRO - [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:16 by jop") - - (PROG ((FNS (CAR ARGS)) - (ARGLST (CDR ARGS))) - (RETURN `(if ,FNS - then (if (AND (LISTP ,FNS) - (NEQ (CAR ,FNS) - 'LAMBDA)) - then (for FN in ,FNS do (CL:FUNCALL FN ,@ARGLST)) - else (CL:FUNCALL ,FNS ,@ARGLST]) (ASKFORLABEL - [LAMBDA (PLOT MARGINNAME) (* ; "Edited 5-May-87 18:16 by jop") - - (* ;; "Prompt for new label and make the required call to LABELPLOT") - - [COND - ((EQ MARGINNAME 'TITLE) - (SETQ MARGINNAME 'TOP] - (PROG ((PLOTPROMPT (fetch PLOTPROMPTWINDOW of PLOT)) - (MARGIN (SELECTQ MARGINNAME - (BOTTOM (fetch BOTTOMMARGIN of PLOT)) - (LEFT (fetch LEFTMARGIN of PLOT)) - (TOP (fetch TOPMARGIN of PLOT)) - (RIGHT (fetch RIGHTMARGIN of PLOT)) - (HELP "ILLEGAL MARGIN NAME" MARGINNAME))) - (PROMPT (SELECTQ MARGINNAME - (BOTTOM "BOTTOM MARGIN LABEL?") - (LEFT "LEFT MARGIN LABEL?") - (TOP "TITLE?") - (RIGHT "RIGHT MARGIN LABEL?") - (HELP "ILLEGAL MARGIN NAME" MARGINNAME))) - LABEL NEWLABEL) - (SETQ LABEL (fetch (MARGIN LABEL) of MARGIN)) - (TERPRI PLOTPROMPT) - [SETQ NEWLABEL (PROMPTFORWORD PROMPT LABEL "Type a label" PLOTPROMPT NIL NIL - (CHARCODE (EOL LF ESCAPE TAB] - (COND - ((AND (NEQ NEWLABEL LABEL) - (NOT (STREQUAL NEWLABEL LABEL))) - (PLOTLABEL PLOT MARGINNAME NEWLABEL]) (ASKFORSCALE - [LAMBDA (PLOT AXIS) (* ; "Edited 5-May-87 18:16 by jop") - - (PROG ((PLOTPROMPT (fetch PLOTPROMPTWINDOW of PLOT)) - (LOWER (PLOT.WORLDTOLABEL (SELECTQ AXIS - (X (fetch (PLOT XLOWER) of PLOT)) - (Y (fetch (PLOT YLOWER) of PLOT)) - (HELP "Illegal axis" AXIS)) - PLOT AXIS)) - (UPPER (PLOT.WORLDTOLABEL (SELECTQ AXIS - (X (fetch (PLOT XUPPER) of PLOT)) - (Y (fetch (PLOT YUPPER) of PLOT)) - (HELP "Illegal axis" AXIS)) - PLOT AXIS))) - (TERPRI PLOTPROMPT) - (SETQ LOWER (PLOT.LABELTOWORLD [READ (OPENSTRINGSTREAM (PROMPTFORWORD (CONCAT AXIS - " axis: From " - ) - LOWER "Type a number" - PLOTPROMPT NIL NIL - (CHARCODE (EOL LF ESCAPE TAB] - PLOT AXIS)) - (SETQ UPPER (PLOT.LABELTOWORLD [READ (OPENSTRINGSTREAM (PROMPTFORWORD " to " UPPER - "Type a number" PLOTPROMPT - NIL NIL - (CHARCODE (EOL LF ESCAPE TAB] - PLOT AXIS)) - (RETURN (CONS LOWER UPPER]) (BOXREGION - [LAMBDA (REGION STREAM) (* ; "Edited 5-May-87 18:16 by jop") - - (* ;; "Draw a box around a region in STREAM") - - (PROG ((RLEFT (fetch LEFT of REGION)) - (RBOTTOM (fetch BOTTOM of REGION)) - (RRIGHT (fetch RIGHT of REGION)) - (RTOP (fetch TOP of REGION)) - (LINEWIDTH (DSPSCALE NIL STREAM))) - (DRAWLINE RLEFT RBOTTOM RRIGHT RBOTTOM LINEWIDTH 'REPLACE STREAM) - (DRAWLINE RRIGHT RBOTTOM RRIGHT RTOP LINEWIDTH 'REPLACE STREAM) - (DRAWLINE RRIGHT RTOP RLEFT RTOP LINEWIDTH 'REPLACE STREAM) - (DRAWLINE RLEFT RTOP RLEFT RBOTTOM LINEWIDTH 'REPLACE STREAM]) (CHOOSESCALE - [LAMBDA (MIN MAX AXISINFO TICINFO PLOT) (* ; "Edited 5-May-87 18:25 by jop") - - (PROG ((SCALEFN (fetch (AXISINFO SCALEFN) of AXISINFO)) - NEWINTERVAL) - [SETQ NEWINTERVAL (COND - (SCALEFN (CL:FUNCALL SCALEFN MIN MAX TICINFO PLOT)) - (T (DEFAULTSCALEFN MIN MAX TICINFO] - (AND (NOT (type? AXISINTERVAL NEWINTERVAL)) - (HELP "Not an AXISINTERVAL" NEWINTERVAL)) - (RETURN NEWINTERVAL]) (CHOOSETICS - [LAMBDA (MIN MAX AXISINFO PLOT) (* ; "Edited 5-May-87 18:25 by jop") - - (PROG ((TICFN (fetch (AXISINFO TICFN) of AXISINFO)) - NEWTICINFO) - [SETQ NEWTICINFO (COND - (TICFN (CL:FUNCALL TICFN MIN MAX PLOT)) - (T (DEFAULTTICFN MIN MAX] - (AND (NOT (type? TICINFO NEWTICINFO)) - (HELP "Not a TICINFO" NEWTICINFO)) - (RETURN NEWTICINFO]) (CLOSEPLOTWINDOW - [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:17 by jop") - - (LET [(PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (WHENCLOSEDFN (PLOTPROP PLOT 'WHENCLOSEDFN] - - (* ;; "Unfix the right menu") - - (PLOT.FIXRIGHTMENU PLOT NIL) - - (* ;; "Cleanup Window Props") - - (COND - ((WINDOWP PLOTWINDOW) - (WINDOWPROP PLOTWINDOW 'PLOT NIL) - (WINDOWDELPROP PLOTWINDOW 'REPAINTFN (FUNCTION PLOT.REPAINTFN)) - (WINDOWDELPROP PLOTWINDOW 'RESHAPEFN (FUNCTION PLOT.REPAINTFN)) - (WINDOWDELPROP PLOTWINDOW 'CLOSEFN (FUNCTION PLOT.CLOSEFN)) - (WINDOWPROP PLOTWINDOW 'BUTTONEVENTFN (FUNCTION TOTOPW)) - (WINDOWPROP PLOTWINDOW 'RIGHTBUTTONFN NIL) - (WINDOWPROP PLOTWINDOW 'COPYBUTTONEVENTFN NIL) - (WINDOWPROP PLOTWINDOW 'HARDCOPYFN NIL) - (WINDOWPROP PLOTWINDOW 'ICONFN NIL) - (CLOSEW PLOTWINDOW) - (DETACHALLWINDOWS PLOTWINDOW))) - - (* ;; "A user hook") - - (APPLY.AFTERFN WHENCLOSEDFN PLOT]) (CLOSESTPLOTOBJECT - [LAMBDA (PLOT STREAMPOSITION) (* ; "Edited 5-May-87 18:17 by jop") - - (for OBJECT in (fetch PLOTOBJECTS of PLOT) smallest (DISTANCETOPLOTOBJECT OBJECT STREAMPOSITION - PLOT]) (COMPOUNDSUBTYPE - [LAMBDA (COMPOUNDOBJECT) (* ; "Edited 5-May-87 18:18 by jop") - - (fetch COMPOUNDTYPE of (fetch OBJECTDATA of COMPOUNDOBJECT]) (COMPUTEBOTTOMMARGIN - [LAMBDA (STREAM BOTTOMMARGIN PLOT) (* ; "Edited 5-May-87 18:18 by jop") - - (* ;; "Returns a size cons pair (width . height) in streamcoordinates") - - (DECLARE (SPECVARS SMALLFONT LARGEFONT)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (TICS? (fetch (MARGIN TICS?) of BOTTOMMARGIN)) - (LABEL (fetch (MARGIN LABEL) of BOTTOMMARGIN)) - (WIDTH 0) - SMALLASCENT LARGEHEIGHT HEIGHT) - (SETQ SMALLASCENT (FONTPROP SMALLFONT 'ASCENT)) - (SETQ LARGEHEIGHT (FONTPROP LARGEFONT 'HEIGHT)) (* ; - "margin of at least one LARGEHEIGHT") - - [SETQ HEIGHT (COND - ((OR TICS? LABEL) - LARGEHEIGHT) - (T (ITIMES 2 LARGEHEIGHT] - [COND - (TICS? (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 3 SMALLASCENT] - [COND - (LABEL (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 2 LARGEHEIGHT))) - (SETQ WIDTH (STRINGWIDTH LABEL LARGEFONT] - (RETURN (CONS WIDTH HEIGHT]) (COMPUTELEFTMARGIN - [LAMBDA (STREAM LEFTMARGIN PLOT) (* ; "Edited 13-May-87 13:36 by jop") - - (* ;; "Returns a (width . height) pair") - - (DECLARE (SPECVARS PRXFLG SMALLPLOTFONT LARGEPLOTFONT)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (TICS? (fetch (MARGIN TICS?) of LEFTMARGIN)) - (TICLIST (fetch (MARGIN TICLIST) of LEFTMARGIN)) - (LABEL (fetch (MARGIN LABEL) of LEFTMARGIN)) - (HEIGHT 0) - LARGEWIDTH SMALLWIDTH WIDTH) - (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) - (SETQ LARGEWIDTH (STRINGWIDTH 'A LARGEFONT)) - [SETQ WIDTH (COND - ((OR TICS? LABEL) - LARGEWIDTH) - (T (ITIMES 2 LARGEWIDTH] - [COND - (TICS? (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 SMALLWIDTH) - (bind TICWIDTH for TICPAIR in TICLIST - largest (STRINGWIDTH (CDR TICPAIR) - SMALLFONT) finally (RETURN $$EXTREME] - [COND - (LABEL (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 LARGEWIDTH))) - (SETQ HEIGHT (ITIMES (NCHARS LABEL) - (FONTPROP LARGEFONT 'HEIGHT] - (RETURN (CONS WIDTH HEIGHT]) (COMPUTERIGHTMARGIN - [LAMBDA (STREAM RIGHTMARGIN PLOT) (* ; "Edited 13-May-87 13:37 by jop") - - (* ;; "Returns a (width . height) pair") - - (DECLARE (SPECVARS PRXFLG SMALLFONT LARGEFONT)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (TICS? (fetch (MARGIN TICS?) of RIGHTMARGIN)) - (TICLIST (fetch (MARGIN TICLIST) of RIGHTMARGIN)) - (LABEL (fetch (MARGIN LABEL) of RIGHTMARGIN)) - (HEIGHT 0) - SMALLWIDTH LARGEWIDTH WIDTH) - (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) - (SETQ LARGEWIDTH (STRINGWIDTH 'A LARGEFONT)) - [SETQ WIDTH (COND - ((OR TICS? LABEL) - LARGEWIDTH) - (T (ITIMES 2 LARGEWIDTH] - [COND - (TICS? (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 SMALLWIDTH) - (for TICPAIR in TICLIST largest (STRINGWIDTH (CDR TICPAIR) - SMALLFONT) - finally (RETURN $$EXTREME] - [COND - (LABEL (SETQ WIDTH (IPLUS WIDTH (ITIMES 2 LARGEWIDTH))) - (SETQ HEIGHT (ITIMES (NCHARS LABEL) - (FONTPROP LARGEFONT 'HEIGHT] - (RETURN (CONS WIDTH HEIGHT]) (COMPUTETOPMARGIN - [LAMBDA (STREAM TOPMARGIN PLOT) (* ; "Edited 5-May-87 18:19 by jop") - - (DECLARE (SPECVARS SMALLFONT LARGEFONT)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (TICS? (fetch (MARGIN TICS?) of TOPMARGIN)) - (LABEL (fetch (MARGIN LABEL) of TOPMARGIN)) - (WIDTH 0) - SMALLASCENT LARGEHEIGHT HEIGHT) - (SETQ SMALLASCENT (FONTPROP SMALLFONT 'ASCENT)) - (SETQ LARGEHEIGHT (FONTPROP LARGEFONT 'HEIGHT)) (* ; - "margin of at least one LARGEHEIGHT") - - [SETQ HEIGHT (COND - ((OR TICS? LABEL) - LARGEHEIGHT) - (T (ITIMES 2 LARGEHEIGHT] - [COND - (TICS? (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 3 SMALLASCENT] - [COND - (LABEL (SETQ HEIGHT (IPLUS HEIGHT (ITIMES 2 LARGEHEIGHT))) - (SETQ WIDTH (IMAX WIDTH (STRINGWIDTH LABEL LARGEFONT] - (RETURN (CONS WIDTH HEIGHT]) (COPYMENU - [LAMBDA (MENU NEWITEMS) (* ; "Edited 5-May-87 18:19 by jop") - - (* ;; "Note that menu props are not copied") - - (create MENU - ITEMS _ (OR NEWITEMS (fetch ITEMS of MENU)) - WHENSELECTEDFN _ (fetch WHENSELECTEDFN of MENU) - WHENHELDFN _ (fetch WHENHELDFN of MENU) - WHENUNHELDFN _ (fetch WHENUNHELDFN of MENU) - MENUPOSITION _ (fetch MENUPOSITION of MENU) - MENUOFFSET _ (fetch MENUOFFSET of MENU) - MENUFONT _ (fetch MENUFONT of MENU) - MENUTITLEFONT _ (fetch MENUTITLEFONT of MENU) - TITLE _ (fetch TITLE of MENU) - CENTERFLG _ (fetch CENTERFLG of MENU) - MENUBORDERSIZE _ (fetch MENUBORDERSIZE of MENU) - MENUOUTLINESIZE _ (fetch MENUOUTLINESIZE of MENU) - CHANGEOFFSETFLG _ (fetch CHANGEOFFSETFLG of MENU]) (CREATEPLOT - [LAMBDA (OPENFLG REGION TITLE BORDER) (* ; "Edited 5-May-87 18:19 by jop") - - (* ;; "Creates a PLOT. If OPENFLG is T then the PLOT's asssociated window is opened. The other arguments are passed to CREATEW") - - (PROG ((PLOT (create PLOT))) - (replace (PLOT PLOTSCALE) of PLOT - with (create PLOTSCALE - XAXISINFO _ (create AXISINFO) - XINTERVAL _ (create AXISINTERVAL - MIN _ 0.0 - MAX _ 1.0) - XTICINFO _ - (create TICINFO - TICMIN _ 0.0 - TICMAX _ 1.0 - TICINC _ 1.0 - NTICS _ 2) - YAXISINFO _ (create AXISINFO) - YINTERVAL _ (create AXISINTERVAL - MIN _ 0.0 - MAX _ 1.0) - YTICINFO _ - (create TICINFO - TICMIN _ 0.0 - TICMAX _ 1.0 - TICINC _ 1.0 - NTICS _ 2))) - (PLOTMENU PLOT 'MIDDLE (PLOT.DEFAULTMENU 'MIDDLE)) - (PLOTMENU PLOT 'RIGHT (PLOT.DEFAULTMENU 'RIGHT)) (* ; - "Compute size of margins in stream coordinates") - - (replace (PLOT BOTTOMMARGIN) of PLOT with (create MARGIN - TICMETHOD _ 'DEFAULT)) - (replace (PLOT LEFTMARGIN) of PLOT with (create MARGIN - TICMETHOD _ 'DEFAULT)) - (replace (PLOT TOPMARGIN) of PLOT with (create MARGIN - TICMETHOD _ 'DEFAULT)) - (replace (PLOT RIGHTMARGIN) of PLOT with (create MARGIN - TICMETHOD _ 'DEFAULT)) - (* ; - "Cache display parameters until OPENPLOTWINDOW is called") - - [COND - ((OR REGION TITLE BORDER) - (replace (PLOT PLOTWINDOW) of PLOT with (LIST REGION TITLE BORDER] - (COND - (OPENFLG (OPENPLOTWINDOW PLOT))) - (RETURN PLOT]) (CREATEPLOTFNS - [LAMBDA (DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN COPYFN PUTFN - GETFN BORROWFROM) (* ; "Edited 5-May-87 18:20 by jop") - - (* ;; "Create an instance of PLOTFNS, a vector of functions that implement generic plot object operations. A DRAWFN , ERASEFN , and a EXTENTFN are required. If there is a DISTANCEFN then a HIGHLIGHTFN must also be supplied. Supplies defaults for some generic operations. If BORROWFROM then it must be another PLOTFNS, in which case NIL functions are inherited from USING.") - - (DECLARE (SPECVARS DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN - COPYFN PUTFN GETFN)) - [COND - (BORROWFROM [COND - ((AND (NULL LOWLIGHTFN) - (NULL HIGHLIGHTFN)) - (SETQ LOWLIGHTFN (fetch LOWLIGHTFN of BORROWFROM] - (for FN in '(DRAWFN ERASEFN EXTENTFN HIGHLIGHTFN LABELFN DISTANCEFN MOVEFN COPYFN PUTFN - GETFN) do (COND - ((NULL (EVAL FN)) - (SET FN (RECORDACCESS FN BORROWFROM] - (COND - ((NOT (AND DRAWFN ERASEFN EXTENTFN)) - (HELP "Attempt to create PLOTFNS without required FNS"))) - (COND - ((AND DISTANCEFN (NOT HIGHLIGHTFN)) - (HELP "DISTANCEFN without a HIGHLIGHTFN"))) - (create PLOTFNS - DRAWFN _ DRAWFN - ERASEFN _ ERASEFN - HIGHLIGHTFN _ (OR HIGHLIGHTFN (FUNCTION PLOTOPERROR)) - LOWLIGHTFN _ (OR LOWLIGHTFN HIGHLIGHTFN (FUNCTION PLOTOPERROR)) - MOVEFN _ (OR MOVEFN (FUNCTION PLOTOPERROR)) - LABELFN _ (OR LABELFN (FUNCTION LABELGENERIC)) - EXTENTFN _ EXTENTFN - DISTANCEFN _ [OR DISTANCEFN (FUNCTION (LAMBDA NIL MAX.SMALLP] - COPYFN _ (OR COPYFN (FUNCTION COPYGENERIC)) - PUTFN _ (OR PUTFN (FUNCTION PUTGENERIC)) - GETFN _ (OR GETFN (FUNCTION GETGENERIC]) (CREATEPLOTOBJECT - [LAMBDA (OBJECTFNS OBJECTSUBTYPE OBJECTLABEL OBJECTMENU OBJECTDATA) - (* ; "Edited 5-May-87 18:20 by jop") - - (COND - ((NOT (AND OBJECTFNS OBJECTDATA)) - (HELP "Attempt to create a PLOTOBJECT without a FNS vector or OBJECTDATA"))) - (PROG ((PLOTOBJECT (create PLOTOBJECT - OBJECTFNS _ OBJECTFNS - OBJECTSUBTYPE _ OBJECTSUBTYPE - OBJECTLABEL _ OBJECTLABEL - OBJECTDATA _ OBJECTDATA))) (* ; - "PLOTOBJECTPROP coerces OBJECTMENU to a menu if it is an item list") - - (PLOTOBJECTPROP PLOTOBJECT 'OBJECTMENU OBJECTMENU) - (RETURN PLOTOBJECT]) (DEFAULTSCALEFN - [LAMBDA (MIN MAX TICINFO) (* ; "Edited 5-May-87 18:20 by jop") - - (create AXISINTERVAL - MIN _ (fetch (TICINFO TICMIN) of TICINFO) - MAX _ (fetch (TICINFO TICMAX) of TICINFO]) (DEFAULTTICFN - [LAMBDA (MIN MAX TICS ROUND POWER) (* ; "Edited 5-May-87 18:20 by jop") - - (* ;; "Computes an interval that includes (MIN,MAX) and can be exactly spanned by (NTICS-1) *some increment. If TICS is NIL tries a few values and chooses the one that yields the shortest interval.") - - (COND - [(NULL TICS) - (SETQ TICS '(3 4 5 6 7 8] - ((FIXP TICS) - (SETQ TICS (LIST TICS))) - ((NLISTP TICS) - (HELP "Not a list of FIXP's" TICS))) - (bind (SHORTEST _ (SCALE MIN MAX (CAR TICS) - ROUND POWER)) - CURRENT for NTICS in (CDR TICS) do (SETQ CURRENT (SCALE MIN MAX NTICS ROUND POWER)) - (COND - ((LESSP (fetch TICINTERVALLENGTH of CURRENT) - (fetch TICINTERVALLENGTH of SHORTEST)) - (SETQ SHORTEST CURRENT))) finally (RETURN SHORTEST]) (DEFAULTTICMETHOD - [LAMBDA (MARGIN PLOTSCALE PLOT) (* ; "Edited 5-May-87 18:21 by jop") - - (* ;; "Return the default tic list based on the values of PLOTSCALE") - - (PROG ((TICINFO (SELECTQ MARGIN - ((BOTTOM TOP) - (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) - ((RIGHT LEFT) - (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) - (HELP "MARGIN must be one of RIGHT, LEFT, TOP, BOTTOM" MARGIN))) - TICINC) - (SETQ TICINC (fetch (TICINFO TICINC) of TICINFO)) - (RETURN (COND - ((LISTP TICINC) - TICINC) - ((NUMBERP TICINC) (* ; - "Be carefull that min and max tics correspond to min and max of interval") - - (NCONC1 (for I from 1 to (SUB1 (fetch (TICINFO NTICS) of TICINFO)) as X - from (fetch (TICINFO TICMIN) of TICINFO) by TICINC collect X) - (fetch (TICINFO TICMAX) of TICINFO))) - (T (HELP "Invalid TICINC" TICINC]) (DELETEPLOTOBJECT - [LAMBDA (OBJECT PLOT NODRAWFLG NOSAVEFLG) (* ; "Edited 5-May-87 18:21 by jop") - - (* ;; "Delete object from display list of plot. If (NULL NODRAWFLG) then update the display (open it if necessary) if (NULL NOSAVEFLG) then intern the object on the save list.") - - (LET [(PLOTOBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT)) - (PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (WHENDELETEDFN (PLOTOBJECTPROP OBJECT 'WHENDELETEDFN] - (if (MEMB OBJECT PLOTOBJECTS) - then (if (EQ OBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) - then (if (NULL NODRAWFLG) - then (if (OPENWP PLOTWINDOW) - then (LOWLIGHTPLOTOBJECT OBJECT PLOT))) - (replace (PLOT SELECTEDOBJECT) of PLOT with NIL)) - (replace (PLOT PLOTOBJECTS) of PLOT with (DREMOVE OBJECT PLOTOBJECTS)) - (if (NULL NOSAVEFLG) - then (push (fetch (PLOT PLOTSAVELIST) of PLOT) - OBJECT)) - (if (NULL NODRAWFLG) - then (if (NOT (OPENWP PLOTWINDOW)) - then (OPENPLOTWINDOW PLOT) - else (ERASEPLOTOBJECT OBJECT PLOT))) - (APPLY.AFTERFN WHENDELETEDFN OBJECT PLOT NODRAWFLG NOSAVEFLG) - OBJECT]) (DESELECTPLOTOBJECT - [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:21 by jop") - - (if (fetch (PLOT SELECTEDOBJECT) of PLOT) - then (LOWLIGHTPLOTOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT) - PLOT) - (replace (PLOT SELECTEDOBJECT) of PLOT with NIL]) (DISTANCETOPLOTOBJECT - [LAMBDA (OBJECT STREAMPOSITION PLOT) (* ; "Edited 5-May-87 18:25 by jop") - - (CL:FUNCALL (fetch (PLOTFNS DISTANCEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT STREAMPOSITION PLOT]) (DRAWBOTTOMMARGIN - [LAMBDA (BOTTOMMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 13-May-87 17:11 by jop") - - (* ;; "DRAW the BOTTOM MARGIN") - - (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (LABEL (fetch (MARGIN LABEL) of BOTTOMMARGIN)) - (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of (fetch PLOTSCALE of PLOT))) - SMALLPLOTFONTASCENT BOTTOM) - (SETQ SMALLPLOTFONTASCENT (FONTPROP SMALLFONT 'ASCENT)) - (SETQ BOTTOM (fetch (REGION BOTTOM) of (fetch STREAMSUBREGION of VIEWPORT))) - (if (fetch (MARGIN TICS?) of BOTTOMMARGIN) - then - - (* ;; "DRAW TICS and TIC labels if necessary") - - (DRAW-TICS-TOP-BOTTOM (fetch (MARGIN TICLIST) of BOTTOMMARGIN) - (fetch MIN of XINTERVAL) - (fetch MAX of XINTERVAL) - (IPLUS SMALLPLOTFONTASCENT BOTTOM) - (IDIFFERENCE BOTTOM SMALLPLOTFONTASCENT) - (ITIMES 2 SMALLPLOTFONTASCENT) - SMALLFONT STREAM VIEWPORT T)) - (if LABEL - then (DRAW-LABEL-TOP-BOTTOM LABEL LARGEFONT [PLUS (fetch (REGION BOTTOM) of - STREAMREGION - ) - (IPLUS (FONTPROP STREAM 'DESCENT) - (FONTPROP LARGEFONT - 'HEIGHT] - STREAMREGION STREAM]) (DRAWLEFTMARGIN - [LAMBDA (LEFTMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 13-May-87 17:10 by jop") - - (* ;; "DRAW the BOTTOM MARGIN") - - (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (LABEL (fetch (MARGIN LABEL) of LEFTMARGIN)) - (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of (fetch PLOTSCALE of PLOT))) - SMALLWIDTH LEFT) - (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) - (SETQ LEFT (fetch LEFT of (fetch STREAMSUBREGION of VIEWPORT))) - (if (fetch (MARGIN TICS?) of LEFTMARGIN) - then - - (* ;; "DRAW TICS and TIC labels if necessary") - - (DRAW-TICS-LEFT-RIGHT (fetch (MARGIN TICLIST) of LEFTMARGIN) - (fetch MIN of YINTERVAL) - (fetch MAX of YINTERVAL) - (IPLUS SMALLWIDTH LEFT) - (IDIFFERENCE LEFT SMALLWIDTH) - SMALLWIDTH SMALLFONT STREAM VIEWPORT T)) - (if LABEL - then (DRAW-LABEL-LEFT-RIGHT LABEL LARGEFONT (PLUS (fetch (REGION LEFT) of STREAMREGION) - (STRINGWIDTH 'A LARGEFONT)) - STREAMREGION STREAM]) (DRAWMARGIN - [LAMBDA (MARGIN STREAM STREAMVIEWPORT STREAMREGION PLOT) (* ; "Edited 5-May-87 18:23 by jop") - - (* ;; "Draws the margin MARGIN (one of RIGHT LEFT BOTTOM or TOP)") - - (SELECTQ MARGIN - (RIGHT (DRAWRIGHTMARGIN (fetch RIGHTMARGIN of PLOT) - STREAM STREAMVIEWPORT STREAMREGION PLOT)) - (LEFT (DRAWLEFTMARGIN (fetch LEFTMARGIN of PLOT) - STREAM STREAMVIEWPORT STREAMREGION PLOT)) - (BOTTOM (DRAWBOTTOMMARGIN (fetch BOTTOMMARGIN of PLOT) - STREAM STREAMVIEWPORT STREAMREGION PLOT)) - (TOP (DRAWTOPMARGIN (fetch TOPMARGIN of PLOT) - STREAM STREAMVIEWPORT STREAMREGION PLOT)) - (HELP "MARGIN must be one of RIGHT, LEFT, BOTTOM, or TOP " MARGIN]) (DRAWPLOTOBJECT - [LAMBDA (OBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 18:23 by jop") - - (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - (WHENDRAWNFN (PLOTOBJECTPROP OBJECT 'WHENDRAWNFN] - (CL:FUNCALL (fetch (PLOTFNS DRAWFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT VIEWPORT PLOT) - (COND - (TEXTOBJECT (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT))) - (APPLY.AFTERFN WHENDRAWNFN OBJECT VIEWPORT PLOT]) (DRAWPLOT - [LAMBDA (PLOT CURRENTSTREAM STREAMVIEWPORT STREAMREGION) (* ; "Edited 6-May-87 18:28 by jop") - - (* ;; "Draws a plot on CURRENTSTREAM. STREAMREGION is the region the PLOT will occupy. Does not blank the STREAMREGION before drawing") - - (COND - ((NOT (type? PLOT PLOT)) - (HELP "Not a PLOT " PLOT))) (* ; - "Will not check, for the moment, that the streamregion is large enough") - - (BOXREGION (fetch STREAMSUBREGION of STREAMVIEWPORT) - CURRENTSTREAM) - (for MARGIN in '(BOTTOM LEFT TOP RIGHT) do (DRAWMARGIN MARGIN CURRENTSTREAM STREAMVIEWPORT - STREAMREGION PLOT)) - (for OBJECT in (fetch PLOTOBJECTS of PLOT) do (DRAWPLOTOBJECT OBJECT STREAMVIEWPORT PLOT]) (DRAWRIGHTMARGIN - [LAMBDA (RIGHTMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 13-May-87 17:10 by jop") - - (* ;; "DRAW the RIGHT MARGIN") - - (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (LABEL (fetch (MARGIN LABEL) of RIGHTMARGIN)) - (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of (fetch PLOTSCALE of PLOT))) - SMALLWIDTH RIGHT) - (SETQ SMALLWIDTH (STRINGWIDTH 'A SMALLFONT)) - (SETQ RIGHT (fetch (REGION RIGHT) of (fetch STREAMSUBREGION of VIEWPORT))) - (if (fetch (MARGIN TICS?) of RIGHTMARGIN) - then - - (* ;; "DRAW TICS and TIC labels if necessary") - - (DRAW-TICS-LEFT-RIGHT (fetch (MARGIN TICLIST) of RIGHTMARGIN) - (fetch MIN of YINTERVAL) - (fetch MAX of YINTERVAL) - (IPLUS SMALLWIDTH RIGHT) - (IDIFFERENCE RIGHT SMALLWIDTH) - SMALLWIDTH SMALLFONT STREAM VIEWPORT)) - (if LABEL - then (DRAW-LABEL-LEFT-RIGHT LABEL LARGEFONT (DIFFERENCE (fetch RIGHT of STREAMREGION) - (ITIMES 2 (STRINGWIDTH 'A LARGEFONT) - )) - STREAMREGION STREAM]) (DRAWTOPMARGIN - [LAMBDA (TOPMARGIN STREAM VIEWPORT STREAMREGION PLOT) (* ; "Edited 13-May-87 17:11 by jop") - - (* ;; "DRAW the Top MARGIN") - - (DECLARE (SPECVARS SMALLFONT LARGEFONT PRXFLG)) - (PROG ((SMALLFONT (FONTCREATE SMALLPLOTFONT NIL NIL NIL STREAM)) - (LARGEFONT (FONTCREATE LARGEPLOTFONT NIL NIL NIL STREAM)) - (LABEL (fetch (MARGIN LABEL) of TOPMARGIN)) - (XINTERVAL (fetch (PLOTSCALE XINTERVAL) of (fetch PLOTSCALE of PLOT))) - SMALLFONTASCENT TOP) - (SETQ SMALLFONTASCENT (FONTPROP SMALLFONT 'ASCENT)) - (SETQ TOP (fetch TOP of (fetch STREAMSUBREGION of VIEWPORT))) - (if (fetch (MARGIN TICS?) of TOPMARGIN) - then - - (* ;; "DRAW TICS and TIC labels if necessary") - - (DRAW-TICS-TOP-BOTTOM (fetch (MARGIN TICLIST) of TOPMARGIN) - (fetch MIN of XINTERVAL) - (fetch MAX of XINTERVAL) - (IPLUS SMALLFONTASCENT TOP) - (IDIFFERENCE TOP SMALLFONTASCENT) - SMALLFONTASCENT SMALLFONT STREAM VIEWPORT)) - (if LABEL - then (DRAW-LABEL-TOP-BOTTOM LABEL LARGEFONT [IDIFFERENCE (fetch TOP of STREAMREGION) - (IPLUS (FONTPROP LARGEFONT - 'HEIGHT) - (FONTPROP STREAM 'ASCENT] - STREAMREGION STREAM]) (ERASEPLOTOBJECT - [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:24 by jop") - - (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - (WHENERASEDFN (PLOTOBJECTPROP OBJECT 'WHENERASEDFN] - (CL:FUNCALL (fetch (PLOTFNS ERASEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT - (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) - PLOT) - (COND - (TEXTOBJECT (ERASEPLOTOBJECT TEXTOBJECT PLOT))) - (APPLY.AFTERFN WHENERASEDFN OBJECT PLOT]) (EXTENDEDSCALEFN - [LAMBDA (MIN MAX TICINFO) (* ; "Edited 5-May-87 18:28 by jop") - - (PROG ((NEWMIN (fetch (TICINFO TICMIN) of TICINFO)) - (NEWMAX (fetch (TICINFO TICMAX) of TICINFO)) - (EPISILON 0.05) - DELTA) - (SETQ DELTA (FTIMES EPISILON (FDIFFERENCE NEWMAX NEWMIN))) - (RETURN (create AXISINTERVAL - MIN _ (FDIFFERENCE NEWMIN DELTA) - MAX _ (FPLUS NEWMAX DELTA]) (EXTENTOFPLOTOBJECT - [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:28 by jop") - - (CL:FUNCALL (fetch (PLOTFNS EXTENTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT PLOT]) (EXTENTOFPLOT - [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:28 by jop") - - (bind EXTENT (MINX _ MAX.FLOAT) - (MAXX _ MIN.FLOAT) - (MINY _ MAX.FLOAT) - (MAXY _ MIN.FLOAT) for OBJECT in (fetch PLOTOBJECTS of PLOT) - do (SETQ EXTENT (EXTENTOFPLOTOBJECT OBJECT)) - [COND - ((LESSP (fetch MINX of EXTENT) - MINX) - (SETQ MINX (fetch MINX of EXTENT] - [COND - ((GREATERP (fetch MAXX of EXTENT) - MAXX) - (SETQ MAXX (fetch MAXX of EXTENT] - [COND - ((LESSP (fetch MINY of EXTENT) - MINY) - (SETQ MINY (fetch MINY of EXTENT] - [COND - ((GREATERP (fetch MAXY of EXTENT) - MAXY) - (SETQ MAXY (fetch MAXY of EXTENT] - finally (RETURN (create EXTENT - MINX _ MINX - MAXX _ MAXX - MINY _ MINY - MAXY _ MAXY]) (GETPLOTWINDOW - [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:29 by jop") - - (WINDOWP (fetch (PLOT PLOTWINDOW) of PLOT]) (GETTICLIST - [LAMBDA (MARGINNAME PLOT) (* ; "Edited 7-May-87 18:07 by jop") - - (LET* ((MARGIN (SELECTQ MARGINNAME - (BOTTOM (fetch BOTTOMMARGIN of PLOT)) - (LEFT (fetch LEFTMARGIN of PLOT)) - (TOP (fetch TOPMARGIN of PLOT)) - (RIGHT (fetch RIGHTMARGIN of PLOT)) - (SHOULDNT))) - (TICMETHOD (fetch TICMETHOD of MARGIN))) - (COND - ((EQ TICMETHOD 'DEFAULT) - (DEFAULTTICMETHOD MARGINNAME (fetch PLOTSCALE of PLOT) - PLOT)) - ((LITATOM TICMETHOD) - (CL:FUNCALL TICMETHOD MARGINNAME (fetch PLOTSCALE of PLOT) - PLOT)) - ((LISTP TICMETHOD) - TICMETHOD) - (T (HELP "Illegal ticmethod" TICMETHOD]) (HIGHLIGHTPLOTOBJECT - [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") - - (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - (WHENHIGHLIGHTEDFN (PLOTOBJECTPROP OBJECT 'WHENHIGHLIGHTEDFN] - (CL:FUNCALL (fetch (PLOTFNS HIGHLIGHTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT - (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) - PLOT) - (COND - (TEXTOBJECT (HIGHLIGHTPLOTOBJECT TEXTOBJECT PLOT))) - (APPLY.AFTERFN WHENHIGHLIGHTEDFN OBJECT PLOT]) (LABELPLOTOBJECT - [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") - - (PROG [(WHENLABELEDFN (PLOTOBJECTPROP OBJECT 'WHENLABELEDFN] - (CL:FUNCALL (fetch (PLOTFNS LABELFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT PLOT) - (APPLY.AFTERFN WHENLABELEDFN OBJECT PLOT]) (LOWLIGHTPLOTOBJECT - [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 18:30 by jop") - - (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - (WHENLOWLIGHTEDFN (PLOTOBJECTPROP OBJECT 'WHENLOWLIGHTEDFN] - (CL:FUNCALL (fetch (PLOTFNS LOWLIGHTFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT - (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) - PLOT) - (COND - (TEXTOBJECT (LOWLIGHTPLOTOBJECT TEXTOBJECT PLOT))) - (APPLY.AFTERFN WHENLOWLIGHTEDFN OBJECT PLOT]) (MANUALRESCALE - [LAMBDA (PLOT AXIS) (* ; "Edited 5-May-87 18:30 by jop") - - [COND - ((NULL AXIS) - (SETQ AXIS 'BOTH] - (PROG ((PLOTSCALE (fetch PLOTSCALE of PLOT)) - (PLOTOBJECTS (fetch PLOTOBJECTS of PLOT)) - NEWSCALE) - [COND - ((OR (EQ AXIS 'BOTH) - (EQ AXIS 'X)) - (SETQ NEWSCALE (ASKFORSCALE PLOT 'X)) - (COND - ((GREATERP (CDR NEWSCALE) - (CAR NEWSCALE)) - (LET ((NEWMIN (CAR NEWSCALE)) - (NEWMAX (CDR NEWSCALE)) - (AXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE))) - (replace (PLOTSCALE XTICINFO) of PLOTSCALE with (CHOOSETICS NEWMIN NEWMAX - AXISINFO PLOT)) - (replace (PLOTSCALE XINTERVAL) of PLOTSCALE - with (create AXISINTERVAL - MIN _ NEWMIN - MAX _ NEWMAX] - [COND - ((OR (EQ AXIS 'BOTH) - (EQ AXIS 'Y)) - (SETQ NEWSCALE (ASKFORSCALE PLOT 'Y)) - (COND - ((GREATERP (CDR NEWSCALE) - (CAR NEWSCALE)) - (LET ((NEWMIN (CAR NEWSCALE)) - (NEWMAX (CDR NEWSCALE)) - (AXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE))) - (replace (PLOTSCALE YTICINFO) of PLOTSCALE with (CHOOSETICS NEWMIN NEWMAX - AXISINFO PLOT)) - (replace (PLOTSCALE YINTERVAL) of PLOTSCALE - with (create AXISINTERVAL - MIN _ NEWMIN - MAX _ NEWMAX] - (REDRAWPLOTWINDOW PLOT]) (MINSTREAMREGIONSIZE - [LAMBDA (STREAM PLOT) (* ; "Edited 5-May-87 18:30 by jop") - - (* ;; "Compute the minimun acceptable size for a plot STREAMREGION. In the case of PLOTWINDOWS, corresponds to the min exceptable interior size of the WINDOW. Returns a dotted pair (MINX . MINY)") - (* ; "Sizes are (width . height) pairs") - - (PROG ((BOTTOMMARGINSIZE (COMPUTEBOTTOMMARGIN STREAM (fetch BOTTOMMARGIN of PLOT) - PLOT)) - (LEFTMARGINSIZE (COMPUTELEFTMARGIN STREAM (fetch LEFTMARGIN of PLOT) - PLOT)) - (RIGHTMARGINSIZE (COMPUTERIGHTMARGIN STREAM (fetch RIGHTMARGIN of PLOT) - PLOT)) - (TOPMARGINSIZE (COMPUTETOPMARGIN STREAM (fetch TOPMARGIN of PLOT) - PLOT)) - MINX MINY) (* ; "The constant 100 is heuristic") - - (SETQ MINX (IPLUS (CAR LEFTMARGINSIZE) - (IMAX (CAR BOTTOMMARGINSIZE) - (CAR TOPMARGINSIZE) - 100) - (CAR RIGHTMARGINSIZE))) - (SETQ MINY (IPLUS (CDR BOTTOMMARGINSIZE) - (IMAX (CDR LEFTMARGINSIZE) - (CDR RIGHTMARGINSIZE) - 100) - (CDR TOPMARGINSIZE))) - (RETURN (CONS MINX MINY]) (MOVEPLOTOBJECT - [LAMBDA (OBJECT DX DY PLOT) (* ; "Edited 5-May-87 18:30 by jop") - - (CL:FUNCALL (fetch (PLOTFNS MOVEFN) of (fetch (PLOTOBJECT OBJECTFNS) of OBJECT)) - OBJECT DX DY PLOT]) (OPENPLOTWINDOW - [LAMBDA (PLOT) (* ; "Edited 19-May-87 10:17 by jop") - - (* ;; - "Open window associated with PLOT. Creates circularities later broken by PLOT.CLOSEFN") - - (COND - ((NOT (type? PLOT PLOT)) - (HELP "Not a plot" PLOT))) - (PROG ((WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) - (WHENOPENEDFN (PLOTPROP PLOT 'WHENOPENEDFN)) - MINSIZE WINDOWRESHAPEFLG PROMPTCREATEDFLG MINWINDOWEXTENT) - (COND - ((OPENWP WINDOW) (* ; "No need to continue") - - (RETURN WINDOW))) - [COND - ((NOT (WINDOWP WINDOW)) - (LET (REGION TITLE BORDER) - [COND - ((LISTP WINDOW) - (SETQ REGION (CAR WINDOW)) - (SETQ TITLE (CADR WINDOW)) - (SETQ BORDER (CADDR WINDOW] - (SETQ WINDOW (CREATEW (OR REGION (CREATEREGION 0 0 100 100)) - (OR TITLE "Plot Window") - BORDER T)) - (replace (PLOT PLOTWINDOW) of PLOT with WINDOW) - (SETQ WINDOWRESHAPEFLG (NOT REGION] - - (* ;; "setup plot window props") - - (WINDOWPROP WINDOW 'PLOT PLOT) - (WINDOWADDPROP WINDOW 'REPAINTFN (FUNCTION PLOT.REPAINTFN)) - (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION PLOT.REPAINTFN)) - (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION PLOT.CLOSEFN)) - (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION PLOT.BUTTONEVENTFN)) - (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION PLOT.BUTTONEVENTFN)) - (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (FUNCTION PLOT.COPYBUTTONEVENTFN)) - (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION PLOT.HARDCOPYFN)) - (WINDOWPROP WINDOW 'ICONFN (FUNCTION PLOT.ICONFN)) (* ; - "Rest of VIEWPORT initializations in REDRAWPLOTWINDOW") - - [replace (PLOT PLOTWINDOWVIEWPORT) of PLOT with (CREATEVIEWPORT (WINDOWPROP WINDOW - 'DSP] - - (* ;; "Get a prompt window, if none exists") - - (COND - ((NULL PLOTPROMPTWINDOW) - (SETQ PLOTPROMPTWINDOW (CREATEW [CREATEREGION 0 0 100 (HEIGHTIFWINDOW - (FONTPROP (DEFAULTFONT - 'DISPLAY) - 'HEIGHT] - NIL NIL T)) - (WINDOWPROP PLOTPROMPTWINDOW 'PAGEFULLFN (FUNCTION NILL)) - [WINDOWPROP PLOTPROMPTWINDOW 'MAXSIZE (CONS MAX.SMALLP (fetch HEIGHT - of (WINDOWPROP - PLOTPROMPTWINDOW - 'REGION] - (DSPSCROLL 'ON PLOTPROMPTWINDOW) - (replace (PLOT PLOTPROMPTWINDOW) of PLOT with PLOTPROMPTWINDOW) - (SETQ PROMPTCREATEDFLG T))) (* ; - "Establish a min size for the window") - - (CREATETICLISTS PLOT) - (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP WINDOW 'DSP) - PLOT)) - [WINDOWPROP WINDOW (COND - ((NULL (ATTACHEDWINDOWS WINDOW)) - 'MINSIZE) - (T 'MAINWINDOWMINSIZE)) - (CONS (WIDTHIFWINDOW (CAR MINSIZE) - (WINDOWPROP WINDOW 'BORDER)) - (HEIGHTIFWINDOW (CDR MINSIZE) - (WINDOWPROP WINDOW 'TITLE) - (WINDOWPROP WINDOW 'BORDER] - (COND - ([AND (NOT WINDOWRESHAPEFLG) - (OR (ILESSP (WINDOWPROP WINDOW 'WIDTH) - (CAR MINSIZE)) - (ILESSP (WINDOWPROP WINDOW 'HEIGHT) - (CDR MINSIZE] - (SETQ WINDOWRESHAPEFLG T) - (PROMPTPRINT "Window too small: reshape"))) - [IF WINDOWRESHAPEFLG - THEN (* ; - "Shaping window implies redrawing it") - - (SHAPEW WINDOW) - ELSE (LET ((PLOTWINDOWVIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) - (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT))) - (OPENW WINDOW) - (ADJUSTVIEWPORT PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL WINDOW) - PLOT) - (DRAWPLOT PLOT (WINDOWPROP WINDOW 'DSP) - PLOTWINDOWVIEWPORT - (DSPCLIPPINGREGION NIL WINDOW)) - (IF SELECTEDOBJECT - THEN (HIGHLIGHTPLOTOBJECT SELECTEDOBJECT PLOT] - (* ; - "Attach the promptwindow if necessary") - - (ATTACHWINDOW PLOTPROMPTWINDOW WINDOW 'TOP) (* ; "attach the fixed menu") - - (COND - ((PLOTPROP PLOT 'FIXEDRIGHTMENU?) - (PLOT.FIXRIGHTMENU PLOT T))) (* ; "A user hook") - - (APPLY.AFTERFN WHENOPENEDFN PLOT) - (RETURN WINDOW]) (PLOT.BUTTONEVENTFN - [LAMBDA (PLOTWINDOW) (* ; "Edited 7-May-87 10:14 by jop") - - (TOTOPW PLOTWINDOW) - (LET* ((PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) - (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT))) - (COND - [(LASTMOUSESTATE LEFT) - (LET ((OLDX 0) - (OLDY 0) - (PLOTSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of (fetch (PLOT - PLOTWINDOWVIEWPORT - ) of PLOT))) - (POSITION (create POSITION)) - NEWX NEWY NEWSELECTEDOBJECT) - (while (MOUSESTATE LEFT) do (replace (POSITION XCOORD) of POSITION - with (SETQ NEWX (LASTMOUSEX PLOTWINDOW))) - (replace (POSITION YCOORD) of POSITION - with (SETQ NEWY (LASTMOUSEY PLOTWINDOW))) - [COND - [(INSIDEP PLOTSUBREGION POSITION) - (COND - ((NOT (AND (EQ OLDX NEWX) - (EQ OLDY NEWY))) - (SETQ NEWSELECTEDOBJECT (CLOSESTPLOTOBJECT - PLOT POSITION)) - (COND - ((AND NEWSELECTEDOBJECT (NEQ - NEWSELECTEDOBJECT - SELECTEDOBJECT - )) - (COND - (SELECTEDOBJECT (LOWLIGHTPLOTOBJECT - SELECTEDOBJECT PLOT))) - (HIGHLIGHTPLOTOBJECT NEWSELECTEDOBJECT - PLOT) - (replace (PLOT SELECTEDOBJECT) - of PLOT with NEWSELECTEDOBJECT) - (SETQ SELECTEDOBJECT NEWSELECTEDOBJECT) - (* ; - "Try to print a meaningfull message in the PLOTPROMPTWINDOW") - - (PLOTPROMPT (fetch (PLOTOBJECT OBJECTLABEL - ) of - NEWSELECTEDOBJECT - ) - PLOT] - (T (COND - (SELECTEDOBJECT (LOWLIGHTPLOTOBJECT - SELECTEDOBJECT PLOT) - (SETQ SELECTEDOBJECT NIL) - (replace (PLOT SELECTEDOBJECT) - of PLOT with SELECTEDOBJECT] - (SETQ OLDX NEWX) - (SETQ OLDY NEWY] - [(AND SELECTEDOBJECT (LASTMOUSESTATE MIDDLE)) - (LET ((MIDDLEMENU (fetch (PLOT MIDDLEMENU) of PLOT)) - (OBJECTMENU (fetch (PLOTOBJECT OBJECTMENU) of SELECTEDOBJECT)) - MIDMENU) - (SETQ MIDMENU (COND - (OBJECTMENU [COND - ((LITATOM OBJECTMENU) - (SETQ OBJECTMENU (LISTGET (fetch (PLOT OTHERMENUS - ) - of PLOT) - OBJECTMENU] - OBJECTMENU) - (T MIDDLEMENU))) - (COND - (MIDMENU (PUTMENUPROP MIDMENU 'PLOT PLOT) - (PUTMENUPROP MIDMENU 'MODE 'MIDDLE) - (MENU MIDMENU) - (PUTMENUPROP MIDMENU 'MODE NIL) - (PUTMENUPROP MIDMENU 'PLOT NIL] - ((LASTMOUSESTATE RIGHT) - (LET [(RIGHTMENU (fetch (PLOT RIGHTMENU) of PLOT)) - (FIXEDRIGHTMENU? (PLOTPROP PLOT 'FIXEDRIGHTMENU?] - (COND - ([OR FIXEDRIGHTMENU? (IGREATERP (fetch (POSITION YCOORD) - of (CURSORPOSITION NIL PLOTWINDOW)) - (WINDOWPROP PLOTWINDOW 'HEIGHT] - (DOWINDOWCOM PLOTWINDOW)) - (RIGHTMENU (PUTMENUPROP RIGHTMENU 'PLOT PLOT) - (MENU RIGHTMENU) - (PUTMENUPROP RIGHTMENU 'PLOT NIL]) (PLOT.CLOSEFN - [LAMBDA (W) (* ; "Edited 5-May-87 18:38 by jop") - - (CLOSEPLOTWINDOW (WINDOWPROP W 'PLOT]) (PLOT.DEFAULTMENU - [LAMBDA ARGS (* ; "Edited 5-May-87 18:38 by jop") - - (* ;; "If no third argument then simply return items list for given menu (middle or right), else replace the cached menu with the new list of items") - - (DECLARE (GLOBALVARS PLOT.DEFAULTMIDDLEMENU PLOT.DEFAULTRIGHTMENU)) - (COND - ((LESSP ARGS 1) - (HELP "Must have at least one arg, MENUNAME"))) - (PROG ((MENUNAME (ARG ARGS 1)) - (NEWITEMS (AND (GREATERP ARGS 1) - (ARG ARGS 2))) - MENU) - (COND - ((AND (GREATERP ARGS 1) - (NOT (LISTP NEWITEMS))) - (HELP "Not a list" NEWITEMS))) - (SETQ MENU (SELECTQ MENUNAME - (MIDDLE (AND (BOUNDP 'PLOT.DEFAULTMIDDLEMENU) - PLOT.DEFAULTMIDDLEMENU)) - (RIGHT (AND (BOUNDP 'PLOT.DEFAULTRIGHTMENU) - PLOT.DEFAULTRIGHTMENU)) - (SHOULDNT))) - [COND - ((GREATERP ARGS 1) - [SETQ MENU (AND NEWITEMS (COND - (MENU (COPYMENU MENU NEWITEMS)) - (T (create MENU - ITEMS _ NEWITEMS] - (SELECTQ MENUNAME - (MIDDLE (SETQ PLOT.DEFAULTMIDDLEMENU MENU)) - (RIGHT (SETQ PLOT.DEFAULTRIGHTMENU MENU)) - (SHOULDNT] - (RETURN MENU]) (PLOT.FIXRIGHTMENU - [LAMBDA ARGS (* ; "Edited 5-May-87 18:39 by jop") - - (COND - ((ILESSP ARGS 1) - (HELP "Must have at least one arg"))) - (LET* ((PLOT (ARG ARGS 1)) - [FIXEDFLG (COND - ((IGREATERP ARGS 1) - (ARG ARGS 2] - (OLDVALUE (PLOTPROP PLOT 'FIXEDRIGHTMENU?)) - (PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT))) - [COND - ((IGREATERP ARGS 1) - (LET [(FIXEDRIGHTMENU (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU] - (PLOTPROP PLOT 'FIXEDRIGHTMENU? (NOT (NULL FIXEDFLG))) - (COND - [FIXEDFLG (COND - ((AND (OPENWP PLOTWINDOW) - (NULL FIXEDRIGHTMENU)) - (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU (ATTACHMENU - (fetch (PLOT RIGHTMENU) - of PLOT) - PLOTWINDOW - 'RIGHT - 'TOP] - (T (COND - (FIXEDRIGHTMENU (CLOSEW FIXEDRIGHTMENU) - (DETACHWINDOW FIXEDRIGHTMENU) - (WINDOWPROP PLOTWINDOW 'FIXEDRIGHTMENU NIL] - OLDVALUE]) (PLOT.HARDCOPYFN - [LAMBDA (PLOTWINDOW PRINTERSTREAM) (* ; "Edited 13-May-87 12:27 by jop") - - (* ;; "Modified to allow hardcopy of plots on PRESS printers -- no landscape drawing") - - (* ;; "Modified to center plot on page") - - (PROG ((WINDOWREGION (DSPCLIPPINGREGION NIL PLOTWINDOW)) - (PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) - (VIEWPORT (CREATEVIEWPORT PRINTERSTREAM)) - PRINTERCLIPREGION STREAMREGION K) - [if (EQ (IMAGESTREAMTYPE PRINTERSTREAM) - 'INTERPRESS) - then (LET ((MICASPERINCH 2540)) - (if (GREATERP (fetch WIDTH of WINDOWREGION) - (fetch HEIGHT of WINDOWREGION)) - then (* ; "Print in landscape mode") - - (ROTATE.IP PRINTERSTREAM 90) - (CONCATT.IP PRINTERSTREAM) - [TRANSLATE.IP PRINTERSTREAM 0 (FIX (MINUS (TIMES 8.5 MICASPERINCH] - (CONCATT.IP PRINTERSTREAM) (* ; - "Make sure the clippingregion is rational") - - (DSPCLIPPINGREGION (CREATEREGION (FIX (TIMES 0.5 MICASPERINCH)) - (FIX (TIMES 0.5 MICASPERINCH)) - (FIX (TIMES 10 MICASPERINCH)) - (FIX (TIMES 7.5 MICASPERINCH))) - PRINTERSTREAM) - else (* ; - "Make sure the clippingregion is rational") - - (DSPCLIPPINGREGION (CREATEREGION (FIX (TIMES 0.5 MICASPERINCH)) - (FIX (TIMES 0.5 MICASPERINCH)) - (FIX (TIMES 7.5 MICASPERINCH)) - (FIX (TIMES 10 MICASPERINCH))) - PRINTERSTREAM] - (SETQ PRINTERCLIPREGION (DSPCLIPPINGREGION NIL PRINTERSTREAM)) - (* ; "Reset the margins") - - (DSPLEFTMARGIN (fetch (REGION LEFT) of PRINTERCLIPREGION) - PRINTERSTREAM) - (DSPBOTTOMMARGIN (fetch (REGION BOTTOM) of PRINTERCLIPREGION) - PRINTERSTREAM) - (DSPRIGHTMARGIN (fetch (REGION RIGHT) of PRINTERCLIPREGION) - PRINTERSTREAM) - (DSPTOPMARGIN (fetch (REGION TOP) of PRINTERCLIPREGION) - PRINTERSTREAM) (* ; - "maintain the PLOTWINDOW's aspect ratio") - - [SETQ K (MIN (QUOTIENT (fetch (REGION WIDTH) of PRINTERCLIPREGION) - (fetch (REGION WIDTH) of WINDOWREGION)) - (QUOTIENT (fetch (REGION HEIGHT) of PRINTERCLIPREGION) - (fetch (REGION HEIGHT) of WINDOWREGION] - (SETQ STREAMREGION (LET [(SWIDTH (TIMES K (fetch (REGION WIDTH) of WINDOWREGION))) - (SHEIGHT (TIMES K (fetch (REGION HEIGHT) of WINDOWREGION] - - (* ;; "center plot on page") - - (CREATEREGION (PLUS (fetch (REGION LEFT) of PRINTERCLIPREGION) - (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) - of PRINTERCLIPREGION) - SWIDTH) - 2)) - (PLUS (fetch BOTTOM of PRINTERCLIPREGION) - (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) - of PRINTERCLIPREGION) - SHEIGHT) - 2)) - SWIDTH SHEIGHT))) - (CREATETICLISTS PLOT) - (ADJUSTVIEWPORT VIEWPORT STREAMREGION PLOT) - (DRAWPLOT PLOT PRINTERSTREAM VIEWPORT STREAMREGION]) (PLOT.ICONFN - [LAMBDA (PLOTWINDOW OLDICON) (* ; "Edited 5-May-87 18:40 by jop") - - (PROG ((PLOT (WINDOWPROP PLOTWINDOW 'PLOT)) - (TITLEFONT (WINDOWTITLEFONT)) - ICONWWIDTH ICONWHEIGHT SUBREGION ICONW VIEWPORT) - (if (GREATERP (WINDOWPROP PLOTWINDOW 'WIDTH) - (WINDOWPROP PLOTWINDOW 'HEIGHT)) - then (SETQ ICONWWIDTH (WIDTHIFWINDOW 100)) - [SETQ ICONWHEIGHT (HEIGHTIFWINDOW (FIXR (TIMES 100 (FQUOTIENT (WINDOWPROP - PLOTWINDOW - 'HEIGHT) - (WINDOWPROP PLOTWINDOW - 'WIDTH] - else [SETQ ICONWWIDTH (WIDTHIFWINDOW (FIXR (TIMES 100 (FQUOTIENT (WINDOWPROP PLOTWINDOW - 'WIDTH) - (WINDOWPROP PLOTWINDOW - 'HEIGHT] - (SETQ ICONWHEIGHT (HEIGHTIFWINDOW 100))) - (if OLDICON - then (SHAPEW OLDICON (CREATEREGION (fetch LEFT of (WINDOWPROP OLDICON 'REGION)) - (fetch BOTTOM of (WINDOWPROP OLDICON 'REGION)) - ICONWWIDTH ICONWHEIGHT)) - (SETQ ICONW OLDICON) - else (SETQ ICONW (CREATEW (GETBOXREGION ICONWWIDTH ICONWHEIGHT))) - (DSPFONT TITLEFONT ICONW)) - (CLEARW ICONW) - [SETQ SUBREGION (CREATEREGION [FIXR (TIMES 0.1 (WINDOWPROP ICONW 'WIDTH] - [FIXR (TIMES 0.1 (WINDOWPROP ICONW 'HEIGHT] - [FIXR (TIMES 0.8 (WINDOWPROP ICONW 'WIDTH] - (FIXR (TIMES 0.8 (WINDOWPROP ICONW 'HEIGHT] - [SETQ VIEWPORT (CREATEVIEWPORT (WINDOWPROP ICONW 'DSP) - SUBREGION - (fetch WORLDREGION of (fetch PLOTWINDOWVIEWPORT of PLOT] - (BOXREGION SUBREGION ICONW) - [LET ((OBJECTS (fetch PLOTOBJECTS of PLOT)) - TOBJECTS) - (if (ILESSP (SETQ TOBJECTS (LENGTH OBJECTS)) - 50) - then (* ; - "few enough objects so that all of them may be drawn") - - (for OBJECT in OBJECTS do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT)) - else (* ; "Sample the display list") - - (bind (SAMPLERATE _ (FIXR (FQUOTIENT TOBJECTS 50))) for OBJECT in OBJECTS - as I from 1 when (IEQP 0 (IMOD I SAMPLERATE)) - do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT] - (CENTERPRINTINREGION (OR (PLOTLABEL PLOT 'TOP) - (if (NOT (STREQUAL (WINDOWPROP PLOTWINDOW 'TITLE) - "Plot Window")) - then (WINDOWPROP PLOTWINDOW 'TITLE)) - "Plot Icon") - NIL ICONW) - (RETURN ICONW]) (PLOT.LABELTOWORLD - [LAMBDA (VALUE PLOT AXIS) (* ; "Edited 5-May-87 18:26 by jop") - - (* ;; "given label VALUE computes corresponding VALUE in world coords") - - (PROG [(FN (SELECTQ AXIS - (X (PLOTPROP PLOT 'XWORLDFN)) - (Y (PLOTPROP PLOT 'YWORLDFN)) - (HELP "Illegal axis" AXIS] - (RETURN (COND - (FN (CL:FUNCALL FN VALUE PLOT AXIS)) - (T (* ; "use identity transformation") - - VALUE]) (PLOT.REPAINTFN - [LAMBDA (WINDOW) (* ; "Edited 5-May-87 18:40 by jop") - - (* ;; "Redraws a PLOT WINDOW based on data stored on property list of WINDOW") - - (REDRAWPLOTWINDOW (WINDOWPROP WINDOW 'PLOT]) (PLOT.RESET - [LAMBDA (PLOT XSCALE YSCALE FLUSHMARGINS FLUSHPROPS NODRAWFLG) - (* ; "Edited 5-May-87 18:40 by jop") - - (* ;; "Reset a PLOT for reuse. XSCALE must be an AXISINTERVAL, defaults to the current interval. Similarly for YSCALE. Non-NIL FLUSHMARGINS means flush all labels, ticmethods, etc. Non-NIL FLUSHPROPS means flush all PLOTPROPS and cached menus") - - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT A PLOT" PLOT)) (* ; "Flush display list") - - (replace (PLOT PLOTOBJECTS) of PLOT with NIL) - (replace (PLOT SELECTEDOBJECT) of PLOT with NIL) - (replace (PLOT PLOTSAVELIST) of PLOT with NIL) - (if FLUSHMARGINS - then (for MARGIN in '(BOTTOM LEFT TOP RIGHT) do (PLOTLABEL PLOT MARGIN NIL T) - (PLOTTICS PLOT MARGIN NIL T) - (PLOTTICMETHOD PLOT MARGIN NIL T))) - (if XSCALE - then (PLOTAXISINTERVAL PLOT 'X XSCALE T)) - (if YSCALE - then (PLOTAXISINTERVAL PLOT 'Y YSCALE T)) (* ; "Flush PLOT PROPS") - - (if FLUSHPROPS - then (replace (PLOT PLOTUSERDATA) of PLOT with NIL) - (replace (PLOT OTHERMENUS) of PLOT with NIL)) - (if (NULL NODRAWFLG) - then (REDRAWPLOTWINDOW PLOT]) (PLOT.SETUP - [LAMBDA (OPSTABLE) (* ; "Edited 7-May-87 18:28 by jop") - - (* ;; "Assume opstable is a list of lists, one list for each PLOT object. The CAR of each sublist is the the name of the PLOT object, e.g. POINT. Then follows pairs of method-names and function-names, e.g. (ADDFN ADDPOINTOBJECT)") - - [bind ASSOCLST for OBJECTLST in OPSTABLE - do (SET (PACK* (CAR OBJECTLST) - 'FNS) - (APPLY (FUNCTION CREATEPLOTFNS) - (first (SETQ ASSOCLST (CDR OBJECTLST)) for FNNAME - in '(DRAWFN ERASEFN EXTENTFN DISTANCEFN HIGHLIGHTFN LOWLIGHTFN LABELFN - MOVEFN COPYFN PUTFN GETFN) collect (CADR (ASSOC FNNAME ASSOCLST] - (SETQ LARGEPLOTFONT (FONTCREATE LARGEPLOTFONT)) - (SETQ SMALLPLOTFONT (FONTCREATE SMALLPLOTFONT]) (PLOT.SKETCH.CREATE - [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:41 by jop") - - (* ;; "Creates a SKETCH STREAM and dumps the contents of PLOT into it") - - (if (NOT (type? PLOT PLOT)) - then (HELP "Not a PLOT " PLOT)) - (if (NOT (CL:FBOUNDP 'OPENSKETCHSTREAM)) - then (PLOTPROMPT "SKETCHSTREAM not loaded" PLOT) - else (PROG ([SKETCHSTREAM (OPENSKETCHSTREAM "LAYOUT OF PLOT" - (if (fetch PLOTWINDOW of PLOT) - then (LET [(PLOTREGION (WINDOWPROP (fetch PLOTWINDOW - of PLOT) - 'REGION] - (LIST 'REGION (GETBOXREGION (fetch WIDTH - of PLOTREGION) - (fetch HEIGHT of PLOTREGION - ] - SKETCHVIEWPORT) - (SETQ SKETCHVIEWPORT (CREATEVIEWPORT SKETCHSTREAM)) - (ADJUSTVIEWPORT SKETCHVIEWPORT (DSPCLIPPINGREGION NIL SKETCHSTREAM) - PLOT) - (DRAWPLOT PLOT SKETCHSTREAM SKETCHVIEWPORT (DSPCLIPPINGREGION NIL SKETCHSTREAM]) (PLOT.WHENSELECTEDFN - [LAMBDA (ITEM MENU) (* ; "Edited 5-May-87 18:42 by jop") - - (LET* ([PLOT (OR (GETMENUPROP MENU 'PLOT) - (WINDOWPROP (MAINWINDOW (WFROMMENU MENU)) - 'PLOT] - (MODE (GETMENUPROP MENU 'MODE)) - (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) - (SELECTEDFN (CADR ITEM)) - EXTRAARGS ARGSTOPASS) - [COND - ((LISTP SELECTEDFN) - (SETQ EXTRAARGS (CDR SELECTEDFN)) - (SETQ SELECTEDFN (CAR SELECTEDFN] - (SETQ ARGSTOPASS (for ARG in EXTRAARGS collect (EVAL ARG))) - (COND - ((EQ MODE 'MIDDLE) - (replace (PLOT SELECTEDOBJECT) of PLOT with NIL) - (LOWLIGHTPLOTOBJECT SELECTEDOBJECT PLOT) - (CL:APPLY SELECTEDFN SELECTEDOBJECT PLOT ARGSTOPASS)) - (T (CL:APPLY SELECTEDFN PLOT ARGSTOPASS]) (PLOT.WORLDTOLABEL - [LAMBDA (VALUE PLOT AXIS) (* ; "Edited 5-May-87 18:26 by jop") - - (* ;; "Given VALUE in world coords, computes corresponding label VALUE") - - (PROG [(FN (SELECTQ AXIS - (X (PLOTPROP PLOT 'XLABELFN)) - (Y (PLOTPROP PLOT 'YLABELFN)) - (HELP "Illegal axis" AXIS] - (RETURN (COND - (FN (CL:FUNCALL FN VALUE PLOT AXIS)) - (T (* ; "use identity transformation") - - VALUE]) (PLOTADDMENUITEMS - [LAMBDA (PLOT MENUNAME ITEMSTOADD) (* ; "Edited 5-May-87 18:42 by jop") - - (* ;; "Add ITEMSTOADD to end of menu MENUNAME item list") - - (PROG ((MENU (SELECTQ MENUNAME - (MIDDLE (fetch MIDDLEMENU of PLOT)) - (RIGHT (fetch RIGHTMENU of PLOT)) - (LISTGET (fetch OTHERMENUS of PLOT) - MENUNAME))) - (MENUITEMS (PLOTMENUITEMS PLOT MENUNAME))) - (if ITEMSTOADD - then (SETQ ITEMSTOADD (for ITEM in ITEMSTOADD - unless (for ELEMENT in MENUITEMS - thereis (EQUAL (CAR ELEMENT) - (CAR ITEM))) collect ITEM)) - (PLOTMENUITEMS PLOT MENUNAME (APPEND MENUITEMS ITEMSTOADD))) - (RETURN MENUITEMS]) (PLOTADDPROP - [LAMBDA (PLOT PROP ITEMTOADD FIRSTFLG) (* ; "Edited 5-May-87 18:42 by jop") - - (* ;; "As in WINDOWADDPROP.") - - (PROG [(PROPVAL (MKLIST (PLOTPROP PLOT PROP] - [if (NOT (MEMB ITEMTOADD PROPVAL)) - then (if FIRSTFLG - then (SETQ PROPVAL (CONS ITEMTOADD PROPVAL)) - else (SETQ PROPVAL (APPEND PROPVAL (LIST ITEMTOADD] - (RETURN (PLOTPROP PLOT PROP PROPVAL]) (PLOTAXISINTERVAL - [LAMBDA (PLOT AXIS INTERVAL NODRAWFLG) (* ; "Edited 5-May-87 18:42 by jop") - - (* ;; "If INTERVAL is NIL returns the current INTERVAL for AXIS of PLOT. If INTERVAL is non-NIL it must be an INTERVAL, in which case the interval for axis AXIS of PLOT is set to INTERVAL") - - (PROG ((PLOTSCALE (fetch PLOTSCALE of PLOT)) - OLDVALUE) - (SETQ OLDVALUE (SELECTQ AXIS - (X (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) - (Y (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) - (SHOULDNT))) - (if (type? AXISINTERVAL INTERVAL) - then (SELECTQ AXIS - (X (replace (PLOTSCALE XINTERVAL) of PLOTSCALE with INTERVAL)) - (Y (replace (PLOTSCALE YINTERVAL) of PLOTSCALE with INTERVAL)) - (SHOULDNT)) - (if (NULL NODRAWFLG) - then (REDRAWPLOTWINDOW PLOT))) - (RETURN OLDVALUE]) (PLOTDELMENUITEMS - [LAMBDA (PLOT MENUNAME ITEMSTODELETE) (* ; "Edited 5-May-87 18:42 by jop") - - (* ;; "Delete ITEMSTODELETE from menu MENUNAME item list. RETURNS new item list if something deleted or else NIL. ITEMSTODELETE may be a list of lists or of atoms, in which case the atoms are compared to secessive CARS of MENUNAME's item list") - - (SETQ ITEMSTODELETE (MKLIST ITEMSTODELETE)) - (PROG ((MENU (SELECTQ MENUNAME - (MIDDLE (fetch MIDDLEMENU of PLOT)) - (RIGHT (fetch RIGHTMENU of PLOT)) - (LISTGET (fetch OTHERMENUS of PLOT) - MENUNAME))) - MENUITEMS SOMETHINGDELETED) - (SETQ MENUITEMS (AND MENU (fetch ITEMS of MENU))) - [bind TARGET for ITEMTODELETE in ITEMSTODELETE - do (if (LITATOM ITEMTODELETE) - then (if [SETQ TARGET (for ITEM in MENUITEMS thereis (EQUAL ITEMTODELETE - (CAR ITEM] - then (SETQ SOMETHINGDELETED T) - (SETQ MENUITEMS (REMOVE TARGET MENUITEMS))) - elseif [AND (LISTP ITEMTODELETE) - (SETQ TARGET (CAR (MEMBER ITEMTODELETE MENUITEMS] - then (SETQ SOMETHINGDELETED T) - (SETQ MENUITEMS (REMOVE TARGET MENUITEMS] - (RETURN (if SOMETHINGDELETED - then (PLOTMENUITEMS PLOT MENUNAME MENUITEMS) - MENUITEMS]) (PLOTDELPROP - [LAMBDA (PLOT PROP ITEMTODELETE) (* ; "Edited 5-May-87 18:43 by jop") - - (* ;; "As in WINDOWDELPROP") - - (PROG ((PROPVAL (PLOTPROP PLOT PROP))) - (RETURN (if (EQ ITEMTODELETE PROPVAL) - then (PLOTPROP PLOT PROP NIL) - elseif (MEMB ITEMTODELETE PROPVAL) - then (PLOTPROP PLOT PROP (REMOVE ITEMTODELETE PROPVAL]) (PLOTLABEL -(LAMBDA ARGS (* ; "Edited 25-Feb-88 13:49 by jop") (* ;; "IF NEWLABEL is not present then return current POSITION label of PLOT, else set the label to NEWLABEL and return the old value. NODRAWFLG T suppresses redrawing. POSITIOn may be one of X , Y , TITLE") (COND ((LESSP ARGS 2) (HELP "PLOTLABEL takes at least two args, plot and position"))) (PROG ((PLOT (ARG ARGS 1)) (POSITION (ARG ARGS 2)) (NEWLABEL (AND (GREATERP ARGS 2) (ARG ARGS 3))) (NODRAWFLG (AND (GREATERP ARGS 3) (ARG ARGS 4))) MARGIN OLDLABEL) (SETQ MARGIN (SELECTQ POSITION (BOTTOM (fetch BOTTOMMARGIN of PLOT)) (LEFT (fetch LEFTMARGIN of PLOT)) (TOP (fetch TOPMARGIN of PLOT)) (RIGHT (fetch RIGHTMARGIN of PLOT)) (HELP "Illegal margin" POSITION))) (SETQ OLDLABEL (fetch (MARGIN LABEL) of MARGIN)) (COND ((GREATERP ARGS 2) (replace (MARGIN LABEL) of MARGIN with (AND NEWLABEL (MKSTRING NEWLABEL))) (COND ((NULL NODRAWFLG) (REDRAWPLOTWINDOW PLOT))))) (RETURN OLDLABEL))) -) (PLOTMENU - [LAMBDA ARGS (* jop%: "12-Dec-85 10:31") - - (* * If no third argument then simply return items list for given menu - (middle or right)%, else replace the cached menu with the new list of items. - If the NEWMENU's whenselectedfn is NIL it is replaced with PLOT.WHENSELECTEDFN) - - (COND - ((ILESSP ARGS 2) - (HELP "Must have at least two args, PLOT and MENUNAME"))) - (PROG ((PLOT (ARG ARGS 1)) - (MENUNAME (ARG ARGS 2)) - (NEWMENU (AND (IGREATERP ARGS 2) - (ARG ARGS 3))) - PLOTWINDOW OLDVALUE) - (SETQ PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (SETQ OLDVALUE (SELECTQ MENUNAME - (MIDDLE (fetch MIDDLEMENU of PLOT)) - (RIGHT (fetch RIGHTMENU of PLOT)) - (LISTGET (fetch OTHERMENUS of PLOT) - MENUNAME))) - [COND - ((NOT (OR (NULL NEWMENU) - (type? MENU NEWMENU))) - (HELP "Not a menu" NEWMENU)) - ((AND NEWMENU (NULL (fetch WHENSELECTEDFN of NEWMENU))) - (replace (MENU WHENSELECTEDFN) of NEWMENU with (FUNCTION PLOT.WHENSELECTEDFN] - [COND - ((IGREATERP ARGS 2) - [SELECTQ MENUNAME - (MIDDLE (replace MIDDLEMENU of PLOT with NEWMENU)) - (RIGHT (replace RIGHTMENU of PLOT with NEWMENU)) - (COND - ((NULL (fetch OTHERMENUS of PLOT)) - (replace OTHERMENUS of PLOT with (LIST MENUNAME NEWMENU)) - NEWMENU) - (T (LISTPUT (fetch OTHERMENUS of PLOT) - MENUNAME NEWMENU] - (COND - ((AND (OPENWP PLOTWINDOW) - (EQ MENUNAME 'RIGHT) - (PLOTPROP PLOT 'FIXEDRIGHTMENU?)) (* Update the fixed menu) - (PLOT.FIXRIGHTMENU PLOT NIL) - (PLOT.FIXRIGHTMENU PLOT T] - (RETURN OLDVALUE]) (PLOTMENUITEMS - [LAMBDA ARGS (* jop%: "11-Dec-85 14:39") - - (* * If no third argument then simply return items list for given menu - (middle or right)%, else replace the cached menu with the new list of items) - - (if (LESSP ARGS 2) - then (HELP "Must have at least two args, PLOT and MENUNAME")) - (PROG ((PLOT (ARG ARGS 1)) - (MENUNAME (ARG ARGS 2)) - (NEWITEMS (AND (GREATERP ARGS 2) - (ARG ARGS 3))) - MENU) - (if (AND (GREATERP ARGS 2) - (NOT (LISTP NEWITEMS))) - then (HELP "Not a list" NEWITEMS)) - (SETQ MENU (SELECTQ MENUNAME - (MIDDLE (fetch MIDDLEMENU of PLOT)) - (RIGHT (fetch RIGHTMENU of PLOT)) - (LISTGET (fetch OTHERMENUS of PLOT) - MENUNAME))) - (if (GREATERP ARGS 2) - then [SETQ MENU (AND NEWITEMS (if MENU - then (COPYMENU MENU NEWITEMS) - else (create MENU - ITEMS _ NEWITEMS] - (PLOTMENU PLOT MENUNAME MENU)) - (RETURN (if (LESSP ARGS 3) - then (if MENU - then (fetch ITEMS of MENU)) - else NEWITEMS]) (PLOTOBJECTADDPROP - [LAMBDA (OBJECT PROP ITEMTOADD FIRSTFLG) (* jop%: "20-Jan-86 16:03") - - (* * As in WINDOWADDPROP.) - - (PROG [(PROPVAL (MKLIST (PLOTOBJECTPROP OBJECT PROP] - [if (NOT (MEMB ITEMTOADD PROPVAL)) - then (if FIRSTFLG - then (SETQ PROPVAL (CONS ITEMTOADD PROPVAL)) - else (SETQ PROPVAL (APPEND PROPVAL (LIST ITEMTOADD] - (RETURN (PLOTOBJECTPROP OBJECT PROP PROPVAL]) (PLOTOBJECTDELPROP - [LAMBDA (OBJECT PROP ITEMTODELETE) (* jop%: "20-Jan-86 16:03") - - (* * As in WINDOWDELPROP) - - (PROG ((PROPVAL (PLOTOBJECTPROP OBJECT PROP))) - (RETURN (if (EQ ITEMTODELETE PROPVAL) - then (PLOTOBJECTPROP OBJECT PROP NIL) - elseif (MEMB ITEMTODELETE PROPVAL) - then (PLOTOBJECTPROP OBJECT PROP (REMOVE ITEMTODELETE PROPVAL]) (PLOTOBJECTLABEL - [LAMBDA (OBJECT LABEL PLOT NODRAWFLG) (* edited%: "27-Mar-86 21:29") - - (* * IF LABEL is NIL then return current label of OBJECT, else set the label to - LABEL and return the old value. NODRAWFLG T suppresses drawing) - - (if (NOT (type? PLOTOBJECT OBJECT)) - then (HELP "NOT A PLOTOBJECT" OBJECT)) - (PROG ((OLDLABEL (fetch (PLOTOBJECT OBJECTLABEL) of OBJECT))) - (if LABEL - then (if (AND (NULL NODRAWFLG) - (PLOTOBJECTPROP OBJECT 'LABEL) - PLOT) - then (UNLABELPLOTOBJECT OBJECT PLOT)) - (replace (PLOTOBJECT OBJECTLABEL) of OBJECT with LABEL) - (if (AND PLOT (NULL NODRAWFLG)) - then (LABELPLOTOBJECT OBJECT PLOT))) - (RETURN OLDLABEL]) (PLOTOBJECTPROP - [LAMBDA ARGS (* ; "Edited 5-May-87 18:43 by jop") - - (* ;; "As in WINDOWPROP. Operates on field OBJECTUSERDATA of PLOTOBJECT. If PROP is (QUOTE MENU) then accesses the object menu") - - (COND - ((LESSP ARGS 2) - (HELP "OBJECTPROP takes at least two arguments, plotobject and prop"))) - (PROG ((PLOTOBJECT (ARG ARGS 1)) - (PROPNAME (ARG ARGS 2)) - (NEWVALUE (AND (GREATERP ARGS 2) - (ARG ARGS 3))) - (FIELDNAMES '(OBJECTMENU OBJECTLABEL OBJECTDATA)) - OLDVALUE OBJECTUSERDATA) - (SETQ OBJECTUSERDATA (fetch (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT)) - [SETQ OLDVALUE (COND - ((MEMB PROPNAME FIELDNAMES) - (SELECTQ PROPNAME - (OBJECTMENU (fetch (PLOTOBJECT OBJECTMENU) of PLOTOBJECT)) - (OBJECTLABEL (fetch (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - (SHOULDNT))) - (T (LISTGET OBJECTUSERDATA PROPNAME] - [COND - ((GREATERP ARGS 2) - (COND - ((MEMB PROPNAME FIELDNAMES) - (SELECTQ PROPNAME - (OBJECTMENU (replace (PLOTOBJECT OBJECTMENU) of PLOTOBJECT - with (OR [COND - ((LISTP NEWVALUE) - (COND - ((type? MENU OLDVALUE) - (LET ((NEWMENU (COPYMENU OLDVALUE NEWVALUE))) - [COND - ((NULL (fetch WHENSELECTEDFN - of NEWMENU)) - (replace WHENSELECTEDFN of NEWMENU - with (FUNCTION PLOT.WHENSELECTEDFN] - NEWMENU)) - (T (create MENU - ITEMS _ NEWVALUE - WHENSELECTEDFN _ - (FUNCTION PLOT.WHENSELECTEDFN] - NEWVALUE))) - (OBJECTLABEL (replace (PLOTOBJECT OBJECTLABEL) of PLOTOBJECT with NEWVALUE)) - (OBJECTDATA (replace (PLOTOBJECT OBJECTDATA) of PLOTOBJECT with NEWVALUE)) - (SHOULDNT))) - (T (COND - ((NULL OBJECTUSERDATA) - (replace (PLOTOBJECT OBJECTUSERDATA) of PLOTOBJECT with (LIST PROPNAME - NEWVALUE))) - (T (LISTPUT OBJECTUSERDATA PROPNAME NEWVALUE] - (RETURN OLDVALUE]) (PLOTOBJECTPROPMACRO - [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:44 by jop") - - (LET [(BPLOTOBJECT (CAR ARGS)) - (BPROPNAME (CADR ARGS)) - (FIELDNAMES '(OBJECTMENU OBJECTLABEL OBJECTDATA] - (COND - ((OR (NOT (EQLENGTH ARGS 2)) - (NEQ (CAR BPROPNAME) - 'QUOTE) - (MEMB (CADR BPROPNAME) - FIELDNAMES)) - 'IGNOREMACRO) - (T `(LISTGET (fetch (PLOTOBJECT OBJECTUSERDATA) of ,BPLOTOBJECT) - ,BPROPNAME]) (PLOTOBJECTSUBTYPE - [LAMBDA (PLOTOBJECT) (* jop%: "20-Jan-86 16:21") - (fetch (PLOTOBJECT OBJECTSUBTYPE) of PLOTOBJECT]) (PLOTOPERROR - [LAMBDA NIL (* edited%: "19-May-85 13:48") - (HELP "ATTEMPT To APPLY a generic PLOT operation to a deficient PLOT OBJECT"]) (PLOTPROMPT - [LAMBDA (TEXT PLOT) (* jop%: " 3-Mar-85 15:42") - (PROG ((PLOTPROMPTWINDOW (fetch PLOTPROMPTWINDOW of PLOT))) - (printout PLOTPROMPTWINDOW T TEXT]) (PLOTPROP - [LAMBDA ARGS (* ; "Edited 5-May-87 18:45 by jop") - - (* ;; "As in WINDOWPROP. See also PLOTPROPMACRO") - - (COND - ((LESSP ARGS 2) - (HELP "PLOTPROP TAKES AT LEAST TWO ARGUMENTS, PLOT and PROPNAME"))) - (PROG ((PLOT (ARG ARGS 1)) - (PROPNAME (ARG ARGS 2)) - (NEWVALUE (AND (GREATERP ARGS 2) - (ARG ARGS 3))) - (FIELDS '(XLOWER XUPPER YLOWER YUPPER MIDDLEMENU RIGHTMENU OTHERMENUS LEFTMARGIN - RIGHTMARGIN TOPMARGIN BOTTOMMARGIN PLOTWINDOW PLOTWINDOWVIEWPORT - PLOTPROMPTWINDOW PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO - MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST)) - OLDVALUE USERDATA) - - (* ;; "FIELDS is given as an explicit LIST for efficiency reasons -- RECORDFIELDNAMES, although more robust, takes too long") - - (SETQ USERDATA (fetch (PLOT PLOTUSERDATA) of PLOT)) - [SETQ OLDVALUE (COND - ((MEMB PROPNAME FIELDS) - (RECORDACCESS PROPNAME PLOT)) - (T (LISTGET USERDATA PROPNAME] - [COND - ((GREATERP ARGS 2) - (COND - ((MEMB PROPNAME FIELDS) - (RECORDACCESS PROPNAME PLOT NIL 'REPLACE NEWVALUE)) - (T (COND - ((NULL USERDATA) - (replace (PLOT PLOTUSERDATA) of PLOT with (LIST PROPNAME NEWVALUE))) - (T (LISTPUT USERDATA PROPNAME NEWVALUE] - (RETURN OLDVALUE]) (PLOTPROPMACRO - [LAMBDA (ARGS) (* ; "Edited 5-May-87 18:47 by jop") - - (LET [(BPLOT (CAR ARGS)) - (BPROPNAME (CADR ARGS)) - (BVALUE (CADDR ARGS)) - (FIELDNAMES '(XLOWER XUPPER YLOWER YUPPER MIDDLEMENU RIGHTMENU OTHERMENUS LEFTMARGIN - RIGHTMARGIN TOPMARGIN BOTTOMMARGIN PLOTWINDOW PLOTWINDOWVIEWPORT - PLOTPROMPTWINDOW PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO - MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST] - (if (NEQ (CAR BPROPNAME) - 'QUOTE) - then 'IGNOREMACRO - else (if (MEMB (CADR BPROPNAME) - FIELDNAMES) - then [if (EQLENGTH ARGS 3) - then `(PROG1 (fetch (PLOT ,(CADR BPROPNAME)) of ,BPLOT) - (replace (PLOT ,(CADR BPROPNAME)) of ,BPLOT - with ,BVALUE)) - else `(fetch (PLOT ,(CADR BPROPNAME)) of ,BPLOT] - else (if (NOT (EQLENGTH ARGS 2)) - then 'IGNOREMACRO - else `(LISTGET (fetch (PLOT PLOTUSERDATA) of ,BPLOT) - ,BPROPNAME]) (PLOTREMPROP - [LAMBDA (PLOT PROPNAME) (* ; "Edited 5-May-87 18:47 by jop") - - (* ;; "Destructively removes PROPNAME from proplist of PLOT") - - (if (NOT (type? PLOT PLOT)) - then (HELP "Not a plot" PLOT)) - (PROG ((FIELDS (RECORDFIELDNAMES 'PLOT)) - (USERDATA (fetch (PLOT PLOTUSERDATA) of PLOT)) - LSTPTR OLDVALUE) - (SETQ OLDVALUE (if (MEMB PROPNAME FIELDS) - then (RECORDACCESS PROPNAME PLOT) - else (LISTGET USERDATA PROPNAME))) - [if (MEMB PROPNAME FIELDS) - then (RECORDACCESS PROPNAME PLOT NIL 'REPLACE NIL) - else (if (SETQ LSTPTR (MEMB PROPNAME USERDATA)) - then (* ; "Splice out the offending links") - - (if (EQ LSTPTR USERDATA) - then (replace (PLOT PLOTUSERDATA) of PLOT with (CDDR USERDATA)) - else (RPLACD (NLEFT USERDATA 1 LSTPTR) - (CDDR LSTPTR] - (RETURN OLDVALUE]) (PLOTSCALEFN - [LAMBDA ARGS (* ; "Edited 5-May-87 18:47 by jop") - - (* *) - - (COND - ((ILESSP ARGS 2) - (HELP "Must have at least two args"))) - (PROG ((PLOT (ARG ARGS 1)) - (AXIS (ARG ARGS 2)) - AXISINFO OLDVALUE) - (SETQ AXISINFO (SELECTQ AXIS - (X (fetch (PLOTSCALE XAXISINFO) of (fetch PLOTSCALE of PLOT))) - (Y (fetch (PLOTSCALE YAXISINFO) of (fetch PLOTSCALE of PLOT))) - (SHOULDNT))) - (SETQ OLDVALUE (fetch (AXISINFO SCALEFN) of AXISINFO)) - [COND - ((IGREATERP ARGS 2) - (LET [(NEWVALUE (ARG ARGS 3)) - (NODRAWFLG (AND (IGREATERP ARGS 3) - (ARG ARGS 4] - (replace (AXISINFO SCALEFN) of AXISINFO with NEWVALUE) - (RESCALEPLOT PLOT AXIS NODRAWFLG] - (RETURN OLDVALUE]) (PLOTTICFN - [LAMBDA ARGS (* ; "Edited 6-May-87 09:23 by jop") - - (if (ILESSP ARGS 2) - then (HELP "Must have at least two args")) - (PROG ((PLOT (ARG ARGS 1)) - (AXIS (ARG ARGS 2)) - AXISINFO OLDVALUE) - (SETQ AXISINFO (SELECTQ AXIS - (X (fetch (PLOTSCALE XAXISINFO) of (fetch PLOTSCALE of PLOT))) - (Y (fetch (PLOTSCALE YAXISINFO) of (fetch PLOTSCALE of PLOT))) - (SHOULDNT))) - (SETQ OLDVALUE (fetch (AXISINFO TICFN) of AXISINFO)) - (if (IGREATERP ARGS 2) - then (LET [(NEWVALUE (ARG ARGS 3)) - (NODRAWFLG (AND (IGREATERP ARGS 3) - (ARG ARGS 4] - (replace (AXISINFO TICFN) of AXISINFO with NEWVALUE) - (RESCALEPLOT PLOT AXIS NODRAWFLG))) - (RETURN OLDVALUE]) (PLOTTICINFO - [LAMBDA (PLOT AXIS NEWTICINFO NODRAWFLG) (* ; "Edited 6-May-87 09:24 by jop") - - (PROG ((PLOTSCALE (fetch PLOTSCALE of PLOT)) - OLDVALUE) - (SETQ OLDVALUE (SELECTQ AXIS - (X (fetch (PLOTSCALE XTICINFO) of PLOTSCALE)) - (Y (fetch (PLOTSCALE YTICINFO) of PLOTSCALE)) - (SHOULDNT))) - (if (type? TICINFO NEWTICINFO) - then (SELECTQ AXIS - (X (replace (PLOTSCALE XTICINFO) of PLOTSCALE with NEWTICINFO)) - (Y (replace (PLOTSCALE YTICINFO) of PLOTSCALE with NEWTICINFO)) - (SHOULDNT)) - (if (NULL NODRAWFLG) - then (REDRAWPLOTWINDOW PLOT))) - (RETURN OLDVALUE]) (PLOTTICMETHOD - [LAMBDA (PLOT MARGINNAME NEWMETHOD NODRAWFLG) (* ; "Edited 6-May-87 09:24 by jop") - - (* ;; "If NEWMETHOD not present then RETURNS current tic method for margin MARGIN , else replaces the method with NEWMETHOD, which may be a list of numbers, or a list of CONS pairs (VALUE . LABEL), or a function to be APPLIED to MARGIN PLOTSCALE PLOT, or the atom DEFAULT") - - (PROG (MARGIN OLDVALUE) - (SETQ MARGIN (SELECTQ MARGINNAME - (BOTTOM (fetch BOTTOMMARGIN of PLOT)) - (LEFT (fetch LEFTMARGIN of PLOT)) - (TOP (fetch TOPMARGIN of PLOT)) - (RIGHT (fetch RIGHTMARGIN of PLOT)) - (HELP "ILLEGAL MARGIN" MARGIN))) - (SETQ OLDVALUE (fetch (MARGIN TICMETHOD) of MARGIN)) - (if NEWMETHOD - then (replace (MARGIN TICMETHOD) of MARGIN with NEWMETHOD) - (if (AND (NULL NODRAWFLG) - (fetch TICS? of MARGIN)) - then (REDRAWPLOTWINDOW PLOT))) - (RETURN OLDVALUE]) (PLOTTICS - [LAMBDA ARGS (* ; "Edited 6-May-87 09:24 by jop") - - (COND - ((ILESSP ARGS 2) - (HELP "Must have at least two args"))) - (PROG ((PLOT (ARG ARGS 1)) - (MARGINNAME (ARG ARGS 2)) - MARGIN OLDVALUE) - (SETQ MARGIN (SELECTQ MARGINNAME - (BOTTOM (fetch BOTTOMMARGIN of PLOT)) - (LEFT (fetch LEFTMARGIN of PLOT)) - (TOP (fetch TOPMARGIN of PLOT)) - (RIGHT (fetch RIGHTMARGIN of PLOT)) - (HELP "Illegal margin" MARGINNAME))) - (SETQ OLDVALUE (fetch (MARGIN TICS?) of MARGIN)) - [COND - ((IGREATERP ARGS 2) - (LET [(NEWVALUE (ARG ARGS 3)) - (NODRAWFLG (AND (IGREATERP ARGS 3) - (ARG ARGS 4] - (replace (MARGIN TICS?) of MARGIN with NEWVALUE) - (COND - ((NULL NODRAWFLG) - (REDRAWPLOTWINDOW PLOT] - (RETURN OLDVALUE]) (PRINTFONT - [LAMBDA (FONT STREAM) (* ; "Edited 6-May-87 09:25 by jop") - - (PRINTOUT STREAM "(READFONT)(FAMILY" %, |.P2| (FONTPROP FONT 'FAMILY) - %, "SIZE" %, |.P2| (FONTPROP FONT 'SIZE) - %, "FACE" %, (FONTPROP FONT 'FACE) - %, "ROTATION" %, (FONTPROP FONT 'ROTATION) - %, "DEVICE" %, (FONTPROP FONT 'DEVICE) - ")") - T]) (PRINTMENU - [LAMBDA (MENU STREAM) (* ; "Edited 6-May-87 09:25 by jop") - - (* ;; "Function for dumping menus on file") - - (PRINTOUT STREAM "(READMENU)(ITEMS" %, |.P2| (fetch ITEMS of MENU) - %, "WHENSELECTEDFN" %, |.P2| (fetch WHENSELECTEDFN of MENU) - %, "WHENHELDFN" %, |.P2| (fetch WHENHELDFN of MENU) - %, "WHENUNHELDFN" %, |.P2| (fetch WHENUNHELDFN of MENU) - %, "MENUPOSITION" %, |.P2| (fetch MENUPOSITION of MENU) - %, "MENUOFFSET" %, |.P2| (fetch MENUOFFSET of MENU) - %,) (* ; - "use HPRINT here to avoid dumping the whole font") - - (PRINTOUT STREAM "MENUFONT" %,) - (HPRINT (fetch MENUFONT of MENU) - STREAM T T) - (PRINTOUT STREAM %,) - (PRINTOUT STREAM "TITLE" %, |.P2| (fetch TITLE of MENU) - %, "CENTERFLG" %, |.P2| (fetch CENTERFLG of MENU) - %, "MENUROWS" %, |.P2| (fetch MENUROWS of MENU) - %, "MENUCOLUMNS" %, |.P2| (fetch MENUCOLUMNS of MENU) - %, "ITEMHEIGHT" %, |.P2| (fetch ITEMHEIGHT of MENU) - %, "ITEMWIDTH" %, |.P2| (fetch ITEMWIDTH of MENU) - %, "MENUBORDERSIZE" %, |.P2| (fetch MENUBORDERSIZE of MENU) - %, "MENUOUTLINESIZE" %, |.P2| (fetch MENUOUTLINESIZE of MENU) - %, "CHANGEOFFSETFLG" %, |.P2| (fetch CHANGEOFFSETFLG of MENU) - ")") - T]) (REDRAWPLOTWINDOW - [LAMBDA (PLOT) (* ; "Edited 7-May-87 18:16 by jop") - - (* ;; "Redraws the PLOTWINDOW of a PLOT") - - (PROG ((PLOTWINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (PLOTWINDOWVIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) - (SELECTEDOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) - MINSIZE) - (COND - ((NOT (OPENWP PLOTWINDOW)) (* ; - "Assumes OPENPLOTWINDOW will call REDRAWPLOTWINDOW") - - (OPENPLOTWINDOW PLOT)) - (T (CREATETICLISTS PLOT) (* ; "Setup the tic lists ") - - (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP PLOTWINDOW 'DSP) - PLOT)) (* ; - "Establish a min size for the WINDOW") - (* ; - "Uses MAINWINDOWMINSIZE since PLOTWINDOW is the main window of a group") - - [WINDOWPROP PLOTWINDOW 'MAINWINDOWMINSIZE (CONS (WIDTHIFWINDOW (CAR MINSIZE) - (WINDOWPROP PLOTWINDOW - 'BORDER)) - (HEIGHTIFWINDOW (CDR MINSIZE) - (WINDOWPROP PLOTWINDOW - 'TITLE) - (WINDOWPROP PLOTWINDOW - 'BORDER] - (COND - ((OR (LESSP (WINDOWPROP PLOTWINDOW 'WIDTH) - (CAR MINSIZE)) - (LESSP (WINDOWPROP PLOTWINDOW 'HEIGHT) - (CDR MINSIZE))) - (PROMPTPRINT "Plotwindow too small: reshape") - (* ; - "Assumes SHAPEW will call REDRAWPLOTWINDOW") - - (SHAPEW PLOTWINDOW)) - (T (ADJUSTVIEWPORT PLOTWINDOWVIEWPORT (DSPCLIPPINGREGION NIL PLOTWINDOW) - PLOT) - (CLEARW PLOTWINDOW) - (DRAWPLOT PLOT (WINDOWPROP PLOTWINDOW 'DSP) - PLOTWINDOWVIEWPORT - (DSPCLIPPINGREGION NIL PLOTWINDOW)) - (COND - (SELECTEDOBJECT (HIGHLIGHTPLOTOBJECT SELECTEDOBJECT PLOT]) (RELABELSELECTEDPLOTOBJECT - [LAMBDA (SELECTEDOBJECT PLOT) (* ; "Edited 6-May-87 09:26 by jop") - - (PROG ((PLOTPROMPTWINDOW (fetch (PLOT PLOTPROMPTWINDOW) of PLOT)) - LABEL LABELFLG) (* ; - "If the object is labeled, delete the label.") - - (if (PLOTOBJECTPROP SELECTEDOBJECT 'LABEL) - then (UNLABELPLOTOBJECT SELECTEDOBJECT PLOT) - (SETQ LABELFLG T)) - (SETQ LABEL (fetch (PLOTOBJECT OBJECTLABEL) of SELECTEDOBJECT)) - (TERPRI PLOTPROMPTWINDOW) - [SETQ LABEL (PROMPTFORWORD "TYPE NEW LABEL :" LABEL "ENTER NIL FOR NO LABEL" - PLOTPROMPTWINDOW NIL NIL (CHARCODE (EOL LF ESCAPE TAB] - (replace (PLOTOBJECT OBJECTLABEL) of SELECTEDOBJECT with LABEL) - (LABELPLOTOBJECT SELECTEDOBJECT PLOT]) (RESCALEPLOT - [LAMBDA (PLOT AXIS NODRAWFLG) (* ; "Edited 6-May-87 09:26 by jop") - - [COND - ((NULL AXIS) - (SETQ AXIS 'BOTH] - (LET* ((PLOTSCALE (fetch PLOTSCALE of PLOT)) - (PLOTOBJECTS (fetch PLOTOBJECTS of PLOT)) - (PLOTEXTENT (EXTENTOFPLOT PLOT)) - (MINX (fetch (EXTENT MINX) of PLOTEXTENT)) - (MAXX (fetch (EXTENT MAXX) of PLOTEXTENT)) - (MINY (fetch (EXTENT MINY) of PLOTEXTENT)) - (MAXY (fetch (EXTENT MAXY) of PLOTEXTENT))) - (COND - (PLOTOBJECTS (LET ((XINTERVAL (fetch (PLOTSCALE XINTERVAL) of PLOTSCALE)) - (XAXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) - (YINTERVAL (fetch (PLOTSCALE YINTERVAL) of PLOTSCALE)) - (YAXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) - TEMP) - [COND - ((AND (OR (EQ AXIS 'BOTH) - (EQ AXIS 'X)) - (GREATERP MAXX MINX)) - (LET ((AXISINFO (fetch (PLOTSCALE XAXISINFO) of PLOTSCALE)) - TICINFO) - (SETQ TICINFO (CHOOSETICS MINX MAXX AXISINFO PLOT)) - (replace (PLOTSCALE XTICINFO) of PLOTSCALE with TICINFO) - (replace (PLOTSCALE XINTERVAL) of PLOTSCALE - with (CHOOSESCALE MINX MAXX AXISINFO TICINFO PLOT] - [COND - ((AND (OR (EQ AXIS 'BOTH) - (EQ AXIS 'Y)) - (GREATERP MAXY MINY)) - (LET ((AXISINFO (fetch (PLOTSCALE YAXISINFO) of PLOTSCALE)) - TICINFO) - (SETQ TICINFO (CHOOSETICS MINY MAXY AXISINFO PLOT)) - (replace (PLOTSCALE YTICINFO) of PLOTSCALE with TICINFO) - (replace (PLOTSCALE YINTERVAL) of PLOTSCALE - with (CHOOSESCALE MINY MAXY AXISINFO TICINFO PLOT] - (COND - ((NULL NODRAWFLG) - (REDRAWPLOTWINDOW PLOT]) (SCALE - [LAMBDA (MIN MAX NTICS ROUND POWER) (* ; "Edited 6-May-87 09:26 by jop") - - (* ;; "Scaling algorithm for plots. NTICS is the desired number of tics. Round is a list of acceptable scaling factors. POWER is the power of ten to use. Returns a TICINFO including NEWMAX, NEWMIN, INC, and NTICS") - - [COND - ((NULL ROUND) - (SETQ ROUND '(5.0 2.5 2.0 1.5 1.0] (* ; - "Rounding Constants. Notice that they are in decreasing order and end with 1.0") - - (PROG ((NUMINC (SUB1 NTICS)) - RAWINC MANTISSA INDEX) - (SETQ RAWINC (FQUOTIENT (DIFFERENCE MAX MIN) - NUMINC)) (* ; "POWER is the power of ten") - - [SETQ POWER (EXPT 10.0 (OR POWER (PLOT.FLOOR (PLOT.LOG10 RAWINC] - (* ; "MANTISSA is the scale factor") - - (SETQ MANTISSA (FQUOTIENT RAWINC POWER)) - [COND - ((GREATERP MANTISSA (CAR ROUND)) - (SETQ POWER (TIMES 10 POWER)) - (SETQ INDEX (LAST ROUND))) - (T (SETQ INDEX (for MARK on ROUND as TEST in (CDR ROUND) until (GREATERP MANTISSA TEST) - finally (RETURN MARK] - - (* ;; "Find new max and new min") - - (RETURN (bind (NEWMAX _ MIN) - NEWMIN INC FACTOR LOWERMULT UPPERMULT while (LESSP NEWMAX MAX) - do (SETQ INC (TIMES (CAR INDEX) - POWER)) - (SETQ FACTOR (FQUOTIENT (FDIFFERENCE (FPLUS MAX MIN) - (FTIMES NUMINC INC)) - (FTIMES 2.0 INC))) - [SETQ NEWMIN (FTIMES INC (SETQ LOWERMULT (PLOT.CEILING FACTOR] - [COND - ((GREATERP NEWMIN MIN) - (SETQ NEWMIN (FTIMES INC (SETQ LOWERMULT (SUB1 LOWERMULT] - (COND - ((AND (GEQ MIN 0.0) - (MINUSP NEWMIN)) - (SETQ LOWERMULT 0) - (SETQ NEWMIN 0.0))) - (SETQ UPPERMULT (IPLUS LOWERMULT NUMINC)) - (SETQ NEWMAX (FTIMES INC UPPERMULT)) - [COND - ((AND (LEQ MAX 0.0) - (GREATERP NEWMAX 0.0)) - (SETQ UPPERMULT 0) - (SETQ NEWMAX 0.0) - (SETQ LOWERMULT (IMINUS NUMINC)) - (SETQ NEWMIN (SETQ NEWMIN (FTIMES INC LOWERMULT] - [COND - ((NULL (SETQ INDEX (NLEFT ROUND 1 INDEX))) - (SETQ INDEX (LAST ROUND)) - (SETQ POWER (TIMES 10 POWER] - finally (RETURN (create TICINFO - TICMAX _ NEWMAX - TICMIN _ NEWMIN - TICINC _ INC - NTICS _ NTICS]) (TOGGELLABEL - [LAMBDA (SELECTEDOBJECT PLOT) (* ; "Edited 6-May-87 09:26 by jop") - - (COND - ((PLOTOBJECTPROP SELECTEDOBJECT 'LABEL) - (UNLABELPLOTOBJECT SELECTEDOBJECT PLOT)) - (T (LABELPLOTOBJECT SELECTEDOBJECT PLOT]) (TOGGLEEXTENDEDAXES - [LAMBDA (PLOT AXIS) (* jop%: "10-Dec-85 17:56") - - (* *) - - [COND - ((NULL AXIS) - (SETQ AXIS 'BOTH] - [PROG [(XSCALEFN (PLOTSCALEFN PLOT 'X)) - (YSCALEFN (PLOTSCALEFN PLOT 'Y] - [COND - ((OR (EQ AXIS 'X) - (EQ AXIS 'BOTH)) - (COND - ((EQ XSCALEFN (FUNCTION EXTENDEDSCALEFN)) (* recover previous state) - (PLOTSCALEFN PLOT 'X (PLOTPROP PLOT 'OLDXSCALEFN) - T)) - (T (* Remember the old fn for next time) - (PLOTPROP PLOT 'OLDXSCALEFN (PLOTSCALEFN PLOT 'X)) - (PLOTSCALEFN PLOT 'X (FUNCTION EXTENDEDSCALEFN) - T] - (COND - ((OR (EQ AXIS 'Y) - (EQ AXIS 'BOTH)) - (COND - ((EQ YSCALEFN (FUNCTION EXTENDEDSCALEFN)) - (PLOTSCALEFN PLOT 'Y (PLOTPROP PLOT 'OLDYSCALEFN) - T)) - (T (PLOTPROP PLOT 'OLDYSCALEFN (PLOTSCALEFN PLOT 'Y)) - (PLOTSCALEFN PLOT 'Y (FUNCTION EXTENDEDSCALEFN) - T] - (RESCALEPLOT PLOT AXIS]) (TOGGLEFIXEDMENU - [LAMBDA (PLOT) (* jop%: "12-Dec-85 10:34") - - (* *) - - (PLOT.FIXRIGHTMENU PLOT (NOT (PLOT.FIXRIGHTMENU PLOT]) (TOGGLETICS - [LAMBDA (PLOT MARGINNAME) (* jop%: "10-Dec-85 21:27") - [COND - [(NULL MARGINNAME) - (for MARGIN in '(BOTTOM LEFT) do (COND - ((PLOTTICS PLOT MARGIN) - (PLOTTICS PLOT MARGIN NIL T)) - (T (PLOTTICS PLOT MARGIN T T] - (T (COND - ((PLOTTICS PLOT MARGINNAME) - (PLOTTICS PLOT MARGINNAME NIL T)) - (T (PLOTTICS PLOT MARGINNAME T T] - (REDRAWPLOTWINDOW PLOT]) (TRANSLATEPLOTOBJECT - [LAMBDA (OBJECT DX DY PLOT NODRAWFLG) (* ; "Edited 6-May-87 09:27 by jop") - - (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - (WHENTRANSLATEDFN (PLOTOBJECTPROP OBJECT 'WHENTRANSLATEDFN] - (if (NULL NODRAWFLG) - then (if (EQ OBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT)) - then (LOWLIGHTPLOTOBJECT (fetch (PLOT SELECTEDOBJECT) of PLOT) - PLOT) - (replace (PLOT SELECTEDOBJECT) of PLOT with NIL)) - (ERASEPLOTOBJECT OBJECT PLOT)) (* ; - "Destructively modify the data structure for OBJECT") - - (MOVEPLOTOBJECT OBJECT DX DY PLOT) - (if (NULL NODRAWFLG) - then (DRAWPLOTOBJECT OBJECT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT) - PLOT)) - (if TEXTOBJECT - then (TRANSLATEPLOTOBJECT TEXTOBJECT DX DY PLOT NODRAWFLG)) - (APPLY.AFTERFN WHENTRANSLATEDFN OBJECT DX DY PLOT NODRAWFLG]) (UNDELETEPLOTOBJECT - [LAMBDA (PLOT MODE) (* ; "Edited 6-May-87 09:27 by jop") - - (* ;; "MODE MAY BE ONE OF TOP, SELECT, ABOVE, ALL,. NIL defaults to TOP. TOP means restore the top element of the save stack. SELECT means choose an object to restore from a menu. ABOVE means restore all objects above the selected object. ALL means restore all the objects on the save stack.") - - (if (NULL MODE) - then (SETQ MODE 'TOP)) - (PROG ((SAVELIST (fetch (PLOT PLOTSAVELIST) of PLOT)) - SELECTION OBJECTSTORESTORE) - (if (NULL SAVELIST) - then (PLOTPROMPT "No object to undelete" PLOT) - (RETURN NIL)) - (SETQ OBJECTSTORESTORE - (SELECTQ MODE - (TOP (LIST (CAR SAVELIST))) - (ALL SAVELIST) - ((ABOVE SELECT) - [SETQ SELECTION - (MENU (create MENU - ITEMS _ (bind OBJECTLABEL for OBJECT in SAVELIST as I from 1 - collect (SETQ OBJECTLABEL (fetch (PLOTOBJECT OBJECTLABEL - ) of OBJECT)) - (LIST (if OBJECTLABEL - then (CONCAT (PLOTOBJECTSUBTYPE OBJECT) - " " OBJECTLABEL) - else (PLOTOBJECTSUBTYPE OBJECT)) - I] - (AND SELECTION - (if (EQ MODE 'SELECT) - then (LIST (CAR (NTH SAVELIST SELECTION))) - else (for I from 1 to SELECTION as OBJECT in SAVELIST collect OBJECT)))) - (SHOULDNT "Illegal mode"))) - [if OBJECTSTORESTORE - then (for OBJECT in OBJECTSTORESTORE do (ADDPLOTOBJECT OBJECT PLOT)) - (replace (PLOT PLOTSAVELIST) of PLOT with (SELECTQ MODE - (TOP (CDR SAVELIST)) - (ALL NIL) - (ABOVE (CDR (NTH SAVELIST SELECTION) - )) - (SELECT (DREMOVE (CAR - OBJECTSTORESTORE - ) - SAVELIST)) - (SHOULDNT "ILLEGAL MODE"] - (RETURN OBJECTSTORESTORE]) (UNLABELPLOTOBJECT - [LAMBDA (OBJECT PLOT) (* ; "Edited 6-May-87 09:27 by jop") - - (* *) - - (PROG [(TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - (WHENUNLABELEDFN (PLOTOBJECTPROP OBJECT 'WHENUNLABELEDFN] - (COND - (TEXTOBJECT (ERASEPLOTOBJECT TEXTOBJECT PLOT) - (PLOTOBJECTPROP OBJECT 'LABEL NIL) - (APPLY.AFTERFN WHENUNLABELEDFN OBJECT PLOT)) - (T (PLOTPROMPT "NOT A LABELED OBJECT" PLOT]) (WHICHLABEL - [LAMBDA (PLOT) (* ; "Edited 6-May-87 09:27 by jop") - - (* ;; "Prompt for new label and make the required call to ASKFORLABEL") - - (PROG ([LMENU (CONSTANT (create MENU - ITEMS _ '(TOP LEFT BOTTOM RIGHT] - MARGIN) - (PLOTPROMPT "Select a margin" PLOT) - (SETQ MARGIN (MENU LMENU)) - (AND MARGIN (ASKFORLABEL PLOT MARGIN]) (WHICHPLOT - [LAMBDA (X Y) (* ; "Edited 6-May-87 09:27 by jop") - - (* ;; "like WHICHW but returns corresponding plot. First arg may be a window") - - (PROG ((W (OR (WINDOWP X) - (WHICHW X Y))) - PLOT) - [SETQ PLOT (OR (WINDOWPROP W 'PLOT) - (WINDOWPROP (WINDOWPROP W 'ICONFOR) - 'PLOT] - (RETURN (COND - ((type? PLOT PLOT) - PLOT]) ) (* ;; "Fns to do our own number printing") (DEFINEQ (PLOT.PRINTNUM - [LAMBDA (F) (* ; "Edited 7-May-87 17:23 by jop") - - (SETQ F (FLOAT F)) - (LET ((STR (CL:MAKE-ARRAY 14 :ELEMENT-TYPE 'CL:STRING-CHAR :FILL-POINTER 0)) - [MINUSFLAG (AND (< F 0.0) - (SETQ F (- F] - (ROUND 5) - NUMSTR INTEXP) - (IF (AND (OR (< F 0.001) - (>= F 1.0E+7)) - (NOT (ZEROP F))) - THEN (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) - (FLTSTR F ROUND)) - (PLOT.ENUM-STRING STR NUMSTR INTEXP MINUSFLAG) - ELSE (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) - (FLTSTR F ROUND)) - (PLOT.FNUM-STRING STR NUMSTR INTEXP MINUSFLAG]) (PLOT.FNUM-STRING - [LAMBDA (OUTSTR MANTSTR INTEXP MINUSP) (* ; "Edited 7-May-87 17:21 by jop") - - (LET* ((DIGITS (CL:LENGTH MANTSTR)) - (POINTPLACE (+ DIGITS INTEXP)) - (INDEX 0)) - (COND - (MINUSP (CL:SETF (CL:AREF OUTSTR 0) - #\-) - (SETQ INDEX 1))) - [COND - [(< POINTPLACE 0) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\0) - (SETQ INDEX (CL:1+ INDEX)) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\.) - (SETQ INDEX (CL:1+ INDEX)) - (CL:DOTIMES (I (- POINTPLACE)) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\0) - (SETQ INDEX (CL:1+ INDEX))) - (CL:DOTIMES (I DIGITS) - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR I)) - (SETQ INDEX (CL:1+ INDEX] - [(< INTEXP 0) - (CL:DOTIMES (I POINTPLACE) - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR I)) - (SETQ INDEX (CL:1+ INDEX))) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\.) - (SETQ INDEX (CL:1+ INDEX)) - (CL:DO ((I POINTPLACE (CL:1+ I))) - ((EQ I DIGITS)) - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR I)) - (SETQ INDEX (CL:1+ INDEX] - (T (CL:DOTIMES (I DIGITS) - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR I)) - (SETQ INDEX (CL:1+ INDEX))) - (CL:DOTIMES (I INTEXP) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\0) - (SETQ INDEX (CL:1+ INDEX))) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\.) - (SETQ INDEX (CL:1+ INDEX)) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\0) - (SETQ INDEX (CL:1+ INDEX] - [COND - ((OR (< POINTPLACE 0) - (< INTEXP 0)) - - (* ;; "Trim off extraneous zeros") - - (CL:DO ((I (CL:1- INDEX) - (CL:1- I))) - ((NOT (EQ (CL:AREF OUTSTR I) - #\0)) - (CL:IF (NOT (EQ (CL:AREF OUTSTR I) - #\.)) - (SETQ INDEX (CL:1+ I)) - (SETQ INDEX (+ I 2] - (CL:SETF (CL:FILL-POINTER OUTSTR) - INDEX) - OUTSTR]) (PLOT.ENUM-STRING - [LAMBDA (OUTSTR MANTSTR INTEXP MINUSP) (* ; "Edited 13-May-87 09:21 by jop") - - (* ;; "Prints exponential notation observing rounding & exponent spacing") - - (LET ((DIGITS (CL:LENGTH MANTSTR)) - (INDEX 0) - EXPOFFSET) - (COND - (MINUSP (CL:SETF (CL:AREF OUTSTR 0) - #\-) - (SETQ INDEX 1))) - - (* ;; "Print the mantissa") - - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR 0)) - (SETQ INDEX (CL:1+ INDEX)) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\.) - (SETQ INDEX (CL:1+ INDEX)) - (CL:DO ((I 1 (CL:1+ I))) - ((EQ I DIGITS)) - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR I)) - (SETQ INDEX (CL:1+ INDEX))) - - (* ;; "Trim off extraneous zeros") - - [CL:DO ((I (CL:1- INDEX) - (CL:1- I))) - ((NOT (EQ (CL:AREF OUTSTR I) - #\0)) - (CL:IF (NOT (EQ (CL:AREF OUTSTR I) - #\.)) - (SETQ INDEX (CL:1+ I)) - (SETQ INDEX (+ I 2] - - (* ;; "mantissa done - now for the exponent") - - (SETQ EXPOFFSET (- (+ INTEXP DIGITS) - 1)) - (SETQ MANTSTR (MKSTRING EXPOFFSET)) - (SETQ DIGITS (CL:LENGTH MANTSTR)) - (CL:SETF (CL:AREF OUTSTR INDEX) - #\E) - (SETQ INDEX (CL:1+ INDEX)) - (CL:DOTIMES (I DIGITS) - (CL:SETF (CL:AREF OUTSTR INDEX) - (CL:AREF MANTSTR I)) - (SETQ INDEX (CL:1+ INDEX))) - (CL:SETF (CL:FILL-POINTER OUTSTR) - INDEX) - OUTSTR]) (CREATETICLISTS - [LAMBDA (PLOT) (* ; "Edited 7-May-87 18:08 by jop") - - (LET ((BOTTOMMARGIN (fetch (PLOT BOTTOMMARGIN) of PLOT)) - (LEFTMARGIN (fetch (PLOT LEFTMARGIN) of PLOT)) - (RIGHTMARGIN (fetch (PLOT RIGHTMARGIN) of PLOT)) - (TOPMARGIN (fetch (PLOT TOPMARGIN) of PLOT))) - [IF (fetch (MARGIN TICS?) of BOTTOMMARGIN) - THEN (replace (MARGIN TICLIST) of BOTTOMMARGIN with (NORMALIZE-TICLIST - (GETTICLIST 'BOTTOM PLOT] - [IF (fetch (MARGIN TICS?) of LEFTMARGIN) - THEN (replace (MARGIN TICLIST) of LEFTMARGIN with (NORMALIZE-TICLIST (GETTICLIST - 'LEFT PLOT] - [IF (fetch (MARGIN TICS?) of RIGHTMARGIN) - THEN (replace (MARGIN TICLIST) of RIGHTMARGIN with (NORMALIZE-TICLIST - (GETTICLIST 'RIGHT PLOT] - [IF (fetch (MARGIN TICS?) of TOPMARGIN) - THEN (replace (MARGIN TICLIST) of TOPMARGIN with (NORMALIZE-TICLIST (GETTICLIST - 'TOP PLOT] - NIL]) (NORMALIZE-TICLIST - [LAMBDA (TICLIST) (* ; "Edited 27-May-87 18:19 by jop") - - (BIND VALUE LABEL FOR TIC IN TICLIST COLLECT (IF (LISTP TIC) - THEN (SETQ VALUE (CAR TIC)) - (SETQ LABEL (CDR TIC)) - ELSE (SETQ VALUE (SETQ LABEL TIC))) - (CONS VALUE (IF (FLOATP LABEL) - THEN (PLOT.PRINTNUM LABEL) - ELSE LABEL]) ) (DEFINEQ (DRAW-TICS-LEFT-RIGHT - [LAMBDA (TICLIST MIN MAX RIGHTTIC LEFTTIC TICOFFSET TICFONT STREAM VIEWPORT LEFT-P) - (* ; "Edited 13-May-87 16:56 by jop") - - (LET ((FONT (DSPFONT NIL STREAM))) - (DSPFONT TICFONT STREAM) - [bind YWINDOWLOC TICVALUE TICLABEL for TICPAIR in TICLIST - do (SETQ TICVALUE (CAR TICPAIR)) - (SETQ TICLABEL (CDR TICPAIR)) - (if (AND (GEQ TICVALUE MIN) - (LEQ TICVALUE MAX)) - then (SETQ YWINDOWLOC (WORLDTOSTREAMY TICVALUE VIEWPORT)) - (MOVETO LEFTTIC YWINDOWLOC STREAM) - (DRAWTO RIGHTTIC YWINDOWLOC (DSPSCALE NIL STREAM) - 'REPLACE STREAM) - (if TICLABEL - then (IF LEFT-P - THEN (MOVETO (DIFFERENCE LEFTTIC (PLUS TICOFFSET - (STRINGWIDTH TICLABEL - STREAM))) - YWINDOWLOC STREAM) - ELSE (MOVETO (PLUS RIGHTTIC TICOFFSET) - YWINDOWLOC STREAM)) - (PRIN1 TICLABEL STREAM] - (DSPFONT FONT STREAM]) (DRAW-TICS-TOP-BOTTOM - [LAMBDA (TICLIST MIN MAX TOPOFTIC BOTTOMOFTIC TICOFFSET TICFONT STREAM VIEWPORT BOTTOM-P) - (* ; "Edited 13-May-87 17:03 by jop") - - (LET ((FONT (DSPFONT NIL STREAM))) - (DSPFONT TICFONT STREAM) - [bind XWINDOWLOC TICVALUE TICLABEL for TICPAIR in TICLIST - do (SETQ TICVALUE (CAR TICPAIR)) - (SETQ TICLABEL (CDR TICPAIR)) - (if (AND (GEQ TICVALUE MIN) - (LEQ TICVALUE MAX)) - then (SETQ XWINDOWLOC (WORLDTOSTREAMX TICVALUE VIEWPORT)) - (* ; "always draw the tic mark") - - (MOVETO XWINDOWLOC TOPOFTIC STREAM) - (DRAWTO XWINDOWLOC BOTTOMOFTIC (DSPSCALE NIL STREAM) - 'REPLACE STREAM) - (if TICLABEL - then (IF BOTTOM-P - THEN (MOVETO XWINDOWLOC (DIFFERENCE BOTTOMOFTIC TICOFFSET) - STREAM) - ELSE (MOVETO XWINDOWLOC (PLUS TOPOFTIC TICOFFSET) - STREAM)) - (RELMOVETO (IMINUS (IQUOTIENT (STRINGWIDTH TICLABEL TICFONT) - 2)) - 0 STREAM) - (PRIN1 TICLABEL STREAM] - (DSPFONT FONT STREAM]) (DRAW-LABEL-LEFT-RIGHT - [LAMBDA (LABEL LABELFONT XOFFSET STREAMREGION STREAM) (* ; "Edited 13-May-87 17:15 by jop") - - (LET ((FONT (DSPFONT NIL STREAM))) - (DSPFONT LABELFONT STREAM) - (MOVETO XOFFSET (DIFFERENCE (fetch (REGION TOP) of STREAMREGION) - (IQUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of STREAMREGION) - (ITIMES (FONTPROP STREAM 'HEIGHT) - (NCHARS LABEL))) - 2)) - STREAM) - (bind (LF _ (DSPLINEFEED NIL STREAM)) for I from 0 to (SUB1 (CL:LENGTH LABEL)) - do (CL:PRINC (CL:AREF LABEL I) - STREAM) - (MOVETO XOFFSET (IPLUS (DSPYPOSITION NIL STREAM) - LF) - STREAM)) - (DSPFONT FONT STREAM]) (DRAW-LABEL-TOP-BOTTOM - [LAMBDA (LABEL LABELFONT YOFFSET STREAMREGION STREAM) (* ; "Edited 13-May-87 16:34 by jop") - - (LET ((FONT (DSPFONT NIL STREAM))) - (DSPFONT LABELFONT STREAM) - (MOVETO (PLUS (fetch (REGION LEFT) of STREAMREGION) - (IMAX 0 (IQUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of STREAMREGION) - (STRINGWIDTH LABEL STREAM)) - 2))) - YOFFSET STREAM) - (PRIN1 LABEL STREAM) - (DSPFONT FONT STREAM]) ) (RPAQQ PLOT.DEFAULTMIDDLEMENUITEMS ((Label TOGGELLABEL "Toggle label on/off" (SUBITEMS (Relabel RELABELSELECTEDPLOTOBJECT "Change label"))) (Delete DELETEPLOTOBJECT "Delete object"))) (RPAQQ PLOT.DEFAULTRIGHTMENUITEMS ((Layout PLOT.SKETCH.CREATE "Create a sketch of the PLOT") (Redraw REDRAWPLOTWINDOW "Redraw plot") [Rescale RESCALEPLOT "Rescale plot axes" (SUBITEMS (X% Axis (RESCALEPLOT 'X) "Rescale X axis" (SUBITEMS (Automatic (RESCALEPLOT 'X) "Rescale automatically") (Manual (MANUALRESCALE 'X) "Rescale manually"))) (Y% Axis (RESCALEPLOT 'Y) "Rescale Y axis" (SUBITEMS (Automatic (RESCALEPLOT 'Y) "Rescale automatically") (Manual (MANUALRESCALE 'Y) "Rescale manually"] (Extend TOGGLEEXTENDEDAXES "Extend plot axes on/off" (SUBITEMS (X% Axis (TOGGLEEXTENDEDAXES 'X) "Extend X axis on/off") (Y% Axis (TOGGLEEXTENDEDAXES 'Y) "Extend Y axis on/off"))) (Labels WHICHLABEL "Relabel plot" (SUBITEMS (Title (ASKFORLABEL 'TOP) "Title plot") (Left (ASKFORLABEL 'LEFT) "Label left of plot") (Bottom (ASKFORLABEL 'BOTTOM) "Label bottom of plot") (Right (ASKFORLABEL 'RIGHT) "Label right of plot"))) (Tics TOGGLETICS "Tics on or off" (SUBITEMS (Top (TOGGLETICS 'TOP) "Top tics on/off") (Left (TOGGLETICS 'LEFT) "Left tics on/off") (Bottom (TOGGLETICS 'BOTTOM) "Bottom tics on/off") (Right (TOGGLETICS 'RIGHT) "Right tics on/off"))) (Undelete UNDELETEPLOTOBJECT "Undelete last deleted object" (SUBITEMS (Top (UNDELETEPLOTOBJECT 'TOP) "Undelete last deleted object" ) (Select (UNDELETEPLOTOBJECT 'SELECT) "Select object to undelete" ) (Above (UNDELETEPLOTOBJECT 'ABOVE) "Undelete all objects above selected object" ) (All (UNDELETEPLOTOBJECT 'ALL) "Undelete all deleted objects" ))) (Fixed% Menu TOGGLEFIXEDMENU "Fix Plot menu"))) (RPAQQ OBJECTOPSTABLE ((POINT (DRAWFN DRAWPOINTOBJECT) (ERASEFN ERASEPOINTOBJECT) (HIGHLIGHTFN HIGHLIGHTPOINT) (MOVEFN MOVEPOINT) (LABELFN LABELPOINT) (EXTENTFN EXTENTOFPOINT) (DISTANCEFN DISTANCETOPOINT) (COPYFN COPYPOINT) (PUTFN PUTPOINT) (GETFN GETPOINT)) (CURVE (DRAWFN DRAWCURVEOBJECT) (ERASEFN ERASECURVEOBJECT) (HIGHLIGHTFN HIGHLIGHTCURVE) (MOVEFN MOVECURVE) (EXTENTFN EXTENTOFCURVE) (DISTANCEFN DISTANCETOCURVE) (COPYFN COPYCURVE) (PUTFN PUTCURVE) (GETFN GETCURVE)) (POLYGON (DRAWFN DRAWPOLYGONOBJECT) (ERASEFN ERASEPOLYGONOBJECT) (HIGHLIGHTFN HIGHLIGHTPOLYGON) (MOVEFN MOVEPOLYGON) (EXTENTFN EXTENTOFPOLYGON) (DISTANCEFN DISTANCETOPOLYGON) (COPYFN COPYPOLYGON) (PUTFN PUTPOLYGON) (GETFN GETPOLYGON)) (LINE (DRAWFN DRAWLINEOBJECT) (ERASEFN ERASELINEOBJECT) (HIGHLIGHTFN HIGHLIGHTLINE) (MOVEFN MOVELINE) (EXTENTFN EXTENTOFLINE) (DISTANCEFN DISTANCETOLINE) (COPYFN COPYLINE) (PUTFN PUTLINE) (GETFN GETLINE)) (GRAPH (DRAWFN DRAWGRAPHOBJECT) (ERASEFN ERASEGRAPHOBJECT) (HIGHLIGHTFN HIGHLIGHTGRAPH) (EXTENTFN EXTENTOFGRAPH) (DISTANCEFN DISTANCETOGRAPH) (COPYFN COPYGRAPHOBJECT) (PUTFN PUTGRAPH) (GETFN GETGRAPH)) (TEXT (DRAWFN DRAWTEXTOBJECT) (ERASEFN ERASETEXTOBJECT) (HIGHLIGHTFN HIGHLIGHTTEXT) (MOVEFN MOVETEXT) (LABELFN LABELTEXT) (EXTENTFN EXTENTOFTEXT) (DISTANCEFN DISTANCETOTEXT) (COPYFN COPYTEXT) (PUTFN PUTTEXT) (GETFN GETTEXT)) (COMPOUND (DRAWFN DRAWCOMPOUNDOBJECT) (ERASEFN ERASECOMPOUNDOBJECT) (HIGHLIGHTFN HIGHLIGHTCOMPOUND) (LOWLIGHTFN LOWLIGHTCOMPOUND) (MOVEFN MOVECOMPOUND) (EXTENTFN EXTENTOFCOMPOUND) (DISTANCEFN DISTANCETOCOMPOUND) (COPYFN COPYCOMPOUND) (PUTFN PUTCOMPOUND) (GETFN GETCOMPOUND)) (FILLEDRECTANGLE (DRAWFN DRAWFILLEDRECTANGLEOBJECT) (ERASEFN ERASEFILLEDRECTANGLEOBJECT) (HIGHLIGHTFN HIGHLIGHTFILLEDRECTANGLE) (MOVEFN MOVEFILLEDRECTANGLE) (EXTENTFN EXTENTOFFILLEDRECTANGLE) (DISTANCEFN DISTANCETOFILLEDRECTANGLE) (COPYFN COPYFILLEDRECTANGLE) (PUTFN PUTFILLEDRECTANGLE) (GETFN GETFILLEDRECTANGLE)))) (DECLARE%: EVAL@COMPILE (DATATYPE EXTENT ((MINX FLOATING) (MAXX FLOATING) (MINY FLOATING) (MAXY FLOATING))) (DATATYPE MARGIN (TICS? TICMETHOD LABEL TICLIST)) (DATATYPE PLOT (PLOTOBJECTS PLOTSCALE SELECTEDOBJECT WINDOWINFO MARGININFO MENUINFO PLOTUSERDATA PLOTSAVELIST) (* ;; "PLOTOBJECTS is a display list, PLOTSCALE describes the scale in world coordinates, USERDATA is a prop list, SAVELIST is for undelete") (* ;;  "WINDOWINFO descibes the associated PLOTWINDOW and its attached PLOTPROMPTWINDOW") (DATATYPE WINDOWINFO (PLOTWINDOW PLOTWINDOWVIEWPORT PLOTPROMPTWINDOW)) (* ;; "MARGININFO describes the size of the plot margins in stream coordinates") (DATATYPE MARGININFO (LEFTMARGIN RIGHTMARGIN TOPMARGIN BOTTOMMARGIN)) (* ;; "MENUINFO decribes the PLOT's menus") (DATATYPE MENUINFO (MIDDLEMENU RIGHTMENU OTHERMENUS)) [ACCESSFNS PLOT ([XLOWER (fetch MIN of (fetch XINTERVAL of (fetch PLOTSCALE of DATUM] [XUPPER (fetch MAX of (fetch XINTERVAL of (fetch PLOTSCALE of DATUM] [YLOWER (fetch MIN of (fetch YINTERVAL of (fetch PLOTSCALE of DATUM] (YUPPER (fetch MAX of (fetch YINTERVAL of (fetch PLOTSCALE of DATUM]) (DATATYPE PLOTFNS (DRAWFN ERASEFN HIGHLIGHTFN LOWLIGHTFN LABELFN MOVEFN EXTENTFN DISTANCEFN COPYFN PUTFN GETFN)) (DATATYPE PLOTOBJECT (OBJECTFNS OBJECTSUBTYPE OBJECTUSERDATA OBJECTMENU OBJECTLABEL OBJECTDATA)) (DATATYPE AXISINFO (SCALEFN TICFN) (* ; "SCALEFN and TICFN are functions") ) (DATATYPE AXISINTERVAL ((MIN FLOATING) (MAX FLOATING)) [ACCESSFNS (INTERVALLENGTH (FDIFFERENCE (fetch MAX of DATUM) (fetch MIN of DATUM]) (DATATYPE PLOTSCALE (XINTERVAL XAXISINFO XTICINFO YINTERVAL YAXISINFO YTICINFO) (* ;; "XINTERVAL YINTERVAL are instances of AXISINTERVAL, XAXISINFO and YAXISINFO are instances of AXISINFO and XTICINFO and YTICINFO are instances of TICINFO") ) (DATATYPE TICINFO ((TICMIN FLOATING) (TICMAX FLOATING) TICINC NTICS) [ACCESSFNS (TICINTERVALLENGTH (FDIFFERENCE (fetch (TICINFO TICMAX) of DATUM) (fetch (TICINFO TICMIN) of DATUM]) ) (/DECLAREDATATYPE 'EXTENT '(FLOATP FLOATP FLOATP FLOATP) '((EXTENT 0 FLOATP) (EXTENT 2 FLOATP) (EXTENT 4 FLOATP) (EXTENT 6 FLOATP)) '8) (/DECLAREDATATYPE 'MARGIN '(POINTER POINTER POINTER POINTER) '((MARGIN 0 POINTER) (MARGIN 2 POINTER) (MARGIN 4 POINTER) (MARGIN 6 POINTER)) '8) (/DECLAREDATATYPE 'MENUINFO '(POINTER POINTER POINTER) '((MENUINFO 0 POINTER) (MENUINFO 2 POINTER) (MENUINFO 4 POINTER)) '6) (/DECLAREDATATYPE 'MARGININFO '(POINTER POINTER POINTER POINTER) '((MARGININFO 0 POINTER) (MARGININFO 2 POINTER) (MARGININFO 4 POINTER) (MARGININFO 6 POINTER)) '8) (/DECLAREDATATYPE 'WINDOWINFO '(POINTER POINTER POINTER) '((WINDOWINFO 0 POINTER) (WINDOWINFO 2 POINTER) (WINDOWINFO 4 POINTER)) '6) (/DECLAREDATATYPE 'PLOT '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOT 0 POINTER) (PLOT 2 POINTER) (PLOT 4 POINTER) (PLOT 6 POINTER) (PLOT 8 POINTER) (PLOT 10 POINTER) (PLOT 12 POINTER) (PLOT 14 POINTER)) '16) (/DECLAREDATATYPE 'PLOTFNS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTFNS 0 POINTER) (PLOTFNS 2 POINTER) (PLOTFNS 4 POINTER) (PLOTFNS 6 POINTER) (PLOTFNS 8 POINTER) (PLOTFNS 10 POINTER) (PLOTFNS 12 POINTER) (PLOTFNS 14 POINTER) (PLOTFNS 16 POINTER) (PLOTFNS 18 POINTER) (PLOTFNS 20 POINTER)) '22) (/DECLAREDATATYPE 'PLOTOBJECT '(POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTOBJECT 0 POINTER) (PLOTOBJECT 2 POINTER) (PLOTOBJECT 4 POINTER) (PLOTOBJECT 6 POINTER) (PLOTOBJECT 8 POINTER) (PLOTOBJECT 10 POINTER)) '12) (/DECLAREDATATYPE 'AXISINFO '(POINTER POINTER) '((AXISINFO 0 POINTER) (AXISINFO 2 POINTER)) '4) (/DECLAREDATATYPE 'AXISINTERVAL '(FLOATP FLOATP) '((AXISINTERVAL 0 FLOATP) (AXISINTERVAL 2 FLOATP)) '4) (/DECLAREDATATYPE 'PLOTSCALE '(POINTER POINTER POINTER POINTER POINTER POINTER) '((PLOTSCALE 0 POINTER) (PLOTSCALE 2 POINTER) (PLOTSCALE 4 POINTER) (PLOTSCALE 6 POINTER) (PLOTSCALE 8 POINTER) (PLOTSCALE 10 POINTER)) '12) (/DECLAREDATATYPE 'TICINFO '(FLOATP FLOATP POINTER POINTER) '((TICINFO 0 FLOATP) (TICINFO 2 FLOATP) (TICINFO 4 POINTER) (TICINFO 6 POINTER)) '8) (DECLARE%: EVAL@COMPILE (PUTPROPS APPLY.AFTERFN MACRO (ARGS (APPLY.AFTERFN.MACRO ARGS))) (PUTPROPS PLOTOBJECTSUBTYPE? MACRO [ARGS `(EQ ',(CAR ARGS) (fetch (PLOTOBJECT OBJECTSUBTYPE) of ,(CADR ARGS]) (PUTPROPS PLOTOBJECTPROP MACRO (ARGS (PLOTOBJECTPROPMACRO ARGS))) (PUTPROPS PLOTPROP MACRO (ARGS (PLOTPROPMACRO ARGS))) ) (PUTPROPS PLOTOBJECTPROP ARGNAMES (NIL (PLOTOBJECT PROP NEWVALUE) . PROPARGS)) (PUTPROPS PLOT.DEFAULTMENU ARGNAMES (NIL (MENUNAME NEWMENUITEMS) . MENUARGS)) (PUTPROPS PLOT.FIXRIGHTMENU ARGNAMES (NIL (PLOT FIXEDFLG) . PROPARGS)) (PUTPROPS PLOTLABEL ARGNAMES (NIL (PLOT MARGINNAME NEWLABEL NODRAWFLG) . LABELARGS)) (PUTPROPS PLOTMENU ARGNAMES (NIL (PLOT MENUNAME NEWMENU) . MENUARGS)) (PUTPROPS PLOTMENUITEMS ARGNAMES (NIL (PLOT MENUNAME NEWMENUITEMS) . MENUARGS)) (PUTPROPS PLOTPRETTYFNS ARGNAMES (NIL (PLOT AXIS NEWPRETTYSCALEFN NEWINVPRETTYSCALEFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTPROP ARGNAMES (NIL (PLOT PROP NEWVALUE) . PROPARGS)) (PUTPROPS PLOTSCALEFN ARGNAMES (NIL (PLOT AXIS NEWSCALEFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTTICFN ARGNAMES (NIL (PLOT AXIS NEWTICFN NODRAWFLG) . PROPARGS)) (PUTPROPS PLOTTICS ARGNAMES (NIL (PLOT MARGINNAME NEWTICFLG NODRAWFLG) . LABELARGS)) (RPAQ? SMALLPLOTFONT '(GACHA 8 MRR)) (RPAQ? LARGEPLOTFONT '(GACHA 12 BRR)) (* ;;; "PLOT I/O") (DEFINEQ (COPYPLOTOBJECT - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 18:26 by jop") - - (* ;; "Returns a copy of PLOTOBJECT. OBJECTPROPS are handled as follows. If the PLOTOBJECT has a COPYFN (which may be a list of fns) on its prop list, apply's it to NEWPLOTOBJECT PLOTOBJECT PLOT and expects it to copy the OBJECTPROPs, else calls COPYALL, except for PLOTOBJECTS or lists of PLOTOBJECTS which are COPYOBJECT'ed") - - (PROG ([OBJECTCOPYFN (MKLIST (PLOTOBJECTPROP PLOTOBJECT 'COPYFN] - NEWPLOTOBJECT) - (SETQ NEWPLOTOBJECT (CREATEPLOTOBJECT (fetch OBJECTFNS of PLOTOBJECT) - (PLOTOBJECTSUBTYPE PLOTOBJECT) - (COPYALL (fetch OBJECTLABEL of PLOTOBJECT)) - (fetch OBJECTMENU of PLOTOBJECT) - (CL:FUNCALL (fetch (PLOTFNS COPYFN) of (fetch OBJECTFNS - of PLOTOBJECT)) - PLOTOBJECT PLOT))) - [for PROPNAME in (for PROP in (fetch OBJECTUSERDATA of PLOTOBJECT) - by (CDDR PROP) collect PROP) - do (PLOTOBJECTPROP NEWPLOTOBJECT PROPNAME - (OR (AND OBJECTCOPYFN (bind PROPVALUE for FN in OBJECTCOPYFN - until (SETQ PROPVALUE (CL:FUNCALL FN NEWPLOTOBJECT - PLOTOBJECT PLOT PROPNAME - )) - finally (RETURN PROPVALUE))) - (LET ((PROPVALUE (PLOTOBJECTPROP PLOTOBJECT PROPNAME))) - (COND - ((type? PLOTOBJECT PROPVALUE) - (COPYPLOTOBJECT PROPVALUE)) - [(LISTP PROPVALUE) - (for ITEM in PROPVALUE collect (COND - ((type? PLOTOBJECT ITEM) - (COPYPLOTOBJECT ITEM PLOT)) - (T (HCOPYALL ITEM] - (T (HCOPYALL PROPVALUE] - (COND - ([OR (NOT (type? PLOTOBJECT NEWPLOTOBJECT)) - (NOT (EQ (PLOTOBJECTSUBTYPE NEWPLOTOBJECT) - (PLOTOBJECTSUBTYPE PLOTOBJECT] - (HELP "Not a plotobject of correct type" NEWPLOTOBJECT))) - (RETURN NEWPLOTOBJECT]) (COPYPLOT - [LAMBDA (PLOT OPENFLG REGION TITLE BORDER) (* ; "Edited 5-May-87 18:27 by jop") - - (* ;; "Copies a PLOT. Copying of PLOTPROP's is handled as follows. If PLOT has a COPYPLOTFN, (which may be a list of fns) calls it with NEWPLOT PLOT as args, and expects it to copy the PLOTPROPS intelligently, else HCOPYALL's the PROPS, except for PLOTOBJECTS or lists of PLOTOBJECTS which are COPYOBJECT'ed") - - (PROG ([COPYFN (MKLIST (PLOTPROP PLOT 'COPYFN] - (NEWPLOT (create PLOT))) (* ; "OK to share Menus") - - (replace (PLOT MIDDLEMENU) of NEWPLOT with (fetch (PLOT MIDDLEMENU) of PLOT)) - (replace (PLOT RIGHTMENU) of NEWPLOT with (fetch (PLOT RIGHTMENU) of PLOT)) - (* ; - "OTHERMENUS copied since it is a list in prop format and consists of MENU's or LITATOMS") - - (replace (PLOT OTHERMENUS) of NEWPLOT with (COPY (fetch (PLOT OTHERMENUS) of PLOT))) - (replace (PLOT LEFTMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT LEFTMARGIN) - of PLOT))) - (replace (PLOT RIGHTMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT RIGHTMARGIN - ) - of PLOT))) - (replace (PLOT TOPMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT TOPMARGIN) - of PLOT))) - (replace (PLOT BOTTOMMARGIN) of NEWPLOT with (create MARGIN copying (fetch (PLOT - BOTTOMMARGIN - ) - of PLOT))) - (* ; - "Plot objects not shared since they can be distructively modified") - - (replace (PLOT PLOTOBJECTS) of NEWPLOT with (for OBJECT in (fetch (PLOT PLOTOBJECTS) - of PLOT) - collect (COPYPLOTOBJECT OBJECT PLOT))) - (replace (PLOT PLOTSCALE) of NEWPLOT with (create PLOTSCALE copying (fetch (PLOT PLOTSCALE) - of PLOT))) - (* ; - "Does a HCOPYALL since we don't know what's cached here") - - [for PROPNAME in (for PROP in (fetch (PLOT PLOTUSERDATA) of PLOT) by (CDDR PROP) - collect PROP) - do (PLOTPROP NEWPLOT PROPNAME (OR (AND COPYFN (bind PROPVALUE for FN in COPYFN - until (SETQ PROPVALUE - (CL:FUNCALL FN NEWPLOT PLOT - PROPNAME)) - finally (RETURN PROPVALUE))) - (LET ((PROPVALUE (PLOTPROP PLOT PROPNAME))) - (COND - ((type? PLOTOBJECT PROPVALUE) - (COPYPLOTOBJECT PROPVALUE)) - [(LISTP PROPVALUE) - (for ITEM in PROPVALUE - collect (COND - ((type? PLOTOBJECT ITEM) - (COPYPLOTOBJECT ITEM PLOT)) - (T (HCOPYALL ITEM] - (T (HCOPYALL PROPVALUE] - (* ; "Cache the display parameters") - - [COND - ((OR REGION TITLE BORDER) - (replace (PLOT PLOTWINDOW) of NEWPLOT with (LIST REGION TITLE BORDER] - (COND - (OPENFLG (OPENPLOTWINDOW NEWPLOT))) - (RETURN NEWPLOT]) (PLOTOBJECTPRINT - [LAMBDA (PLOTOBJECT STREAM) (* ; "Edited 7-May-87 10:27 by jop") - - (PRINTOUT STREAM "#<" (fetch OBJECTSUBTYPE of PLOTOBJECT) - " PLOTOBJECT>@") - (\PRINTADDR PLOTOBJECT STREAM) - T]) (PRINTPLOTOBJECT - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:27 by jop") - - (* ;; "Puts a plot object on STREAM") - - (PROG [(OBJECTPUTFN (MKLIST (PLOTOBJECTPROP PLOTOBJECT 'PUTFN] - (PRINTOUT STREAM "(READPLOTOBJECT)(" %, "OBJECTSUBTYPE" %, |.P2| (fetch (PLOTOBJECT - OBJECTSUBTYPE - ) - of PLOTOBJECT) - %, "OBJECTDATA" %,) - (CL:FUNCALL (fetch (PLOTFNS PUTFN) of (fetch OBJECTFNS of PLOTOBJECT)) - PLOTOBJECT PLOT STREAM) - (PRINTOUT STREAM %, "OBJECTMENU" %,) - (HPRINT (fetch OBJECTMENU of PLOTOBJECT) - STREAM T T) - (PRINTOUT STREAM %, "OBJECTLABEL" %, |.P2| (fetch OBJECTLABEL of PLOTOBJECT) - %,) - (PRINTOUT STREAM "OBJECTUSERDATA (") - (for PROPNAME in (for PROP in (fetch OBJECTUSERDATA of PLOTOBJECT) - by (CDDR PROP) collect PROP) - do (PRINTOUT STREAM PROPNAME %,) - (if (NULL (for FN in OBJECTPUTFN thereis (CL:FUNCALL FN PLOTOBJECT PLOT PROPNAME - STREAM))) - then (HPRINT (PLOTOBJECTPROP PLOTOBJECT PROPNAME) - STREAM NIL T))) - (PRINTOUT STREAM "))") - (RETURN T]) (PRINTPLOT - [LAMBDA (PLOT STREAM) (* ; "Edited 5-May-87 18:27 by jop") - - (* ;; "Puts out a symbolic representation of PLOT on STREAM") - - (PROG ([PUTFN (MKLIST (PLOTPROP PLOT 'PUTFN] - MENU) - (PRINTOUT STREAM "(READPLOT)(") - (PRINTOUT STREAM "RIGHTMENU" %,) - (if (EQ (PLOT.DEFAULTMENU 'RIGHT) - (fetch (PLOT RIGHTMENU) of PLOT)) - then (PRINTOUT STREAM "DEFAULT" %,) - else (HPRINT (fetch (PLOT RIGHTMENU) of PLOT) - STREAM T T)) - (PRINTOUT STREAM "MIDDLEMENU" %,) - (if (EQ (PLOT.DEFAULTMENU 'MIDDLE) - (fetch (PLOT MIDDLEMENU) of PLOT)) - then (PRINTOUT STREAM "DEFAULT" %,) - else (HPRINT (fetch (PLOT MIDDLEMENU) of PLOT) - STREAM T T)) - (for FIELDNAME in '((PLOT OTHERMENUS) - (PLOT LEFTMARGIN) - (PLOT TOPMARGIN) - (PLOT RIGHTMARGIN) - (PLOT BOTTOMMARGIN) - (PLOT PLOTSCALE)) do (PRINTOUT STREAM (CADR FIELDNAME) - %,) - (HPRINT (RECORDACCESS FIELDNAME PLOT) - STREAM T T)) - (PRINTOUT STREAM %, "PLOTOBJECTS (") - (for OBJECT in (fetch (PLOT PLOTOBJECTS) of PLOT) do (HPRINT OBJECT STREAM T T)) - (PRINTOUT STREAM ")" %,) - (PRINTOUT STREAM %, "PLOTUSERDATA (") - (for PROPNAME in (for PROP in (fetch (PLOT PLOTUSERDATA) of PLOT) by (CDDR PROP) - collect PROP) - do (PRINTOUT STREAM %, PROPNAME %,) - (if (NULL (for FN in PUTFN thereis (CL:FUNCALL FN PLOT PROPNAME STREAM))) - then (HPRINT (PLOTPROP PLOT PROPNAME) - STREAM NIL T))) - (PRINTOUT STREAM ")" %,) - (PRINTOUT STREAM ")") - (RETURN T]) (READFONT - [LAMBDA (STREAM) (* jop%: "27-Aug-85 13:34") - (PROG ((PROPLIST (READ STREAM))) - (RETURN (FONTCREATE (LISTGET PROPLIST 'FAMILY) - (LISTGET PROPLIST 'SIZE) - (LISTGET PROPLIST 'FACE) - (LISTGET PROPLIST 'ROTATION) - (LISTGET PROPLIST 'DEVICE]) (READMENU - [LAMBDA (STREAM) (* ; "Edited 6-May-87 09:31 by jop") - - (* ;; "Function For Reading Menus From File") - - (PROG ((PROPLIST (HREAD STREAM))) - (RETURN (create MENU - ITEMS _ (LISTGET PROPLIST 'ITEMS) - WHENSELECTEDFN _ (LISTGET PROPLIST 'WHENSELECTEDFN) - WHENHELDFN _ (LISTGET PROPLIST 'WHENHELDFN) - WHENUNHELDFN _ (LISTGET PROPLIST 'WHENUNHELDFN) - MENUPOSITION _ (LISTGET PROPLIST 'MENUPOSITION) - MENUOFFSET _ (LISTGET PROPLIST 'MENUOFFSET) - MENUFONT _ (LISTGET PROPLIST 'MENUFONT) - TITLE _ (LISTGET PROPLIST 'TITLE) - CENTERFLG _ (LISTGET PROPLIST 'CENTERFLG) - MENUROWS _ (LISTGET PROPLIST 'MENUROWS) - MENUCOLUMNS _ (LISTGET PROPLIST 'MENUCOLUMNS) - ITEMHEIGHT _ (LISTGET PROPLIST 'ITEMHEIGHT) - ITEMWIDTH _ (LISTGET PROPLIST 'ITEMWIDTH) - MENUBORDERSIZE _ (LISTGET PROPLIST 'MENUBORDERSIZE) - MENUOUTLINESIZE _ (LISTGET PROPLIST 'MENUOUTLINESIZE) - CHANGEOFFSETFLG _ (LISTGET PROPLIST 'CHANGEOFFSETFLG]) (READPLOTOBJECT - [LAMBDA (STREAM) (* ; "Edited 5-May-87 18:27 by jop") - - (* ;; "Reads a plot object from STREAM previously written out by PRINTOBJECT") - - (PROG ((PROPLST (HREAD STREAM)) - OBJECTSUBTYPE OBJECTFNS OBJECTGETFN NEWOBJECT OBJECTUSERDATA) - (SETQ OBJECTSUBTYPE (LISTGET PROPLST 'OBJECTSUBTYPE)) - [SETQ OBJECTFNS (EVAL (PACK* OBJECTSUBTYPE 'FNS] - (SETQ OBJECTGETFN (fetch (PLOTFNS GETFN) of OBJECTFNS)) - [SETQ NEWOBJECT (CREATEPLOTOBJECT OBJECTFNS OBJECTSUBTYPE (LISTGET PROPLST 'OBJECTLABEL) - (LISTGET PROPLST 'OBJECTMENU) - (CL:FUNCALL OBJECTGETFN (LISTGET PROPLST 'OBJECTDATA] - (SETQ OBJECTUSERDATA (LISTGET PROPLST 'OBJECTUSERDATA)) - (for PROPNAME in OBJECTUSERDATA by (CDDR PROPNAME) as PROPVALUE in (CDR OBJECTUSERDATA) - by (CDDR PROPVALUE) do (PLOTOBJECTPROP NEWOBJECT PROPNAME - (if (AND (LISTP PROPVALUE) - (EQ (CAR PROPVALUE) - 'FUNCTION)) - then (SETQ PROPVALUE (CL:FUNCALL (CADR PROPVALUE) - NEWOBJECT PROPNAME)) - else PROPVALUE))) - (RETURN NEWOBJECT]) (READPLOT - [LAMBDA (STREAM) (* ; "Edited 5-May-87 18:28 by jop") - - (* ;; - "Reads In a Symbolic Representation Of A PLOT From Stream Previously Written Out By PRINTPLOT") - - (LET* [(PROPLST (HREAD STREAM)) - (RIGHTMENU (LISTGET PROPLST 'RIGHTMENU)) - (MIDDLEMENU (LISTGET PROPLST 'MIDDLEMENU)) - (USERDATA (LISTGET PROPLST 'PLOTUSERDATA)) - (PLOT (create PLOT - OTHERMENUS _ (LISTGET PROPLST 'OTHERMENUS) - LEFTMARGIN _ (LISTGET PROPLST 'LEFTMARGIN) - TOPMARGIN _ (LISTGET PROPLST 'TOPMARGIN) - RIGHTMARGIN _ (LISTGET PROPLST 'RIGHTMARGIN) - BOTTOMMARGIN _ (LISTGET PROPLST 'BOTTOMMARGIN) - PLOTSCALE _ (LISTGET PROPLST 'PLOTSCALE) - PLOTOBJECTS _ (LISTGET PROPLST 'PLOTOBJECTS] - (PLOTMENU PLOT 'RIGHT (if (EQ RIGHTMENU 'DEFAULT) - then (PLOT.DEFAULTMENU 'RIGHT) - else RIGHTMENU)) - (PLOTMENU PLOT 'MIDDLE (if (EQ MIDDLEMENU 'DEFAULT) - then (PLOT.DEFAULTMENU 'MIDDLE) - else MIDDLEMENU)) - (for PROPNAME in USERDATA by (CDDR PROPNAME) as PROPVALUE in (CDR USERDATA) - by (CDDR PROPVALUE) do (PLOTPROP PLOT PROPNAME - (if [AND (LISTP PROPVALUE) - (AND (LISTP (CAR PROPVALUE)) - (EQ (CAAR PROPVALUE) - 'FUNCTION] - then (* ; - "Assumes Lists Of Form ((Function Foo) Bar)") - - (SETQ PROPVALUE (CL:FUNCALL (CADAR PROPVALUE) - PLOT PROPNAME (CADR - PROPVALUE - ))) - else PROPVALUE))) - PLOT]) ) (DEFINEQ (PRINT-VECTOR - [LAMBDA (VECTOR STREAM) (* ; "Edited 1-Jun-87 17:34 by jop") - - (PRINTOUT STREAM "(READ-VECTOR)") - (PRIN2 (COERCE VECTOR 'LIST) - STREAM]) (READ-VECTOR - [LAMBDA (STREAM) (* ; "Edited 1-Jun-87 17:39 by jop") - - (LET ((LST (HREAD STREAM))) - (CL:MAKE-ARRAY (LENGTH LST) - :INITIAL-CONTENTS LST]) ) (PUTDEF (QUOTE PLOTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (PLTS (HORRIBLEVARS . PLTS]) (ADDTOVAR HPRINTMACROS (FONTDESCRIPTOR . PRINTFONT) (MENU . PRINTMENU) (PLOT . PRINTPLOT) (PLOTOBJECT . PRINTPLOTOBJECT) (ONED-ARRAY . PRINT-VECTOR)) (ADDTOVAR HPRINTREADFNS READPLOT READPLOTOBJECT READFONT READMENU READ-VECTOR) (DEFPRINT 'PLOTOBJECT (FUNCTION PLOTOBJECTPRINT)) (* ;;; "Numeric fns") (DEFINEQ (PLOT.EXP10 - [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") - - (* ;; "this procedure returns exact power of ten for integer args") - - (EXPT 10.0 X]) (PLOT.LOG10 - [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") - - (* ;; "Returns log base 10 of X") - - (PROG [(C (CONSTANT (FQUOTIENT 1.0 (LOG 10.0] - (RETURN (FTIMES C (LOG X]) (PLOT.FLOOR - [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") - - (SETQ X (FLOAT X)) - (PROG ((FIXX (FIX X))) - (RETURN (COND - [(MINUSP X) - (COND - ((EQP FIXX X) - FIXX) - (T (SUB1 FIXX] - (T FIXX]) (PLOT.CEILING - [LAMBDA (X) (* ; "Edited 6-May-87 09:32 by jop") - - (SETQ X (FLOAT X)) - (PROG ((FIXX (FIX X))) - (RETURN (COND - ((MINUSP X) - FIXX) - (T (COND - ((EQP FIXX X) - FIXX) - (T (ADD1 FIXX]) (SINEWAVE - [LAMBDA (N FREQUENCY FROM TO AMPLITUDE) (* ; "Edited 6-May-87 09:33 by jop") - - (* ;; "produce N points on a sine wave") - - (PROG ((TWOPI (TIMES 2.0 3.14159)) - (RANGE (FDIFFERENCE TO FROM))) - (if (NULL FREQUENCY) - then (SETQ FREQUENCY 1)) - (if (NULL AMPLITUDE) - then (SETQ AMPLITUDE 1)) - (RETURN (bind (X _ FROM) - (INC _ (FQUOTIENT RANGE N)) - POINT for I from 1 to N collect [SETQ POINT - (create POSITION - XCOORD _ X - YCOORD _ - (TIMES AMPLITUDE - (SIN (TIMES FREQUENCY X) - T] - (SETQ X (PLUS X INC)) - POINT]) ) (* ;;; "PLOT image object FNS") (DEFINEQ (CREATEPLOTIMAGEOBJ - [LAMBDA (PLOT) (* ; "Edited 27-May-87 18:38 by jop") - - (* ;; "creates PLOT image object from PLOT") - - (LET* ((WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (REGION (IF (WINDOWP WINDOW) - THEN (WINDOWPROP WINDOW 'REGION) - ELSE (CAR WINDOW))) - (OBJ (IMAGEOBJCREATE (COPYPLOT PLOT) - PLOTIMAGEFNS))) - (IMAGEOBJPROP OBJ 'WIDTH (FETCH (REGION WIDTH) OF REGION)) - (IMAGEOBJPROP OBJ 'HEIGHT (FETCH (REGION HEIGHT) OF REGION)) - OBJ]) (CREATEPLOTBITMAPOBJ - [LAMBDA (PLOT) (* ; "Edited 5-May-87 18:19 by jop") - - (LET* [(WINDOW (fetch (PLOT PLOTWINDOW) of PLOT)) - (BITMAP (BITMAPCREATE (WINDOWPROP WINDOW 'WIDTH) - (WINDOWPROP WINDOW 'HEIGHT] - (BITBLT WINDOW NIL NIL BITMAP) - (BITMAPTEDITOBJ BITMAP 1 0]) (PLIO.BUTTONEVENTINFN - [LAMBDA (PLOTIMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) - (* ; "Edited 6-May-87 09:34 by jop") - - (PROG ([CHOICEMENU (CONSTANT (create MENU - CENTERFLG _ T - ITEMS _ '(("Select" 'SELECT "Select the image object") - ("Reshape" 'RESHAPE "Reshape the image objcet") - ("Plot Window" 'EDIT - "Open a window containing plot"] - (PLOT (IMAGEOBJPROP PLOTIMAGEOBJ 'OBJECTDATUM)) - (IMAGEWIDTH (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH)) - (IMAGEHEIGHT (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT)) - MINSIZE NEWREGION WIN NEWPLOT) - - (* ;; "consider selection if BUTTON=NIL to handle plots in Koto version of Sketch") - - (COND - ((OR (NOT BUTTON) - (EQ BUTTON 'LEFT)) - (SELECTQ (MENU CHOICEMENU) - (RESHAPE (SETQ MINSIZE (MINSTREAMREGIONSIZE (WINDOWPROP (fetch PLOTWINDOW - of PLOT) - 'DSP) - PLOT)) (* ; - "Assumes the WINDOWSTREAM has been changed to fit the imageobj") - - (SETQ NEWREGION (GETREGION (CAR MINSIZE) - (CDR MINSIZE) - (CREATEREGION (DSPXOFFSET NIL WINDOWSTREAM) - (DSPYOFFSET NIL WINDOWSTREAM) - IMAGEWIDTH IMAGEHEIGHT))) - (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH (fetch WIDTH of NEWREGION)) - (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT (fetch HEIGHT of NEWREGION)) - (* ; "Redraw the Image object") - - (RETURN 'CHANGED)) - (EDIT (SETQ NEWPLOT (COPYPLOT PLOT NIL (GETBOXREGION (WIDTHIFWINDOW IMAGEWIDTH) - (HEIGHTIFWINDOW IMAGEHEIGHT T)) - "Plot Edit Window")) - (SETQ WIN (OPENPLOTWINDOW NEWPLOT)) - - (* ;; "Cache some info some that changes to NEWPLOT may be reinserted into TEXTSTREAM. Windowprops are used because they are not copied (HACK)") - - (* ;; - "sketch doesn't pass down anything for TEXTSTREAM arg so must use viewer window instead") - - (WINDOWPROP WIN 'SOURCEHOST (OR TEXTSTREAM WINDOW WINDOWSTREAM)) - (WINDOWPROP WIN 'SOURCEIMAGEOBJ PLOTIMAGEOBJ) - (WINDOWADDPROP WIN 'CLOSEFN 'PLIO.EDITCLOSEFN T) - - (* ;; "handle reinsert by a closefn rather than an new menu item -- similar to the behavior of Sketch image object edits (PLOTADDMENUITEMS NEWPLOT (QUOTE RIGHT) (QUOTE ((Reinsert PLIO.REINSERTOBJ 'Change source image object'))))") - - (RETURN T)) - (RETURN NIL))) - (T (RETURN NIL]) (PLIO.COPYFN - [LAMBDA (PLOTIOBJ) (* ; "Edited 6-May-87 09:35 by jop") - (* ; "simple copy") - - (PROG ((NEWOBJ (IMAGEOBJCREATE NIL PLOTIMAGEFNS))) - [IMAGEOBJPROP NEWOBJ 'OBJECTDATUM (COPYPLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM] - (IMAGEOBJPROP NEWOBJ 'WIDTH (IMAGEOBJPROP PLOTIOBJ 'WIDTH)) - (IMAGEOBJPROP NEWOBJ 'HEIGHT (IMAGEOBJPROP PLOTIOBJ 'HEIGHT)) - (RETURN NEWOBJ]) (PLIO.GETFN - [LAMBDA (STREAM TEXTSTREAM) (* ; "Edited 6-May-87 09:35 by jop") - - (* ;; "PLOT IMAGEOBJECT GETFN") - - (PROG ((PROPLST (HREAD STREAM)) - PLOTIMAGEOBJ) - (SETQ PLOTIMAGEOBJ (IMAGEOBJCREATE (LISTGET PROPLST 'PLOT) - PLOTIMAGEFNS)) - (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH (LISTGET PROPLST 'WIDTH)) - (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT (LISTGET PROPLST 'HEIGHT)) - (RETURN PLOTIMAGEOBJ]) (PLIO.PUTFN - [LAMBDA (PLOTIMAGEOBJ STREAM) (* ; "Edited 6-May-87 09:35 by jop") - - (* ;; "PLOT IMAGEOBJECT PUTFN") - - (PRINTOUT STREAM "(WIDTH" %, (IMAGEOBJPROP PLOTIMAGEOBJ 'WIDTH) - %, "HEIGHT" %, (IMAGEOBJPROP PLOTIMAGEOBJ 'HEIGHT) - %, "PLOT" %,) - (HPRINT (IMAGEOBJPROP PLOTIMAGEOBJ 'OBJECTDATUM) - STREAM T T) - (PRINTOUT STREAM ")"]) (PLIO.REINSERTOBJ - [LAMBDA (PLOT) (* ; "Edited 6-May-87 09:35 by jop") - - (* ;; "allows modified plot to be reinserted in document") - - (* ;; "modified to work with Sketch as well as TEdit sources") - - (PROG ((PLOTWINDOW (fetch PLOTWINDOW of PLOT)) - HOST OBJ) - (SETQ HOST (WINDOWPROP PLOTWINDOW 'SOURCEHOST)) - (SETQ OBJ (WINDOWPROP PLOTWINDOW 'SOURCEIMAGEOBJ)) - (COND - ((NOT (IMAGEOBJP OBJ)) - (HELP "Not an IMAGEOBJ" OBJ))) (* ; - "Destructively change imageobj to retain EQ ness") - - (IMAGEOBJPROP OBJ 'OBJECTDATUM (COPYPLOT PLOT)) - (IMAGEOBJPROP OBJ 'WIDTH (WINDOWPROP PLOTWINDOW 'WIDTH)) - (IMAGEOBJPROP OBJ 'HEIGHT (WINDOWPROP PLOTWINDOW 'HEIGHT)) - (IMAGE.OBJECT.CHANGED HOST OBJ]) (PLOT.COPYBUTTONEVENTFN - [LAMBDA (WINDOW) (* ; "Edited 6-May-87 09:36 by jop") - - (* ;; "Allows plots to be copy selected") - - (PROG ((PLOT (WINDOWPROP WINDOW 'PLOT)) - [IMAGETYPEMENU (CONSTANT (create MENU - ITEMS _ '((Plot 'PLOT) - (Bitmap 'BITMAP] - IMAGEOBJ) - (INVERTW WINDOW) - (UNTILMOUSESTATE UP) - (INVERTW WINDOW) - (COND - ((INSIDEP WINDOW (CURSORPOSITION NIL WINDOW)) - (SELECTQ (MENU IMAGETYPEMENU) - (PLOT (SETQ IMAGEOBJ (CREATEPLOTIMAGEOBJ PLOT))) - (BITMAP (SETQ IMAGEOBJ (CREATEPLOTBITMAPOBJ PLOT))) - NIL) - (AND IMAGEOBJ (COPYINSERT IMAGEOBJ]) (PLIO.DISPLAYFN - [LAMBDA (PLOTIOBJ IMAGESTREAM) (* ; "Edited 7-May-87 18:21 by jop") - - (* ;; "Displays plot image object") - - (PROG ((PLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM)) - (VIEWPORT (IMAGEOBJPROP PLOTIOBJ 'VIEWPORT)) - (SCALE (DSPSCALE NIL IMAGESTREAM)) - STREAMREGION) - (COND - ((OR (NULL VIEWPORT) - (NOT (EQ (fetch PARENTSTREAM of VIEWPORT) - IMAGESTREAM))) - (SETQ VIEWPORT (CREATEVIEWPORT IMAGESTREAM)) - (IMAGEOBJPROP PLOTIOBJ 'VIEWPORT VIEWPORT))) - [SETQ STREAMREGION (CREATEREGION (DSPXPOSITION NIL IMAGESTREAM) - (DSPYPOSITION NIL IMAGESTREAM) - [FIXR (TIMES SCALE (IMAGEOBJPROP PLOTIOBJ 'WIDTH] - (FIXR (TIMES SCALE (IMAGEOBJPROP PLOTIOBJ 'HEIGHT] - (CREATETICLISTS PLOT) - (ADJUSTVIEWPORT VIEWPORT STREAMREGION PLOT) - (DRAWPLOT PLOT IMAGESTREAM VIEWPORT STREAMREGION]) (PLIO.IMAGEBOXFN - [LAMBDA (PLOTIOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 6-May-87 09:36 by jop") - - (* ;; "Determines size of plotimageobj") - - (PROG ((IMAGEWIDTH (IMAGEOBJPROP PLOTIOBJ 'WIDTH)) - (IMAGEHEIGHT (IMAGEOBJPROP PLOTIOBJ 'HEIGHT)) - (PLOT (IMAGEOBJPROP PLOTIOBJ 'OBJECTDATUM)) - (SCALE (COND - (IMAGESTREAM (DSPSCALE NIL IMAGESTREAM)) - (T 1))) - NEWREGION MINSIZE) - - (* ;; "(* this doesn't work with Sketch which has no rightmargin) (if (GREATERP (TIMES SCALE IMAGEWIDTH) (DIFFERENCE RIGHTMARGIN CURRENTX)) then (if (NOT (EQ (IMAGESTREAMTYPE IMAGESTREAM) (QUOTE DISPLAY))) then (HELP 'PLOT image object too big')) (PROMPTPRINT 'Image object too wide. Choose a smaller region') (SETQ MINSIZE (MINSTREAMREGIONSIZE IMAGESTREAM PLOT)) (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE))) (SETQ IMAGEWIDTH (fetch WIDTH of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE WIDTH) IMAGEWIDTH) (SETQ IMAGEHEIGHT (fetch HEIGHT of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE HEIGHT) IMAGEHEIGHT))") - - (RETURN (create IMAGEBOX - XSIZE _ (TIMES SCALE IMAGEWIDTH) - YSIZE _ (TIMES SCALE IMAGEHEIGHT) - YDESC _ 0 - XKERN _ 0]) ) (* ;; "additional fns to allow plot im. objs. to work in Sketch") (DEFINEQ (PLIO.EDITCLOSEFN - [LAMBDA (W) (* ; "Edited 5-May-87 18:10 by jop") - - (* ;; "this plot window is from an image object. Reinsert plot if requested") - - (* ;; "later could test if plot has been changed -- if no changes don't ask to reinsert") - - (LET (RESULT) - (SETQ RESULT (SELECTQ (MENU (CONSTANT (create MENU - TITLE _ "Change source image object?" - ITEMS _ '(("Yes" 'YES - "This image used in the document instead of the one that is there." - ) - ("No" 'NO - "The changes made to this image will not be put into the document." - )) - CENTERFLG _ T))) - (YES (PLIO.REINSERTOBJ (WHICHPLOT W)) - NIL) - (NO NIL) - (NIL (* ; - "user selected outside the menu -- abort the close") - - 'DON'T) - NIL)) - (OR RESULT (WINDOWDELPROP W 'CLOSEFN 'PLIO.EDITCLOSEFN)) - (* ; - "clean up window prop -- required since currently PLOT.CLOSEFN calls CLOSEW!") - - RESULT]) (IMAGE.OBJECT.CHANGED - [LAMBDA (HOST OBJECT) (* ; "Edited 5-May-87 18:11 by jop") - - (* ;; "notifies HOST that OBJECT has changed and needs to be redisplayed") - - (* ;; "currently assumes object is in TEdit or Sketch") - - (LET (CANONICALHOST) - (COND - ([SETQ CANONICALHOST (CAR (NLSETQ (TEXTSTREAM HOST] - (TEDIT.OBJECT.CHANGED CANONICALHOST OBJECT)) - ([SETQ CANONICALHOST (CAR (NLSETQ (INSURE.SKETCH HOST] - (* ; - "INSURE.SKETCH noerrorflg doesn't work") - - (SK.MARK.DIRTY CANONICALHOST) (* ; - "this sets SKETCHCHANGED prop of all viewers on the sketch") - - (for SKW in (SKETCH.ALL.VIEWERS CANONICALHOST) do (REDISPLAYW SKW))) - (T (HELP "Can't update image object in " HOST]) ) (RPAQ? PLOTIMAGEFNS (IMAGEFNSCREATE (FUNCTION PLIO.DISPLAYFN) (FUNCTION PLIO.IMAGEBOXFN) (FUNCTION PLIO.PUTFN) (FUNCTION PLIO.GETFN) (FUNCTION PLIO.COPYFN) (FUNCTION PLIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PLOTIMAGEFNS) ) (* ;;; "Initialize") (PLOT.SETUP OBJECTOPSTABLE) (PLOT.DEFAULTMENU 'MIDDLE PLOT.DEFAULTMIDDLEMENUITEMS) (PLOT.DEFAULTMENU 'RIGHT PLOT.DEFAULTRIGHTMENUITEMS) (* ;;; "Dependent files") (FILESLOAD TWODGRAPHICS PLOTOBJECTS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) TWODGRAPHICS UNBOXEDOPS) ) (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 PLOTTICS PLOTTICFN PLOTSCALEFN PLOTPROP PLOTOBJECTPROP PLOTMENUITEMS PLOTMENU PLOTLABEL PLOT.FIXRIGHTMENU PLOT.DEFAULTMENU) ) (PUTPROPS PLOT COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1993 2000)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5735 132687 (ADDPLOTOBJECT 5745 . 6715) (ADJUSTSCALE? 6717 . 9285) (ADJUSTVIEWPORT 9287 . 12067) (APPLY.AFTERFN.MACRO 12069 . 12621) (ASKFORLABEL 12623 . 14086) (ASKFORSCALE 14088 . 16043) (BOXREGION 16045 . 16781) (CHOOSESCALE 16783 . 17334) (CHOOSETICS 17336 . 17842) (CLOSEPLOTWINDOW 17844 . 19029) (CLOSESTPLOTOBJECT 19031 . 19356) (COMPOUNDSUBTYPE 19358 . 19567) (COMPUTEBOTTOMMARGIN 19569 . 20855) (COMPUTELEFTMARGIN 20857 . 22384) (COMPUTERIGHTMARGIN 22386 . 23912) (COMPUTETOPMARGIN 23914 . 25105) (COPYMENU 25107 . 26125) (CREATEPLOT 26127 . 28841) (CREATEPLOTFNS 28843 . 30955) ( CREATEPLOTOBJECT 30957 . 31781) (DEFAULTSCALEFN 31783 . 32062) (DEFAULTTICFN 32064 . 33169) ( DEFAULTTICMETHOD 33171 . 34479) (DELETEPLOTOBJECT 34481 . 36072) (DESELECTPLOTOBJECT 36074 . 36451) ( DISTANCETOPLOTOBJECT 36453 . 36731) (DRAWBOTTOMMARGIN 36733 . 38730) (DRAWLEFTMARGIN 38732 . 40270) ( DRAWMARGIN 40272 . 41119) (DRAWPLOTOBJECT 41121 . 41667) (DRAWPLOT 41669 . 42578) (DRAWRIGHTMARGIN 42580 . 44216) (DRAWTOPMARGIN 44218 . 45952) (ERASEPLOTOBJECT 45954 . 46563) (EXTENDEDSCALEFN 46565 . 47089) (EXTENTOFPLOTOBJECT 47091 . 47350) (EXTENTOFPLOT 47352 . 48548) (GETPLOTWINDOW 48550 . 48732) ( GETTICLIST 48734 . 49673) (HIGHLIGHTPLOTOBJECT 49675 . 50311) (LABELPLOTOBJECT 50313 . 50701) ( LOWLIGHTPLOTOBJECT 50703 . 51333) (MANUALRESCALE 51335 . 53437) (MINSTREAMREGIONSIZE 53439 . 55085) ( MOVEPLOTOBJECT 55087 . 55346) (OPENPLOTWINDOW 55348 . 61393) (PLOT.BUTTONEVENTFN 61395 . 67551) ( PLOT.CLOSEFN 67553 . 67725) (PLOT.DEFAULTMENU 67727 . 69326) (PLOT.FIXRIGHTMENU 69328 . 70994) ( PLOT.HARDCOPYFN 70996 . 75743) (PLOT.ICONFN 75745 . 79390) (PLOT.LABELTOWORLD 79392 . 80016) ( PLOT.REPAINTFN 80018 . 80302) (PLOT.RESET 80304 . 81849) (PLOT.SETUP 81851 . 82798) ( PLOT.SKETCH.CREATE 82800 . 84377) (PLOT.WHENSELECTEDFN 84379 . 85373) (PLOT.WORLDTOLABEL 85375 . 86000 ) (PLOTADDMENUITEMS 86002 . 87017) (PLOTADDPROP 87019 . 87541) (PLOTAXISINTERVAL 87543 . 88670) ( PLOTDELMENUITEMS 88672 . 90376) (PLOTDELPROP 90378 . 90860) (PLOTLABEL 90862 . 91817) (PLOTMENU 91819 . 94099) (PLOTMENUITEMS 94101 . 95679) (PLOTOBJECTADDPROP 95681 . 96212) (PLOTOBJECTDELPROP 96214 . 96713) (PLOTOBJECTLABEL 96715 . 97675) (PLOTOBJECTPROP 97677 . 101111) (PLOTOBJECTPROPMACRO 101113 . 101721) (PLOTOBJECTSUBTYPE 101723 . 101904) (PLOTOPERROR 101906 . 102105) (PLOTPROMPT 102107 . 102337) (PLOTPROP 102339 . 104045) (PLOTPROPMACRO 104047 . 105468) (PLOTREMPROP 105470 . 106698) (PLOTSCALEFN 106700 . 107767) (PLOTTICFN 107769 . 108820) (PLOTTICINFO 108822 . 109725) (PLOTTICMETHOD 109727 . 110953) (PLOTTICS 110955 . 112129) (PRINTFONT 112131 . 112553) (PRINTMENU 112555 . 114186) ( REDRAWPLOTWINDOW 114188 . 117127) (RELABELSELECTEDPLOTOBJECT 117129 . 118119) (RESCALEPLOT 118121 . 120841) (SCALE 120843 . 124194) (TOGGELLABEL 124196 . 124487) (TOGGLEEXTENDEDAXES 124489 . 125855) ( TOGGLEFIXEDMENU 125857 . 126073) (TOGGLETICS 126075 . 126708) (TRANSLATEPLOTOBJECT 126710 . 127916) ( UNDELETEPLOTOBJECT 127918 . 131079) (UNLABELPLOTOBJECT 131081 . 131639) (WHICHLABEL 131641 . 132133) ( WHICHPLOT 132135 . 132685)) (132739 140434 (PLOT.PRINTNUM 132749 . 133553) (PLOT.FNUM-STRING 133555 . 136337) (PLOT.ENUM-STRING 136339 . 138221) (CREATETICLISTS 138223 . 139700) (NORMALIZE-TICLIST 139702 . 140432)) (140435 145131 (DRAW-TICS-LEFT-RIGHT 140445 . 141940) (DRAW-TICS-TOP-BOTTOM 141942 . 143563) (DRAW-LABEL-LEFT-RIGHT 143565 . 144534) (DRAW-LABEL-TOP-BOTTOM 144536 . 145129)) (161567 179763 (COPYPLOTOBJECT 161577 . 164511) (COPYPLOT 164513 . 169609) (PLOTOBJECTPRINT 169611 . 169880) ( PRINTPLOTOBJECT 169882 . 171593) (PRINTPLOT 171595 . 173883) (READFONT 173885 . 174296) (READMENU 174298 . 175682) (READPLOTOBJECT 175684 . 177249) (READPLOT 177251 . 179761)) (179764 180227 ( PRINT-VECTOR 179774 . 179990) (READ-VECTOR 179992 . 180225)) (180740 183291 (PLOT.EXP10 180750 . 180985) (PLOT.LOG10 180987 . 181256) (PLOT.FLOOR 181258 . 181658) (PLOT.CEILING 181660 . 182068) ( SINEWAVE 182070 . 183289)) (183332 193822 (CREATEPLOTIMAGEOBJ 183342 . 184017) (CREATEPLOTBITMAPOBJ 184019 . 184407) (PLIO.BUTTONEVENTINFN 184409 . 187944) (PLIO.COPYFN 187946 . 188474) (PLIO.GETFN 188476 . 189012) (PLIO.PUTFN 189014 . 189452) (PLIO.REINSERTOBJ 189454 . 190430) ( PLOT.COPYBUTTONEVENTFN 190432 . 191311) (PLIO.DISPLAYFN 191313 . 192438) (PLIO.IMAGEBOXFN 192440 . 193820)) (193897 196716 (PLIO.EDITCLOSEFN 193907 . 195658) (IMAGE.OBJECT.CHANGED 195660 . 196714))))) STOP \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS.~1~ b/lispusers/PLOTOBJECTS.~1~ deleted file mode 100644 index f3629ca6..00000000 --- a/lispusers/PLOTOBJECTS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Jun-92 16:56:29" |{PELE:MV:ENVOS}MEDLEY>PLOTOBJECTS.;2| 103453 changes to%: (VARS PLOTOBJECTSCOMS) (FNS COPYGENERIC DISTANCETOCOMPOUND DISTANCETOCURVE DISTANCETOFILLEDRECTANGLE DISTANCETOGRAPH DISTANCETOLINE DISTANCETOPOINT DISTANCETOPOLYGON DISTANCETOTEXT EXTENTOFCOMPOUND EXTENTOFCURVE EXTENTOFFILLEDRECTANGLE EXTENTOFPOINT EXTENTOFPOLYGON EXTENTOFTEXT LABELGENERIC MOVECOMPOUND MOVECURVE MOVEFILLEDRECTANGLE MOVELINE MOVEPOLYGON MOVETEXT PUTGENERIC) previous date%: " 5-May-87 18:01:23" |{PELE:MV:ENVOS}MEDLEY>PLOTOBJECTS.;1|) (* ; " Copyright (c) 1985, 1986, 1987, 1992 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PLOTOBJECTSCOMS) (RPAQQ PLOTOBJECTSCOMS [(FNS COPYCOMPOUND COPYCURVE COPYFILLEDRECTANGLE COPYGENERIC COPYGRAPHOBJECT COPYLINE COPYPOINT COPYPOLYGON COPYTEXT CREATECOMPOUND CREATECURVE CREATEFILLEDRECTANGLE CREATEGRAPH CREATELINE CREATEPOINT CREATEPOLYGON CREATETEXT DISTANCETOCOMPOUND DISTANCETOCURVE DISTANCETOFILLEDRECTANGLE DISTANCETOGRAPH DISTANCETOLINE DISTANCETOPOINT DISTANCETOPOLYGON DISTANCETOTEXT DRAWCOMPOUNDOBJECT DRAWCURVEOBJECT DRAWFILLEDRECTANGLEOBJECT DRAWGRAPHOBJECT DRAWLINEOBJECT DRAWPOINTOBJECT DRAWPOLYGONOBJECT DRAWTEXTOBJECT ERASECOMPOUNDOBJECT ERASECURVEOBJECT ERASEFILLEDRECTANGLEOBJECT ERASEGRAPHOBJECT ERASELINEOBJECT ERASEPOINTOBJECT ERASEPOLYGONOBJECT ERASETEXTOBJECT EXTENTOFCOMPOUND EXTENTOFCURVE EXTENTOFFILLEDRECTANGLE EXTENTOFGRAPH EXTENTOFLINE EXTENTOFPOINT EXTENTOFPOLYGON EXTENTOFTEXT GETCOMPOUND GETCURVE GETFILLEDRECTANGLE GETGENERIC GETGRAPH GETLINE GETPOINT GETPOLYGON GETTEXT HIGHLIGHTCOMPOUND HIGHLIGHTCURVE HIGHLIGHTFILLEDRECTANGLE HIGHLIGHTGRAPH HIGHLIGHTLINE HIGHLIGHTPOINT HIGHLIGHTPOLYGON HIGHLIGHTTEXT LABELGENERIC LABELPOINT LABELTEXT LOWLIGHTCOMPOUND MOVECOMPOUND MOVECURVE MOVEFILLEDRECTANGLE MOVELINE MOVEPOINT MOVEPOLYGON MOVETEXT PLOTCOMPOUND PLOTCURVE PLOTFILLEDRECTANGLE PLOTGRAPH PLOTLINE PLOTPOINT PLOTPOINTS PLOTPOLYGON PLOTTEXT PUTCOMPOUND PUTCURVE PUTFILLEDRECTANGLE PUTGENERIC PUTGRAPH PUTLINE PUTPOINT PUTPOLYGON PUTTEXT) (MACROS L1METRIC L2METRIC) (VARS CIRCLE CROSS DASH DOT DOTDASH SHADE1 SHADE2 SHADE3 SHADE4 SHADE5 SHADE6 SHADE7 SHADE8 STAR) (RECORDS COMPOUNDDATA CURVEDATA FILLEDRECTANGLEDATA GRAPHDATA LINEDATA PLOT.STYLE POINTDATA POLYGONDATA TEXTDATA) (PROP ARGNAMES PLOTCOMPOUND) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PLOTCOMPOUND]) (DEFINEQ (COPYCOMPOUND [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:45 by jop") (* ;; "Copyfn for COMPOUND objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create COMPOUNDDATA COMPONENTS _ (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of OBJECTDATA) collect (COPYPLOTOBJECT OBJECT PLOT)) COMPOUNDTYPE _ (fetch (COMPOUNDDATA COMPOUNDTYPE) of OBJECTDATA]) (COPYCURVE [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for CURVE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create CURVEDATA CURVEPOINTS _ (COPYALL (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA)) STYLE _ (COPYALL (fetch (CURVEDATA STYLE) of OBJECTDATA]) (COPYFILLEDRECTANGLE [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for FILLEDRECTANGLE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create FILLEDRECTANGLEDATA OBJECTLEFT _ (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA) OBJECTBOTTOM _ (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) OBJECTWIDTH _ (fetch (FILLEDRECTANGLEDATA OBJECTWIDTH) of OBJECTDATA) OBJECTHEIGHT _ (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of OBJECTDATA) BORDERWIDTH _ (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) TEXTURE _ (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA]) (COPYGENERIC [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 1-Jun-92 16:41 by jds") (* ;; "Default COPYFN") (HCOPYALL (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT]) (COPYGRAPHOBJECT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create GRAPHDATA GRAPHFN _ (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA) NSAMPLES _ (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA) STYLE _ (COPYALL (fetch (GRAPHDATA STYLE) of OBJECTDATA]) (COPYLINE [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for LINE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create LINEDATA INFINITESLOPE? _ (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) SLOPE _ (fetch (LINEDATA SLOPE) of OBJECTDATA) CONSTANT _ (fetch (LINEDATA CONSTANT) of OBJECTDATA) STYLE _ (COPYALL (fetch (LINEDATA STYLE) of OBJECTDATA]) (COPYPOINT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for POINT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create POINTDATA POINTPOSITION _ (COPYALL (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) SYMBOL _ (fetch (POINTDATA SYMBOL) of OBJECTDATA]) (COPYPOLYGON [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") (* ;; "Copyfn for POLYGON objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create POLYGONDATA POLYGONPOINTS _ (COPYALL (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA)) STYLE _ (COPYALL (fetch (POLYGONDATA STYLE) of OBJECTDATA]) (COPYTEXT [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Copyfn for TEXT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (RETURN (create TEXTDATA TEXTPOSITION _ (COPYALL (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA)) TEXT _ (COPYALL (fetch (TEXTDATA TEXT) of OBJECTDATA)) FONT _ (fetch (TEXTDATA FONT) of OBJECTDATA]) (CREATECOMPOUND [LAMBDA (COMPOUNDTYPE COMPONENTS LABEL MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "create a compound plot object. First is the required Compoundtype, then the components, a list of plotobjects, then the optional label,and menu") (CREATEPLOTOBJECT COMPOUNDFNS 'COMPOUND LABEL MENU (create COMPOUNDDATA COMPONENTS _ COMPONENTS COMPOUNDTYPE _ COMPOUNDTYPE]) (CREATECURVE [LAMBDA (POSITIONS LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Create a curve plot object") (CREATEPLOTOBJECT CURVEFNS 'CURVE LABEL MENU (create CURVEDATA CURVEPOINTS _ POSITIONS STYLE _ (COND ((FIXP STYLE) (create PLOT.STYLE LINEWIDTH _ STYLE)) ((LISTP STYLE) (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE))) (T (create PLOT.STYLE LINEWIDTH _ 1]) (CREATEFILLEDRECTANGLE [LAMBDA (LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Create a filledrectangle plot object") (if (NULL TEXTURE) then (SETQ TEXTURE 'SHADE3)) (CREATEPLOTOBJECT FILLEDRECTANGLEFNS 'FILLEDRECTANGLE LABEL MENU (create FILLEDRECTANGLEDATA OBJECTLEFT _ LEFT OBJECTBOTTOM _ BOTTOM OBJECTWIDTH _ WIDTH OBJECTHEIGHT _ HEIGHT BORDERWIDTH _ (OR BORDERWIDTH 1) TEXTURE _ TEXTURE]) (CREATEGRAPH [LAMBDA (GRAPHFN NSAMPLES LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") (CREATEPLOTOBJECT GRAPHFNS 'GRAPH LABEL MENU (create GRAPHDATA GRAPHFN _ GRAPHFN NSAMPLES _ (OR (FIXP NSAMPLES) 100) STYLE _ (if (FIXP STYLE) then (create PLOT.STYLE LINEWIDTH _ STYLE) elseif (LISTP STYLE) then (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE)) else (create PLOT.STYLE LINEWIDTH _ 1]) (CREATELINE [LAMBDA (SLOPE CONSTANT LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") (* ;; "Create a line plot object") (CREATEPLOTOBJECT LINEFNS 'LINE LABEL MENU (create LINEDATA INFINITESLOPE? _ (NOT SLOPE) SLOPE _ (OR SLOPE 0.0) CONSTANT _ CONSTANT STYLE _ (COND ((FIXP STYLE) (create PLOT.STYLE LINEWIDTH _ STYLE)) ((LISTP STYLE) (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE))) (T (create PLOT.STYLE LINEWIDTH _ 1]) (CREATEPOINT [LAMBDA (POSITION LABEL SYMBOL MENU) (* ; "Edited 5-May-87 17:48 by jop") (* ;; "Create a point plot object") (if (NULL SYMBOL) then (SETQ SYMBOL STAR)) (CREATEPLOTOBJECT POINTFNS 'POINT LABEL MENU (create POINTDATA POINTPOSITION _ POSITION SYMBOL _ SYMBOL]) (CREATEPOLYGON [LAMBDA (POSITIONS LABEL STYLE MENU) (* ; "Edited 5-May-87 17:48 by jop") (* ;; "Create a polygon Plot object") (CREATEPLOTOBJECT POLYGONFNS 'POLYGON LABEL MENU (create POLYGONDATA POLYGONPOINTS _ POSITIONS STYLE _ (if (FIXP STYLE) then (create PLOT.STYLE LINEWIDTH _ STYLE) elseif (LISTP STYLE) then (create PLOT.STYLE LINEWIDTH _ (CAR STYLE) DASHING _ (CADR STYLE) COLOR _ (CADDR STYLE)) else (create PLOT.STYLE LINEWIDTH _ 1]) (CREATETEXT [LAMBDA (POSITION TEXT LABEL FONT MENU) (* ; "Edited 5-May-87 17:48 by jop") (* ;; "Create a Text Plot object") (CREATEPLOTOBJECT TEXTFNS 'TEXT LABEL MENU (create TEXTDATA TEXTPOSITION _ POSITION TEXT _ TEXT FONT _ FONT]) (DISTANCETOCOMPOUND [LAMBDA (COMPOUNDDATA STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:42 by jds") (PROG [(COMPONENTS (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDDATA] (RETURN (bind (CMIN _ (DISTANCETOPLOTOBJECT (CAR COMPONENTS) STREAMPOSITION PLOT)) PMIN for PART in (CDR COMPONENTS) do (SETQ PMIN (DISTANCETOPLOTOBJECT PART STREAMPOSITION PLOT)) (if (LESSP PMIN CMIN) then (SETQ CMIN PMIN)) finally (RETURN CMIN]) (DISTANCETOCURVE [LAMBDA (CURVEDATA STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC STREAMPOSITION (for POINT in (fetch (CURVEDATA STREAMPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of CURVEDATA)) smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLE STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) (CLOSEST (CONSTANT (create POSITION))) (STREAMX (fetch XCOORD of STREAMPOSITION)) (STREAMY (fetch YCOORD of STREAMPOSITION)) STREAMLEFT STREAMBOTTOM STREAMRIGHT STREAMTOP INSIDEFLG) (SETQ STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) (SETQ STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) (SETQ STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) (SETQ STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA)) [replace XCOORD of CLOSEST with (if (GREATERP STREAMX STREAMRIGHT) then STREAMRIGHT elseif (LESSP STREAMX STREAMLEFT) then STREAMLEFT else (if (OR (GREATERP STREAMY STREAMTOP) (LESSP STREAMY STREAMBOTTOM)) then STREAMX else (SETQ INSIDEFLG T) (* ;; "Hack to deal with the case of adjacent filledrectangles. Bonus subtracted from metric if cursor inside rectangle") (if (LESSP (IMIN (IDIFFERENCE STREAMTOP STREAMY) (IDIFFERENCE STREAMY STREAMBOTTOM)) (IMIN (IDIFFERENCE STREAMRIGHT STREAMX) (IDIFFERENCE STREAMX STREAMLEFT))) then STREAMX else (if (LESSP (IDIFFERENCE STREAMRIGHT STREAMX) (IDIFFERENCE STREAMX STREAMLEFT)) then STREAMRIGHT else STREAMLEFT] [replace YCOORD of CLOSEST with (if (GREATERP STREAMY STREAMTOP) then STREAMTOP elseif (LESSP STREAMY STREAMBOTTOM) then STREAMBOTTOM else (if (OR (GREATERP STREAMX STREAMRIGHT) (LESSP STREAMX STREAMLEFT)) then STREAMY else (if (LESSP (IMIN (IDIFFERENCE STREAMRIGHT STREAMX) (IDIFFERENCE STREAMX STREAMLEFT)) (IMIN (IDIFFERENCE STREAMTOP STREAMY) (IDIFFERENCE STREAMY STREAMBOTTOM))) then STREAMY else (if (LESSP (IDIFFERENCE STREAMTOP STREAMY) (IDIFFERENCE STREAMY STREAMBOTTOM)) then STREAMTOP else STREAMBOTTOM] (RETURN (if INSIDEFLG then (IDIFFERENCE (L1METRIC STREAMPOSITION CLOSEST) 2) else (L1METRIC STREAMPOSITION CLOSEST]) (DISTANCETOGRAPH [LAMBDA (GRAPHOBJECT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC STREAMPOSITION (for POINT in (fetch (GRAPHDATA STREAMPOSITIONS) of (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOLINE [LAMBDA (LINEOBJECT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (PROG ((X0 (fetch XCOORD of STREAMPOSITION)) (Y0 (fetch YCOORD of STREAMPOSITION)) (STREAMSLOPE (fetch STREAMSLOPE of (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) ) (STREAMCONSTANT (fetch STREAMCONSTANT of (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT))) MP BP XI YI) (* ; "Assumes use of the L1metric") (RETURN (FIXR (COND ((fetch INFINITESLOPE? of (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (FABS (FDIFFERENCE X0 STREAMCONSTANT))) ((EQP STREAMSLOPE 0.0) (FABS (FDIFFERENCE Y0 STREAMCONSTANT))) (T (SETQ MP (FMINUS (FQUOTIENT 1.0 STREAMSLOPE))) (SETQ BP (FDIFFERENCE Y0 (FTIMES MP X0))) (SETQ XI (FQUOTIENT (FDIFFERENCE BP STREAMCONSTANT) (FDIFFERENCE STREAMSLOPE MP))) (SETQ YI (FPLUS (FTIMES MP XI) BP)) (L1METRIC STREAMPOSITION (create POSITION XCOORD _ XI YCOORD _ YI]) (DISTANCETOPOINT [LAMBDA (POINT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC (fetch (POINTDATA STREAMPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT)) STREAMPOSITION]) (DISTANCETOPOLYGON [LAMBDA (POLYGONDATA STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC STREAMPOSITION (for POINT in (fetch (POLYGONDATA STREAMPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of POLYGONDATA)) smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOTEXT [LAMBDA (TEXTOBJECT STREAMPOSITION PLOT) (* ; "Edited 1-Jun-92 16:43 by jds") (L1METRIC (fetch (TEXTDATA STREAMPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) STREAMPOSITION]) (DRAWCOMPOUNDOBJECT [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:25") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (DRAWPLOTOBJECT OBJECT VIEWPORT PLOT]) (DRAWCURVEOBJECT [LAMBDA (CURVEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:49 by jop") (* ;; "Draw a series of connected lines in VIEWPORT. Style is the line width in pixels.") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) (POINTS (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA)) (STREAMPOINTS (for PT in POINTS collect (WORLDTOSTREAM PT VIEWPORT))) (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) (fetch YCOORD of (CAR STREAMPOINTS)) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'REPLACE STREAM COLOR DASHING)) (COND ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) (replace (CURVEDATA STREAMPOINTS) of OBJECTDATA with STREAMPOINTS]) (DRAWFILLEDRECTANGLEOBJECT [LAMBDA (FILLEDRECTANGLEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:49 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLEOBJECT)) (TEXTURE (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA)) (BORDERWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA))) STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT STREAMRIGHT STREAMTOP) (SETQ STREAMLEFT (WORLDTOSTREAMX (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA) VIEWPORT)) (SETQ STREAMBOTTOM (WORLDTOSTREAMY (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) VIEWPORT)) (SETQ STREAMWIDTH (DIFFERENCE (WORLDTOSTREAMX (fetch (FILLEDRECTANGLEDATA OBJECTRIGHT) of OBJECTDATA) VIEWPORT) STREAMLEFT)) (SETQ STREAMHEIGHT (DIFFERENCE (WORLDTOSTREAMY (fetch (FILLEDRECTANGLEDATA OBJECTTOP) of OBJECTDATA) VIEWPORT) STREAMBOTTOM)) (SETQ STREAMRIGHT (PLUS STREAMLEFT STREAMWIDTH)) (SETQ STREAMTOP (PLUS STREAMBOTTOM STREAMHEIGHT)) (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT 'TEXTURE 'PAINT TEXTURE) (MOVETO STREAMLEFT STREAMBOTTOM STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'REPLACE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'REPLACE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'REPLACE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'REPLACE STREAM) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA with STREAMLEFT) (replace (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA with STREAMBOTTOM) (replace (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA with STREAMWIDTH) (replace (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA with STREAMHEIGHT]) (DRAWGRAPHOBJECT [LAMBDA (GRAPHOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) (XUPPER (fetch (PLOT XUPPER) of PLOT)) (XLOWER (fetch (PLOT XLOWER) of PLOT)) (YUPPER (fetch (PLOT YUPPER) of PLOT)) (YLOWER (fetch (PLOT YLOWER) of PLOT)) (GRAPHFN (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA)) (NSAMPLES (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA)) (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) STREAMPOSITIONS) [SETQ STREAMPOSITIONS (NCONC1 (bind (INC _ (FQUOTIENT (FDIFFERENCE XUPPER XLOWER) (SUB1 NSAMPLES))) for I from 1 to (SUB1 NSAMPLES) as X from XLOWER by INC collect (CREATEPOSITION (WORLDTOSTREAMX X VIEWPORT) (WORLDTOSTREAMY (APPLY* GRAPHFN X) VIEWPORT))) (CREATEPOSITION (WORLDTOSTREAMX XUPPER VIEWPORT) (WORLDTOSTREAMY (APPLY* GRAPHFN XUPPER) VIEWPORT] (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) (fetch YCOORD of (CAR STREAMPOSITIONS)) STREAM) for PT in (CDR STREAMPOSITIONS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'REPLACE STREAM COLOR DASHING)) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA with STREAMPOSITIONS]) (DRAWLINEOBJECT [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (XUPPER (fetch (PLOT XUPPER) of PLOT)) (XLOWER (fetch (PLOT XLOWER) of PLOT)) (YUPPER (fetch (PLOT YUPPER) of PLOT)) (YLOWER (fetch (PLOT YLOWER) of PLOT)) (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) (INFINITESLOPE? (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA)) (SLOPE (fetch (LINEDATA SLOPE) of OBJECTDATA)) (CONSTANT (fetch (LINEDATA CONSTANT) of OBJECTDATA)) STREAMSLOPE STREAMCONSTANT STREAMPT1 STREAMPT2 X1 Y1 X2 Y2) (SETQ X1 (COND (INFINITESLOPE? CONSTANT) (T XLOWER))) [SETQ Y1 (COND (INFINITESLOPE? YLOWER) (T (FPLUS CONSTANT (FTIMES SLOPE X1] (SETQ X2 (COND (INFINITESLOPE? CONSTANT) (T XUPPER))) [SETQ Y2 (COND (INFINITESLOPE? YUPPER) (T (FPLUS CONSTANT (FTIMES SLOPE X2] [SETQ STREAMSLOPE (AND (NOT INFINITESLOPE?) (FTIMES SLOPE (FQUOTIENT (fetch (VIEWPORT WORLDTOSTREAMMY) of VIEWPORT) (fetch (VIEWPORT WORLDTOSTREAMMX) of VIEWPORT] [SETQ STREAMCONSTANT (COND (INFINITESLOPE? (WORLDTOSTREAMX CONSTANT VIEWPORT)) (T (FDIFFERENCE (WORLDTOSTREAMY CONSTANT VIEWPORT) (FTIMES STREAMSLOPE (fetch (VIEWPORT WORLDTOSTREAMAX) of VIEWPORT] (SETQ STREAMPT1 (CREATEPOSITION (WORLDTOSTREAMX X1 VIEWPORT) (WORLDTOSTREAMY Y1 VIEWPORT))) (SETQ STREAMPT2 (CREATEPOSITION (WORLDTOSTREAMX X2 VIEWPORT) (WORLDTOSTREAMY Y2 VIEWPORT))) (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'REPLACE STREAM COLOR DASHING) (COND ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) (COND (STREAMSLOPE (replace (LINEDATA STREAMSLOPE) of OBJECTDATA with STREAMSLOPE)) (T (replace (LINEDATA STREAMSLOPE) of OBJECTDATA with 0.0))) (replace (LINEDATA STREAMCONSTANT) of OBJECTDATA with STREAMCONSTANT) (replace (LINEDATA STREAMPT1) of OBJECTDATA with STREAMPT1) (replace (LINEDATA STREAMPT2) of OBJECTDATA with STREAMPT2]) (DRAWPOINTOBJECT [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (* ;; "Draw a glyph at POINTPOSITION. SYMBOL is the glyph to be drawn.") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (PT (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) (STREAMPT (WORLDTOSTREAM PT VIEWPORT))) (CLIPPED.PLOTAT STREAMSUBREGION STREAMPT SYMBOL STREAM) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (POINTDATA STREAMPOSITION) of OBJECTDATA with STREAMPT]) (DRAWPOLYGONOBJECT [LAMBDA (POLYGONOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") (* ;; "Draws a polygon in VIEWPORT.") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) (POINTS (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA)) (STREAMPOINTS (for PT in POINTS collect (WORLDTOSTREAM PT VIEWPORT))) (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) (fetch YCOORD of START) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'REPLACE STREAM COLOR DASHING) finally (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of START) (fetch YCOORD of START) LINEWIDTH 'REPLACE STREAM COLOR DASHING)) (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) then (replace (POLYGONDATA STREAMPOINTS) of OBJECTDATA with STREAMPOINTS]) (DRAWTEXTOBJECT [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (PT (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA)) STREAMX STREAMY) (SETQ STREAMX (WORLDTOSTREAMX (fetch XCOORD of PT) VIEWPORT)) (SETQ STREAMY (WORLDTOSTREAMY (fetch YCOORD of PT) VIEWPORT)) (RESETLST (RESETSAVE (DSPFONT FONT STREAM) (LIST 'DSPFONT (DSPFONT NIL STREAM) STREAM)) (MOVETO STREAMX STREAMY STREAM) (CLIPPED.PRIN1 STREAMSUBREGION TEXT STREAM)) (COND ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) 'DSP)) (replace (TEXTDATA STREAMPOSITION) of OBJECTDATA with (CREATEPOSITION STREAMX STREAMY]) (ERASECOMPOUNDOBJECT [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:26") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (ERASEPLOTOBJECT OBJECT PLOT]) (ERASECURVEOBJECT [LAMBDA (CURVEOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:51 by jop") (* ;; "Erase the CURVEOBJECT, using the cached stream coordinates") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) (STREAMPOINTS (fetch (CURVEDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) (fetch YCOORD of (CAR STREAMPOINTS)) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'ERASE STREAM COLOR]) (ERASEFILLEDRECTANGLEOBJECT [LAMBDA (FILLEDRECTANGLE VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) (TEXTURE (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA)) (BORDERWIDTH (TIMES (DSPSCALE NIL STREAM) (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA))) (STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) (STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) (STREAMWIDTH (fetch (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA)) (STREAMHEIGHT (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA)) (STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) (STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA))) (MOVETO STREAMLEFT STREAMBOTTOM STREAM) (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT 'TEXTURE 'INVERT TEXTURE) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'ERASE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'ERASE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'ERASE STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'ERASE STREAM]) (ERASEGRAPHOBJECT [LAMBDA (GRAPHOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) (STREAMPOSITIONS (fetch (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA)) (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) (fetch YCOORD of (CAR STREAMPOSITIONS)) STREAM) for PT in (CDR STREAMPOSITIONS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'ERASE STREAM COLOR]) (ERASELINEOBJECT [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS (fetch (PLOT.STYLE LINEWIDTH) of STYLE) 2)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) (STREAMPT1 (fetch (LINEDATA STREAMPT1) of OBJECTDATA)) (STREAMPT2 (fetch (LINEDATA STREAMPT2) of OBJECTDATA))) (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'ERASE STREAM COLOR]) (ERASEPOINTOBJECT [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") (* ;; "Erase POINT, using cached stream coordinates") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (STREAMPT (fetch (POINTDATA STREAMPOSITION) of OBJECTDATA))) (CLIPPED.PLOTAT STREAMSUBREGION STREAMPT SYMBOL STREAM 'ERASE]) (ERASEPOLYGONOBJECT [LAMBDA (POLYGONOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:52 by jop") (* ;; "Erase a POLYGONDATA") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) (STREAMPOINTS (fetch (POLYGONDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) (fetch YCOORD of START) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'ERASE STREAM COLOR) finally (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of START) (fetch YCOORD of START) LINEWIDTH 'ERASE STREAM COLOR]) (ERASETEXTOBJECT [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:52 by jop") (* ;; "ERASE the TEXTDATA") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (STREAMPOSITION (fetch (TEXTDATA STREAMPOSITION) of OBJECTDATA)) (STREAMX (fetch XCOORD of STREAMPOSITION)) (STREAMY (fetch YCOORD of STREAMPOSITION)) BLANCREGION) (RESETLST (RESETSAVE (DSPFONT FONT STREAM) (LIST 'DSPFONT (DSPFONT NIL STREAM) STREAM)) (MOVETO STREAMX STREAMY STREAM) (SETQ BLANCREGION (STRINGREGION TEXT STREAM)) (with REGION BLANCREGION (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE]) (EXTENTOFCOMPOUND [LAMBDA (COMPOUNDOBJECT) (* ; "Edited 1-Jun-92 16:46 by jds") (bind (CMINX _ MAX.FLOAT) (CMAXX _ MIN.FLOAT) (CMINY _ MAX.FLOAT) (CMAXY _ MIN.FLOAT) PEXTENT for PART in (fetch (COMPOUNDDATA COMPONENTS) of (fetch OBJECTDATA of COMPOUNDOBJECT)) declare (TYPE FLOATING CMINX CMAXX CMINY CMAXY) do (SETQ PEXTENT (EXTENTOFPLOTOBJECT PART)) (if (LESSP (fetch (EXTENT MINX) of PEXTENT) CMINX) then (SETQ CMINX (fetch (EXTENT MINX) of PEXTENT))) (if (GREATERP (fetch (EXTENT MAXX) of PEXTENT) CMAXX) then (SETQ CMAXX (fetch (EXTENT MAXX) of PEXTENT))) (if (LESSP (fetch (EXTENT MINY) of PEXTENT) CMINY) then (SETQ CMINY (fetch (EXTENT MINY) of PEXTENT))) (if (GREATERP (fetch (EXTENT MAXY) of PEXTENT) CMAXY) then (SETQ CMAXY (fetch (EXTENT MAXY) of PEXTENT))) finally (RETURN (create EXTENT MINX _ CMINX MAXX _ CMAXX MINY _ CMINY MAXY _ CMAXY]) (EXTENTOFCURVE [LAMBDA (CURVEOBJECT) (* ; "Edited 1-Jun-92 16:46 by jds") (bind (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) X Y for POSITION in (fetch (CURVEDATA CURVEPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT )) declare (TYPE FLOATING MINX MAXX MINY MAXY X Y) do (SETQ X (fetch XCOORD of POSITION)) (SETQ Y (fetch YCOORD of POSITION)) (COND ((FLESSP X MINX) (SETQ MINX X))) (COND ((FGREATERP X MAXX) (SETQ MAXX X))) (COND ((FLESSP Y MINY) (SETQ MINY Y))) (COND ((FGREATERP Y MAXY) (SETQ MAXY Y))) finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY]) (EXTENTOFFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLE) (* ; "Edited 1-Jun-92 16:46 by jds") (create EXTENT MINX _ (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) MAXX _ (fetch (FILLEDRECTANGLEDATA OBJECTRIGHT) of (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) MINY _ (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) MAXY _ (fetch (FILLEDRECTANGLEDATA OBJECTTOP) of (fetch (PLOTOBJECT OBJECTDATA ) of FILLEDRECTANGLE ]) (EXTENTOFGRAPH [LAMBDA (GRAPHOBJECT) (* ; "Edited 5-May-87 17:53 by jop") (create EXTENT MINX _ MAX.FLOAT MAXX _ MIN.FLOAT MINY _ MAX.FLOAT MAXY _ MIN.FLOAT]) (EXTENTOFLINE [LAMBDA (LINEOBJECT) (* jop%: " 5-Mar-85 14:03") (create EXTENT MINX _ MAX.FLOAT MAXX _ MIN.FLOAT MINY _ MAX.FLOAT MAXY _ MIN.FLOAT]) (EXTENTOFPOINT [LAMBDA (POINT) (* ; "Edited 1-Jun-92 16:47 by jds") (PROG [(POSITION (fetch (POINTDATA POINTPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT] (RETURN (create EXTENT MINX _ (fetch XCOORD of POSITION) MAXX _ (fetch XCOORD of POSITION) MINY _ (fetch YCOORD of POSITION) MAXY _ (fetch YCOORD of POSITION]) (EXTENTOFPOLYGON [LAMBDA (POLYGONOBJECT) (* ; "Edited 1-Jun-92 16:47 by jds") (bind (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) X Y for POSITION in (fetch POLYGONPOINTS of (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) declare (TYPE FLOATING MINX MAXX MINY MAXY X Y) do (SETQ X (fetch XCOORD of POSITION)) (SETQ Y (fetch YCOORD of POSITION)) (if (FLESSP X MINX) then (SETQ MINX X)) (if (FGREATERP X MAXX) then (SETQ MAXX X)) (if (FLESSP Y MINY) then (SETQ MINY Y)) (if (FGREATERP Y MAXY) then (SETQ MAXY Y)) finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY]) (EXTENTOFTEXT [LAMBDA (TEXTOBJECT) (* ; "Edited 1-Jun-92 16:47 by jds") (PROG [(POSITION (fetch TEXTPOSITION of (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT ] (RETURN (create EXTENT MINX _ (fetch XCOORD of POSITION) MAXX _ (fetch XCOORD of POSITION) MINY _ (fetch YCOORD of POSITION) MAXY _ (fetch YCOORD of POSITION]) (GETCOMPOUND [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:53 by jop") (* ;; "GETFN for COMPOUND objects") (create COMPOUNDDATA COMPOUNDTYPE _ (LISTGET PROPLST 'COMPOUNDTYPE) COMPONENTS _ (LISTGET PROPLST 'COMPONENTS]) (GETCURVE [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "GETFN for CURVE objects") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create CURVEDATA CURVEPOINTS _ (LISTGET PROPLST 'CURVEPOINTS) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETFILLEDRECTANGLE [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "GETFN for FILLEDRECTANGLE objects") (create FILLEDRECTANGLEDATA OBJECTLEFT _ (LISTGET PROPLST 'OBJECTLEFT) OBJECTBOTTOM _ (LISTGET PROPLST 'OBJECTBOTTOM) OBJECTWIDTH _ (LISTGET PROPLST 'OBJECTWIDTH) OBJECTHEIGHT _ (LISTGET PROPLST 'OBJECTHEIGHT) BORDERWIDTH _ (LISTGET PROPLST 'BORDERWIDTH) TEXTURE _ (LISTGET PROPLST 'TEXTURE]) (GETGENERIC [LAMBDA (EXPR) (* jop%: "27-Aug-85 17:11") EXPR]) (GETGRAPH [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create GRAPHDATA GRAPHFN _ (LISTGET PROPLST 'GRAPHFN) NSAMPLES _ (LISTGET PROPLST 'NSAMPLES) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETLINE [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "GETFN for LINE objects") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create LINEDATA INFINITESLOPE? _ (LISTGET PROPLST 'INFINITESLOPE?) SLOPE _ (LISTGET PROPLST 'SLOPE) CONSTANT _ (LISTGET PROPLST 'CONSTANT) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETPOINT [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") (* ;; "Putfn for POINT objects") (create POINTDATA POINTPOSITION _ (LISTGET PROPLST 'POINTPOSITION) SYMBOL _ (LET [(SYMBOL (LISTGET PROPLST 'SYMBOL] (if (LITATOM SYMBOL) then (EVAL SYMBOL) else SYMBOL]) (GETPOLYGON [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:55 by jop") (* ;; "GETFN for POLYGON objects") (PROG [(STYLELST (LISTGET PROPLST 'STYLE] (RETURN (create POLYGONDATA POLYGONPOINTS _ (LISTGET PROPLST 'POLYGONPOINTS) STYLE _ (create PLOT.STYLE LINEWIDTH _ (CAR STYLELST) DASHING _ (CADR STYLELST) COLOR _ (CADDR STYLELST]) (GETTEXT [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:55 by jop") (* ;; "GETFN for TEXT objects") (create TEXTDATA TEXTPOSITION _ (LISTGET PROPLST 'TEXTPOSITION) TEXT _ (LISTGET PROPLST 'TEXT) FONT _ (LISTGET PROPLST 'FONT]) (HIGHLIGHTCOMPOUND [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:26") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (HIGHLIGHTPLOTOBJECT OBJECT PLOT]) (HIGHLIGHTCURVE [LAMBDA (CURVEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (* ;; "Highlight the CURVEOBJECT, by redrawing in invert mode with fatter lines") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) (STREAMPOINTS (fetch (CURVEDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) (fetch YCOORD of (CAR STREAMPOINTS)) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLE VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) (BORDERWIDTH (IPLUS 2 (OR (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) 1))) (STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) (STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) (STREAMWIDTH (fetch (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA)) (STREAMHEIGHT (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA)) (STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) (STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA))) (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT 'TEXTURE 'INVERT BLACKSHADE) (MOVETO STREAMLEFT STREAMBOTTOM STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'INVERT STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'INVERT STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'INVERT STREAM) (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'INVERT STREAM]) (HIGHLIGHTGRAPH [LAMBDA (GRAPHOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) (STREAMPOSITIONS (fetch (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA)) (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) (fetch YCOORD of (CAR STREAMPOSITIONS)) STREAM) for PT in (CDR STREAMPOSITIONS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTLINE [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS (fetch (PLOT.STYLE LINEWIDTH) of STYLE) 2)) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) (STREAMPT1 (fetch (LINEDATA STREAMPT1) of OBJECTDATA)) (STREAMPT2 (fetch (LINEDATA STREAMPT2) of OBJECTDATA))) (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTPOINT [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "Highlight POINT") (LET* [(STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (STREAMPT (fetch (POINTDATA STREAMPOSITION) of OBJECTDATA)) (WIDTHGLYPH (BITMAPWIDTH SYMBOL)) (HEIGHTGLYPH (BITMAPHEIGHT SYMBOL)) (OFFSETX (IDIFFERENCE (fetch XCOORD of STREAMPT) (IQUOTIENT WIDTHGLYPH 2))) (OFFSETY (IDIFFERENCE (fetch YCOORD of STREAMPT) (IQUOTIENT HEIGHTGLYPH 2] (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM OFFSETX OFFSETY WIDTHGLYPH HEIGHTGLYPH 'TEXTURE 'INVERT BLACKSHADE]) (HIGHLIGHTPOLYGON [LAMBDA (POLYGONOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "Highlight a Polygon") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) (STREAMPOINTS (fetch (POLYGONDATA STREAMPOINTS) of OBJECTDATA)) (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) (fetch YCOORD of START) STREAM) for PT in (CDR STREAMPOINTS) do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) (fetch YCOORD of PT) LINEWIDTH 'INVERT STREAM COLOR) finally (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of START) (fetch YCOORD of START) LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTTEXT [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "HIGHLIGHT the TEXTDATA") (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (STREAMPOSITION (fetch (TEXTDATA STREAMPOSITION) of OBJECTDATA)) (STREAMX (fetch XCOORD of STREAMPOSITION)) (STREAMY (fetch YCOORD of STREAMPOSITION)) BLANCREGION) (RESETLST (RESETSAVE (DSPFONT FONT STREAM) (LIST 'DSPFONT (DSPFONT NIL STREAM) STREAM)) (MOVETO STREAMX STREAMY STREAM) (SETQ BLANCREGION (STRINGREGION TEXT STREAM)) (with REGION BLANCREGION (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE 'INVERT BLACKSHADE]) (LABELGENERIC [LAMBDA (OBJECT PLOT) (* ; "Edited 1-Jun-92 16:49 by jds") (* ;; "Generic label routine. Intended for interactive use only") (PROG ((LABEL (fetch OBJECTLABEL of OBJECT)) (VIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) LABELPOSITION) (COND (TEXTOBJECT (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT)) (T (PLOTPROMPT (CONCAT "SELECT A POSITION FOR LABEL " LABEL) PLOT) (SETQ LABELPOSITION (STREAMTOWORLD (GETPOSITION (fetch (PLOT PLOTWINDOW) of PLOT)) VIEWPORT)) (SETQ TEXTOBJECT (CREATETEXT LABELPOSITION LABEL NIL SMALLPLOTFONT)) (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) (PLOTOBJECTPROP OBJECT 'LABEL TEXTOBJECT]) (LABELPOINT [LAMBDA (POINT PLOT) (* ; "Edited 5-May-87 17:56 by jop") (* ;; "Label a POINT") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) (VIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) (LABEL (fetch (PLOTOBJECT OBJECTLABEL) of POINT)) (TEXTOBJECT (PLOTOBJECTPROP POINT 'LABEL)) SYMBOL LABELPOSITION) (SETQ LABELPOSITION (create POSITION using (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) ) (SETQ SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (* ;  "Displace Label to right of point object") (if TEXTOBJECT then (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) else [replace XCOORD of LABELPOSITION with (PLUS (fetch XCOORD of LABELPOSITION) (TIMES 2 (STREAMTOWORLDXLENGTH (BITMAPWIDTH SYMBOL) VIEWPORT] (SETQ TEXTOBJECT (CREATETEXT LABELPOSITION LABEL NIL SMALLPLOTFONT)) (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) (* ;  "CACHE LABEL ON PROP LIST OF OBJECT") (PLOTOBJECTPROP POINT 'LABEL TEXTOBJECT]) (LABELTEXT [LAMBDA (TEXTOBJECT PLOT) (* jop%: "20-Feb-86 17:56") (PLOTPROMPT "Cannot label text" PLOT]) (LOWLIGHTCOMPOUND [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:27") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT )) do (LOWLIGHTPLOTOBJECT OBJECT PLOT]) (MOVECOMPOUND [LAMBDA (COMPOUNDOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of COMPOUNDOBJECT)) do (MOVEPLOTOBJECT OBJECT DX DY PLOT]) (MOVECURVE [LAMBDA (CURVEOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG [(POINTS (fetch (CURVEDATA CURVEPOINTS) of (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT] (for POINT in POINTS do (replace XCOORD of POINT with (PLUS DX (fetch XCOORD of POINT))) (replace YCOORD of POINT with (PLUS DY (fetch YCOORD of POINT]) (MOVEFILLEDRECTANGLE [LAMBDA (FILLEDRECTANGLEOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLEOBJECT))) (replace (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA with (PLUS DX (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA))) (replace (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA with (PLUS DY (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA]) (MOVELINE [LAMBDA (LINEOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT))) (replace (LINEDATA CONSTANT) of OBJECTDATA with (if (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) then (PLUS DX (fetch (LINEDATA CONSTANT) of OBJECTDATA)) else (DIFFERENCE (PLUS (fetch (LINEDATA CONSTANT) of OBJECTDATA) (TIMES DX (fetch (LINEDATA SLOPE) of OBJECTDATA)) ) DY]) (MOVEPOINT [LAMBDA (POINT DX DY PLOT) (* jop%: "24-Feb-86 14:43") (PROG [(POSITION (fetch (POINTDATA POINTPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT] (replace XCOORD of POSITION with (PLUS DX (fetch XCOORD of POSITION))) (replace YCOORD of POSITION with (PLUS DY (fetch YCOORD of POSITION]) (MOVEPOLYGON [LAMBDA (POLYGONOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG [(POINTS (fetch POLYGONPOINTS of (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT ] (for POINT in POINTS do (replace XCOORD of POINT with (PLUS DX (fetch XCOORD of POINT))) (replace YCOORD of POINT with (PLUS DY (fetch YCOORD of POINT]) (MOVETEXT [LAMBDA (TEXTOBJECT DX DY PLOT) (* ; "Edited 1-Jun-92 16:50 by jds") (PROG [(POSITION (fetch TEXTPOSITION of (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT ] (replace XCOORD of POSITION with (PLUS DX (fetch XCOORD of POSITION))) (replace YCOORD of POSITION with (PLUS DY (fetch YCOORD of POSITION]) (PLOTCOMPOUND [LAMBDA ARGS (* ; "Edited 5-May-87 17:57 by jop") (* ;; "ADD A COMPOUND OBJECT with an unknown number of COMPONENTS. First arg must be a PLOT. Second arg must be the compound object type. Next are the Nospread COMPONENTS, then the optional LABEL, MENU, and NODRAWFLG") (if (LESSP ARGS 3) then (HELP "Must have at least 3 args. Plot, compound type, and one component")) (PROG ((PLOT (ARG ARGS 1)) (COMPOUNDTYPE (ARG ARGS 2)) COMPONENTS STARTRESTARGS) (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (SETQ COMPONENTS (for I from 3 to ARGS while (type? PLOTOBJECT (ARG ARGS I)) collect (ARG ARGS I))) (SETQ STARTRESTARGS (PLUS 3 (LENGTH COMPONENTS))) (RETURN (ADDPLOTOBJECT [CREATECOMPOUND COMPOUNDTYPE COMPONENTS (if (GEQ ARGS STARTRESTARGS) then (ARG ARGS STARTRESTARGS)) (if (GEQ ARGS (PLUS 1 STARTRESTARGS)) then (ARG ARGS (PLUS 1 STARTRESTARGS] PLOT (if (GEQ ARGS (PLUS 2 STARTRESTARGS)) then (ARG ARGS (PLUS 2 STARTRESTARGS]) (PLOTCURVE [LAMBDA (PLOT POSITIONS LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:57 by jop") (* ;; "User Entry Point. Draw a piecewise linear curve in a Plotting WINDOW. Style is either the line width to use or a list (width dashing color) or an instance of PLOT.STYLE. POSITIONS is a list of positions to be contected.") (COND ((NOT (type? PLOT PLOT)) (HELP "NOT a PLOT " PLOT))) (ADDPLOTOBJECT (CREATECURVE POSITIONS LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTFILLEDRECTANGLE [LAMBDA (PLOT LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU NODRAWFLG) (* ; "Edited 5-May-87 17:57 by jop") (* ;;  "User Entry Point. Draw a FILLEDRECTANGLE in a Plotting WINDOW. Style is the line width to use.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (if (NULL TEXTURE) then (SETQ TEXTURE SHADE3)) (ADDPLOTOBJECT (CREATEFILLEDRECTANGLE LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU) PLOT NODRAWFLG]) (PLOTGRAPH [LAMBDA (PLOT GRAPHFN NSAMPLES LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (ADDPLOTOBJECT (CREATEGRAPH GRAPHFN NSAMPLES LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTLINE [LAMBDA (PLOT SLOPE CONSTANT LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point.") (COND ((NOT (type? PLOT PLOT)) (HELP "NOT a PLOT " PLOT))) (ADDPLOTOBJECT (CREATELINE SLOPE CONSTANT LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTPOINT [LAMBDA (PLOT POSITION LABEL SYMBOL MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User entry point. Add a point to the plotwindow WINDOW, at world position POSITION, with Label LABEL and plotting symbol SYMBOL") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (ADDPLOTOBJECT (CREATEPOINT POSITION LABEL SYMBOL MENU) PLOT NODRAWFLG]) (PLOTPOINTS [LAMBDA (PLOT POSITIONS LABELS SYMBOL MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point. Draw the POINTs at POSITIONS in a Plotting WINDOW. Symbol is a LITATOM which Describes the glyph to use.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (PROG (EXTENT NEWSCALES OBJECTS) [SETQ EXTENT (bind (MINX _ MAX.FLOAT) (MAXX _ MIN.FLOAT) (MINY _ MAX.FLOAT) (MAXY _ MIN.FLOAT) for PT in POSITIONS do (if (LESSP (fetch XCOORD of PT) MINX) then (SETQ MINX (fetch XCOORD of PT))) (if (GREATERP (fetch XCOORD of PT) MAXX) then (SETQ MAXX (fetch XCOORD of PT))) (if (LESSP (fetch YCOORD of PT) MINY) then (SETQ MINY (fetch YCOORD of PT))) (if (GREATERP (fetch YCOORD of PT) MAXY) then (SETQ MAXY (fetch YCOORD of PT))) finally (RETURN (create EXTENT MINX _ MINX MAXX _ MAXX MINY _ MINY MAXY _ MAXY] (ADJUSTSCALE? EXTENT PLOT) (* ;  "Scale up the plot so that each ADDOBJECT need not rescale") [SETQ OBJECTS (bind (LABEL _ LABELS) for POSITION in POSITIONS collect (PROG1 (CREATEPOINT POSITION (CAR LABEL) SYMBOL MENU) (SETQ LABEL (CDR LABEL] (* ; "Do surgury on the display list") (replace (PLOT PLOTOBJECTS) of PLOT with (APPEND OBJECTS (fetch (PLOT PLOTOBJECTS) of PLOT))) (if (NULL NODRAWFLG) then (REDRAWPLOTWINDOW PLOT)) (RETURN OBJECTS]) (PLOTPOLYGON [LAMBDA (PLOT POSITIONS LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") (* ;; "User Entry Point. Draw a POLYGON in a Plotting WINDOW. Style is the line width to use. POSITIONS is a list of positions to be contected.") (if (NOT (type? PLOT PLOT)) then (HELP "NOT a PLOT " PLOT)) (ADDPLOTOBJECT (CREATEPOLYGON POSITIONS LABEL STYLE MENU) PLOT NODRAWFLG]) (PLOTTEXT [LAMBDA (PLOT POSITION TEXT LABEL FONT MENU NODRAWFLG) (* edited%: "27-Mar-86 21:22") (COND ((NOT (type? PLOT PLOT)) (HELP "NOT A PLOT " PLOT))) (COND ((NULL FONT) (SETQ FONT SMALLPLOTFONT))) (ADDPLOTOBJECT (CREATETEXT POSITION TEXT LABEL FONT MENU) PLOT NODRAWFLG]) (PUTCOMPOUND [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "PUTFN for COMPOUND objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (PRINTOUT STREAM "(" %,) (PRINTOUT STREAM "COMPOUNDTYPE" %, |.P2| (fetch (COMPOUNDDATA COMPOUNDTYPE) of OBJECTDATA) %,) (PRINTOUT STREAM "COMPONENTS (" %,) (* ;  "THIS ASSUMES APPROPRIATE HPRINT MACROS") (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of OBJECTDATA) do (HPRINT OBJECT STREAM T T)) (PRINTOUT STREAM "))"]) (PUTCURVE [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "Putfn for CURVE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "CURVEPOINTS" %, |.P2| (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA ) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) %, ")"]) (PUTFILLEDRECTANGLE [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "PUTFN for FILLEDRECTANGLE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) (PRINTOUT STREAM "(" %,) (PRINTOUT STREAM "OBJECTLEFT" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA ) %,) (PRINTOUT STREAM "OBJECTBOTTOM" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) %,) (PRINTOUT STREAM "OBJECTWIDTH" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTWIDTH) of OBJECTDATA) %,) (PRINTOUT STREAM "OBJECTHEIGHT" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of OBJECTDATA) %,) (PRINTOUT STREAM "BORDERWIDTH" %, |.P2| (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) %,) (PRINTOUT STREAM "TEXTURE" %, |.P2| (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA) %,) (PRINTOUT STREAM ")"]) (PUTGENERIC [LAMBDA (OBJECT PLOT STREAM) (* ; "Edited 1-Jun-92 16:52 by jds") (HPRINT (fetch (PLOTOBJECT OBJECTDATA) of OBJECT) STREAM NIL T]) (PUTGRAPH [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "Putfn for CURVE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "GRAPHFN" %, |.P2| (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA) %, "NSAMPLES" %, |.P2| (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) %, ")"]) (PUTLINE [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") (* ;; "Putfn for LINE objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "INFINITESLOPE?" %, |.P2| (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) %, "SLOPE" %, |.P2| (fetch (LINEDATA SLOPE) of OBJECTDATA) %, "CONSTANT" %, |.P2| (fetch (LINEDATA CONSTANT) of OBJECTDATA) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) ")"]) (PUTPOINT [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") (* ;; "Putfn for POINT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) SYMBOL LAB) (SETQ SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) (SETQ LAB (if (EQ SYMBOL STAR) then 'STAR elseif (EQ SYMBOL CROSS) then 'CROSS elseif (EQ SYMBOL CIRCLE) then 'CIRCLE)) (PRINTOUT STREAM "(" %, "POINTPOSITION" %, |.P2| (fetch (POINTDATA POINTPOSITION) of OBJECTDATA) %, "SYMBOL" %,) (if LAB then (PRINTOUT STREAM |.P2| LAB %,) else (HPRINT SYMBOL STREAM T T)) (PRINTOUT STREAM ")"]) (PUTPOLYGON [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") (* ;; "Putfn for POLYGON objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) STYLE) (SETQ STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "POLYGONPOINTS" %, |.P2| (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA) %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) (fetch (PLOT.STYLE DASHING) of STYLE) (fetch (PLOT.STYLE COLOR) of STYLE)) %, ")"]) (PUTTEXT [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") (* ;; "Putfn for TEXT objects") (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) FONT) (SETQ FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) (PRINTOUT STREAM "(" %, "TEXTPOSITION" %, |.P2| (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA ) %, "TEXT" %, |.P2| (fetch (TEXTDATA TEXT) of OBJECTDATA) %, "FONT" %,) (* ; "Assumes FONT has an HPRINTMACRO") (HPRINT FONT STREAM T T) (PRINTOUT STREAM ")"]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS L1METRIC MACRO [OPENLAMBDA (POINT1 POINT2) (* jop%: "17-Jan-85 15:27") (* ;; "Computes the L 1 metric between POINT1 and POINT2") (PLUS (IABS (DIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2))) (IABS (DIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2]) (PUTPROPS L2METRIC MACRO [OPENLAMBDA (POINT1 POINT2 PLOT) (* jop%: "17-Jan-85 15:27") (* ;; "Computes the L 2 metric between POINT1 and POINT2") (FPLUS (FTIMES (FDIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2)) (FDIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2))) (FTIMES (FTIMES (fetch NORMCONSTANT of PLOT) (FDIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2) )) (FTIMES (fetch NORMCONSTANT of PLOT) (FDIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2]) ) (RPAQQ CIRCLE #*(5 5)G@@@HH@@HH@@HH@@G@@@) (RPAQQ CROSS #*(5 5)B@@@B@@@OH@@B@@@B@@@) (RPAQQ DASH (5)) (RPAQQ DOT (1 5)) (RPAQQ DOTDASH (5 5 1 5)) (RPAQQ SHADE1 64) (RPAQQ SHADE2 576) (RPAQQ SHADE3 4680) (RPAQQ SHADE4 37449) (RPAQQ SHADE5 55899) (RPAQQ SHADE6 31710) (RPAQQ SHADE7 64479) (RPAQQ SHADE8 65023) (RPAQQ STAR #*(5 5)JH@@G@@@OH@@G@@@JH@@) (DECLARE%: EVAL@COMPILE (DATATYPE COMPOUNDDATA (COMPOUNDTYPE COMPONENTS)) (DATATYPE CURVEDATA (CURVEPOINTS STREAMPOINTS STYLE)) (DATATYPE FILLEDRECTANGLEDATA ((OBJECTLEFT FLOATING) (OBJECTBOTTOM FLOATING) (OBJECTWIDTH FLOATING) (OBJECTHEIGHT FLOATING) STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT BORDERWIDTH TEXTURE) BORDERWIDTH _ 1 [ACCESSFNS ((OBJECTRIGHT (PLUS (fetch ( FILLEDRECTANGLEDATA OBJECTLEFT) of DATUM) (fetch ( FILLEDRECTANGLEDATA OBJECTWIDTH) of DATUM))) (OBJECTTOP (PLUS (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of DATUM) (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of DATUM))) (STREAMRIGHT (PLUS (fetch ( FILLEDRECTANGLEDATA STREAMLEFT) of DATUM) (fetch ( FILLEDRECTANGLEDATA STREAMWIDTH) of DATUM))) (STREAMTOP (PLUS (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of DATUM) (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of DATUM]) (DATATYPE GRAPHDATA (GRAPHFN NSAMPLES STYLE STREAMPOSITIONS)) (DATATYPE LINEDATA (STYLE INFINITESLOPE? (SLOPE FLOATING) (CONSTANT FLOATING) (STREAMSLOPE FLOATING) (STREAMCONSTANT FLOATING) STREAMPT1 STREAMPT2) STYLE _ 1) (DATATYPE PLOT.STYLE (LINEWIDTH DASHING COLOR) LINEWIDTH _ 1) (DATATYPE POINTDATA (POINTPOSITION STREAMPOSITION SYMBOL) SYMBOL _ STAR) (DATATYPE POLYGONDATA (POLYGONPOINTS STREAMPOINTS STYLE) STYLE _ 1) (DATATYPE TEXTDATA (TEXTPOSITION STREAMPOSITION TEXT FONT) FONT _ SMALLPLOTFONT) ) (/DECLAREDATATYPE 'COMPOUNDDATA '(POINTER POINTER) '((COMPOUNDDATA 0 POINTER) (COMPOUNDDATA 2 POINTER)) '4) (/DECLAREDATATYPE 'CURVEDATA '(POINTER POINTER POINTER) '((CURVEDATA 0 POINTER) (CURVEDATA 2 POINTER) (CURVEDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'FILLEDRECTANGLEDATA '(FLOATP FLOATP FLOATP FLOATP POINTER POINTER POINTER POINTER POINTER POINTER) '((FILLEDRECTANGLEDATA 0 FLOATP) (FILLEDRECTANGLEDATA 2 FLOATP) (FILLEDRECTANGLEDATA 4 FLOATP) (FILLEDRECTANGLEDATA 6 FLOATP) (FILLEDRECTANGLEDATA 8 POINTER) (FILLEDRECTANGLEDATA 10 POINTER) (FILLEDRECTANGLEDATA 12 POINTER) (FILLEDRECTANGLEDATA 14 POINTER) (FILLEDRECTANGLEDATA 16 POINTER) (FILLEDRECTANGLEDATA 18 POINTER)) '20) (/DECLAREDATATYPE 'GRAPHDATA '(POINTER POINTER POINTER POINTER) '((GRAPHDATA 0 POINTER) (GRAPHDATA 2 POINTER) (GRAPHDATA 4 POINTER) (GRAPHDATA 6 POINTER)) '8) (/DECLAREDATATYPE 'LINEDATA '(POINTER POINTER FLOATP FLOATP FLOATP FLOATP POINTER POINTER) '((LINEDATA 0 POINTER) (LINEDATA 2 POINTER) (LINEDATA 4 FLOATP) (LINEDATA 6 FLOATP) (LINEDATA 8 FLOATP) (LINEDATA 10 FLOATP) (LINEDATA 12 POINTER) (LINEDATA 14 POINTER)) '16) (/DECLAREDATATYPE 'PLOT.STYLE '(POINTER POINTER POINTER) '((PLOT.STYLE 0 POINTER) (PLOT.STYLE 2 POINTER) (PLOT.STYLE 4 POINTER)) '6) (/DECLAREDATATYPE 'POINTDATA '(POINTER POINTER POINTER) '((POINTDATA 0 POINTER) (POINTDATA 2 POINTER) (POINTDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'POLYGONDATA '(POINTER POINTER POINTER) '((POLYGONDATA 0 POINTER) (POLYGONDATA 2 POINTER) (POLYGONDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'TEXTDATA '(POINTER POINTER POINTER POINTER) '((TEXTDATA 0 POINTER) (TEXTDATA 2 POINTER) (TEXTDATA 4 POINTER) (TEXTDATA 6 POINTER)) '8) (PUTPROPS PLOTCOMPOUND ARGNAMES (NIL (PLOT COMPOUNDTYPE COMPONENT1 |...| LABEL MENU NODRAWFLG ) . COMPOUNDARGS)) (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 PLOTCOMPOUND) ) (PUTPROPS PLOTOBJECTS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3192 93498 (COPYCOMPOUND 3202 . 3810) (COPYCURVE 3812 . 4306) (COPYFILLEDRECTANGLE 4308 . 5251) (COPYGENERIC 5253 . 5475) (COPYGRAPHOBJECT 5477 . 5987) (COPYLINE 5989 . 6640) (COPYPOINT 6642 . 7133) (COPYPOLYGON 7135 . 7643) (COPYTEXT 7645 . 8213) (CREATECOMPOUND 8215 . 8779) ( CREATECURVE 8781 . 10109) (CREATEFILLEDRECTANGLE 10111 . 10807) (CREATEGRAPH 10809 . 12202) ( CREATELINE 12204 . 13659) (CREATEPOINT 13661 . 14135) (CREATEPOLYGON 14137 . 15494) (CREATETEXT 15496 . 15862) (DISTANCETOCOMPOUND 15864 . 16616) (DISTANCETOCURVE 16618 . 17085) ( DISTANCETOFILLEDRECTANGLE 17087 . 21005) (DISTANCETOGRAPH 21007 . 21479) (DISTANCETOLINE 21481 . 23257 ) (DISTANCETOPOINT 23259 . 23581) (DISTANCETOPOLYGON 23583 . 24056) (DISTANCETOTEXT 24058 . 24382) ( DRAWCOMPOUNDOBJECT 24384 . 24910) (DRAWCURVEOBJECT 24912 . 26547) (DRAWFILLEDRECTANGLEOBJECT 26549 . 29377) (DRAWGRAPHOBJECT 29379 . 31949) (DRAWLINEOBJECT 31951 . 35386) (DRAWPOINTOBJECT 35388 . 36325) (DRAWPOLYGONOBJECT 36327 . 38423) (DRAWTEXTOBJECT 38425 . 39751) (ERASECOMPOUNDOBJECT 39753 . 40196) ( ERASECURVEOBJECT 40198 . 41371) (ERASEFILLEDRECTANGLEOBJECT 41373 . 43088) (ERASEGRAPHOBJECT 43090 . 44185) (ERASELINEOBJECT 44187 . 45036) (ERASEPOINTOBJECT 45038 . 45698) (ERASEPOLYGONOBJECT 45700 . 47297) (ERASETEXTOBJECT 47299 . 48527) (EXTENTOFCOMPOUND 48529 . 50047) (EXTENTOFCURVE 50049 . 52434) (EXTENTOFFILLEDRECTANGLE 52436 . 53844) (EXTENTOFGRAPH 53846 . 54109) (EXTENTOFLINE 54111 . 54362) ( EXTENTOFPOINT 54364 . 54973) (EXTENTOFPOLYGON 54975 . 56852) (EXTENTOFTEXT 56854 . 57538) (GETCOMPOUND 57540 . 57867) (GETCURVE 57869 . 58459) (GETFILLEDRECTANGLE 58461 . 59027) (GETGENERIC 59029 . 59152) (GETGRAPH 59154 . 59742) (GETLINE 59744 . 60459) (GETPOINT 60461 . 60933) (GETPOLYGON 60935 . 61535) (GETTEXT 61537 . 61882) (HIGHLIGHTCOMPOUND 61884 . 62329) (HIGHLIGHTCURVE 62331 . 63517) ( HIGHLIGHTFILLEDRECTANGLE 63519 . 65151) (HIGHLIGHTGRAPH 65153 . 66247) (HIGHLIGHTLINE 66249 . 67097) ( HIGHLIGHTPOINT 67099 . 68152) (HIGHLIGHTPOLYGON 68154 . 69755) (HIGHLIGHTTEXT 69757 . 71006) ( LABELGENERIC 71008 . 72036) (LABELPOINT 72038 . 73693) (LABELTEXT 73695 . 73849) (LOWLIGHTCOMPOUND 73851 . 74294) (MOVECOMPOUND 74296 . 74760) (MOVECURVE 74762 . 75416) (MOVEFILLEDRECTANGLE 75418 . 75978) (MOVELINE 75980 . 76814) (MOVEPOINT 76816 . 77242) (MOVEPOLYGON 77244 . 77976) (MOVETEXT 77978 . 78553) (PLOTCOMPOUND 78555 . 80040) (PLOTCURVE 80042 . 80595) (PLOTFILLEDRECTANGLE 80597 . 81233) ( PLOTGRAPH 81235 . 81592) (PLOTLINE 81594 . 81945) (PLOTPOINT 81947 . 82408) (PLOTPOINTS 82410 . 84826) (PLOTPOLYGON 84828 . 85304) (PLOTTEXT 85306 . 85661) (PUTCOMPOUND 85663 . 86442) (PUTCURVE 86444 . 87260) (PUTFILLEDRECTANGLE 87262 . 88775) (PUTGENERIC 88777 . 88983) (PUTGRAPH 88985 . 89819) (PUTLINE 89821 . 90808) (PUTPOINT 90810 . 91801) (PUTPOLYGON 91803 . 92628) (PUTTEXT 92630 . 93496))))) STOP \ No newline at end of file diff --git a/lispusers/PLOTOBJECTS.~2~ b/lispusers/PLOTOBJECTS.~2~ deleted file mode 100644 index 4a6e7909..00000000 --- a/lispusers/PLOTOBJECTS.~2~ +++ /dev/null @@ -1,1263 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-May-2000 10:31:55" {DSK}medley3.5>lispusers>PLOTOBJECTS.;3 98205 changes to%: (VARS PLOTOBJECTSCOMS CIRCLE CROSS) previous date%: " 4-Nov-93 14:59:31" {DSK}medley3.5>lispusers>PLOTOBJECTS.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1993, 2000 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PLOTOBJECTSCOMS) (RPAQQ PLOTOBJECTSCOMS [(FNS COPYCOMPOUND COPYCURVE COPYFILLEDRECTANGLE COPYGENERIC COPYGRAPHOBJECT COPYLINE COPYPOINT COPYPOLYGON COPYTEXT CREATECOMPOUND CREATECURVE CREATEFILLEDRECTANGLE CREATEGRAPH CREATELINE CREATEPOINT CREATEPOLYGON CREATETEXT DISTANCETOCOMPOUND DISTANCETOCURVE DISTANCETOFILLEDRECTANGLE DISTANCETOGRAPH DISTANCETOLINE DISTANCETOPOINT DISTANCETOPOLYGON DISTANCETOTEXT DRAWCOMPOUNDOBJECT DRAWCURVEOBJECT DRAWFILLEDRECTANGLEOBJECT DRAWGRAPHOBJECT DRAWLINEOBJECT DRAWPOINTOBJECT DRAWPOLYGONOBJECT DRAWTEXTOBJECT ERASECOMPOUNDOBJECT ERASECURVEOBJECT ERASEFILLEDRECTANGLEOBJECT ERASEGRAPHOBJECT ERASELINEOBJECT ERASEPOINTOBJECT ERASEPOLYGONOBJECT ERASETEXTOBJECT EXTENTOFCOMPOUND EXTENTOFCURVE EXTENTOFFILLEDRECTANGLE EXTENTOFGRAPH EXTENTOFLINE EXTENTOFPOINT EXTENTOFPOLYGON EXTENTOFTEXT GETCOMPOUND GETCURVE GETFILLEDRECTANGLE GETGENERIC GETGRAPH GETLINE GETPOINT GETPOLYGON GETTEXT HIGHLIGHTCOMPOUND HIGHLIGHTCURVE HIGHLIGHTFILLEDRECTANGLE HIGHLIGHTGRAPH HIGHLIGHTLINE HIGHLIGHTPOINT HIGHLIGHTPOLYGON HIGHLIGHTTEXT LABELGENERIC LABELPOINT LABELTEXT LOWLIGHTCOMPOUND MOVECOMPOUND MOVECURVE MOVEFILLEDRECTANGLE MOVELINE MOVEPOINT MOVEPOLYGON MOVETEXT PLOTCOMPOUND PLOTCURVE PLOTFILLEDRECTANGLE PLOTGRAPH PLOTLINE PLOTPOINT PLOTPOINTS PLOTPOLYGON PLOTTEXT PUTCOMPOUND PUTCURVE PUTFILLEDRECTANGLE PUTGENERIC PUTGRAPH PUTLINE PUTPOINT PUTPOLYGON PUTTEXT) (MACROS L1METRIC L2METRIC) (VARS CIRCLE CROSS DASH DOT DOTDASH SHADE1 SHADE2 SHADE3 SHADE4 SHADE5 SHADE6 SHADE7 SHADE8 STAR) (RECORDS COMPOUNDDATA CURVEDATA FILLEDRECTANGLEDATA GRAPHDATA LINEDATA PLOT.STYLE POINTDATA POLYGONDATA TEXTDATA) (PROP ARGNAMES PLOTCOMPOUND) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) PLOT TWODGRAPHICS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PLOTCOMPOUND]) (DEFINEQ (COPYCOMPOUND - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:45 by jop") - - (* ;; "Copyfn for COMPOUND objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create COMPOUNDDATA - COMPONENTS _ (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of OBJECTDATA) - collect (COPYPLOTOBJECT OBJECT PLOT)) - COMPOUNDTYPE _ (fetch (COMPOUNDDATA COMPOUNDTYPE) of OBJECTDATA]) (COPYCURVE - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (* ;; "Copyfn for CURVE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create CURVEDATA - CURVEPOINTS _ (COPYALL (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA)) - STYLE _ (COPYALL (fetch (CURVEDATA STYLE) of OBJECTDATA]) (COPYFILLEDRECTANGLE - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (* ;; "Copyfn for FILLEDRECTANGLE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create FILLEDRECTANGLEDATA - OBJECTLEFT _ (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA) - OBJECTBOTTOM _ (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) - OBJECTWIDTH _ (fetch (FILLEDRECTANGLEDATA OBJECTWIDTH) of OBJECTDATA) - OBJECTHEIGHT _ (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of OBJECTDATA) - BORDERWIDTH _ (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) - TEXTURE _ (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA]) (COPYGENERIC - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (* ;; "Default COPYFN") - - (HCOPYALL (fetch OBJECTDATA of PLOTOBJECT]) (COPYGRAPHOBJECT - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create GRAPHDATA - GRAPHFN _ (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA) - NSAMPLES _ (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA) - STYLE _ (COPYALL (fetch (GRAPHDATA STYLE) of OBJECTDATA]) (COPYLINE - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (* ;; "Copyfn for LINE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create LINEDATA - INFINITESLOPE? _ (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA) - SLOPE _ (fetch (LINEDATA SLOPE) of OBJECTDATA) - CONSTANT _ (fetch (LINEDATA CONSTANT) of OBJECTDATA) - STYLE _ (COPYALL (fetch (LINEDATA STYLE) of OBJECTDATA]) (COPYPOINT - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (* ;; "Copyfn for POINT objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create POINTDATA - POINTPOSITION _ (COPYALL (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) - SYMBOL _ (fetch (POINTDATA SYMBOL) of OBJECTDATA]) (COPYPOLYGON - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:46 by jop") - - (* ;; "Copyfn for POLYGON objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create POLYGONDATA - POLYGONPOINTS _ (COPYALL (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA)) - STYLE _ (COPYALL (fetch (POLYGONDATA STYLE) of OBJECTDATA]) (COPYTEXT - [LAMBDA (PLOTOBJECT PLOT) (* ; "Edited 5-May-87 17:47 by jop") - - (* ;; "Copyfn for TEXT objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (RETURN (create TEXTDATA - TEXTPOSITION _ (COPYALL (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA)) - TEXT _ (COPYALL (fetch (TEXTDATA TEXT) of OBJECTDATA)) - FONT _ (fetch (TEXTDATA FONT) of OBJECTDATA]) (CREATECOMPOUND - [LAMBDA (COMPOUNDTYPE COMPONENTS LABEL MENU) (* ; "Edited 5-May-87 17:47 by jop") - - (* ;; "create a compound plot object. First is the required Compoundtype, then the components, a list of plotobjects, then the optional label,and menu") - - (CREATEPLOTOBJECT COMPOUNDFNS 'COMPOUND LABEL MENU (create COMPOUNDDATA - COMPONENTS _ COMPONENTS - COMPOUNDTYPE _ COMPOUNDTYPE]) (CREATECURVE - [LAMBDA (POSITIONS LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") - - (* ;; "Create a curve plot object") - - (CREATEPLOTOBJECT CURVEFNS 'CURVE LABEL MENU (create CURVEDATA - CURVEPOINTS _ POSITIONS - STYLE _ (COND - ((FIXP STYLE) - (create PLOT.STYLE - LINEWIDTH _ STYLE)) - ((LISTP STYLE) - (create PLOT.STYLE - LINEWIDTH _ (CAR STYLE) - DASHING _ (CADR STYLE) - COLOR _ (CADDR STYLE))) - (T (create PLOT.STYLE - LINEWIDTH _ 1]) (CREATEFILLEDRECTANGLE - [LAMBDA (LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU) - (* ; "Edited 5-May-87 17:47 by jop") - - (* ;; "Create a filledrectangle plot object") - - (if (NULL TEXTURE) - then (SETQ TEXTURE 'SHADE3)) - (CREATEPLOTOBJECT FILLEDRECTANGLEFNS 'FILLEDRECTANGLE LABEL MENU - (create FILLEDRECTANGLEDATA - OBJECTLEFT _ LEFT - OBJECTBOTTOM _ BOTTOM - OBJECTWIDTH _ WIDTH - OBJECTHEIGHT _ HEIGHT - BORDERWIDTH _ (OR BORDERWIDTH 1) - TEXTURE _ TEXTURE]) (CREATEGRAPH - [LAMBDA (GRAPHFN NSAMPLES LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") - - (CREATEPLOTOBJECT GRAPHFNS 'GRAPH LABEL MENU (create GRAPHDATA - GRAPHFN _ GRAPHFN - NSAMPLES _ (OR (FIXP NSAMPLES) - 100) - STYLE _ - (if (FIXP STYLE) - then (create PLOT.STYLE - LINEWIDTH _ STYLE) - elseif (LISTP STYLE) - then (create PLOT.STYLE - LINEWIDTH _ (CAR STYLE) - DASHING _ (CADR STYLE) - COLOR _ (CADDR STYLE)) - else (create PLOT.STYLE - LINEWIDTH _ 1]) (CREATELINE - [LAMBDA (SLOPE CONSTANT LABEL STYLE MENU) (* ; "Edited 5-May-87 17:47 by jop") - - (* ;; "Create a line plot object") - - (CREATEPLOTOBJECT LINEFNS 'LINE LABEL MENU (create LINEDATA - INFINITESLOPE? _ (NOT SLOPE) - SLOPE _ (OR SLOPE 0.0) - CONSTANT _ CONSTANT - STYLE _ (COND - ((FIXP STYLE) - (create PLOT.STYLE - LINEWIDTH _ STYLE)) - ((LISTP STYLE) - (create PLOT.STYLE - LINEWIDTH _ (CAR STYLE) - DASHING _ (CADR STYLE) - COLOR _ (CADDR STYLE))) - (T (create PLOT.STYLE - LINEWIDTH _ 1]) (CREATEPOINT - [LAMBDA (POSITION LABEL SYMBOL MENU) (* ; "Edited 5-May-87 17:48 by jop") - - (* ;; "Create a point plot object") - - (if (NULL SYMBOL) - then (SETQ SYMBOL STAR)) - (CREATEPLOTOBJECT POINTFNS 'POINT LABEL MENU (create POINTDATA - POINTPOSITION _ POSITION - SYMBOL _ SYMBOL]) (CREATEPOLYGON - [LAMBDA (POSITIONS LABEL STYLE MENU) (* ; "Edited 5-May-87 17:48 by jop") - - (* ;; "Create a polygon Plot object") - - (CREATEPLOTOBJECT POLYGONFNS 'POLYGON LABEL MENU (create POLYGONDATA - POLYGONPOINTS _ POSITIONS - STYLE _ - (if (FIXP STYLE) - then (create PLOT.STYLE - LINEWIDTH _ STYLE) - elseif (LISTP STYLE) - then (create PLOT.STYLE - LINEWIDTH _ (CAR STYLE) - DASHING _ (CADR STYLE) - COLOR _ (CADDR STYLE)) - else (create PLOT.STYLE - LINEWIDTH _ 1]) (CREATETEXT - [LAMBDA (POSITION TEXT LABEL FONT MENU) (* ; "Edited 5-May-87 17:48 by jop") - - (* ;; "Create a Text Plot object") - - (CREATEPLOTOBJECT TEXTFNS 'TEXT LABEL MENU - (create TEXTDATA - TEXTPOSITION _ POSITION - TEXT _ TEXT - FONT _ FONT]) (DISTANCETOCOMPOUND - [LAMBDA (COMPOUNDDATA STREAMPOSITION PLOT) (* edited%: "27-Mar-86 21:25") - (PROG [(COMPONENTS (fetch (COMPOUNDDATA COMPONENTS) of (fetch OBJECTDATA of COMPOUNDDATA] - (RETURN (bind (CMIN _ (DISTANCETOPLOTOBJECT (CAR COMPONENTS) - STREAMPOSITION PLOT)) - PMIN for PART in (CDR COMPONENTS) do (SETQ PMIN (DISTANCETOPLOTOBJECT PART - STREAMPOSITION PLOT)) - (if (LESSP PMIN CMIN) - then (SETQ CMIN PMIN)) - finally (RETURN CMIN]) (DISTANCETOCURVE - [LAMBDA (CURVEDATA STREAMPOSITION PLOT) (* edited%: "21-May-85 15:28") - (L1METRIC STREAMPOSITION (for POINT in (fetch (CURVEDATA STREAMPOINTS) - of (fetch OBJECTDATA of CURVEDATA)) - smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOFILLEDRECTANGLE - [LAMBDA (FILLEDRECTANGLE STREAMPOSITION PLOT) (* ; "Edited 5-May-87 17:48 by jop") - - (PROG ((OBJECTDATA (fetch OBJECTDATA of FILLEDRECTANGLE)) - (CLOSEST (CONSTANT (create POSITION))) - (STREAMX (fetch XCOORD of STREAMPOSITION)) - (STREAMY (fetch YCOORD of STREAMPOSITION)) - STREAMLEFT STREAMBOTTOM STREAMRIGHT STREAMTOP INSIDEFLG) - (SETQ STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) - (SETQ STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) - (SETQ STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) - (SETQ STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA)) - [replace XCOORD of CLOSEST - with (if (GREATERP STREAMX STREAMRIGHT) - then STREAMRIGHT - elseif (LESSP STREAMX STREAMLEFT) - then STREAMLEFT - else (if (OR (GREATERP STREAMY STREAMTOP) - (LESSP STREAMY STREAMBOTTOM)) - then STREAMX - else (SETQ INSIDEFLG T) - - (* ;; "Hack to deal with the case of adjacent filledrectangles. Bonus subtracted from metric if cursor inside rectangle") - - (if (LESSP (IMIN (IDIFFERENCE STREAMTOP STREAMY) - (IDIFFERENCE STREAMY STREAMBOTTOM)) - (IMIN (IDIFFERENCE STREAMRIGHT STREAMX) - (IDIFFERENCE STREAMX STREAMLEFT))) - then STREAMX - else (if (LESSP (IDIFFERENCE STREAMRIGHT STREAMX) - (IDIFFERENCE STREAMX STREAMLEFT)) - then STREAMRIGHT - else STREAMLEFT] - [replace YCOORD of CLOSEST - with (if (GREATERP STREAMY STREAMTOP) - then STREAMTOP - elseif (LESSP STREAMY STREAMBOTTOM) - then STREAMBOTTOM - else (if (OR (GREATERP STREAMX STREAMRIGHT) - (LESSP STREAMX STREAMLEFT)) - then STREAMY - else (if (LESSP (IMIN (IDIFFERENCE STREAMRIGHT STREAMX) - (IDIFFERENCE STREAMX STREAMLEFT)) - (IMIN (IDIFFERENCE STREAMTOP STREAMY) - (IDIFFERENCE STREAMY STREAMBOTTOM))) - then STREAMY - else (if (LESSP (IDIFFERENCE STREAMTOP STREAMY) - (IDIFFERENCE STREAMY STREAMBOTTOM)) - then STREAMTOP - else STREAMBOTTOM] - (RETURN (if INSIDEFLG - then (IDIFFERENCE (L1METRIC STREAMPOSITION CLOSEST) - 2) - else (L1METRIC STREAMPOSITION CLOSEST]) (DISTANCETOGRAPH - [LAMBDA (GRAPHOBJECT STREAMPOSITION PLOT) (* jop%: "12-Dec-85 13:15") - (L1METRIC STREAMPOSITION (for POINT in (fetch (GRAPHDATA STREAMPOSITIONS) - of (fetch OBJECTDATA of GRAPHOBJECT)) - smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOLINE [LAMBDA (LINEOBJECT STREAMPOSITION PLOT) (* ; "Edited 4-Nov-93 14:59 by rmk:") (* ; "Edited 5-May-87 17:49 by jop") (PROG ((X0 (fetch XCOORD of STREAMPOSITION)) (Y0 (fetch YCOORD of STREAMPOSITION)) (STREAMSLOPE (fetch STREAMSLOPE of (fetch OBJECTDATA of LINEOBJECT))) (STREAMCONSTANT (fetch (LINEDATA STREAMCONSTANT) of (fetch OBJECTDATA of LINEOBJECT))) MP BP XI YI) (* ; "Assumes use of the L1metric") (RETURN (FIXR (COND ((fetch INFINITESLOPE? of (fetch OBJECTDATA of LINEOBJECT) ) (FABS (FDIFFERENCE X0 STREAMCONSTANT))) ((EQP STREAMSLOPE 0.0) (FABS (FDIFFERENCE Y0 STREAMCONSTANT))) (T (SETQ MP (FMINUS (FQUOTIENT 1.0 STREAMSLOPE))) (SETQ BP (FDIFFERENCE Y0 (FTIMES MP X0))) (SETQ XI (FQUOTIENT (FDIFFERENCE BP STREAMCONSTANT) (FDIFFERENCE STREAMSLOPE MP))) (SETQ YI (FPLUS (FTIMES MP XI) BP)) (L1METRIC STREAMPOSITION (create POSITION XCOORD _ XI YCOORD _ YI]) (DISTANCETOPOINT - [LAMBDA (POINT STREAMPOSITION PLOT) (* edited%: "21-May-85 15:28") - (L1METRIC (fetch (POINTDATA STREAMPOSITION) of (fetch OBJECTDATA of POINT)) - STREAMPOSITION]) (DISTANCETOPOLYGON - [LAMBDA (POLYGONDATA STREAMPOSITION PLOT) (* edited%: "21-May-85 15:32") - (L1METRIC STREAMPOSITION (for POINT in (fetch (POLYGONDATA STREAMPOINTS) - of (fetch OBJECTDATA of POLYGONDATA)) - smallest (L1METRIC POINT STREAMPOSITION]) (DISTANCETOTEXT - [LAMBDA (TEXTOBJECT STREAMPOSITION PLOT) (* jop%: "12-Aug-85 13:42") - (L1METRIC (fetch (TEXTDATA STREAMPOSITION) of (fetch OBJECTDATA of TEXTOBJECT)) - STREAMPOSITION]) (DRAWCOMPOUNDOBJECT - [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:25") - (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of - COMPOUNDOBJECT - )) do (DRAWPLOTOBJECT OBJECT VIEWPORT - PLOT]) (DRAWCURVEOBJECT - [LAMBDA (CURVEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:49 by jop") - - (* ;; "Draw a series of connected lines in VIEWPORT. Style is the line width in pixels.") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) - (POINTS (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA)) - (STREAMPOINTS (for PT in POINTS collect (WORLDTOSTREAM PT VIEWPORT))) - (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) - (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) - (fetch YCOORD of (CAR STREAMPOINTS)) - STREAM) for PT in (CDR STREAMPOINTS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'REPLACE STREAM COLOR DASHING)) - (COND - ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - (replace (CURVEDATA STREAMPOINTS) of OBJECTDATA with STREAMPOINTS]) (DRAWFILLEDRECTANGLEOBJECT - [LAMBDA (FILLEDRECTANGLEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:49 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLEOBJECT)) - (TEXTURE (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA)) - (BORDERWIDTH (TIMES (DSPSCALE NIL STREAM) - (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA))) - STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT STREAMRIGHT STREAMTOP) - (SETQ STREAMLEFT (WORLDTOSTREAMX (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of OBJECTDATA) - VIEWPORT)) - (SETQ STREAMBOTTOM (WORLDTOSTREAMY (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of OBJECTDATA) - VIEWPORT)) - (SETQ STREAMWIDTH (DIFFERENCE (WORLDTOSTREAMX (fetch (FILLEDRECTANGLEDATA OBJECTRIGHT) - of OBJECTDATA) - VIEWPORT) - STREAMLEFT)) - (SETQ STREAMHEIGHT (DIFFERENCE (WORLDTOSTREAMY (fetch (FILLEDRECTANGLEDATA OBJECTTOP) - of OBJECTDATA) - VIEWPORT) - STREAMBOTTOM)) - (SETQ STREAMRIGHT (PLUS STREAMLEFT STREAMWIDTH)) - (SETQ STREAMTOP (PLUS STREAMBOTTOM STREAMHEIGHT)) - (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH - STREAMHEIGHT 'TEXTURE 'PAINT TEXTURE) - (MOVETO STREAMLEFT STREAMBOTTOM STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'REPLACE STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'REPLACE STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'REPLACE STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'REPLACE STREAM) - (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - then (replace (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA with STREAMLEFT) - (replace (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA with STREAMBOTTOM) - (replace (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA with STREAMWIDTH) - (replace (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA with STREAMHEIGHT]) (DRAWGRAPHOBJECT - [LAMBDA (GRAPHOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) - (XUPPER (fetch (PLOT XUPPER) of PLOT)) - (XLOWER (fetch (PLOT XLOWER) of PLOT)) - (YUPPER (fetch (PLOT YUPPER) of PLOT)) - (YLOWER (fetch (PLOT YLOWER) of PLOT)) - (GRAPHFN (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA)) - (NSAMPLES (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA)) - (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) - (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) - STREAMPOSITIONS) - [SETQ STREAMPOSITIONS (NCONC1 (bind (INC _ (FQUOTIENT (FDIFFERENCE XUPPER XLOWER) - (SUB1 NSAMPLES))) for I from 1 - to (SUB1 NSAMPLES) as X from XLOWER by INC - collect (CREATEPOSITION (WORLDTOSTREAMX X VIEWPORT) - (WORLDTOSTREAMY (APPLY* GRAPHFN X) - VIEWPORT))) - (CREATEPOSITION (WORLDTOSTREAMX XUPPER VIEWPORT) - (WORLDTOSTREAMY (APPLY* GRAPHFN XUPPER) - VIEWPORT] - (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) - (fetch YCOORD of (CAR STREAMPOSITIONS)) - STREAM) for PT in (CDR STREAMPOSITIONS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'REPLACE STREAM COLOR DASHING)) - (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - then (replace (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA with STREAMPOSITIONS]) (DRAWLINEOBJECT - [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) - (XUPPER (fetch (PLOT XUPPER) of PLOT)) - (XLOWER (fetch (PLOT XLOWER) of PLOT)) - (YUPPER (fetch (PLOT YUPPER) of PLOT)) - (YLOWER (fetch (PLOT YLOWER) of PLOT)) - (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) - (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) - (INFINITESLOPE? (fetch (LINEDATA INFINITESLOPE?) of OBJECTDATA)) - (SLOPE (fetch (LINEDATA SLOPE) of OBJECTDATA)) - (CONSTANT (fetch (LINEDATA CONSTANT) of OBJECTDATA)) - STREAMSLOPE STREAMCONSTANT STREAMPT1 STREAMPT2 X1 Y1 X2 Y2) - (SETQ X1 (COND - (INFINITESLOPE? CONSTANT) - (T XLOWER))) - [SETQ Y1 (COND - (INFINITESLOPE? YLOWER) - (T (FPLUS CONSTANT (FTIMES SLOPE X1] - (SETQ X2 (COND - (INFINITESLOPE? CONSTANT) - (T XUPPER))) - [SETQ Y2 (COND - (INFINITESLOPE? YUPPER) - (T (FPLUS CONSTANT (FTIMES SLOPE X2] - [SETQ STREAMSLOPE (AND (NOT INFINITESLOPE?) - (FTIMES SLOPE (FQUOTIENT (fetch (VIEWPORT WORLDTOSTREAMMY) - of VIEWPORT) - (fetch (VIEWPORT WORLDTOSTREAMMX) of VIEWPORT] - [SETQ STREAMCONSTANT (COND - (INFINITESLOPE? (WORLDTOSTREAMX CONSTANT VIEWPORT)) - (T (FDIFFERENCE (WORLDTOSTREAMY CONSTANT VIEWPORT) - (FTIMES STREAMSLOPE (fetch (VIEWPORT WORLDTOSTREAMAX) - of VIEWPORT] - (SETQ STREAMPT1 (CREATEPOSITION (WORLDTOSTREAMX X1 VIEWPORT) - (WORLDTOSTREAMY Y1 VIEWPORT))) - (SETQ STREAMPT2 (CREATEPOSITION (WORLDTOSTREAMX X2 VIEWPORT) - (WORLDTOSTREAMY Y2 VIEWPORT))) - (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'REPLACE STREAM COLOR - DASHING) - (COND - ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - (COND - (STREAMSLOPE (replace (LINEDATA STREAMSLOPE) of OBJECTDATA with STREAMSLOPE)) - (T (replace (LINEDATA STREAMSLOPE) of OBJECTDATA with 0.0))) - (replace (LINEDATA STREAMCONSTANT) of OBJECTDATA with STREAMCONSTANT) - (replace (LINEDATA STREAMPT1) of OBJECTDATA with STREAMPT1) - (replace (LINEDATA STREAMPT2) of OBJECTDATA with STREAMPT2]) (DRAWPOINTOBJECT - [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") - - (* ;; "Draw a glyph at POINTPOSITION. SYMBOL is the glyph to be drawn.") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) - (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) - (PT (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) - (STREAMPT (WORLDTOSTREAM PT VIEWPORT))) - (CLIPPED.PLOTAT STREAMSUBREGION STREAMPT SYMBOL STREAM) - (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - then (replace (POINTDATA STREAMPOSITION) of OBJECTDATA with STREAMPT]) (DRAWPOLYGONOBJECT - [LAMBDA (POLYGONOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:50 by jop") - - (* ;; "Draws a polygon in VIEWPORT.") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) - (POINTS (fetch (POLYGONDATA POLYGONPOINTS) of OBJECTDATA)) - (STREAMPOINTS (for PT in POINTS collect (WORLDTOSTREAM PT VIEWPORT))) - (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (TIMES (DSPSCALE NIL STREAM) - (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (DASHING (fetch (PLOT.STYLE DASHING) of STYLE)) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) - (fetch YCOORD of START) - STREAM) for PT in (CDR STREAMPOINTS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'REPLACE STREAM COLOR DASHING) finally (CLIPPED.DRAWTO STREAMSUBREGION - (fetch XCOORD of START) - (fetch YCOORD of START) - LINEWIDTH - 'REPLACE STREAM COLOR DASHING)) - (if (EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - then (replace (POLYGONDATA STREAMPOINTS) of OBJECTDATA with STREAMPOINTS]) (DRAWTEXTOBJECT - [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) - (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) - (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) - (PT (fetch (TEXTDATA TEXTPOSITION) of OBJECTDATA)) - STREAMX STREAMY) - (SETQ STREAMX (WORLDTOSTREAMX (fetch XCOORD of PT) - VIEWPORT)) - (SETQ STREAMY (WORLDTOSTREAMY (fetch YCOORD of PT) - VIEWPORT)) - (RESETLST (RESETSAVE (DSPFONT FONT STREAM) - (LIST 'DSPFONT (DSPFONT NIL STREAM) - STREAM)) - (MOVETO STREAMX STREAMY STREAM) - (CLIPPED.PRIN1 STREAMSUBREGION TEXT STREAM)) - (COND - ((EQ STREAM (WINDOWPROP (fetch (PLOT PLOTWINDOW) of PLOT) - 'DSP)) - (replace (TEXTDATA STREAMPOSITION) of OBJECTDATA with (CREATEPOSITION STREAMX STREAMY]) (ERASECOMPOUNDOBJECT - [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:26") - (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of - COMPOUNDOBJECT - )) do (ERASEPLOTOBJECT OBJECT PLOT]) (ERASECURVEOBJECT - [LAMBDA (CURVEOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:51 by jop") - - (* ;; "Erase the CURVEOBJECT, using the cached stream coordinates") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) - (STREAMPOINTS (fetch (CURVEDATA STREAMPOINTS) of OBJECTDATA)) - (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) - (fetch YCOORD of (CAR STREAMPOINTS)) - STREAM) for PT in (CDR STREAMPOINTS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'ERASE STREAM COLOR]) (ERASEFILLEDRECTANGLEOBJECT - [LAMBDA (FILLEDRECTANGLE VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) - (TEXTURE (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA)) - (BORDERWIDTH (TIMES (DSPSCALE NIL STREAM) - (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA))) - (STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) - (STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) - (STREAMWIDTH (fetch (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA)) - (STREAMHEIGHT (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA)) - (STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) - (STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA))) - (MOVETO STREAMLEFT STREAMBOTTOM STREAM) - (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH - STREAMHEIGHT 'TEXTURE 'INVERT TEXTURE) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'ERASE STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'ERASE STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'ERASE STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'ERASE STREAM]) (ERASEGRAPHOBJECT - [LAMBDA (GRAPHOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:51 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) - (STREAMPOSITIONS (fetch (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA)) - (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) - (fetch YCOORD of (CAR STREAMPOSITIONS)) - STREAM) for PT in (CDR STREAMPOSITIONS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'ERASE STREAM COLOR]) (ERASELINEOBJECT - [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) - (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS (fetch (PLOT.STYLE LINEWIDTH) of STYLE) - 2)) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) - (STREAMPT1 (fetch (LINEDATA STREAMPT1) of OBJECTDATA)) - (STREAMPT2 (fetch (LINEDATA STREAMPT2) of OBJECTDATA))) - (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'ERASE STREAM COLOR]) (ERASEPOINTOBJECT - [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:51 by jop") - - (* ;; "Erase POINT, using cached stream coordinates") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) - (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) - (STREAMPT (fetch (POINTDATA STREAMPOSITION) of OBJECTDATA))) - (CLIPPED.PLOTAT STREAMSUBREGION STREAMPT SYMBOL STREAM 'ERASE]) (ERASEPOLYGONOBJECT - [LAMBDA (POLYGONOBJECT VIEWPORT) (* ; "Edited 5-May-87 17:52 by jop") - - (* ;; "Erase a POLYGONDATA") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) - (STREAMPOINTS (fetch (POLYGONDATA STREAMPOINTS) of OBJECTDATA)) - (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) - (fetch YCOORD of START) - STREAM) for PT in (CDR STREAMPOINTS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'ERASE STREAM COLOR) finally (CLIPPED.DRAWTO STREAMSUBREGION - (fetch XCOORD of START) - (fetch YCOORD of START) - LINEWIDTH - 'ERASE STREAM COLOR]) (ERASETEXTOBJECT - [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:52 by jop") - - (* ;; "ERASE the TEXTDATA") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) - (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) - (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) - (STREAMPOSITION (fetch (TEXTDATA STREAMPOSITION) of OBJECTDATA)) - (STREAMX (fetch XCOORD of STREAMPOSITION)) - (STREAMY (fetch YCOORD of STREAMPOSITION)) - BLANCREGION) - (RESETLST (RESETSAVE (DSPFONT FONT STREAM) - (LIST 'DSPFONT (DSPFONT NIL STREAM) - STREAM)) - (MOVETO STREAMX STREAMY STREAM) - (SETQ BLANCREGION (STRINGREGION TEXT STREAM)) - (with REGION BLANCREGION (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM LEFT - BOTTOM WIDTH HEIGHT 'TEXTURE]) (EXTENTOFCOMPOUND - [LAMBDA (COMPOUNDOBJECT) (* ; "Edited 5-May-87 17:52 by jop") - - (bind (CMINX _ MAX.FLOAT) - (CMAXX _ MIN.FLOAT) - (CMINY _ MAX.FLOAT) - (CMAXY _ MIN.FLOAT) - PEXTENT for PART in (fetch (COMPOUNDDATA COMPONENTS) of (fetch OBJECTDATA of COMPOUNDOBJECT - )) - declare (TYPE FLOATING CMINX CMAXX CMINY CMAXY) - do (SETQ PEXTENT (EXTENTOFPLOTOBJECT PART)) - (if (LESSP (fetch MINX of PEXTENT) - CMINX) - then (SETQ CMINX (fetch MINX of PEXTENT))) - (if (GREATERP (fetch MAXX of PEXTENT) - CMAXX) - then (SETQ CMAXX (fetch MAXX of PEXTENT))) - (if (LESSP (fetch MINY of PEXTENT) - CMINY) - then (SETQ CMINY (fetch MINY of PEXTENT))) - (if (GREATERP (fetch MAXY of PEXTENT) - CMAXY) - then (SETQ CMAXY (fetch MAXY of PEXTENT))) - finally (RETURN (create EXTENT - MINX _ CMINX - MAXX _ CMAXX - MINY _ CMINY - MAXY _ CMAXY]) (EXTENTOFCURVE - [LAMBDA (CURVEOBJECT) (* ; "Edited 5-May-87 17:52 by jop") - - (bind (MINX _ MAX.FLOAT) - (MAXX _ MIN.FLOAT) - (MINY _ MAX.FLOAT) - (MAXY _ MIN.FLOAT) - X Y for POSITION in (fetch (CURVEDATA CURVEPOINTS) of (fetch OBJECTDATA of CURVEOBJECT)) - declare (TYPE FLOATING MINX MAXX MINY MAXY X Y) do (SETQ X (fetch XCOORD of POSITION)) - (SETQ Y (fetch YCOORD of POSITION)) - (COND - ((FLESSP X MINX) - (SETQ MINX X))) - (COND - ((FGREATERP X MAXX) - (SETQ MAXX X))) - (COND - ((FLESSP Y MINY) - (SETQ MINY Y))) - (COND - ((FGREATERP Y MAXY) - (SETQ MAXY Y))) - finally (RETURN (create EXTENT - MINX _ MINX - MAXX _ MAXX - MINY _ MINY - MAXY _ MAXY]) (EXTENTOFFILLEDRECTANGLE - [LAMBDA (FILLEDRECTANGLE) (* edited%: "21-May-85 15:29") - (create EXTENT - MINX _ (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of (fetch OBJECTDATA of FILLEDRECTANGLE)) - MAXX _ (fetch (FILLEDRECTANGLEDATA OBJECTRIGHT) of (fetch OBJECTDATA of FILLEDRECTANGLE)) - MINY _ (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of (fetch OBJECTDATA of FILLEDRECTANGLE)) - MAXY _ (fetch (FILLEDRECTANGLEDATA OBJECTTOP) of (fetch OBJECTDATA of FILLEDRECTANGLE]) (EXTENTOFGRAPH - [LAMBDA (GRAPHOBJECT) (* ; "Edited 5-May-87 17:53 by jop") - - (create EXTENT - MINX _ MAX.FLOAT - MAXX _ MIN.FLOAT - MINY _ MAX.FLOAT - MAXY _ MIN.FLOAT]) (EXTENTOFLINE - [LAMBDA (LINEOBJECT) (* jop%: " 5-Mar-85 14:03") - (create EXTENT - MINX _ MAX.FLOAT - MAXX _ MIN.FLOAT - MINY _ MAX.FLOAT - MAXY _ MIN.FLOAT]) (EXTENTOFPOINT - [LAMBDA (POINT) (* edited%: "21-May-85 15:28") - (PROG [(POSITION (fetch (POINTDATA POINTPOSITION) of (fetch OBJECTDATA of POINT] - (RETURN (create EXTENT - MINX _ (fetch XCOORD of POSITION) - MAXX _ (fetch XCOORD of POSITION) - MINY _ (fetch YCOORD of POSITION) - MAXY _ (fetch YCOORD of POSITION]) (EXTENTOFPOLYGON - [LAMBDA (POLYGONOBJECT) (* ; "Edited 5-May-87 17:53 by jop") - - (bind (MINX _ MAX.FLOAT) - (MAXX _ MIN.FLOAT) - (MINY _ MAX.FLOAT) - (MAXY _ MIN.FLOAT) - X Y for POSITION in (fetch POLYGONPOINTS of (fetch OBJECTDATA of POLYGONOBJECT)) - declare (TYPE FLOATING MINX MAXX MINY MAXY X Y) do (SETQ X (fetch XCOORD of POSITION)) - (SETQ Y (fetch YCOORD of POSITION)) - (if (FLESSP X MINX) - then (SETQ MINX X)) - (if (FGREATERP X MAXX) - then (SETQ MAXX X)) - (if (FLESSP Y MINY) - then (SETQ MINY Y)) - (if (FGREATERP Y MAXY) - then (SETQ MAXY Y)) - finally (RETURN (create EXTENT - MINX _ MINX - MAXX _ MAXX - MINY _ MINY - MAXY _ MAXY]) (EXTENTOFTEXT - [LAMBDA (TEXTOBJECT) (* ; "Edited 5-May-87 17:53 by jop") - - (PROG [(POSITION (fetch TEXTPOSITION of (fetch OBJECTDATA of TEXTOBJECT] - (RETURN (create EXTENT - MINX _ (fetch XCOORD of POSITION) - MAXX _ (fetch XCOORD of POSITION) - MINY _ (fetch YCOORD of POSITION) - MAXY _ (fetch YCOORD of POSITION]) (GETCOMPOUND - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:53 by jop") - - (* ;; "GETFN for COMPOUND objects") - - (create COMPOUNDDATA - COMPOUNDTYPE _ (LISTGET PROPLST 'COMPOUNDTYPE) - COMPONENTS _ (LISTGET PROPLST 'COMPONENTS]) (GETCURVE - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") - - (* ;; "GETFN for CURVE objects") - - (PROG [(STYLELST (LISTGET PROPLST 'STYLE] - (RETURN (create CURVEDATA - CURVEPOINTS _ (LISTGET PROPLST 'CURVEPOINTS) - STYLE _ (create PLOT.STYLE - LINEWIDTH _ (CAR STYLELST) - DASHING _ (CADR STYLELST) - COLOR _ (CADDR STYLELST]) (GETFILLEDRECTANGLE - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") - - (* ;; "GETFN for FILLEDRECTANGLE objects") - - (create FILLEDRECTANGLEDATA - OBJECTLEFT _ (LISTGET PROPLST 'OBJECTLEFT) - OBJECTBOTTOM _ (LISTGET PROPLST 'OBJECTBOTTOM) - OBJECTWIDTH _ (LISTGET PROPLST 'OBJECTWIDTH) - OBJECTHEIGHT _ (LISTGET PROPLST 'OBJECTHEIGHT) - BORDERWIDTH _ (LISTGET PROPLST 'BORDERWIDTH) - TEXTURE _ (LISTGET PROPLST 'TEXTURE]) (GETGENERIC - [LAMBDA (EXPR) (* jop%: "27-Aug-85 17:11") - EXPR]) (GETGRAPH - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") - - (PROG [(STYLELST (LISTGET PROPLST 'STYLE] - (RETURN (create GRAPHDATA - GRAPHFN _ (LISTGET PROPLST 'GRAPHFN) - NSAMPLES _ (LISTGET PROPLST 'NSAMPLES) - STYLE _ (create PLOT.STYLE - LINEWIDTH _ (CAR STYLELST) - DASHING _ (CADR STYLELST) - COLOR _ (CADDR STYLELST]) (GETLINE - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") - - (* ;; "GETFN for LINE objects") - - (PROG [(STYLELST (LISTGET PROPLST 'STYLE] - (RETURN (create LINEDATA - INFINITESLOPE? _ (LISTGET PROPLST 'INFINITESLOPE?) - SLOPE _ (LISTGET PROPLST 'SLOPE) - CONSTANT _ (LISTGET PROPLST 'CONSTANT) - STYLE _ (create PLOT.STYLE - LINEWIDTH _ (CAR STYLELST) - DASHING _ (CADR STYLELST) - COLOR _ (CADDR STYLELST]) (GETPOINT - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:54 by jop") - - (* ;; "Putfn for POINT objects") - - (create POINTDATA - POINTPOSITION _ (LISTGET PROPLST 'POINTPOSITION) - SYMBOL _ (LET [(SYMBOL (LISTGET PROPLST 'SYMBOL] - (if (LITATOM SYMBOL) - then (EVAL SYMBOL) - else SYMBOL]) (GETPOLYGON - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:55 by jop") - - (* ;; "GETFN for POLYGON objects") - - (PROG [(STYLELST (LISTGET PROPLST 'STYLE] - (RETURN (create POLYGONDATA - POLYGONPOINTS _ (LISTGET PROPLST 'POLYGONPOINTS) - STYLE _ (create PLOT.STYLE - LINEWIDTH _ (CAR STYLELST) - DASHING _ (CADR STYLELST) - COLOR _ (CADDR STYLELST]) (GETTEXT - [LAMBDA (PROPLST) (* ; "Edited 5-May-87 17:55 by jop") - - (* ;; "GETFN for TEXT objects") - - (create TEXTDATA - TEXTPOSITION _ (LISTGET PROPLST 'TEXTPOSITION) - TEXT _ (LISTGET PROPLST 'TEXT) - FONT _ (LISTGET PROPLST 'FONT]) (HIGHLIGHTCOMPOUND - [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:26") - (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of - COMPOUNDOBJECT - )) do (HIGHLIGHTPLOTOBJECT OBJECT PLOT]) (HIGHLIGHTCURVE - [LAMBDA (CURVEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") - - (* ;; "Highlight the CURVEOBJECT, by redrawing in invert mode with fatter lines") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of CURVEOBJECT)) - (STREAMPOINTS (fetch (CURVEDATA STREAMPOINTS) of OBJECTDATA)) - (STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (first (MOVETO (fetch XCOORD of (CAR STREAMPOINTS)) - (fetch YCOORD of (CAR STREAMPOINTS)) - STREAM) for PT in (CDR STREAMPOINTS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'INVERT STREAM COLOR]) (HIGHLIGHTFILLEDRECTANGLE - [LAMBDA (FILLEDRECTANGLE VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of FILLEDRECTANGLE)) - (BORDERWIDTH (IPLUS 2 (OR (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) of OBJECTDATA) - 1))) - (STREAMLEFT (fetch (FILLEDRECTANGLEDATA STREAMLEFT) of OBJECTDATA)) - (STREAMBOTTOM (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of OBJECTDATA)) - (STREAMWIDTH (fetch (FILLEDRECTANGLEDATA STREAMWIDTH) of OBJECTDATA)) - (STREAMHEIGHT (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of OBJECTDATA)) - (STREAMRIGHT (fetch (FILLEDRECTANGLEDATA STREAMRIGHT) of OBJECTDATA)) - (STREAMTOP (fetch (FILLEDRECTANGLEDATA STREAMTOP) of OBJECTDATA))) - (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM STREAMLEFT STREAMBOTTOM STREAMWIDTH - STREAMHEIGHT 'TEXTURE 'INVERT BLACKSHADE) - (MOVETO STREAMLEFT STREAMBOTTOM STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMBOTTOM BORDERWIDTH 'INVERT STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMRIGHT STREAMTOP BORDERWIDTH 'INVERT STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMTOP BORDERWIDTH 'INVERT STREAM) - (CLIPPED.DRAWTO STREAMSUBREGION STREAMLEFT STREAMBOTTOM BORDERWIDTH 'INVERT STREAM]) (HIGHLIGHTGRAPH - [LAMBDA (GRAPHOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of GRAPHOBJECT)) - (STREAMPOSITIONS (fetch (GRAPHDATA STREAMPOSITIONS) of OBJECTDATA)) - (STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (first (MOVETO (fetch XCOORD of (CAR STREAMPOSITIONS)) - (fetch YCOORD of (CAR STREAMPOSITIONS)) - STREAM) for PT in (CDR STREAMPOSITIONS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'INVERT STREAM COLOR]) (HIGHLIGHTLINE - [LAMBDA (LINEOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:55 by jop") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of LINEOBJECT)) - (STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS (fetch (PLOT.STYLE LINEWIDTH) of STYLE) - 2)) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE)) - (STREAMPT1 (fetch (LINEDATA STREAMPT1) of OBJECTDATA)) - (STREAMPT2 (fetch (LINEDATA STREAMPT2) of OBJECTDATA))) - (CLIPPED.DRAWBETWEEN STREAMSUBREGION STREAMPT1 STREAMPT2 LINEWIDTH 'INVERT STREAM COLOR]) (HIGHLIGHTPOINT - [LAMBDA (POINT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") - - (* ;; "Highlight POINT") - - (LET* [(STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) - (SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) - (STREAMPT (fetch (POINTDATA STREAMPOSITION) of OBJECTDATA)) - (WIDTHGLYPH (BITMAPWIDTH SYMBOL)) - (HEIGHTGLYPH (BITMAPHEIGHT SYMBOL)) - (OFFSETX (IDIFFERENCE (fetch XCOORD of STREAMPT) - (IQUOTIENT WIDTHGLYPH 2))) - (OFFSETY (IDIFFERENCE (fetch YCOORD of STREAMPT) - (IQUOTIENT HEIGHTGLYPH 2] - (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM OFFSETX OFFSETY WIDTHGLYPH HEIGHTGLYPH - 'TEXTURE - 'INVERT BLACKSHADE]) (HIGHLIGHTPOLYGON - [LAMBDA (POLYGONOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") - - (* ;; "Highlight a Polygon") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POLYGONOBJECT)) - (STREAMPOINTS (fetch (POLYGONDATA STREAMPOINTS) of OBJECTDATA)) - (STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) - (LINEWIDTH (IPLUS 2 (fetch (PLOT.STYLE LINEWIDTH) of STYLE))) - (COLOR (fetch (PLOT.STYLE COLOR) of STYLE))) - (bind (START _ (CAR STREAMPOINTS)) first (MOVETO (fetch XCOORD of START) - (fetch YCOORD of START) - STREAM) for PT in (CDR STREAMPOINTS) - do (CLIPPED.DRAWTO STREAMSUBREGION (fetch XCOORD of PT) - (fetch YCOORD of PT) - LINEWIDTH - 'INVERT STREAM COLOR) finally (CLIPPED.DRAWTO STREAMSUBREGION - (fetch XCOORD of START) - (fetch YCOORD of START) - LINEWIDTH - 'INVERT STREAM COLOR]) (HIGHLIGHTTEXT - [LAMBDA (TEXTOBJECT VIEWPORT PLOT) (* ; "Edited 5-May-87 17:56 by jop") - - (* ;; "HIGHLIGHT the TEXTDATA") - - (LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)) - (STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)) - (OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of TEXTOBJECT)) - (TEXT (fetch (TEXTDATA TEXT) of OBJECTDATA)) - (FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) - (STREAMPOSITION (fetch (TEXTDATA STREAMPOSITION) of OBJECTDATA)) - (STREAMX (fetch XCOORD of STREAMPOSITION)) - (STREAMY (fetch YCOORD of STREAMPOSITION)) - BLANCREGION) - (RESETLST (RESETSAVE (DSPFONT FONT STREAM) - (LIST 'DSPFONT (DSPFONT NIL STREAM) - STREAM)) - (MOVETO STREAMX STREAMY STREAM) - (SETQ BLANCREGION (STRINGREGION TEXT STREAM)) - (with REGION BLANCREGION (CLIPPED.BITBLT STREAMSUBREGION NIL NIL NIL STREAM LEFT - BOTTOM WIDTH HEIGHT 'TEXTURE 'INVERT BLACKSHADE]) (LABELGENERIC - [LAMBDA (OBJECT PLOT) (* ; "Edited 5-May-87 17:56 by jop") - - (* ;; "Generic label routine. Intended for interactive use only") - - (PROG ((LABEL (fetch OBJECTLABEL of OBJECT)) - (VIEWPORT (fetch PLOTWINDOWVIEWPORT of PLOT)) - (TEXTOBJECT (PLOTOBJECTPROP OBJECT 'LABEL)) - LABELPOSITION) - (COND - (TEXTOBJECT (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT)) - (T (PLOTPROMPT (CONCAT "SELECT A POSITION FOR LABEL " LABEL) - PLOT) - (SETQ LABELPOSITION (STREAMTOWORLD (GETPOSITION (fetch PLOTWINDOW of PLOT)) - VIEWPORT)) - (SETQ TEXTOBJECT (CREATETEXT LABELPOSITION LABEL NIL SMALLPLOTFONT)) - (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) - (PLOTOBJECTPROP OBJECT 'LABEL TEXTOBJECT]) (LABELPOINT - [LAMBDA (POINT PLOT) (* ; "Edited 5-May-87 17:56 by jop") - - (* ;; "Label a POINT") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of POINT)) - (VIEWPORT (fetch (PLOT PLOTWINDOWVIEWPORT) of PLOT)) - (LABEL (fetch (PLOTOBJECT OBJECTLABEL) of POINT)) - (TEXTOBJECT (PLOTOBJECTPROP POINT 'LABEL)) - SYMBOL LABELPOSITION) - (SETQ LABELPOSITION (create POSITION using (fetch (POINTDATA POINTPOSITION) of OBJECTDATA)) - ) - (SETQ SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) - (* ; - "Displace Label to right of point object") - - (if TEXTOBJECT - then (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) - else [replace XCOORD of LABELPOSITION with (PLUS (fetch XCOORD of LABELPOSITION) - (TIMES 2 (STREAMTOWORLDXLENGTH - (BITMAPWIDTH SYMBOL) - VIEWPORT] - (SETQ TEXTOBJECT (CREATETEXT LABELPOSITION LABEL NIL SMALLPLOTFONT)) - (DRAWPLOTOBJECT TEXTOBJECT VIEWPORT PLOT) (* ; - "CACHE LABEL ON PROP LIST OF OBJECT") - - (PLOTOBJECTPROP POINT 'LABEL TEXTOBJECT]) (LABELTEXT - [LAMBDA (TEXTOBJECT PLOT) (* jop%: "20-Feb-86 17:56") - (PLOTPROMPT "Cannot label text" PLOT]) (LOWLIGHTCOMPOUND - [LAMBDA (COMPOUNDOBJECT VIEWPORT PLOT) (* edited%: "27-Mar-86 21:27") - (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch (PLOTOBJECT OBJECTDATA) of - COMPOUNDOBJECT - )) do (LOWLIGHTPLOTOBJECT OBJECT PLOT]) (MOVECOMPOUND - [LAMBDA (COMPOUNDOBJECT DX DY PLOT) (* edited%: "27-Mar-86 21:27") - (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of (fetch OBJECTDATA of COMPOUNDOBJECT)) - do (MOVEPLOTOBJECT OBJECT DX DY PLOT]) (MOVECURVE - [LAMBDA (CURVEOBJECT DX DY PLOT) (* jop%: " 8-Dec-85 18:35") - (PROG [(POINTS (fetch (CURVEDATA CURVEPOINTS) of (fetch OBJECTDATA of CURVEOBJECT] - (for POINT in POINTS do (replace XCOORD of POINT with (PLUS DX (fetch XCOORD of POINT))) - (replace YCOORD of POINT with (PLUS DY (fetch YCOORD of POINT]) (MOVEFILLEDRECTANGLE - [LAMBDA (FILLEDRECTANGLEOBJECT DX DY PLOT) (* edited%: "18-May-85 16:32") - (PROG ((OBJECTDATA (fetch OBJECTDATA of FILLEDRECTANGLEOBJECT))) - (replace OBJECTLEFT of OBJECTDATA with (PLUS DX (fetch OBJECTLEFT of OBJECTDATA))) - (replace OBJECTBOTTOM of OBJECTDATA with (PLUS DY (fetch OBJECTBOTTOM of OBJECTDATA]) (MOVELINE [LAMBDA (LINEOBJECT DX DY PLOT) (* ; "Edited 4-Nov-93 14:59 by rmk:") (* edited%: "18-May-85 16:58") (PROG ((OBJECTDATA (fetch OBJECTDATA of LINEOBJECT))) (replace (LINEDATA CONSTANT) of OBJECTDATA with (if (fetch INFINITESLOPE? of OBJECTDATA) then (PLUS DX (fetch (LINEDATA CONSTANT) of OBJECTDATA)) else (DIFFERENCE (PLUS (fetch (LINEDATA CONSTANT) of OBJECTDATA) (TIMES DX (fetch SLOPE of OBJECTDATA))) DY]) (MOVEPOINT - [LAMBDA (POINT DX DY PLOT) (* jop%: "24-Feb-86 14:43") - (PROG [(POSITION (fetch (POINTDATA POINTPOSITION) of (fetch (PLOTOBJECT OBJECTDATA) of POINT] - (replace XCOORD of POSITION with (PLUS DX (fetch XCOORD of POSITION))) - (replace YCOORD of POSITION with (PLUS DY (fetch YCOORD of POSITION]) (MOVEPOLYGON - [LAMBDA (POLYGONOBJECT DX DY PLOT) (* edited%: "18-May-85 16:16") - (PROG [(POINTS (fetch POLYGONPOINTS of (fetch OBJECTDATA of POLYGONOBJECT] - (for POINT in POINTS do (replace XCOORD of POINT with (PLUS DX (fetch XCOORD of POINT))) - (replace YCOORD of POINT with (PLUS DY (fetch YCOORD of POINT]) (MOVETEXT - [LAMBDA (TEXTOBJECT DX DY PLOT) (* edited%: "18-May-85 17:05") - (PROG [(POSITION (fetch TEXTPOSITION of (fetch OBJECTDATA of TEXTOBJECT] - (replace XCOORD of POSITION with (PLUS DX (fetch XCOORD of POSITION))) - (replace YCOORD of POSITION with (PLUS DY (fetch YCOORD of POSITION]) (PLOTCOMPOUND - [LAMBDA ARGS (* ; "Edited 5-May-87 17:57 by jop") - - (* ;; "ADD A COMPOUND OBJECT with an unknown number of COMPONENTS. First arg must be a PLOT. Second arg must be the compound object type. Next are the Nospread COMPONENTS, then the optional LABEL, MENU, and NODRAWFLG") - - (if (LESSP ARGS 3) - then (HELP "Must have at least 3 args. Plot, compound type, and one component")) - (PROG ((PLOT (ARG ARGS 1)) - (COMPOUNDTYPE (ARG ARGS 2)) - COMPONENTS STARTRESTARGS) - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT a PLOT " PLOT)) - (SETQ COMPONENTS (for I from 3 to ARGS while (type? PLOTOBJECT (ARG ARGS I)) - collect (ARG ARGS I))) - (SETQ STARTRESTARGS (PLUS 3 (LENGTH COMPONENTS))) - (RETURN (ADDPLOTOBJECT [CREATECOMPOUND COMPOUNDTYPE COMPONENTS - (if (GEQ ARGS STARTRESTARGS) - then (ARG ARGS STARTRESTARGS)) - (if (GEQ ARGS (PLUS 1 STARTRESTARGS)) - then (ARG ARGS (PLUS 1 STARTRESTARGS] - PLOT - (if (GEQ ARGS (PLUS 2 STARTRESTARGS)) - then (ARG ARGS (PLUS 2 STARTRESTARGS]) (PLOTCURVE - [LAMBDA (PLOT POSITIONS LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:57 by jop") - - (* ;; "User Entry Point. Draw a piecewise linear curve in a Plotting WINDOW. Style is either the line width to use or a list (width dashing color) or an instance of PLOT.STYLE. POSITIONS is a list of positions to be contected.") - - (COND - ((NOT (type? PLOT PLOT)) - (HELP "NOT a PLOT " PLOT))) - (ADDPLOTOBJECT (CREATECURVE POSITIONS LABEL STYLE MENU) - PLOT NODRAWFLG]) (PLOTFILLEDRECTANGLE - [LAMBDA (PLOT LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU NODRAWFLG) - (* ; "Edited 5-May-87 17:57 by jop") - - (* ;; - "User Entry Point. Draw a FILLEDRECTANGLE in a Plotting WINDOW. Style is the line width to use.") - - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT a PLOT " PLOT)) - (if (NULL TEXTURE) - then (SETQ TEXTURE SHADE3)) - (ADDPLOTOBJECT (CREATEFILLEDRECTANGLE LEFT BOTTOM WIDTH HEIGHT LABEL TEXTURE BORDERWIDTH MENU) - PLOT NODRAWFLG]) (PLOTGRAPH - [LAMBDA (PLOT GRAPHFN NSAMPLES LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") - - (* ;; "User Entry Point.") - - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT a PLOT " PLOT)) - (ADDPLOTOBJECT (CREATEGRAPH GRAPHFN NSAMPLES LABEL STYLE MENU) - PLOT NODRAWFLG]) (PLOTLINE - [LAMBDA (PLOT SLOPE CONSTANT LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") - - (* ;; "User Entry Point.") - - (COND - ((NOT (type? PLOT PLOT)) - (HELP "NOT a PLOT " PLOT))) - (ADDPLOTOBJECT (CREATELINE SLOPE CONSTANT LABEL STYLE MENU) - PLOT NODRAWFLG]) (PLOTPOINT - [LAMBDA (PLOT POSITION LABEL SYMBOL MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") - - (* ;; "User entry point. Add a point to the plotwindow WINDOW, at world position POSITION, with Label LABEL and plotting symbol SYMBOL") - - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT a PLOT " PLOT)) - (ADDPLOTOBJECT (CREATEPOINT POSITION LABEL SYMBOL MENU) - PLOT NODRAWFLG]) (PLOTPOINTS - [LAMBDA (PLOT POSITIONS LABELS SYMBOL MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") - - (* ;; "User Entry Point. Draw the POINTs at POSITIONS in a Plotting WINDOW. Symbol is a LITATOM which Describes the glyph to use.") - - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT a PLOT " PLOT)) - (PROG (EXTENT NEWSCALES OBJECTS) - [SETQ EXTENT - (bind (MINX _ MAX.FLOAT) - (MAXX _ MIN.FLOAT) - (MINY _ MAX.FLOAT) - (MAXY _ MIN.FLOAT) for PT in POSITIONS - do (if (LESSP (fetch XCOORD of PT) - MINX) - then (SETQ MINX (fetch XCOORD of PT))) - (if (GREATERP (fetch XCOORD of PT) - MAXX) - then (SETQ MAXX (fetch XCOORD of PT))) - (if (LESSP (fetch YCOORD of PT) - MINY) - then (SETQ MINY (fetch YCOORD of PT))) - (if (GREATERP (fetch YCOORD of PT) - MAXY) - then (SETQ MAXY (fetch YCOORD of PT))) - finally (RETURN (create EXTENT - MINX _ MINX - MAXX _ MAXX - MINY _ MINY - MAXY _ MAXY] - (ADJUSTSCALE? EXTENT PLOT) (* ; - "Scale up the plot so that each ADDOBJECT need not rescale") - - [SETQ OBJECTS (bind (LABEL _ LABELS) for POSITION in POSITIONS - collect (PROG1 (CREATEPOINT POSITION (CAR LABEL) - SYMBOL MENU) - (SETQ LABEL (CDR LABEL] - (* ; "Do surgury on the display list") - - (replace (PLOT PLOTOBJECTS) of PLOT with (APPEND OBJECTS (fetch (PLOT PLOTOBJECTS) - of PLOT))) - (if (NULL NODRAWFLG) - then (REDRAWPLOTWINDOW PLOT)) - (RETURN OBJECTS]) (PLOTPOLYGON - [LAMBDA (PLOT POSITIONS LABEL STYLE MENU NODRAWFLG) (* ; "Edited 5-May-87 17:58 by jop") - - (* ;; "User Entry Point. Draw a POLYGON in a Plotting WINDOW. Style is the line width to use. POSITIONS is a list of positions to be contected.") - - (if (NOT (type? PLOT PLOT)) - then (HELP "NOT a PLOT " PLOT)) - (ADDPLOTOBJECT (CREATEPOLYGON POSITIONS LABEL STYLE MENU) - PLOT NODRAWFLG]) (PLOTTEXT - [LAMBDA (PLOT POSITION TEXT LABEL FONT MENU NODRAWFLG) (* edited%: "27-Mar-86 21:22") - (COND - ((NOT (type? PLOT PLOT)) - (HELP "NOT A PLOT " PLOT))) - (COND - ((NULL FONT) - (SETQ FONT SMALLPLOTFONT))) - (ADDPLOTOBJECT (CREATETEXT POSITION TEXT LABEL FONT MENU) - PLOT NODRAWFLG]) (PUTCOMPOUND - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") - - (* ;; "PUTFN for COMPOUND objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (PRINTOUT STREAM "(" %,) - (PRINTOUT STREAM "COMPOUNDTYPE" %, |.P2| (fetch (COMPOUNDDATA COMPOUNDTYPE) of OBJECTDATA) - %,) - (PRINTOUT STREAM "COMPONENTS (" %,) (* ; - "THIS ASSUMES APPROPRIATE HPRINT MACROS") - - (for OBJECT in (fetch (COMPOUNDDATA COMPONENTS) of OBJECTDATA) - do (HPRINT OBJECT STREAM T T)) - (PRINTOUT STREAM "))"]) (PUTCURVE - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") - - (* ;; "Putfn for CURVE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - STYLE) - (SETQ STYLE (fetch (CURVEDATA STYLE) of OBJECTDATA)) - (PRINTOUT STREAM "(" %, "CURVEPOINTS" %, |.P2| (fetch (CURVEDATA CURVEPOINTS) of OBJECTDATA - ) - %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) - (fetch (PLOT.STYLE DASHING) of STYLE) - (fetch (PLOT.STYLE COLOR) of STYLE)) - %, ")"]) (PUTFILLEDRECTANGLE - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") - - (* ;; "PUTFN for FILLEDRECTANGLE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT))) - (PRINTOUT STREAM "(" %,) - (PRINTOUT STREAM "OBJECTLEFT" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTLEFT) of - OBJECTDATA - ) - %,) - (PRINTOUT STREAM "OBJECTBOTTOM" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) - of OBJECTDATA) - %,) - (PRINTOUT STREAM "OBJECTWIDTH" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTWIDTH) - of OBJECTDATA) - %,) - (PRINTOUT STREAM "OBJECTHEIGHT" %, |.P2| (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) - of OBJECTDATA) - %,) - (PRINTOUT STREAM "BORDERWIDTH" %, |.P2| (fetch (FILLEDRECTANGLEDATA BORDERWIDTH) - of OBJECTDATA) - %,) - (PRINTOUT STREAM "TEXTURE" %, |.P2| (fetch (FILLEDRECTANGLEDATA TEXTURE) of OBJECTDATA) - %,) - (PRINTOUT STREAM ")"]) (PUTGENERIC - [LAMBDA (OBJECT PLOT STREAM) (* jop%: "27-Aug-85 17:10") - (HPRINT (fetch OBJECTDATA of OBJECT) - STREAM NIL T]) (PUTGRAPH - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") - - (* ;; "Putfn for CURVE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - STYLE) - (SETQ STYLE (fetch (GRAPHDATA STYLE) of OBJECTDATA)) - (PRINTOUT STREAM "(" %, "GRAPHFN" %, |.P2| (fetch (GRAPHDATA GRAPHFN) of OBJECTDATA) - %, "NSAMPLES" %, |.P2| (fetch (GRAPHDATA NSAMPLES) of OBJECTDATA) - %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) - (fetch (PLOT.STYLE DASHING) of STYLE) - (fetch (PLOT.STYLE COLOR) of STYLE)) - %, ")"]) (PUTLINE - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 17:59 by jop") - - (* ;; "Putfn for LINE objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - STYLE) - (SETQ STYLE (fetch (LINEDATA STYLE) of OBJECTDATA)) - (PRINTOUT STREAM "(" %, "INFINITESLOPE?" %, |.P2| (fetch (LINEDATA INFINITESLOPE?) - of OBJECTDATA) - %, "SLOPE" %, |.P2| (fetch (LINEDATA SLOPE) of OBJECTDATA) - %, "CONSTANT" %, |.P2| (fetch (LINEDATA CONSTANT) of OBJECTDATA) - %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) - (fetch (PLOT.STYLE DASHING) of STYLE) - (fetch (PLOT.STYLE COLOR) of STYLE)) - ")"]) (PUTPOINT - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") - - (* ;; "Putfn for POINT objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - SYMBOL LAB) - (SETQ SYMBOL (fetch (POINTDATA SYMBOL) of OBJECTDATA)) - (SETQ LAB (if (EQ SYMBOL STAR) - then 'STAR - elseif (EQ SYMBOL CROSS) - then 'CROSS - elseif (EQ SYMBOL CIRCLE) - then 'CIRCLE)) - (PRINTOUT STREAM "(" %, "POINTPOSITION" %, |.P2| (fetch (POINTDATA POINTPOSITION) - of OBJECTDATA) - %, "SYMBOL" %,) - (if LAB - then (PRINTOUT STREAM |.P2| LAB %,) - else (HPRINT SYMBOL STREAM T T)) - (PRINTOUT STREAM ")"]) (PUTPOLYGON - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") - - (* ;; "Putfn for POLYGON objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - STYLE) - (SETQ STYLE (fetch (POLYGONDATA STYLE) of OBJECTDATA)) - (PRINTOUT STREAM "(" %, "POLYGONPOINTS" %, |.P2| (fetch (POLYGONDATA POLYGONPOINTS) - of OBJECTDATA) - %, "STYLE" %, |.P2| (LIST (fetch (PLOT.STYLE LINEWIDTH) of STYLE) - (fetch (PLOT.STYLE DASHING) of STYLE) - (fetch (PLOT.STYLE COLOR) of STYLE)) - %, ")"]) (PUTTEXT - [LAMBDA (PLOTOBJECT PLOT STREAM) (* ; "Edited 5-May-87 18:00 by jop") - - (* ;; "Putfn for TEXT objects") - - (PROG ((OBJECTDATA (fetch (PLOTOBJECT OBJECTDATA) of PLOTOBJECT)) - FONT) - (SETQ FONT (fetch (TEXTDATA FONT) of OBJECTDATA)) - (PRINTOUT STREAM "(" %, "TEXTPOSITION" %, |.P2| (fetch (TEXTDATA TEXTPOSITION) of - OBJECTDATA - ) - %, "TEXT" %, |.P2| (fetch (TEXTDATA TEXT) of OBJECTDATA) - %, "FONT" %,) (* ; "Assumes FONT has an HPRINTMACRO") - - (HPRINT FONT STREAM T T) - (PRINTOUT STREAM ")"]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS L1METRIC MACRO [OPENLAMBDA (POINT1 POINT2) (* jop%: "17-Jan-85 15:27") (* ;; "Computes the L 1 metric between POINT1 and POINT2") (PLUS (IABS (DIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2))) (IABS (DIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2]) (PUTPROPS L2METRIC MACRO [OPENLAMBDA (POINT1 POINT2 PLOT) (* jop%: "17-Jan-85 15:27") (* ;; "Computes the L 2 metric between POINT1 and POINT2") (FPLUS (FTIMES (FDIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2)) (FDIFFERENCE (fetch XCOORD of POINT1) (fetch XCOORD of POINT2))) (FTIMES (FTIMES (fetch NORMCONSTANT of PLOT) (FDIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2))) (FTIMES (fetch NORMCONSTANT of PLOT) (FDIFFERENCE (fetch YCOORD of POINT1) (fetch YCOORD of POINT2]) ) (RPAQQ CIRCLE #*(5 5)G@@@HH@@HH@@HH@@G@@@) (RPAQQ CROSS #*(5 5)B@@@B@@@OH@@B@@@B@@@) (RPAQQ DASH (5)) (RPAQQ DOT (1 5)) (RPAQQ DOTDASH (5 5 1 5)) (RPAQQ SHADE1 64) (RPAQQ SHADE2 576) (RPAQQ SHADE3 4680) (RPAQQ SHADE4 37449) (RPAQQ SHADE5 55899) (RPAQQ SHADE6 31710) (RPAQQ SHADE7 64479) (RPAQQ SHADE8 65023) (RPAQQ STAR #*(5 5)JH@@G@@@OH@@G@@@JH@@) (DECLARE%: EVAL@COMPILE (DATATYPE COMPOUNDDATA (COMPOUNDTYPE COMPONENTS)) (DATATYPE CURVEDATA (CURVEPOINTS STREAMPOINTS STYLE)) (DATATYPE FILLEDRECTANGLEDATA ((OBJECTLEFT FLOATING) (OBJECTBOTTOM FLOATING) (OBJECTWIDTH FLOATING) (OBJECTHEIGHT FLOATING) STREAMLEFT STREAMBOTTOM STREAMWIDTH STREAMHEIGHT BORDERWIDTH TEXTURE) BORDERWIDTH _ 1 [ACCESSFNS ((OBJECTRIGHT (PLUS (fetch ( FILLEDRECTANGLEDATA OBJECTLEFT) of DATUM) (fetch ( FILLEDRECTANGLEDATA OBJECTWIDTH) of DATUM))) (OBJECTTOP (PLUS (fetch (FILLEDRECTANGLEDATA OBJECTBOTTOM) of DATUM) (fetch (FILLEDRECTANGLEDATA OBJECTHEIGHT) of DATUM))) (STREAMRIGHT (PLUS (fetch ( FILLEDRECTANGLEDATA STREAMLEFT) of DATUM) (fetch ( FILLEDRECTANGLEDATA STREAMWIDTH) of DATUM))) (STREAMTOP (PLUS (fetch (FILLEDRECTANGLEDATA STREAMBOTTOM) of DATUM) (fetch (FILLEDRECTANGLEDATA STREAMHEIGHT) of DATUM]) (DATATYPE GRAPHDATA (GRAPHFN NSAMPLES STYLE STREAMPOSITIONS)) (DATATYPE LINEDATA (STYLE INFINITESLOPE? (SLOPE FLOATING) (CONSTANT FLOATING) (STREAMSLOPE FLOATING) (STREAMCONSTANT FLOATING) STREAMPT1 STREAMPT2) STYLE _ 1) (DATATYPE PLOT.STYLE (LINEWIDTH DASHING COLOR) LINEWIDTH _ 1) (DATATYPE POINTDATA (POINTPOSITION STREAMPOSITION SYMBOL) SYMBOL _ STAR) (DATATYPE POLYGONDATA (POLYGONPOINTS STREAMPOINTS STYLE) STYLE _ 1) (DATATYPE TEXTDATA (TEXTPOSITION STREAMPOSITION TEXT FONT) FONT _ SMALLPLOTFONT) ) (/DECLAREDATATYPE 'COMPOUNDDATA '(POINTER POINTER) '((COMPOUNDDATA 0 POINTER) (COMPOUNDDATA 2 POINTER)) '4) (/DECLAREDATATYPE 'CURVEDATA '(POINTER POINTER POINTER) '((CURVEDATA 0 POINTER) (CURVEDATA 2 POINTER) (CURVEDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'FILLEDRECTANGLEDATA '(FLOATP FLOATP FLOATP FLOATP POINTER POINTER POINTER POINTER POINTER POINTER) '((FILLEDRECTANGLEDATA 0 FLOATP) (FILLEDRECTANGLEDATA 2 FLOATP) (FILLEDRECTANGLEDATA 4 FLOATP) (FILLEDRECTANGLEDATA 6 FLOATP) (FILLEDRECTANGLEDATA 8 POINTER) (FILLEDRECTANGLEDATA 10 POINTER) (FILLEDRECTANGLEDATA 12 POINTER) (FILLEDRECTANGLEDATA 14 POINTER) (FILLEDRECTANGLEDATA 16 POINTER) (FILLEDRECTANGLEDATA 18 POINTER)) '20) (/DECLAREDATATYPE 'GRAPHDATA '(POINTER POINTER POINTER POINTER) '((GRAPHDATA 0 POINTER) (GRAPHDATA 2 POINTER) (GRAPHDATA 4 POINTER) (GRAPHDATA 6 POINTER)) '8) (/DECLAREDATATYPE 'LINEDATA '(POINTER POINTER FLOATP FLOATP FLOATP FLOATP POINTER POINTER) '((LINEDATA 0 POINTER) (LINEDATA 2 POINTER) (LINEDATA 4 FLOATP) (LINEDATA 6 FLOATP) (LINEDATA 8 FLOATP) (LINEDATA 10 FLOATP) (LINEDATA 12 POINTER) (LINEDATA 14 POINTER)) '16) (/DECLAREDATATYPE 'PLOT.STYLE '(POINTER POINTER POINTER) '((PLOT.STYLE 0 POINTER) (PLOT.STYLE 2 POINTER) (PLOT.STYLE 4 POINTER)) '6) (/DECLAREDATATYPE 'POINTDATA '(POINTER POINTER POINTER) '((POINTDATA 0 POINTER) (POINTDATA 2 POINTER) (POINTDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'POLYGONDATA '(POINTER POINTER POINTER) '((POLYGONDATA 0 POINTER) (POLYGONDATA 2 POINTER) (POLYGONDATA 4 POINTER)) '6) (/DECLAREDATATYPE 'TEXTDATA '(POINTER POINTER POINTER POINTER) '((TEXTDATA 0 POINTER) (TEXTDATA 2 POINTER) (TEXTDATA 4 POINTER) (TEXTDATA 6 POINTER)) '8) (PUTPROPS PLOTCOMPOUND ARGNAMES (NIL (PLOT COMPOUNDTYPE COMPONENT1 |...| LABEL MENU NODRAWFLG ) . COMPOUNDARGS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) PLOT TWODGRAPHICS) ) (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 PLOTCOMPOUND) ) (PUTPROPS PLOTOBJECTS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1993 2000)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2892 89004 (COPYCOMPOUND 2902 . 3510) (COPYCURVE 3512 . 4006) (COPYFILLEDRECTANGLE 4008 . 4951) (COPYGENERIC 4953 . 5182) (COPYGRAPHOBJECT 5184 . 5694) (COPYLINE 5696 . 6347) (COPYPOINT 6349 . 6840) (COPYPOLYGON 6842 . 7350) (COPYTEXT 7352 . 7920) (CREATECOMPOUND 7922 . 8486) ( CREATECURVE 8488 . 9816) (CREATEFILLEDRECTANGLE 9818 . 10514) (CREATEGRAPH 10516 . 11909) (CREATELINE 11911 . 13366) (CREATEPOINT 13368 . 13842) (CREATEPOLYGON 13844 . 15201) (CREATETEXT 15203 . 15569) ( DISTANCETOCOMPOUND 15571 . 16380) (DISTANCETOCURVE 16382 . 16761) (DISTANCETOFILLEDRECTANGLE 16763 . 20249) (DISTANCETOGRAPH 20251 . 20632) (DISTANCETOLINE 20634 . 22361) (DISTANCETOPOINT 22363 . 22607) (DISTANCETOPOLYGON 22609 . 22994) (DISTANCETOTEXT 22996 . 23240) (DRAWCOMPOUNDOBJECT 23242 . 23768) ( DRAWCURVEOBJECT 23770 . 25405) (DRAWFILLEDRECTANGLEOBJECT 25407 . 28235) (DRAWGRAPHOBJECT 28237 . 30807) (DRAWLINEOBJECT 30809 . 34244) (DRAWPOINTOBJECT 34246 . 35183) (DRAWPOLYGONOBJECT 35185 . 37281 ) (DRAWTEXTOBJECT 37283 . 38609) (ERASECOMPOUNDOBJECT 38611 . 39054) (ERASECURVEOBJECT 39056 . 40229) (ERASEFILLEDRECTANGLEOBJECT 40231 . 41946) (ERASEGRAPHOBJECT 41948 . 43043) (ERASELINEOBJECT 43045 . 43894) (ERASEPOINTOBJECT 43896 . 44556) (ERASEPOLYGONOBJECT 44558 . 46155) (ERASETEXTOBJECT 46157 . 47385) (EXTENTOFCOMPOUND 47387 . 48798) (EXTENTOFCURVE 48800 . 50483) (EXTENTOFFILLEDRECTANGLE 50485 . 51102) (EXTENTOFGRAPH 51104 . 51367) (EXTENTOFLINE 51369 . 51620) (EXTENTOFPOINT 51622 . 52147) ( EXTENTOFPOLYGON 52149 . 53618) (EXTENTOFTEXT 53620 . 54144) (GETCOMPOUND 54146 . 54473) (GETCURVE 54475 . 55065) (GETFILLEDRECTANGLE 55067 . 55633) (GETGENERIC 55635 . 55758) (GETGRAPH 55760 . 56348) (GETLINE 56350 . 57065) (GETPOINT 57067 . 57539) (GETPOLYGON 57541 . 58141) (GETTEXT 58143 . 58488) ( HIGHLIGHTCOMPOUND 58490 . 58935) (HIGHLIGHTCURVE 58937 . 60123) (HIGHLIGHTFILLEDRECTANGLE 60125 . 61757) (HIGHLIGHTGRAPH 61759 . 62853) (HIGHLIGHTLINE 62855 . 63703) (HIGHLIGHTPOINT 63705 . 64758) ( HIGHLIGHTPOLYGON 64760 . 66361) (HIGHLIGHTTEXT 66363 . 67612) (LABELGENERIC 67614 . 68581) (LABELPOINT 68583 . 70238) (LABELTEXT 70240 . 70394) (LOWLIGHTCOMPOUND 70396 . 70839) (MOVECOMPOUND 70841 . 71125 ) (MOVECURVE 71127 . 71590) (MOVEFILLEDRECTANGLE 71592 . 72022) (MOVELINE 72024 . 72779) (MOVEPOINT 72781 . 73207) (MOVEPOLYGON 73209 . 73669) (MOVETEXT 73671 . 74078) (PLOTCOMPOUND 74080 . 75565) ( PLOTCURVE 75567 . 76120) (PLOTFILLEDRECTANGLE 76122 . 76758) (PLOTGRAPH 76760 . 77117) (PLOTLINE 77119 . 77470) (PLOTPOINT 77472 . 77933) (PLOTPOINTS 77935 . 80351) (PLOTPOLYGON 80353 . 80829) (PLOTTEXT 80831 . 81186) (PUTCOMPOUND 81188 . 81967) (PUTCURVE 81969 . 82785) (PUTFILLEDRECTANGLE 82787 . 84300) (PUTGENERIC 84302 . 84489) (PUTGRAPH 84491 . 85325) (PUTLINE 85327 . 86314) (PUTPOINT 86316 . 87307) (PUTPOLYGON 87309 . 88134) (PUTTEXT 88136 . 89002))))) STOP \ No newline at end of file diff --git a/lispusers/PRETTYFILEINDEX.LCOM.~2~ b/lispusers/PRETTYFILEINDEX.LCOM.~2~ deleted file mode 100644 index 87f561c9594c1062eb2828951dc2d0e57b838c0b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 41483 zcmeHwdvIIVc_;6MY|DV!2czpAB03bFt`jAv&3AD4vYwV^(PJaBD9$Fojx$*t8W4AMKxg>U{tB zxD^_k2n|h)91U8%!Nm*bE-tSwm8}cst)TVE>3s6XAGvtx!r7(8%a5L0Dz7d*Jv1=# z=<4#?#i!PmF0DP9&BY3Zd1^S3nU0+t_|Q=6VYEHoKf54phbF=!6XC(2_4uVFr}3pv zT)eb)V8Uv6+se))2C~t7eqhQ@r(>CdwTw}uW{z3zUUf>vvJ;WEbPox|Y7$neDQ zcI-kD7PJtuM4x_D{nW6KwwTC-@_cr6$T z_h&AAtbcsS8XTV(5!knWAHWVDZY7XqV#NXAK!KJaAF?Kli%Lr{wz<@>A|D{S?l+5TxeQ|QlUqs2_$VXNgsrqN<{ zSVm;|t`_`neq+y*^p}4kAE3+j+{=k5KWyjHM6}Y=({m?1O0>81j*Rg7#xlp}VskNT z=%|&B&QHb$8j&D;)S607#Bw=1XN_abnQ0m~)^&Jzr#HgZL^fK8(*%Ic)=9ii@APNv zLjR0Cmzl=f0xH#ebZ~G`0g7MBCnhHP<}yWe)}PJUh1gV~&q@GD{9q~-i)QAsXeyUx z00ES^1W?Ym7%j#}X@(V^GQ)xIYm@vZTj^nl+)H)1WaCGO<78x_EDJj6f&-0Z1XK5rczw4&3~&h5~MbtW@qXQskdXvDH73(-VoAZ=$7 z1v{6rr;-3gXmHp%!+T9N0V3eN=j|8GOrvcy=BwL-GMxmZ3{P^(K@gIApzicR+`&l$*Awol6``WTGiAOB-wCve*+KB%trKmtxEz@)lOrU&1@5fxj>` z=m$*0VU!u0StV`#0tBS=VN7j;rWRcf$xI>@o<`($l(xKmS48f3lDdqG+NHYiyQ!3& zkIj788a`^BnF5g#H57F0t!wMnmz_cKZ%Zg5Eh0;tv-@2-GUJ*U~!Xc z4C5UUO6eBEU=bo4%Sg8AkSL_2%ONSq zLY&4h=Q7e1M4%nSBlJU)Bgv{C;?%K1oZF>Isj?HX6cwqtq@ySMi%~+-ewrpvNX@4( zpOt$xl|s?(&nKp1)AYKU437&aJd-#{r8FJxMzC4|ksBS>dn9!X6^B>~Qk8)mb5n)6 z9M71fJ8mMH%SGpT@K#^G0Dcda4gDfJ#~{FjoI-o9z@zP{DcI zk{q@I_Z+;d#VDRAo?I@MnXR)tR?P7Aq1vwEnN@SMc&hl3j(^d82d@Z0i-fGMDib6da3wE(>JuCt}idZpA}=N3v2*Q+aWzT_VT%@n`HC1|H))$Pt9 zYvUfflbcyJZ`>3}cGhiCXLv=>sV$PZ$o1$%fG-FzjEQlRhiZWpyY0D^Po4eC(nP68 zmzIuxA!8rqW#wVKr6D>Ah)x2clYl7xF+^+mVu8nC556ME;HY4Y7fge zM}ZX^_j}RC?y)CstbCJEuWpCGj+M0sc%1d>SBfcn*nY$wAdvUiqdlcjI~=G5+U-%L zu@p006^v}`=%{GsL^TG|bE!gNK=$a^7#NpQHpZ}BL0O@PP%R<`+SD)x_C^{RRHkUb z8XZ6CsVD7>Ledj{W{r-DT&%PkZpa!94_lkdaXciI6VAXu^;$ zMaP`7Q|P_`c1wnnT;3XiXaEYDgN6dF7^7rTJODui+7TF(H9S7X1PqKS4|YAS_$fw_ z1!)=Ncff<^vIB)&6dXtR5NHt;Ay{8h(Rrb5s15y4dV!jN5qea zM?-FiWlkh=c7`n|VQ6UC8TYmDh%yTRHekh&gS9>~PKp}Xrm_aaxh-fc;{EfGM(tA010*_i!cOzQ+Tp7 zBafsx1QeRKr{-u$23YnQ0t@t)gaN@O^AAHz_U@(-kP}9?xm*To1DG>wwnDV~yZ{aX zS^7xqvNMo7@>#|WFJ|;X10Av^q>2T2*r{m?^Jk7~jfK^Q{4n6G${@w6)y0bk6jy~X z)G%!1WtHTV+;4$Lf{UtX)gRJVM-y!46X^G{ko5w&`MV%oa604v(zpfw7SFW4W% z_>b}n`O6EJE>k^z!MgASUVy<5bMEcU$6z^vco0ol1qkS&(N-&%MLQPh_I^90*1rg& zux%kO06%tA#|SXbp#U z9|(jR`C-UHpgOUcC}=r9011rSnE#BWL{o2dG6^bS)|F5XTZVl{pv8zNcDF}g+*ND~ z7?79RIu>q^mtP7%n5gv#hvurxRmy=cm!GTj7}tvJuT|b)ewg3~k5$tA_akYBmTL6$ z`U6V;dRz>SnIzW|Rz533IK94aR+O|;T;Qvt8d~3@Dt}J?R;rW5&h=@hg^7p=e}^_g zbtz05tDTv@;lbQUnnn`S!9V#iiFe8vBC|Z8$6I(V@c<@$SG;xy-|>@#*htSv`w@@S z=*}cX>M{1M>@wy(L*Y@Ey$w0qoje0UB9fa(gH-9A2`a8QWf;afhckx3CV`$L#>3bF zvQ5k|1jCFj42?qforlZp zRhmJ7e&+T-OUnsH++tg|2}*QAY!|)pt3{?ludOZ%)~*)i@8+*pUh5dVEnW?mjd>$s z^1s>g7kE3(CK%Hz&y=CT;D4{DYIh_nJ&!$;JottgsQq!evuCkAezi+_;a9qP`46xf z@Q2tSMnK}yjz9!kgL?zX2{*o4V5Sig(XL)^pMGQypY+c=>E{mN)8S0hA&U&%S{HmCf5?#IZNOaXqw6z;XbQ7xI zi?fD#+IS;rKK4o^#Sc^qZ>7!5p;B9Ie_C{pOxob3Dz!nlXX;Y7+oa!2+B7!TKa>*L zK4rJ@;~S;+vs>#2?Dkdj+h^5iqzmXiWfa~}rO&F;jI`E1d*$8zFm+>H^ty$4>!irO zSFmBvVS}%}!`5&YI|RYXb2kD(TCIJETn0+32*FI|U``0ahOUH-tC~e^6rRl5`2-n< zEKoPx&+B`vcnGcq2Nlq511fCO7Bof-TFH!E%&;IyJd?y-@cV4?m?~=davS_V#eJ-G znaW&l8Xb$f;uJQUenzdxD!9rNv$#G#I8tKAu>wcA~t4EWdM=E>@x8l|3k zgw)kiTcCENvJp(#J!N`f_7Ew}=v>J@wM!BTg<`X_L{ftm|Q2_DMkrPL$xcx7QiQWhtF zsk31kL}eF73YrkF92=O}4PkJRO~N)TWm}tJ6P9Cd$#SF^uf2lBmdfN>wJwX3P)ue zyZ$HvhhOM7_y#68-^hD`dnid^@vGb zV7RCr*tox*?p&@ci=~JMSm)nrP=-=!t7mF=+2AK1d9(V*cH6!V z2BZu@=G4YALU+|r7~4g?O|}Dl2}PTC1=)Q<&E6y1j;c)BxN|A{9b^Vv)Jrr#Dr6K0 zj8Rt*|J@m@;lN%eav#ME_)K4bF?feVFd)x6qz9HAhoE88lbLOTkpT)msO@XfPKWsVCUf_@2GtOHtW zh}0h~twGhq0*K0{uw@8@l?q+y%1f{hw`LM49a$su@}jw(T*yks=8I&3!=$pYDGEO# z7n*h#a=?+ZjHJ6yjqzj<&Ek`dutzem+x(o`eY>m&rsnAIm~sG zl-{^kFkZ)kh^w{T$akByJ9ry_I7L?CZ2-`S79GfT%Y*=)2Syo*v!Q5B@iu4>z=Ib-e#XG&P6d(w1&> zm)Wu$=`f94e$^~MY+SsHfz;l@3kP2RbiSnd%boDdf=!Mj(PyY z=8?+~W>V2(9MQlb8laol{uJOURb`Ui!D8m)PzY#R*!Fr_WY}lg!YV)8c|4&fC~S;1 zAPNrB@9hq?V7R;0*il0p+uhg`Xc%YPZi89f==iZa;$#H)C@B`kAw^0B0r>$#^w49) z{T&^5+UBBn*{W4GN^RA9%EnuEn~^C#Oup^nzMjQ>btqro#lJtN`J2YZ)jg4< z+QJl&rnLZf!)n2r0&5}1iW(Xoft8Y&-D&vq8?6ol5vTEnC7r?W3z321++$=(L*5$VT>uYwnx-cUv#t^sSc7?;qw6$W4J#SA30 zd%#0E6j9bpk-c6*IW@%(bHw!wD0xUkD6PSZ)yZQ|QXD~rg@GE~YZxtoDADKT$;xqw zu-?No9>f~KXqw=X{}waBxP5YMW2AuM(&)zF(#lqkz8*qf60JhQ>X*+4{;HjOir+X} zInM0%#Lh-Z@UdH>8FY)-VcL=|qNytLPWo zEVqvnWLrh}HwlDl88jemBNA9NhK(K`|H`*c=C-~bkJfez0eWXkqHSb$n2#7?mD`-+ zzZ6uVixN(PUBI4Shz;Zur^xHVg^iE}3?Klzp%lJ3`&-acR#*VY4^u#Mgvr6xwunKL zQwSt2#25K8&I|DTs`;sv&WNZ**J|d;$O4Ka=rr0kSWd^L zQc#8(p$Rzs8Uo;9Fr+OTxO#vQTZsXCQP9N&I*{?|ZSl%x=f()rCs(h8inDyO4v~K2 z0Yq|&MbmvMQaq52Ev)l_jqdpKm6Ok|i0m)OSN&aXQpIQ1BZ2j5MCu1>e^>nt(np1; zsric*3e8kA5~csc%nt5?^HT`hwqUGRk72$h(1+;Uj%GLrgHeTmpwt7vp>+}xAxN6} zgYsqKfd%I}nZO~B1hvIm4+b)Le=#1*G=c6DBuG|PVZAmDp(2cOE_Bp1`I&&kTS74H z(J*yiVqhtN3K*+@3WEx4Aiygl#Rh==LuRL;%=UvJ!Q z0$+L75SBZR-v;~C3+A=BagvnAFI8Us^oiOBB5@^ZR^B`ls6ATQxStk4_I#q-G{nbu zqG$2$db|v}u<EmyyhGOMq+ zE5fVVQ*7&5Y?BDsMECr<6=#jl;rm>$SCe z`_c2q8A?7k0%?o^L3Vb(=g;vSv$%{(6fCEV?(vpDi|H<6wiXa+SuM8M*ccA0BCkcv zWd_%BRP+z`T?nAcFB+o5l)PBzjBSv@I>4ee^f*LC`*|^Astq>7ffTw}+8~gCmxv@| z!7)NefnSXj3YW2&sWS}~SDa2liqn)0p+g+aV!Ref1g;Jy453O_56%Xz250r%Ua0@4 zi0oZ$OTY#p5k++|Kwy%Hg=&;N5PkN3We-SvqK`t>;|phr-HEWG**Fy}o(@7lkV7n2 zNWd0!*lIbk%PWx)LGB0!B5@vnUxH~bqxy?H*Pkn#4%F`B%TrfB5La_kl9~Z`@8)mR zlV?jcqcC0v76Sa6Au1Gv`8*j!K zq4j_0Lv-A`4>#lj3HJB*Ke4>DTDHndYm1kbFJ8WI$wEqj%huBBav8zGk3Y?~OP5g5 zPkZ|s=fsPB5HdUyG4s6syovee27}@zm&RXO z4aB#eTX|;HynZcSUfKMj2V@bmI=V3tF$3!(fUvpoKv{`f>wA2)j7rZhm_}jq>kQ~J z0T?d%T2xz1OqaclI8xc4LnDJCB0fqV)x%6N=@SHFZ zQ-e1U14@$D@k&vQ=>!hHrC`lbpy|(Iu|jwiVd5}iVF4)yq>p@IxCX`I#RT&l92ob~ zT5YLrvQBy*HhP}0BCw}6StlifHB*m2O0FtimI7&06l?dIcqld=;^NbZE%=|3TkBm( zk-`UdcsOksHhH@Q>Lcp)+$6(O^wX(Py@OC9uM6mjS3O6zeT({^b35a4n!jS`d zrfnfg>GClw7HF|o8Z98u7yKp=5HGC`cwDWD=4s_%JN4d2+nmwLzlq)LOU%PBpJBbn zX>GAgv`-;m&^{#>__>9P@4YjX+p=-p4_htwFwJ2hnc*C9M*+^&FbbfV=5~zLFf_nP z;F-JfX2Jo|s6@_W=+y2isgT@{%VPxtpc!)c>fz0Gv1--bDq1n*8qf>x-L4nbtN%9s z6@Fe{epLm6Rlk8<38y2?Lahp`g9!alJev-hFqekts?-`7VaX{*r{Ps4ibFvq$b4`X zx{gM~M|i!8baGa4{2iq~Ve~%fkG;R@D3n)f6?je3>NJIy1FU-+9`mhO{*=N8LxbXQ zya}|l3jI_j>a3|N+)`ku<52|#YBtgDL(CORy}Ki(a&$C^1YJdb+=IU&>1x4OJIh^H z4Cs>90^M`DPB^w|$BDjn9Ylw%mM3o8)nZ6QA;gM~c8LzFpZJ$?3MNzs755a|h|r6Z zRZ!6dG+TDuJyUEKVdM4Jk`?9#B7!7Aq#BRYCD`16L>&51oC-D~R}_wC#q`lVApngO zNVylM;1k2aC|*rU-=M-=eWrU z$mg9gfM%UIbPLBMa9ErDv%uP10-O|@zUyTG5Ks0a9+i%q!$_+2r9=wwBFWO2yod7S zT)aI}eW+}lHsam$UrB=1&&PXS#rcs$_o>=IB55YbunA7{op{HCciM>i?b{RYh<<>s za5lH)-`VY*y!!1pY%(k28sAs{kfMHzeI216viAmRAFz8mOPw1(T%CXvYPTDk|H>@w zuiN`-o%VhN9_~YAvAx$U?XBLl_a7|nt8O8l+w6#T*%th0cChn4M24I2nLT5adJ$G! zdF!!2ZGUB>%kC{5tlJOQhU|lA=HXJXZd+!_Lhm05)b6%>4GAFsY2yvMcO}*KVuoUl z{~&Evf5$#}kPh7bC!^F|HrM;g$}q`DYj>Msr^ehljJdYQ?n3*W6v#~Dxbkkm?mCFr z=Knz+5;09eqJWm7&~_jnr(+voBBpkZjbq z6Fy2MH%8T8G~WxQK^-hbd`S~?zPCdMrx8M?rY*7-xE0R%6C(32A${mmw~;=C75gM& zSz(axNpzBqf3?st81QKN)gj}IF~^Hp3;c^z&+D_byKxBQ6y&dy)jv!ge69Mw%Z7Pv zwsuFN(sTNm#KG5qhWBD?M@=i<@zOXzxNS(E=_RPn~OcjA&+LMun)0 zV1xeY#LNuNDrKf{Fq6$sj$af4FxAB(l82Nyvll3|j4&vQ;L-Siv}R2mwqu>Xc$}V%^6piF$fezpj?mq75@5jY z?p(QkCP6sVf@|)Y>O4UeGC5g&#qi)`9-7DWeB&hyP#OCr_GMR zAF{iu50s5JS&~7laZjly@OkY212`VOADIFG{=cyIcZwBaub80hF0*o9z4{;zskG1T zxv%;yg<`*gXHw}?@#}o-;6;0{-M#gKy%z@w_}syjcawJe>4Y4>J5^2yCrXiyh!qUO zHttbI=xB)NHUzmSgBYM3S^5xFr(NUVIz)Bh7#wq+gEU^8maP?$yno(Nr%o`p5v$Nx~_w${|nDxl7SK8AXT@lu|>t_(Gu|8j4eysZ6oiiZ4 zl{2+RlJTvLdjw$&(1q1Iu1A3h<}3QW>cij!c#vGZ?Z(zCc6$wm;6I>KA9XpAfUTA) zjT)ulx;<)^!bWKjIRMPk05U?@VBduTU5%RGo&1-u7Nppqw4+k!33uL&ejX7W~uvU6R2_)&nxT4@W4I@WVX9+ z-aw7(3A_8-NT>jkkGu@PUAuGZc_0&BV7Tzl4f`Of&)&RYcdvZw+i1t`M#&?DR&Uuy zR&TowUG7jEKSA8>1}rx2^8!__u?#m}mrHxNeC}OdiPik(`j6D<{-5;y#s@{-vWL&T z!*auK*~2U6{)sQ2v4?pxaa|>x6=!&_s0B=}25!7=4`N%sYadOn+`v95+k5{3Q`%cP zveMD{pdBgOk8Z8^@3AM$64mK(}AUzVgi*_C9_F z&hiiI`-;;l+7F^Zae8%N)wFxs>MP%>{sqJaX#@TDZf-nhKXR5kuUCIsfi!}iBUj!% zkhG6n`KNcKa9Q4otXr$MCjtJ`TVE72aGe+9$~$*Ry**dnxf2>S5)LSxhq6kzBBC`$ z8Z>A%Q`3P-CaVYsk-_b!|$$h{FTbbvsOXb3~_jFpZE0B;=4K%MvTkY%vZQ8^Bzf;xu*=b&&(n4zKN z1`{zwnSHQxSuCI2Lbwk+s0BW#16{0%jcCkkrpK!J%=9ne2&~EI2NQPmWp&c49_OO? z4LCH{!;HQw-{PXx_M7uJBWF80Z%YPhcceP6SMM|4Or=loHn@(Hm#3?LEjLWo_*H7; zf$F{GQ^Gduv*ybQwQsq(;#>p*ZRnlSo;9f4fY{UvaovGaj4Tm*+HW=?7)houS*XT5Nf|w`b ziy9Z}u+?%5DMZEAK!(;F6QbY0^Tt^QK7;fcUy3*+zv3^cO9FvCk(!Vb01#Go1wXh= zFcmj=3Rx(pbI~GUD;+g+CJ!rm!<50}QR3Mw5F)4mZ*o``KXw`>iBirKBPM(bsv$CJ zIs&6t1JN)6*&s7KK*LE_$;TwlHjfesu;5%G6o_cH+w9(^K=>SD{&s&v;#S?(l`iU9 zB4i=3bK#bCvYVm9gB0R*oK1t98~dW=z~|YahqMiWcxNO>Jok9dqDg0@SeJqFP8m>~ zxgxTIH7z|J*KHK!C@eTrpgXWH<(~L5LQk)@#hIt>!(|}unIuPhA4}Pj(G*1#fl|k& z_<|-OMH#r|q89z8$U_%ZL4u&Lgkc35NZt|X+>sn42NqAUW6+FLyAa16_^k12qIO3d z`pPr$gV(S<|8}+$LMzV^I)rLb;#C@w)99(n*3^kKu%Kjw)dqqcGR8SJB093+Ce;0% z-DD`Rj7Z0WyJl-$$xb>`2w~w1Dw|?^Iq;=7DnDtwK?egFd?_YG>-VMjj(=P`QT22R zr05Yk)0e9D;{d<#|C$8SG9(gQyVBEmF7Z0fC06%suP=$ml>g!NEAO7+Rw8a%-v|*h z#h-L$)exKmj@|}SC&YgV_@poaiV+})!KuJXo67P_p;+nx8P*d>*n_<_Pp5618#@1z zLg0J>yFNpvBgIOg2m9BGl(-NK_6?;_F8Jt}P7@6O+V(ubFh3*6&&?$a)9&_4XdlUn zDA@zpJAN^*U>~?yLx&!N0q+(LQ~zFa3L52wCvy397;!Ug|>JDQ!-}4RssBCYX)i=K0#ZMEpT`Qk4NGn_U=CfRqMgy;9 zjKJwHWDKD?%dk-u8y2(S<;pcu4=T~cYonajXmAGoc>JX==y zr2dei|7-h-Dz6YzTJ>ZZhmd!Zfu~+f{c17maRG2?sof>#jB-rn`HG*bREa?5$)G(E zsEvz$RT>ppa&`Aj==if=x?()a?WkNX_HagBU0*eCUcX`l4N3|*X?McjT94b4hCOLQ zom7=z-6?g!(DS_A^^D#9YGT{-o_cAo-Gk?QpRs$cIgj5;Zu}^2N=mD2Np;s2Y<;uR zlj=EB*SBW6yY{Gav(l69d8|JBZ|p~S)I8@>gi=;kkc+XjKTxwsd!DGfW(_((+5@hAT8wXJ$Bm_;|{EgPKSxfdY}PI zKyU2O4xenm)c30h-JT2iIZJ zvBU0LWSf!3btm@0+8KLT=`Z%9N~d8*fLp38g!Q7tISF9u4XgDaB_H(-uljr3SM{q{ zsiRndqoz0!#1Znh$y!H>E4(48zp87$OM7Pho}?HoTHa6>W_3QvMEB5{a^OXNa9iWhL>xhB96CI1_*LyzA4l{B*E|Zo zK;2HoZE)a$NyHT(vR1iDyk($eT(61y_0|Y6PPpY&Vw4d`rkbUW;PVe?&}$VL#@czC9EL%NAefHjjyWuc+^r#eB_x3g{rF6 zKo}6Ove#b=BfAO#A3j`R7@&}_Q-NSX=E8B0e(ik2KAFbxe55}>`Uiw~Jqj$6 zuKYVncNVgMi6UWAxFco2r>>udA`eHG8GSxdYm0YAYXOyf3~A8}kLzFM4_HUqG{eMy z1~Y*uoT@l0rNZ3z;u)X(sP5$%Y`(1Se_GXhEm6A@he_vOtv)|{@LKgVh+EZeC~^on zfdv$EtCU>K3YKgb0rH43f&Jn59OyaXG`EEv@No_8kCLF~d`y4-=6xxP9EGrhk>M7p z*)2NcO#(T|vR1)Xmms!u9_-*59b4495uTVKwJyf;>719 zpTPXaeUez?<-8=!YIpuJmpxTG$Z*c{Z-rNcvE~$POmyyH4kyFwvz3IT9;*G&Y=W7t z%9;hu2$atGN&>TCHU) zRUvpp^}tvqA1-+#mC6g{KfEm)twL=6ppm<(q6g!X2Ovb>TN+xJ4rQG<$*jA6+mpROjcQg7D zokLia&dw`r4lttgp$*v#WOrx1z;R3>L&!HU4e)?klJ4y$7$(&gTy?wZisG;glxhgv zc7gyZG-To94^a>wbUxkzJ(%tt^_griT6-pR^8g5p@K*HTEu=r(g;=NJKG-dPJIc_) z)tAL>eG-?Si?j6pk+)kiZ=0F7cj3Q|U3W#qttkpuN5|cEw`dxt6cK+Ju2iH*uHIi} z!Txjg*=v==!-n~@h#(TRO*E;;j5pFa4<&jwQ;rU!HTgwJCm=b$>dT)Itw5|JHjghYF5rWI6UfF*^2v~OUoTG!O%&*} zDb2TIubkP?ip^o?d_Ne>fFxCQwgrpx5I2E;llZcln;fHA@>NO#>E%*VhZz_|5%o-c z-oz86=gZYDcmB^Y`}4PWBh7_3zpIMv&KqLfzxiD_^(lI9Uzw~f$n#m+yR{y(_lgl< z>t)$H)erLfTQBmTUveJ5D343sshhkh->|#Wa`k3hb(OyHk*)RnWOVfmg3dCZI{T`6 zb}c2T_kMr(4TKn+wfAp5clH^3KP*I@>klQ$cGnHN^PR2r@w$3lzgAg9=wC2(HhJST z0-0dPSt$i=Yis@EdU|cio7b-;@P4U10s~syZcj^6J`oVgc6VzlY5nmuf=1f6)>B0h zAU4-0i+$^l79W18_%M~@2VJTBfW7?k=5Na_-ynHz;+NFm?BL4vEAKvSw@2A1x7@DV zyxJu-t_po;K+$P}+FcqSxGg#IGS83K|EeMqidyg0lXApLHT0a$QYG~W>jGLAYp0$tIQ3>n`5f`c<(NU}MAK5qcu z+<;4_)V>;lh=WQLY%oG066_}vg^oXVp_Au=Bq(Y(jGzcsK&R2fWU2r=D=Vdr{}W0F zyOKQxAW9yck-{=@>prKfxsK!c8TdO?h#%56MGpWdJ&EzRL5@f40nm?tcHI&^;DY$XEPwP!%8 z^sO7Xc(X1@%!Ftw0w@lTGz)YX0Z%~%#~w4nDHlmXcZJ_!6}#BzKsNC;rxkaC|lwLpBZsSPsF|C1P+GCK);d>2rYNaCHdhfDpS$iP+@=a{J)G z2$J56slS8x3xzxcyq62GnGn^0BFldPozTD_j5~Qd^FG#kpxmgSDK_vTGC}Ets$$?JIw!Z$U01atI#DVl z9t2^|Mh<*uDpyUI;j8}fkt@u--bqWn}8j`~0#7BwZF$JmQRJcR+Yq~ezn-L?h zem@3K&P%|=gwA3R@wT|ETXg3RuRemGb<|WCXG58n(m7Dda3raONOyuz2-kX8 zOj9mehhfgpn;M8SlPEyihrLS)z3wr2h)VdR2<7WlP0`{zebL8DBuAVZp+!M4J2eB^ zqX;hNkQLPV9Wtgr&srHeQg%FGv~t{aZPI6!E==b*lnKhg_1GT)UjvD@TcKR zlve=@k_hy4eFX||;7PuyI66>3P;mkudY!(hyr72SFlCI1!ihM$QnP2UBT*Hr zw~vlqwgyiuTv}eZybP->{>y{iL-KJ#0xnk;E>kAs%a@L|P#2T=m0nN4X zV`+Z*gYLF{d4UT39~zK;TRnO>4M~4mj_NbubwXvgz+=DHW9Q1AWV&40n}L;Q<2}bo zH54xCRGVrfgmG%gQK!+fLhlJi!=^3SKIQY%zC37D%Xcm~1cSGW5LPhu2`u;88sP)J zJ6~R1y0oTOmEKh&73}hkT_2A1R3dFb5(9Y(F*W>$O`qdgsrIDkxCi8t8N=c(1l&?0 z#t=_~DxZYEM0lg8Y+IrN&$B*nFW4LO#k9P4bhP|r@bJ8&tXB=d%U)Xg*z(fHJup+_ z*9T(d05P=#tfmynV#|yj-_{T|8-0_Ew-|lM%)1Bz5Aj=Y2V@QL9JHkNeLi9;z{Iv4 zYLkJGX#|b2uaRqdJ$u|fccmiasfH)=)Pv~0z)`BEgEqNQZ}6mlwynXb3+EnRK92*L zl#&6{c2KUtZRWofXSe`^pQv-D+?~g@#8dD&fc*Uj;}7~WWVdkzNLsQY5GrORorIbH82xcy~u)ELW z8vuMGJ_|C%;A;Tj&MN01nUWd$$Y4O_%#lGgp?>9wRHW&9Wew#BkWN~?t-=Tg@Ri2| zB4)WT*ubN?D{qt3g-_}zRF>A3tc6QU*4d}lE|X_^aRCJvp1Nc$JOQuq`K6E3_Zpvo zYkO^R;UYl{kIGMZB zUPFo(wVP>Y^LHMDtr$|nwvcvEF4~M&X*@ay^`WpJPeQ1=MlqPc0JKC) z{Y8mn^g#{2K!KCF46>8HMloh7c@!;{BQ0Y0AGTPfJZ=FB1sgTsJaTC~frp_c44o4H z_iD3>HQ?i%%GiPzl+18o0yUVpInn_0Nv=Vn!f}5KGQ;C|tayK8`>242BBS_Q<}ztl z!D(C5s+?NaGCq?_R0L|JP_D%Rf77ZI&-?ss;;eJ;Hu1wZEBZ%Ftsg|JRNg!Hr>Qxu!rCSJ*=mi$(fl8g3L7RmZxiUq*QGsXK@?Oa+%qAgff z@F=S7ZVD{C-kmsrO{=99Dx~pql_hK8sV6BSN3<*GOXrq}c&$B+u$Xh!xrG%l0EF+9 zpE`FDLWj%cn^_|XasAdDKNav<9-1q*7$+x@0IzKo)MmV9Qjq5@&OgW1Zr9tKvM-7_ z?eCE%?(Se(zzE5hkd>`gk`(wWh`sKqngPfn*i?+Q#A#B|MA~6wgn>ASLm%4RMtt1@ z44c2c*2+bS?DMtcRN+f8()LL^A`__O8T^Fe*yT;S8QOy_5=jq$KKzvx!Z5Ed6>3M{4v{sWK|1xH8!Ikr1`xB!L9`*h^nR?) zXQ%*{%BMPDwD28a&~|~;F{~mMMZQ+eIuCI*lz0wEdHJ{_8d$B~Vip3t1@Jl)=n#F3 zkKW`VNjV0~ZJ)~qF1R1*mX%dBSPN*k{-`ufUD)!&U$l!sv zxivCjl$RD)NeWrJxU{&uuu7ZoePXC$|Ge}r)06Ql^2Bt5D|jSlg;O3n#5Ei`v$KwX zwn=UWRLBy5Pg3CP?eq~vet)|l&c%L7pNn=9%Vp?ZA)1iG2V9y4Z}gOnWKtTs0GJJt z6rlpsdOy<%<6@4|0Z~RD$8bTdwbF*ma|69dk4hJZNp2yN0FRa`(Sik!E%|Iu2qk=C z`4d<+NavTHI)9!NHOP$@kkk((6=EJO9(;_`A7%n)AESt=d9rj#Oh9iC`;m~62M~gQ z?A}0YNE}OKqA5tOhbRW)ZD0 zEuXlDp=@ETVlCtQfrqUWVHz}d(u5#xTlm^|;kbqIf*1lE)BPAd{2921#7{Hf)nG7F z-Vf|r{vG+x_L9LLFNnn-tn-Y&cKeYu3aGbBK`xKf&fxOjyP_k!V4&o zJjD7Xk4w636^K(9ri>VPVPmE=UMN}IRc2`!TGS=j8<(ur3kyiUcm$EGD-hK$EkC(@ zUUs3LoUEM-e)NU5TGg7;$n?^|BBs~&uo~L-X^?HqTTiv)Es|LQhpa2~O=?A|qr7|_c^ODY!Y4}+L_X`J6g z(!7pC2PyxKXev!epIS9-S1;Mt zOXVp0L^yo48~E$@ZUEWQ{?U310|;c}e=hrn-v7OR1IYJl|IonkiZG6-86Q~f7Iy#sj1P{M@_ua(tz;JhcIX$eef?7ZcH@J> zrT1xjAXCNnWqc5AUIU@Q_Rt6&S04M`j1WY=<=ve%OXoRTCIF!KWrXmw+|&l)H-C7H zIF8gWRJe%|!qYTy5y*rXR1+ISYonRLui`g8rKKku;rp;Icx({2GF9B#2tgVkTPfb# z2GRNh7$M%D4WbdDyaK&P*$@+kde{_YXmQ-0q8jrUt1GhFxG`@)iZ(^O$yBBod z^MYU!qmk12#ke=X3ct^|fVG$Xw)3+O1ADf|nBYZcYR%tutOuOq^bMm;$f;nK{Sz7Twaby(ka+?sL4GliG3|HMrn&5|C zrq3+?dr-rORNPt%Yt>>P=@ibZnoE`K&6e(d8Fz={S3Z#Zfmwr8}wP`%B(sx^3aYv{v5FR@|J`U!Au3P^vF6qMedley>PRETTYFILEINDEX.;3" 90678 changes to%: (VARS PRETTYFILEINDEXCOMS) (FNS PFI.MAKE.LPT.STREAM) previous date%: "11-Jun-92 16:01:31" "{Pele:mv:envos}Medley>PRETTYFILEINDEX.;2") (* ; " Copyright (c) 1988, 1992 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PRETTYFILEINDEXCOMS) (RPAQQ PRETTYFILEINDEXCOMS [(COMS (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX) (FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN PFI.COLLECT.DEFINERS PFI.AFTER.NEW.PAGE) (FNS PFI.PRINT.FILECREATED PFI.PRINT.TO.TAB PFI.PRINT.ENVIRONMENT) (FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE PFI.ESTIMATE.SIZE1)) (COMS (* ; "Expression handlers") (FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE)) (COMS (* ; "Previewers") (FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ)) (COMS (* ; "Printing the index") (FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME) (FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES)) (COMS (* ; "Combined listings") (FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST PFI.MERGE.INDICES)) (COMS (* ;  "Hooks for seeing files pretty elsewhere") (FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION) (INITVARS (*PRINT-PRETTY-FROM-FILES* T))) (COMS (* ; "Bitmap hack") (FNS PFI.PRINT.BITMAP) (INITVARS (*PRINT-PRETTY-BITMAPS* T))) (INITVARS [*PFI-PRINTOPTIONS* '(REGION (72 54 504 702] (*PFI-DONT-SPAWN*) (*PFI-MAX-WASTED-LINES* 12) [*PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC] (*PFI-INDEX-ORDER* '(FUNCTIONS)) [*PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))) (* ;;  "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN] (\PFI.PROCESS.COMMANDS) (\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (\PFI.PROCESS)) (COMS (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex") (INITVARS (*PFI-TITLE*) (*PFI-PAGE-COUNT* 0))) (ADDVARS (*PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (*PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (*PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (*PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (*PFI-FILTERS* (VARIABLES . CONSTANTS))) (COMS (* ;  "Prettyprint augmentation to mimic system makefile dumping") (FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT MAYBE.PRETTYPRINT.BOLD) (ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) [P (CL:PROCLAIM '(CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG] (RECORDS PFITYPE) (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*)) [DECLARE%: EVAL@COMPILE DOCOPY (* ;  "Public variables to declare special") (P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (GETD 'CODEWRAPPER.PRETTYPRINT) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ;  "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ;  "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE" )) (* ; "Also fix SEE") (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ;  "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION) (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP) 'NILL) 'NON.PFI.PRINT.BITMAP NIL T]) (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (DEFINEQ (PFI.NEW.LISTFILES1 (LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Substitute for LISTFILES1") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FULL (FINDFILE FILENAME T))) (COND ((NOT FULL) (* ; "When called by LISTFILES, FILENAME will already be a full file name") (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FILENAME)) (*PFI-DONT-SPAWN* (MAYBE.PRETTYFILEINDEX FULL PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MAYBE.PRETTYFILEINDEX) FULL PRINTOPTIONS)) FULL)))) ) (PFI.ENQUEUE (LAMBDA (FORM) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Add FORM to the background hardcopy's task list") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (COND ((AND \PFI.PROCESS (NOT (FIND.PROCESS \PFI.PROCESS))) (* ; "Process died, flush handle and any old listing requests") (SETQ \PFI.PROCESS (SETQ \PFI.PROCESS.COMMANDS NIL)))) (SETQ \PFI.PROCESS.COMMANDS (NCONC1 \PFI.PROCESS.COMMANDS FORM)) (COND ((NULL \PFI.PROCESS) (SETQ \PFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \PFI.DO.HARDCOPY)) (QUOTE BEFOREEXIT) (QUOTE DON'T) (QUOTE NAME) "Do-Hardcopy")))))) ) (\PFI.DO.HARDCOPY (LAMBDA NIL (* ; "Edited 25-Mar-88 16:49 by bvm") (* ;;; "Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (while \PFI.PROCESS.COMMANDS bind FORM do (SETQ FORM (pop \PFI.PROCESS.COMMANDS)) (RELEASE.MONITORLOCK \PFI.PROCESSLOCK) (* ; "Release lock while listing so that others can add to my queue") (APPLY (CAR FORM) (CDR FORM)) (OBTAIN.MONITORLOCK \PFI.PROCESSLOCK) finally (* ; "Nothing left to do, so exit") (SETQ \PFI.PROCESS NIL)))) ) (MAYBE.PRETTYFILEINDEX (LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 11-Apr-88 10:50 by bvm") (* ;;; "Performs PRETTYFILEINDEX on FILENAME if it is a file manager file, else calls the old listfiles1.") (COND ((COND ((PRETTYFILEINDEX FILENAME PRINTOPTIONS) T) (T (PFI.ORIGINAL.LISTFILES1 FILENAME PRINTOPTIONS))) (* ;; "Do this here since there is little coordination between the various multiple processes which are listing files") (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FILENAME) NOTLISTEDFILES)) NIL))) ) ) (DEFINEQ (PRETTYFILEINDEX [LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 11-Jun-92 15:58 by cat") (* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.") (RESETLST [PROG ((*STANDARD-OUTPUT* *STANDARD-OUTPUT*) (*STANDARD-INPUT* *STANDARD-INPUT*) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*UPPER-CASE-FILE-NAMES* NIL) (PRETTYFLG T) (*PRINT-PRETTY-BITMAPS* 'PRETTYFILEINDEX) (*PFI-PAGE-COUNT*) (*PFI-PAGE-PREFIX* "Page ") (*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS '%#SIDES) EMPRESS#SIDES) 2)) (*PFI-TITLE*) (*PFI-ITEM*) (*PFI-TYPES* *PFI-TYPES*) (*PFI-FILEVARS*) (*PFI-FNSLST*) (*PFI-LOCATIONS*) (*PFI-MAX-WASTED-LINES* *PFI-MAX-WASTED-LINES*) (*PFI-FUNNY-CHARS*) (*PFI-BITMAP-BASELINE*) (*PFI-PENDING-COMMENTS*) FILECREATED ENV WASOPEN MULTIFILEINDEX CRDATE INDICES PART# FIRSTPAGE LASTPAGE CRDATE) (* ;; "Specials are as follows:") (* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image") (* ;; "*PFI-PAGE-COUNT* -- number of current page") (* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing") (* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers") (* ;; "*PFI-ITEM* -- function, etc currently being printed") (* ;; "*PFI-TYPES* -- list specifying the type associated with an expression") (* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*") (* ;;  "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF") (* ;;  "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences") (* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.") (* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars") (* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default") (* ;;  "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed") (* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.") [if (TYPENAMEP FILENAME 'STREAM) then (* ; "Already have input stream") [SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT] else (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME 'INPUT 'OLD '((SEQUENTIAL T] (SETQ FILENAME (FULLNAME *STANDARD-INPUT*)) (CL:FORMAT PROMPTWINDOW "~%%Starting index of ~A." FILENAME) [if (LISTGET PRINTOPTIONS :COMMON) then (* ; "Common Lisp file") (SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*) else (* ;  "Figure out if this is a file manager file, and if so get environment") (CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED) (\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T)) (if (NULL FILECREATED) then (* ; "Not a File Manager file") (RETURN NIL) elseif (NEQ (CAR (LISTP FILECREATED)) 'FILECREATED) then (* ;  "File started with open paren, but isn't file manager file.") (RETURN (if WASOPEN then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy") (PRINTDEF FILECREATED T T NIL NIL OUTSTREAM) (PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME)) elseif (LISTP (CADDR FILECREATED)) then (* ;  "A compiled file--just use COPYBYTES to avoid binary hassles.") (RETURN (if WASOPEN then (* ;  "Print environment and filecreated before copying rest") (PRINT-READER-ENVIRONMENT ENV OUTSTREAM) (WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED OUTSTREAM)) (COPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME] [if OUTSTREAM then (SETQ *PFI-TITLE* FILENAME) (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT)) else (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) (push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME))) (SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT) (if NOPRINT then (* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually") (\CORE.CLOSEFILE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (\GENERIC-UNREGISTER-STREAM (fetch (STREAM DEVICE) of STREAM) STREAM) (\CORE.DELETEFILE (FULLNAME STREAM) (fetch (STREAM DEVICE) of STREAM)) else (CLOSEF? STREAM] *STANDARD-OUTPUT* (LISTGET PRINTOPTIONS :DONTPRINT] (* ;  "Make sure printer knows original name of file") (RESETSAVE (LINELENGTH (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) *STANDARD-OUTPUT*)) (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (PFI.SETUP.TRANSLATIONS)) [if DONTINDEX then (* ; "This is for SEE etc") (SETQ *PFI-MAX-WASTED-LINES* 0) (SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother") (SETQ *PFI-LOCATIONS* :NONE) else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE)) (* ; "Enable header printing") [SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND] (* ; "Says to do something with coms") [if (NOT (FIXP *PFI-MAX-WASTED-LINES*)) then (* ;  "a parameter expressed as a fraction of page") (SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES* (- (PFI.LINES.REMAINING ) 2] [SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES) (PFI.COLLECT.DEFINERS *PFI-TYPES*] (* ;  "Add known record types and definers to the list.") (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE] [SETQ *PFI-PAGE-COUNT* (SETQ FIRSTPAGE (LOGOR (OR (LISTGET PRINTOPTIONS :FIRSTPAGE) 1) (if *PFI-TWO-SIDED* then (* ; "Make first page odd") 1 else 0] (if (SETQ PART# (LISTGET PRINTOPTIONS :PART)) then (SETQ *PFI-PAGE-PREFIX* (CONCAT *PFI-PAGE-PREFIX* PART# "-"))) (RETURN (WITH-READER-ENVIRONMENT ENV (if FILECREATED then (PFI.PRINT.FILECREATED FILECREATED ENV)) (PFI.PROCESS.FILE DONTINDEX) (if (NOT WASOPEN) then (* ;  "We're through with input file now, so release it") (CLOSEF *STANDARD-INPUT*)) (if (SETQ MULTIFILEINDEX (LISTGET PRINTOPTIONS 'MULTIFILEINDEX)) then (* ;  "True on calls from multifileindex-remember the date and last page#") (SETQ LASTPAGE *PFI-PAGE-COUNT*)) (if (NOT DONTINDEX) then (* ;  "Now that we've scanned whole file, print the index") (SETQ INDICES (PFI.PRINT.INDEX CRDATE))) [if (NULL OUTSTREAM) then (CL:FORMAT PROMPTWINDOW "~%%Finished indexing ~A (~D pages)" FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE] (if (NULL MULTIFILEINDEX) then FILENAME else (push INDICES (LIST FILENAME CRDATE LASTPAGE ENV)) (if (NLISTP MULTIFILEINDEX) then (* ;  "More to do yet, so just return this index") INDICES else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX INDICES) PRINTOPTIONS))))])]) (PFI.MAKE.LPT.STREAM [LAMBDA (PRINTOPTIONS) (* ; "Edited 19-Aug-92 13:57 by jds") (LET ([PRINTER (OR (LISTGET PRINTOPTIONS 'SERVER) (LISTGET PRINTOPTIONS 'HOST] (DEFAULTOPTIONS *PFI-PRINTOPTIONS*) REG S TEMPS SCALE) (* ;; "Get a dummy stream of the right image type, so we can get scaling right, etc. The (CAR (MKLIST ... code is stolen from OPENIMAGESTREAM's decision for IMAGETYPE.") [SETQ TEMPS (OPENIMAGESTREAM "{NODIRCORE}" (CAR (MKLIST (PRINTERPROP (PRINTERTYPE (OR PRINTER (OR (CAR (LISTP DEFAULTPRINTINGHOST )) DEFAULTPRINTINGHOST))) 'CANPRINT] (SETQ SCALE (DSPSCALE NIL TEMPS)) (CLOSEF TEMPS) (* ;; "Set up the margins (REGION) for the page correctly.") [COND [[AND (LISTGET PRINTOPTIONS 'LANDSCAPE) (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION] (* ;  "Don't use default region when caller specified landscape (tee hee)") (SETQ DEFAULTOPTIONS (for TAIL on DEFAULTOPTIONS by (CDDR TAIL) unless (EQ (CAR TAIL) 'REGION) join (LIST (CAR TAIL) (CADR TAIL] [[AND *PFI-TWO-SIDED* (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION)) (NOT (LISTGET PRINTOPTIONS 'REGION] (* ; "Shift image to the left 1/4%" so that it is balanced. Default region is assumed to be 1%" on left and 1/2%" on right. No adjustment if user gave region explicitly") (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS)) 'REGION (create REGION using REG LEFT _ (- (fetch (REGION LEFT) of REG) (FIXR (FTIMES 18 SCALE] (T (* ;;  "Scale the REGION option in *PFI-PRINTOPTIONS* from points into the real stream's units.") (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS)) 'REGION (SCALEREGION SCALE (LISTGET DEFAULTOPTIONS 'REGION] (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS DEFAULTOPTIONS)) [SETQ S (COND (PRINTER (OPENIMAGESTREAM (CONCAT "{LPT}" PRINTER) (CAR (PRINTERPROP (PRINTERTYPE PRINTER) 'CANPRINT)) PRINTOPTIONS)) (T (* ; "Use default printer & type") (OPENIMAGESTREAM NIL NIL PRINTOPTIONS] [STREAMPROP S 'PRINTOPTIONS (APPEND PRINTOPTIONS (STREAMPROP S 'PRINTOPTIONS] S]) (PFI.SETUP.TRANSLATIONS (LAMBDA NIL (* ; "Edited 14-Apr-88 11:51 by bvm") (* ;; "Prepare character translation table for this output stream") (* ;; "*PFI-CHARACTER-TRANSLATIONS* is an alist of (imagetype . charpairs), where each char pair is (sourcecode destcode . fontplist) describing the translation and optional font change for a specified input character. We set *PFI-FUNNY-CHARS* to (oldoutcharfn . triples), where each triple is (sourcecode destcode fontplist . fontcacheplist). ") (LET ((CHARPAIRS (CDR (ASSOC (IMAGESTREAMTYPE *STANDARD-OUTPUT*) *PFI-CHARACTER-TRANSLATIONS*)))) (SETQ *PFI-FUNNY-CHARS* (CONS (fetch (STREAM OUTCHARFN) of *STANDARD-OUTPUT*) (AND CHARPAIRS (LET ((FONT (DSPFONT))) (if (NEQ (CHARWIDTH (CHARCODE i) FONT) (CHARWIDTH (CHARCODE W) FONT)) then (* ; "Font is not fixed width, so don't need this kludge when substituting fonts") (SETQ FONT NIL)) (for PAIR in CHARPAIRS collect (* ;; "Each entry is (oldchar newchar . fontspec), where fontspec is optional plist to give to FONTCOPY to get a font derived from current font to print the char. Here we copy each entry, preparing cache for font change entries") (LIST* (pop PAIR) (pop PAIR) PAIR (if FONT then (* ; "First oldfont-newfont pair designates a fixed-width font") (LIST FONT (CL:APPLY (FUNCTION FONTCOPY) FONT PAIR)) else (* ; "Just waste this fixed-width entry") (LIST NIL NIL)))))))) (if CHARPAIRS then (* ; "Yes, want translation") (replace (STREAM OUTCHARFN) of *STANDARD-OUTPUT* with (FUNCTION PFI.OUTCHARFN))))) ) (PFI.OUTCHARFN (LAMBDA (STREAM CHAR) (* ; "Edited 14-Apr-88 12:40 by bvm") (* ;; "Our own OUTCHARFN that does character translation.") (DESTRUCTURING-BIND (FN . CASES) *PFI-FUNNY-CHARS* (do (if (NULL CASES) then (* ; "Not funny, just do it regular") (if (AND (EQ CHAR (CHARCODE EOL)) *PFI-BITMAP-BASELINE*) then (* ; "End of line on a line where we have printed bitmaps below the baseline--make sure we terpri far enough") (if (AND *PFI-BITMAP-BASELINE* (< *PFI-BITMAP-BASELINE* (DSPYPOSITION NIL STREAM))) then (* ; "Could be false if new page in between") (MOVETO (DSPXPOSITION NIL STREAM) *PFI-BITMAP-BASELINE* STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL) (if (NULL (CDR *PFI-FUNNY-CHARS*)) then (* ; "We existed only for this kludge--restore normal outcharfn") (replace (STREAM OUTCHARFN) of STREAM with FN))) (RETURN (CL:FUNCALL FN STREAM CHAR)) elseif (EQ (CAAR CASES) CHAR) then (* ; "Yes, it's a special char") (RETURN (DESTRUCTURING-BIND (C . FONTINFO) (CDAR CASES) (if (NULL FONTINFO) then (* ; "Simple translation in this font") (CL:FUNCALL FN STREAM C) else (* ; "Want to use char from another font") (LET* ((FONT (DSPFONT NIL STREAM)) (NEWFONT (LISTGET (CDR FONTINFO) FONT)) EXTRASPACE) (if (NOT NEWFONT) then (* ; "Other font not cached yet. FONTINFO = (spec . fontplist), where SPEC is something to give to FONTCOPY to modify the current font.") (NCONC FONTINFO (LIST FONT (SETQ NEWFONT (CL:APPLY (FUNCTION FONTCOPY) FONT (CAR FONTINFO)))))) (DSPFONT NEWFONT STREAM) (if (AND (EQ FONT (CADR FONTINFO)) (> (SETQ EXTRASPACE (- (CHARWIDTH C FONT) (CHARWIDTH C NEWFONT))) 0)) then (* ; "We were in a fixed width font, but substitution is from a font where the char is narrower, so make some space to maintain the fixed-width illusion.") (RELMOVETO (IQUOTIENT EXTRASPACE 2) 0 STREAM) (CL:FUNCALL FN STREAM C) (RELMOVETO (- EXTRASPACE (IQUOTIENT EXTRASPACE 2)) 0 STREAM) else (CL:FUNCALL FN STREAM C)) (DSPFONT FONT STREAM))))) else (SETQ CASES (CDR CASES)))))) ) (PFI.COLLECT.DEFINERS (LAMBDA (KNOWNTYPES) (* ; "Edited 11-Apr-88 12:26 by bvm") (* ;; "Scan all the definers in the system, creating PFITYPE entries for them if they're not already in the entries in KNOWNTYPES (e.g., might want DEFMACRO to be MACROS not FUNCTIONS). Bunch of conditionals in here because between Lyric and Medley the prop names changed from IL symbols to keywords. *PFI-DEFINER-PROPS* = (:definer-for :defined-by :definition-name)") (for TYPE in FILEPKGTYPES bind (BYPROP _ (CADR *PFI-DEFINER-PROPS*)) (NAMEPROP _ (CADDR *PFI-DEFINER-PROPS*)) when (LITATOM TYPE) join (for DEFINER in (GET TYPE BYPROP) collect (create PFITYPE NAME _ TYPE PATTERNS _ DEFINER TESTFN _ (GET DEFINER NAMEPROP)) unless (for ENTRY in KNOWNTYPES thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))))) ) (PFI.AFTER.NEW.PAGE (LAMBDA (STREAM) (* ; "Edited 12-May-88 09:58 by bvm") (DECLARE (USEDFREE *PFI-TITLE* *PFI-ITEM* *PFI-PAGE-COUNT*)) (* ;; "Called after the output image stream has turned the page. Bump our page count and print a suitable header.") (add *PFI-PAGE-COUNT* 1) (if *PFI-TITLE* then (LET ((*PRINT-BASE* 10) (LEFT *PFI-TITLE*) (RIGHT) (OLDFONT (DSPFONT))) (CHANGEFONT DEFAULTFONT) (* ; "Get back to canonical font for the header, saving whatever font was in effect at the page turn") (if (EQ *PFI-ITEM* :INDEX) then (* ; "In the index, omit page numbers") (SETQ *PFI-ITEM* NIL) else (SETQ RIGHT (CONCAT *PFI-PAGE-PREFIX* *PFI-PAGE-COUNT*))) (if (AND *PFI-TWO-SIDED* (EVENP *PFI-PAGE-COUNT*)) then (* ; "On even pages, print page numbers on outside (left)") (swap LEFT RIGHT)) (if LEFT then (PRIN3 LEFT)) (if (AND *PFI-ITEM* (NEQ *PFI-ITEM* :INDEX)) then (printout NIL " (" .FONT BOLDFONT |.P2| *PFI-ITEM* .FONT ITALICFONT " cont." .FONT DEFAULTFONT ")")) (if RIGHT then (DSPXPOSITION (- (DSPRIGHTMARGIN) (STRINGWIDTH RIGHT STREAM))) (PRIN3 RIGHT)) (TERPRI) (TERPRI) (DSPFONT OLDFONT)))) ) ) (DEFINEQ (PFI.PRINT.FILECREATED (LAMBDA (EXPR ENV) (* ; "Edited 13-Apr-88 11:14 by bvm") (* ;; "Display the FILECREATED expression and environment prettily") (* ;; "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") (pop EXPR) (CHANGEFONT ITALICFONT) (LET* ((STRINGS (QUOTE ("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"))) (FONT (DSPFONT)) (STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT))) (TABSTOP (+ (DSPLEFTMARGIN) (APPLY (FUNCTION MAX) STRWIDTHS)))) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "File created:") (PRINTOUT NIL (pop EXPR) " " .FONT LAMBDAFONT (pop EXPR) T T) (* ; "date and file name") (if (OR (NULL (CAR EXPR)) (FIXP (CAR EXPR))) then (* ; "Skip over filemaploc") (pop EXPR)) (if (EQ (CAR EXPR) (QUOTE changes)) then (* ; "handle %"Changes to:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) T NIL T) (TERPRI) (TERPRI) else (pop STRINGS) (pop STRWIDTHS)) (if (EQ (CAR EXPR) (QUOTE previous)) then (* ; "Handle %"Previous date:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTOUT NIL (pop EXPR) " " (pop EXPR) T T) else (pop STRINGS) (pop STRWIDTHS)) (LET ((SPEC (fetch RESPEC of ENV))) (* ; "Show environment") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Read table") (PFI.PRINT.ENVIRONMENT SPEC :READTABLE) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Package") (PFI.PRINT.ENVIRONMENT SPEC :PACKAGE) (if (NEQ *PRINT-BASE* 10) then (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (PFI.PRINT.ENVIRONMENT SPEC :BASE))))) ) (PFI.PRINT.TO.TAB (LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT)) ) (PFI.PRINT.ENVIRONMENT (LAMBDA (SPEC KEYWORD) (* ; "Edited 29-Mar-88 12:46 by bvm") (* ;; "Display the KEYWORD component of a reader environment spec") (LET ((VALUE (LISTGET SPEC KEYWORD))) (if (LISTP VALUE) then (* ; "An expression to create it--show pretty. Use IL package, since that's what they appear in at beginning of file") (LET ((*PACKAGE* *INTERLISP-PACKAGE*)) (PRINTDEF VALUE T T)) else (* ; "Just show the value, sans quotations, etc. The selectq is just in case this environment has no spec, something that shouldn't happen if it came from a define-file-info") (PRIN3 (OR VALUE (SELECTQ KEYWORD (:READTABLE (READTABLEPROP *READTABLE* (QUOTE NAME))) (:PACKAGE (CL:PACKAGE-NAME *PACKAGE*)) (SHOULDNT))))) (TERPRI) (TERPRI))) ) ) (DEFINEQ (PFI.PROCESS.FILE (LAMBDA (DONTINDEX) (* ; "Edited 13-Apr-88 12:59 by bvm") (* ;; "The main loop for PRETTYFILEINDEX--process expressions on the file until we're done.") (bind CH FN EXPR while (SETQ CH (SKIPSEPRCODES)) do (if (EQ CH (CHARCODE ";")) then (PFI.PASS.COMMENT) elseif (AND DONTINDEX (EQ CH (CHARCODE "("))) then (* ;; "From SEE. Want to have a look at the car so we don't take a long time reading the WHOLE expression that we can easily process in pieces, like DEFINEQ") (READCCODE) (* ; "Eat the paren") (if (AND (NOT (SYNTAXP (SKIPSEPRCODES) (QUOTE RIGHTPAREN))) (LITATOM (SETQ FN (CL:READ))) (SETQ EXPR (ASSOC FN *PFI-PREVIEWERS*))) then (* ; "Next thing was a symbol, and we have a previewer for this kind of expression--do it. SYNTAXP is just in case we encountered ( ).") (if *PFI-PENDING-COMMENTS* then (* ; "First dispose of pending comments") (PFI.PRINT.COMMENTS)) (CL:FUNCALL (CDR EXPR) FN) else (* ; "Failed--fall back on reading the whole thing") (PFI.HANDLE.EXPR (CONS FN (CL:READ-DELIMITED-LIST #\))))) elseif (OR (EQ (SETQ EXPR (CL:READ *STANDARD-INPUT* NIL *STANDARD-INPUT*)) *STANDARD-INPUT*) (EQ EXPR (QUOTE STOP))) then (* ; "Hit end of file") (RETURN) else (PFI.HANDLE.EXPR EXPR)) (BLOCK))) ) (PFI.PASS.COMMENT (LAMBDA NIL (* ; "Edited 15-Apr-88 18:16 by bvm") (* ;; "Copy a semi-colon comment to the output stream") (TERPRI) (CHANGEFONT COMMENTFONT) (bind CH do (if (NEQ (SETQ CH (READCCODE *STANDARD-INPUT*)) (CHARCODE EOL)) then (* ; "Pass a character") (\OUTCHAR *STANDARD-OUTPUT* CH) else (TERPRI) (if (NEQ (PEEKCCODE *STANDARD-INPUT* T) (CHARCODE ";")) then (* ; "End of comment") (RETURN)))) (CHANGEFONT DEFAULTFONT)) ) (PFI.HANDLE.EXPR (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:56 by bvm") (* ;; "Prettyprint the expression we just read to the output file, and also do any appropriate indexing") (if (AND *PFI-PENDING-COMMENTS* (NEQ (CAR (LISTP EXPR)) COMMENTFLG)) then (* ; "Dispose of pending comments") (PFI.PRINT.COMMENTS EXPR)) (if (NLISTP EXPR) then (* ; "Not a form") (TERPRI) (PRINT EXPR) elseif (NOT (LITATOM (CAR EXPR))) then (* ; "Odd random form on file. I hope the car is actually a lambda expression") (TERPRI) (PFI.MAYBE.NEW.PAGE EXPR) (PFI.PRETTYPRINT EXPR NIL T) else (CL:FUNCALL (OR (CDR (ASSOC (CAR EXPR) *PFI-HANDLERS*)) (FUNCTION PFI.DEFAULT.HANDLER)) EXPR))) ) (PFI.DEFAULT.HANDLER (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:54 by bvm") (* ;; "The default handler for an expression. Looks up in *PFI-TYPES* for matching entries, then prettyprints the expression.") (LET ((CAR-OF-FORM (CAR EXPR)) PAT ITEMNAME MAINITEM TESTFN TEMPLATE) (if (GET CAR-OF-FORM (CAR *PFI-DEFINER-PROPS*)) then (* ; "Put a little extra space before definers") (TERPRI)) (PFI.MAYBE.NEW.PAGE EXPR) (SETQ TEMPLATE (GET CAR-OF-FORM :DEFINITION-PRINT-TEMPLATE)) (for ENTRY in *PFI-TYPES* when (COND ((EQ (SETQ PAT (fetch (PFITYPE PATTERNS) of ENTRY)) T) (* ; "Matches anything -- TESTFN must be doing all the work") T) ((LISTP PAT) (MEMB CAR-OF-FORM PAT)) (T (EQ CAR-OF-FORM PAT))) do (SETQ TESTFN (fetch (PFITYPE TESTFN) of ENTRY)) (COND ((NULL TESTFN) (* ; "Extract default name") (if (NLISTP (SETQ ITEMNAME (if (AND TEMPLATE (MEMB :NAME TEMPLATE)) then (* ; "We're told more explicitly where the name is") (CL:NTH (CL:POSITION :NAME TEMPLATE) (CDR EXPR)) else (* ; "Name defaultly is second elt") (CADR EXPR)))) then (if (AND ITEMNAME (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) elseif (EQ (CAR ITEMNAME) (QUOTE QUOTE)) then (* ; "A quoted form, like (I.S.OPR 'COLLECT ...)") (PFI.ADD.TO.INDEX (SETQ MAINITEM (CADR ITEMNAME)) ENTRY) elseif (AND (SETQ ITEMNAME (CAR ITEMNAME)) (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (* ; "Some definer that takes a (name . options) slot here") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY))) ((SETQ ITEMNAME (CAR (NLSETQ (CL:FUNCALL TESTFN EXPR ENTRY)))) (COND ((NLISTP ITEMNAME) (* ; "Single object to be indexed as the type in ENTRY") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) (T (* ; "Index as some other type") (for PAIR in (COND ((LITATOM (CAR ITEMNAME)) (* ; "a single pair") (LIST ITEMNAME)) (T (* ; "many") ITEMNAME)) do (for NAME in (CDR PAIR) do (push *PFI-LOCATIONS* (LIST (CAR PAIR) NAME *PFI-PAGE-COUNT*)))))) (COND ((NOT (fetch (PFITYPE AMBIGUOUS?) of ENTRY)) (RETURN)))))) (PFI.PRETTYPRINT EXPR MAINITEM T))) ) (PFI.PRETTYPRINT (LAMBDA (EXPR NAME FORMFLG) (* ; "Edited 7-Apr-88 11:06 by bvm") (* ;; "Prettyprints EXPR. NAME is the %"name%" of the thing being prettyprinted, for benefit of header hackers. FORMFLG is true if thing should be printed as code.") (LET ((*PFI-ITEM* NAME)) (PRINTDEF EXPR T FORMFLG NIL *PFI-FNSLST*)) (TERPRI)) ) (PFI.LINES.REMAINING (LAMBDA NIL (* ; "Edited 11-Apr-88 17:23 by bvm") (* ;; "Returns number of lines left on this page, or a large number if stream does not tell us") (LET ((BOTTOM (DSPBOTTOMMARGIN))) (if (NULL BOTTOM) then 999 else (ADD1 (IQUOTIENT (- (DSPYPOSITION) BOTTOM) (- (DSPLINEFEED NIL *STANDARD-OUTPUT*))))))) ) (PFI.MAYBE.NEW.PAGE (LAMBDA (EXPR MINLINES) (* ; "Edited 13-Apr-88 14:32 by bvm") (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") (LET (REMAINING) (if (OR (DISPLAYSTREAMP *STANDARD-OUTPUT*) (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) *PFI-MAX-WASTED-LINES*) (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR)))) then (TERPRI) else (* ; "put it on a new page") (DSPNEWPAGE)))) ) (PFI.ESTIMATE.SIZE (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:37 by bvm") (* ;; "Guess how many lines EXPR will take, so that we can try getting it all on one page if we're near the bottom. Heuristic is that after the first list element in any element, each subsequent element gets its own line") (+ (LET ((TEMPLATE (AND (LITATOM (CAR EXPR)) (GET (CAR EXPR) :DEFINITION-PRINT-TEMPLATE)))) (if (AND TEMPLATE (MEMB :BODY TEMPLATE)) then (* ; "Make extra space for things that have body") 2 else 1)) (PFI.ESTIMATE.SIZE1 EXPR 0))) ) (PFI.ESTIMATE.SIZE1 (LAMBDA (EXPR INITSUM) (* ; "Edited 13-Apr-88 11:24 by bvm") (* ;; "Recursive part of PFI.ESTIMATE.SIZE's heuristic. We add on to INITSUM, and stop when it looks pointless to dive deeper. Heuristic says we have a new line every time there's a list element with something after it.") (if (LISTP EXPR) then (LET ((TAIL (SOME EXPR (FUNCTION LISTP)))) (add INITSUM (LENGTH (CDR TAIL))) (until (OR (NLISTP TAIL) (> INITSUM *PFI-MAX-WASTED-LINES*)) do (SETQ INITSUM (PFI.ESTIMATE.SIZE1 (pop TAIL) INITSUM))))) INITSUM) ) ) (* ; "Expression handlers") (DEFINEQ (PFI.HANDLE.RPAQQ (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET* ((NAME (CADR EXPR)) (COMSINFO (ASSOC NAME *PFI-FILEVARS*))) (COND ((AND COMSINFO (EQ (CDR COMSINFO) (QUOTE NOBIND))) (* ; "We don't yet know the value of this filevar, so here it is.") (RPLACD COMSINFO (CADDR EXPR)) (LET ((*MAINFILECOMS* (CDAR *PFI-FILEVARS*)) VARS VALUES) (* ;; "*PFI-FILEVARS* is an alist of (filevar . value), for all filevars we've discovered so far and any values of same. Since we have newly discovered the value of this var, the INFILECOMS? below may have changed some, so reevaluate them.") (for PAIR in (CDR *PFI-FILEVARS*) unless (EQ (CDR PAIR) (QUOTE NOBIND)) do (push VARS (CAR PAIR)) (push VALUES (CDR PAIR))) (CL:PROGV VARS VALUES (SETQ *PFI-FNSLST* (APPEND (INFILECOMS? NIL (QUOTE FNS) *MAINFILECOMS*) (INFILECOMS? NIL (QUOTE FUNCTIONS) *MAINFILECOMS*))) (for FV in (INFILECOMS? NIL (QUOTE FILEVARS) *MAINFILECOMS*) unless (OR (ASSOC FV *PFI-FILEVARS*) (BOUNDP FV)) do (* ;; "Add to the list any new filevars uncovered by this evaluation. Don't bother if they're already bound in the sysout, since then their values have already been made use of.") (push (CDR *PFI-FILEVARS*) (CONS FV (QUOTE NOBIND)))))))) (if (NEQ NAME (CAAR *PFI-FILEVARS*)) then (* ; "Don't bother indexing the main COMS") (PFI.ADD.TO.INDEX NAME (QUOTE VARIABLES))) (PFI.PRETTYPRINT EXPR NAME))) ) (PFI.HANDLE.DECLARE (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:33 by bvm") (* ;; "Handle (DECLARE: tags coms ...)") (if (NOT (LET ((TAIL (CDR EXPR))) (* ;; "Filter out (DECLARE: DONTCOPY (FILEMAP --))") (AND (LISTP TAIL) (EQ (pop TAIL) (QUOTE DONTCOPY)) (LISTP TAIL) (EQ (CAR (LISTP (pop TAIL))) (QUOTE FILEMAP)) (NULL TAIL)))) then (TERPRI) (PRIN1 "(") (PROG (STARTOFLINE NEXT) TOP (SETQ STARTOFLINE T) NEXTITEM (if (NLISTP EXPR) then (* ; "Done, except for possible malformed dotted tail") (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI) (RETURN)) (if (NLISTP (SETQ NEXT (pop EXPR))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) (GO NEXTITEM)) (* ;; "Have an interesting com, so go to new line and process it") (TERPRI) (do (PFI.HANDLE.EXPR NEXT) repeatwhile (AND (LISTP EXPR) (LISTP (SETQ NEXT (pop EXPR))))) (GO TOP)))) ) (PFI.HANDLE.EVAL-WHEN (LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:51 by bvm") (* ;; "Handle EVAL-WHEN. This is a lot like DECLARE: -- the inner expressions get treated as top-level.") (PFI.MAYBE.NEW.PAGE NIL (+ 2 (PFI.ESTIMATE.SIZE (CADDR EXPR)))) (* ; "Make space for the first expression, plus the eval-when & .. line") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (PRINT (pop EXPR)) (while (LISTP EXPR) do (PFI.HANDLE.EXPR (pop EXPR))) (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI)) ) (PFI.HANDLE.DEFDEFINER (LAMBDA (EXPR) (* ; "Edited 12-Apr-88 11:16 by bvm") (* ;; "Notice DEFDEFINER expressions. We don't actually evaluate them (let's not side-effect the environment too much), but notice that we should index them and that they should prettyprint interestingly.") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((DEFINER (CADR EXPR)) OPTIONS) (if (LISTP DEFINER) then (SETQ OPTIONS (CDR DEFINER)) (SETQ DEFINER (CAR DEFINER))) (if (NOT (LITATOM DEFINER)) then (* ; "Bogus") (SETQ DEFINER NIL) elseif *PFI-TYPES* then (* ; "We're indexing, maybe add this type") (if (NOT (for ENTRY in *PFI-TYPES* thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))) then (* ; "We don't know about this one yet") (push *PFI-TYPES* (create PFITYPE NAME _ (CADDR EXPR) PATTERNS _ DEFINER TESTFN _ (CADR (ASSOC :NAME OPTIONS))))) (if (NOT (ASSOC DEFINER PRETTYPRINTMACROS)) then (* ; "Help it prettyprint better") (push PRETTYPRINTMACROS (CONS DEFINER (CL:INTERN "PPRINT-DEFINER" (CL:FIND-PACKAGE (if (EQ MAKESYSNAME :LYRIC) then "IL" else "XCL"))))) (if (AND (SETQ OPTIONS (ASSOC :TEMPLATE OPTIONS)) (NOT (GET DEFINER :DEFINITION-PRINT-TEMPLATE))) then (PUT DEFINER :DEFINITION-PRINT-TEMPLATE (CADR OPTIONS)))) (PFI.ADD.TO.INDEX DEFINER (QUOTE DEFINERS))) (PFI.PRETTYPRINT EXPR DEFINER T))) ) (PFI.HANDLE.DEFINEQ (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:34 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...)") (TERPRI) (PRIN1 "(") (PRINT (CAR EXPR)) (for DEF in (CDR EXPR) do (PFI.PRINT.LAMBDA DEF)) (PRIN1 ")") (TERPRI)) ) (PFI.PRINT.LAMBDA (LAMBDA (DEF) (* ; "Edited 11-Apr-88 17:21 by bvm") (* ;; "Print one piece of a DEFINEQ. DEF is (fn (lambda ...)).") (PFI.MAYBE.NEW.PAGE NIL (PFI.ESTIMATE.SIZE1 (CDR DEF) 3)) (LET ((*PFI-ITEM* (CAR DEF))) (PFI.ADD.TO.INDEX *PFI-ITEM* (QUOTE FUNCTIONS)) (PFI.PRINT.LAMBDA.BODY DEF *PFI-FNSLST*)) (TERPRI) (TERPRI)) ) (PFI.PRINT.LAMBDA.BODY (LAMBDA (DEF FNSLST) (* ; "Edited 29-Mar-88 18:46 by bvm") (* ;; "Just the stuff that prints a lambda form. DEF = (name (lambda ...))") (PRIN1 "(") (CHANGEFONT (OR LAMBDAFONT BOLDFONT)) (PRIN2 (CAR DEF)) (CHANGEFONT DEFAULTFONT) (TERPRI) (SPACES 2) (PRINTDEF (CDR DEF) T (QUOTE FNS) T FNSLST) (PRIN1 ")")) ) (PFI.HANDLE.PUTDEF (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:10 by bvm") (* ;; "Called to handle PUTDEF. If in form (PUTDEF 'name 'type 'value), we can index name by type.") (PFI.MAYBE.NEW.PAGE EXPR) (DESTRUCTURING-BIND (NAME TYPE) EXPR (PFI.PRETTYPRINT EXPR (if (AND (LISTP NAME) (EQ (CAR NAME) (QUOTE QUOTE)) (LISTP TYPE) (EQ (CAR TYPE) (QUOTE QUOTE)) (LITATOM (SETQ TYPE (CADR TYPE)))) then (PFI.ADD.TO.INDEX (SETQ NAME (CADR NAME)) TYPE) (* ; "Yes, it is a quoted form we like") NAME)))) ) (PFI.HANDLE.PUTPROPS (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((NAME (CADR EXPR)) (PROP (CADDR EXPR)) TYPE) (* ; "See if PROP means something more specific than 'property'") (PFI.PRETTYPRINT EXPR (if (AND (LITATOM NAME) (SETQ TYPE (COND ((MEMB PROP MACROPROPS) (QUOTE MACRO)) (T (for PAIR in *PFI-PROPERTIES* when (EQ (CAR PAIR) PROP) do (* ; "Index it under this other type") (RETURN (CADR PAIR)) finally (* ; "Nothing better, so index it as having a property") (RETURN (QUOTE PROPERTY))))))) then (PFI.ADD.TO.INDEX NAME TYPE) (* ; "Yes, can name it this") NAME)))) ) (PFI.HANDLE./DECLAREDATATYPE (LAMBDA (EXPR) (* ; "Edited 13-Apr-88 11:29 by bvm") (* ;; "No point in wasting space printing the entirely redundant list of field descriptors from (/DECLAREDATATYPE typename fieldspecs fielddescriptors len supertype)") (PFI.MAYBE.NEW.PAGE EXPR 2) (PFI.PRETTYPRINT (if (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR)))))) then (* ; "Well-formed--bash the third argument") (LIST* (pop EXPR) (pop EXPR) (pop EXPR) (LIST (QUOTE *) (QUOTE ;;) "---field descriptor list elided by lister---") (CDR EXPR)) else EXPR) NIL T)) ) (PFI.HANDLE.* (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:38 by bvm") (* ;; "Handle * comments found at top level. Turn single-semis into double semis so that they print at the left. Save all comments until the next non-comment so we can achieve some locality.") (LET* ((NSEMIS (SEMI-COLON-COMMENT-P EXPR)) (LINEGUESS (+ (CL:CEILING (STRINGWIDTH (if NSEMIS then (CADDR EXPR) else (CDR EXPR)) *STANDARD-OUTPUT*) (TIMES (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) 0.9)) (if (AND NSEMIS (< NSEMIS 3)) then 1 else 2)))) (CASE NSEMIS (1 (* ; "Make it 2 semis") (SETQ EXPR (LIST* (QUOTE *) (QUOTE ;;) (CDDR EXPR)))) ((NIL) (* ; "Interlisp style") (if (NLISTP (CDR EXPR)) elseif (AND (NULL (CDDR EXPR)) (STRINGP (CADR EXPR))) then (* ; "Body is a string, so can print with superior semi-colon printer") (SETQ EXPR (LIST (QUOTE *) (QUOTE ;;) (CADR EXPR))) elseif (NEQ (CADR EXPR) COMMENTFLG) then (* ; "Turn single * into double star so it prints centered") (SETQ EXPR (LIST* (QUOTE *) (QUOTE *) (CDR EXPR)))))) (* ;; "Now don't print the comment yet, since we'd like it to attach to what follows") (if *PFI-PENDING-COMMENTS* then (add (CAR *PFI-PENDING-COMMENTS*) LINEGUESS) (NCONC1 *PFI-PENDING-COMMENTS* EXPR) else (SETQ *PFI-PENDING-COMMENTS* (LIST LINEGUESS EXPR))))) ) (PFI.PRINT.COMMENTS (LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:27 by bvm") (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") (TERPRI) (DESTRUCTURING-BIND (LINES . BODIES) *PFI-PENDING-COMMENTS* (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (LET ((REMAINING (PFI.LINES.REMAINING))) (if (OR (>= LINES REMAINING) (AND (< REMAINING *PFI-MAX-WASTED-LINES*) (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) LINES)))) then (* ; "put it on a new page") (DSPNEWPAGE)))) (for B in BODIES do (PRINTDEF B T T) (if (> (DSPXPOSITION) (DSPLEFTMARGIN)) then (* ; "Go to new line for next comment. Usually this has already been done") (TERPRI))) (SETQ *PFI-PENDING-COMMENTS* NIL))) ) (PFI.HANDLE.FILEMAP (LAMBDA (EXPR) (* ; "Edited 31-Mar-88 15:28 by bvm") (* ;; "Only get here from declare: previewer (during SEE), since declare: expression handler filters out the whole thing.") (PFI.PRETTYPRINT (LIST (QUOTE *) (QUOTE ;;) "---Filemap elided by lister---") NIL T)) ) (PFI.HANDLE.PACKAGE (LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:38 by bvm") (* ;; "Handler for package-related functions, such as in-package, import, export, etc. Eval the form so that the package environment is set correctly for what follows.") (CL:EVAL EXPR) (TERPRI) (PFI.PRETTYPRINT EXPR NIL T)) ) ) (* ; "Previewers") (DEFINEQ (PFI.PREVIEW.DECLARE (LAMBDA (FN) (* ; "Edited 1-Apr-88 11:27 by bvm") (* ;; "Handle (DECLARE: tags coms ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRIN2 FN) (bind STARTOFLINE NEXT until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (if (NLISTP (SETQ NEXT (READ))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) else (* ; "Have an interesting com") (if (NOT STARTOFLINE) then (TERPRI) (* ; "Start expressions on new line") (SETQ STARTOFLINE T)) (PFI.HANDLE.EXPR NEXT)) finally (READCCODE) (* ; "Eat the closing paren") (PRIN1 ")") (TERPRI))) ) (PFI.PREVIEW.DEFINEQ (LAMBDA (FN) (* ; "Edited 8-Apr-88 16:38 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRINT FN) (until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (PFI.PRINT.LAMBDA (READ))) (READCCODE) (* ; "Consume the paren") (PRIN1 ")") (TERPRI)) ) ) (* ; "Printing the index") (DEFINEQ (PFI.PRINT.INDEX (LAMBDA (CRDATE) (* ; "Edited 16-May-88 15:48 by bvm") (* ;; "Compute the indices from the entries we have accumulated, print them, and return them (for multifileindex)") (LET ((LASTPAGE *PFI-PAGE-COUNT*) (*PFI-ITEM* :INDEX)) (LET ((*PFI-TITLE* NIL)) (* ; "Leave off the heading on the first index page, since it is intended to be the cover page--will have the title centered.") (DSPNEWPAGE) (COND ((AND *PFI-TWO-SIDED* (ODDP LASTPAGE)) (* ; "Ensure that the index will not be on the back-side of a two-sided listing") (DSPNEWPAGE)))) (PROGN (* ; "Print title.") (PFI.CENTER.PRINT (LIST *PFI-TITLE* CRDATE) T) (PFI.CENTER.PRINT (CONCAT "-- Listed on " (DATE) " --"))) (LET ((LINESPERPAGE (PFI.LINES.REMAINING)) (INDICES (PFI.CONDENSE.INDEX *PFI-LOCATIONS* LASTPAGE))) (PFI.PRINT.INDICES (APPEND INDICES) LINESPERPAGE) INDICES))) ) (PFI.CONDENSE.INDEX (LAMBDA (TRIPLES LASTPAGE) (* ; "Edited 12-May-88 13:07 by bvm") (* ;; "Condense TRIPLES into a set of indices, one per type. Each element is of the form (type name page), while the resulting indices are of the form (type entries . shape), with each entry looking like (name . pagenumbers). LASTPAGE is maximum page number (for gauging space).") (LET (*PFI-INDEX-ALIST* INDEX OLDNAME) (* ; "*PFI-INDEX-ALIST* is special so filters can look up entries") (for TRIP in TRIPLES do (* ; "Distribute to the correct type") (COND ((NULL (SETQ INDEX (ASSOC (CAR TRIP) *PFI-INDEX-ALIST*))) (push *PFI-INDEX-ALIST* (SETQ INDEX (LIST (CAR TRIP)))))) (COND ((SETQ OLDNAME (ASSOC (CADR TRIP) INDEX)) (* ; "Duplicate entry, so add a page number") (RPLACD OLDNAME (SORT (UNION (CDDR TRIP) (CDR OLDNAME))))) (T (push (CDR INDEX) (CDR TRIP))))) (* ;; "Now remove redundancies") (for TYPEPAIR in *PFI-INDEX-ALIST* bind FILTERS when (SETQ FILTERS (for FILTER in *PFI-FILTERS* collect (CDR FILTER) when (EQ (CAR FILTER) (CAR TYPEPAIR)))) do (* ; "Each filter is either a type name or a list whose car is a function") (RPLACD TYPEPAIR (for PAIR in (CDR TYPEPAIR) collect PAIR unless (for F in FILTERS thereis (COND ((NLISTP F) (* ; "Name exists as another type") (PFI.LOOKUP.NAME (CAR PAIR) F)) (T (CL:FUNCALL (CAR F) PAIR))))))) (PFI.SORT.INDICES (for TYPEPAIR in *PFI-INDEX-ALIST* when (CDR TYPEPAIR) collect (* ;; "Sort them and lay them out, changing format to (type entries . shape). Shape = (#rows #columns colwidth). WHEN is because filters could have removed everyone from a type.") (RPLACD TYPEPAIR (CONS (SORT (CDR TYPEPAIR) (FUNCTION (LAMBDA (X Y) (* ; "Sort case-insensitively by CAR") (ALPHORDER (CAR X) (CAR Y) UPPERCASEARRAY)))) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) LASTPAGE))))))) ) (PFI.SORT.INDICES (LAMBDA (INDICES) (* ; "Edited 12-May-88 12:37 by bvm") (* ;; "INDICES is a list of (TYPE INDEXPAIRS . SHAPE). Sort them into a preferred order of printing.") (if (NULL (CDR INDICES)) then INDICES else (LET ((RESULT (for X in INDICES bind PRIORITY when (SETQ PRIORITY (CL:POSITION (CAR X) *PFI-INDEX-ORDER*)) collect (* ; "Gather up the types that the user-specified order handles") (CONS PRIORITY X)))) (if RESULT then (* ; "Sort them by priority") (SETQ RESULT (MAPCAR (SORT RESULT (FUNCTION (LAMBDA (X Y) (< (CAR X) (CAR Y))))) (FUNCTION CDR))) (* ; "Then remove them from the master list") (SETQ INDICES (CL:SET-DIFFERENCE INDICES RESULT))) (* ;; "Finally, sort remaining indices by decreasing size to facilitate indexer's selection. Leave a marker in between so we can tell the difference between required order and optional.") (NCONC RESULT (LIST T) (SORT INDICES (FUNCTION (LAMBDA (X Y) (LET ((ROWDIF (- (CADDR X) (CADDR Y)))) (if (> ROWDIF 0) then (* ; "X has more rows than Y") T elseif (EQ ROWDIF 0) then (* ; "If same number of rows, go for more items") (> (LENGTH (CADR X)) (LENGTH (CADR Y)))))))))))) ) (PFI.COMPUTE.INDEX.SHAPE (LAMBDA (INDEXPAIRS MAXINDEXNO) (* ; "Edited 11-May-88 19:06 by bvm") (* ;; "Figures out how to lay out INDEXPAIRS, given that the largest possible page number is MAXINDEXNO. Returns a list (nrows ncolumns colwidth).") (LET ((INDEXNOWIDTH (AND MAXINDEXNO (COND ((< MAXINDEXNO 10) 1) ((< MAXINDEXNO 100) 2) (T (NCHARS MAXINDEXNO))))) (INDEXLEN (LENGTH INDEXPAIRS)) NROWS NCOLUMNS WIDTH) (SETQ WIDTH (+ (for PAIR in INDEXPAIRS largest (+ (NCHARS (CAR PAIR) T) (COND ((CDDR PAIR) (* ;; "Multiple page nos--turn into printed rep") (PROG1 (NCHARS (CAR (RPLACA (CDR PAIR) (CONCATLIST (CDR (for P in (CDR PAIR) join (LIST "," P))))))) (RPLACD (CDR PAIR) NIL))) ((STRINGP (CADR PAIR)) (* ; "It's already a string") (NCHARS (CADR PAIR))) (T INDEXNOWIDTH))) finally (RETURN $$EXTREME)) 1)) (* ; "WIDTH is the widest any entry gets: name plus page numbers. Conservative in that we assume page numbers can take up as much space as the largest") (SETQ NCOLUMNS (MAX 1 (MIN INDEXLEN (IQUOTIENT (LINELENGTH) (+ WIDTH 2))))) (* ; "Number of columns that fit if you allow 2 spaces between columns") (SETQ NROWS (CL:CEILING INDEXLEN NCOLUMNS)) (* ;; "Finally recompute NCOLUMNS. This might reduce the number of columns if all the items, printed in NROWS rows, take fewer columns than originally allocated. E.g. 11 items in 5 cols take 3 rows, but in 3 rows you only need 4 cols to print 11 items.") (LIST NROWS (CL:CEILING INDEXLEN NROWS) WIDTH))) ) (PFI.PRINT.INDICES (LAMBDA (INDICES LINESPERPAGE) (* ; "Edited 16-May-88 15:45 by bvm") (* ;; "Print a set of INDICES. LINESPERPAGE is number of lines we expect to fit per page not counting page headers.") (PROG ((HALFPAGE (IQUOTIENT LINESPERPAGE 2)) (LINELEN (LINELENGTH)) (SPACEWIDTH (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) (LINESREMAINING (- (PFI.LINES.REMAINING) 2)) ITEM FREECHOICE PREVITEM) NEWPAGE (* ;; "At this point we are at the top of a page") (TERPRI) (PFI.INDEX.BREAK) TOP (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (NULL FREECHOICE) then (* ; "Have to take the first batch in order") (SETQ ITEM (pop INDICES)) (if (EQ ITEM T) then (* ; "Marks start of optional order. Items from here on are sorted by decreasing size, but we can print them in any order we want") (SETQ FREECHOICE T) (GO TOP)) elseif (SETQ ITEM (find X in INDICES suchthat (<= (CADDR X) (- LINESREMAINING 5)))) then (* ; "Found an item that fits") (SETQ INDICES (DREMOVE ITEM INDICES)) elseif (OR (> LINESREMAINING HALFPAGE) (> (+ (CADDR (CAR (LAST INDICES))) 7) LINESPERPAGE)) then (* ; "Print something here anyway, since we're either less than halfway down the page, or the smallest index doesn't fit on a page") (SETQ ITEM (pop INDICES)) else (* ; "Start a new page and try again") (GO STARTNEWPAGE)) (DESTRUCTURING-BIND (TYPE INDEXPAIRS NROWS NCOLUMNS COLWIDTH) ITEM (PROG ((NROWSREMAINING NROWS) LASTITEM SPACING) (if (AND (EQ NROWS 1) PREVITEM (<= COLWIDTH (CADR PREVITEM)) (<= NCOLUMNS (CAR PREVITEM))) then (* ; "There's only one row, so it would be nice if it could line up with another index. Can do this if this column width is not larger than previous. PREVITEM = (ncolumns colwidth spacing ...)") (SETQ COLWIDTH (CADR PREVITEM)) (SETQ SPACING (CADDR PREVITEM)) else (LET ((NC NCOLUMNS)) (if (OR (NEQ NC 1) (if (< COLWIDTH (IQUOTIENT LINELEN 2)) then (* ; "format as if 2 columns") (SETQ NC 2) else (* ; "Too wide for 2 columns, so use whole width") (SETQ COLWIDTH LINELEN) (SETQ SPACING 0) NIL)) then (* ; "Divide the excess space up between dots and intercolumn spacing") (SETQ COLWIDTH (MIN (PROGN (* ; "Add to COLWIDTH half the excess space") (+ COLWIDTH (IQUOTIENT (- LINELEN (TIMES (+ COLWIDTH 2) NC)) 2))) (PROGN (* ; "Allow 2 spaces between columns") (- (IQUOTIENT LINELEN NC) 2)))) (SETQ SPACING (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN) (TIMES COLWIDTH NC SPACEWIDTH)) (SUB1 NC)))) (SETQ PREVITEM (LIST NC COLWIDTH SPACING)))) (if (AND (> (+ NROWS 5) LINESREMAINING) (< LINESREMAINING HALFPAGE) (<= (+ NROWS 8) LINESPERPAGE)) then (* ;; "This index doesn't fit on the page, we've filled less than half the page, and the index would fit starting on a new page. Each index takes 5 additional lines: blank, heading, blank blank breakline. If on a new page it would take 3 more (blank breakline blank).") (DSPNEWPAGE) (* ; "Start new page") (TERPRI) (* ; "Make top breaklines line up on all index pages") (PFI.INDEX.BREAK) (SETQ LINESREMAINING (- LINESPERPAGE 2))) (TERPRI) (PFI.CENTER.PRINT (CONCAT (if (AND (EQ (NTHCHARCODE TYPE -1) (CHARCODE S)) (NEQ (NTHCHARCODE TYPE -2) (CHARCODE S)) (NOT (STRPOS "IE" TYPE -3))) then (* ; "Turn plural type into singular. Second clause filters out DROSS and CANDIES.") (SUBSTRING TYPE 1 -2) else TYPE) " INDEX") T) (CHANGEFONT DEFAULTFONT) (TERPRI) (SETQ LINESREMAINING (- LINESREMAINING 3)) (while INDEXPAIRS do (SETQ NROWS (IMIN NROWSREMAINING (- LINESREMAINING 1))) (for ROW from 1 to NROWS bind NEXTINDEX do (SETQ NEXTINDEX ROW) (for COLUMN from 1 to NCOLUMNS do (COND ((SETQ LASTITEM (FNTH INDEXPAIRS NEXTINDEX)) (DESTRUCTURING-BIND (LABEL PAGENO) (CAR LASTITEM) (PRIN2 LABEL) (SPACES 1) (FRPTQ (- COLWIDTH (ADD1 (NCHARS LABEL T)) (NCHARS PAGENO)) (\OUTCHAR *STANDARD-OUTPUT* (CHARCODE %.))) (PRIN1 PAGENO) (COND ((NEQ COLUMN NCOLUMNS) (RELMOVETO SPACING 0)))))) (add NEXTINDEX NROWS)) (TERPRI)) (COND ((SETQ INDEXPAIRS (CDR LASTITEM)) (DSPNEWPAGE) (TERPRI) (SETQ LINESREMAINING (- LINESPERPAGE 1)) (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) NCOLUMNS)))) (T (SETQ LINESREMAINING (- LINESREMAINING NROWS))))) (TERPRI) (PFI.INDEX.BREAK T) (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (< (SETQ LINESREMAINING (- LINESREMAINING 2)) 6) then (* ; "No room left here, go to new page. ") (GO STARTNEWPAGE) else (* ; "T in PFI.INDEX.BREAK told it to hold the terpri") (TERPRI)))) (GO TOP) STARTNEWPAGE (DSPNEWPAGE) (SETQ LINESREMAINING (- LINESPERPAGE 2)) (* ; "Account for the break line and blank line we are about to print") (GO NEWPAGE))) ) (PFI.CENTER.PRINT (LAMBDA (STR BOLDFLG) (* ; "Edited 30-Mar-88 14:31 by bvm") (LET ((LMAR (DSPLEFTMARGIN)) GAP) (if BOLDFLG then (CHANGEFONT BOLDFONT)) (DSPXPOSITION (+ LMAR (IQUOTIENT (- (DSPRIGHTMARGIN) LMAR (if (LISTP STR) then (+ (TIMES (SUB1 (LENGTH STR)) (SETQ GAP (TIMES (DSPSCALE) 16))) (for X in STR sum (STRINGWIDTH X *STANDARD-OUTPUT*))) else (STRINGWIDTH STR *STANDARD-OUTPUT*))) 2))) (if (LISTP STR) then (for TAIL on STR do (PRIN3 (CAR TAIL)) (AND (CDR TAIL) (RELMOVETO GAP 0))) else (PRIN3 STR)) (if BOLDFLG then (CHANGEFONT DEFAULTFONT)) (TERPRI))) ) (PFI.INDEX.BREAK (LAMBDA (NOTERPRI) (* ; "Edited 11-Apr-88 16:47 by bvm") (* ;; "Draw the line separating one type index from the next. NOTERPRI suppresses the new line") (LET* ((OLDY (DSPYPOSITION)) (Y (+ (- OLDY (FONTPROP *STANDARD-OUTPUT* (QUOTE DESCENT))) (IQUOTIENT (- (DSPLINEFEED)) 2)))) (* ; "Draw a horizontal line centered on this line") (DRAWLINE (DSPLEFTMARGIN) Y (DSPRIGHTMARGIN) Y (DSPSCALE)) (DSPYPOSITION OLDY)) (OR NOTERPRI (TERPRI))) ) (PFI.LOOKUP.NAME (LAMBDA (NAME TYPE) (* ; "Edited 25-Mar-88 14:07 by bvm") (ASSOC NAME (CDR (ASSOC TYPE *PFI-INDEX-ALIST*)))) ) ) (DEFINEQ (PFI.ADD.TO.INDEX (LAMBDA (NAME TYPE/ENTRY) (* ; "Edited 6-Apr-88 16:15 by bvm") (* ;; "Add to the index an entry for NAME of type TYPE/ENTRY. TYPE/ENTRY can be an element of *pfi-types*, in which case we use its type name component.") (if (NEQ *PFI-LOCATIONS* :NONE) then (push *PFI-LOCATIONS* (LIST (if (NLISTP TYPE/ENTRY) then (* ; "the type directly") TYPE/ENTRY else (* ; "a types triple") (LET ((TYPE (fetch (PFITYPE NAME) of TYPE/ENTRY))) (OR (CAR (LISTP TYPE)) TYPE))) NAME *PFI-PAGE-COUNT*)))) ) (PFI.VARNAME (LAMBDA (EXPR) (* ; "Edited 24-Mar-88 16:09 by bvm") (* ;;; "Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR. Filters after the fact will remove duplications with other variable types") (LET ((NAME (CADR EXPR))) (* ; "Ignore compiler-internal vars") (AND (LITATOM NAME) (NEQ NAME T) (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA)))) NAME))) ) (PFI.CONSTANTNAMES (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 14:24 by bvm") (* ;;; "Called when expression is (CONSTANTS --) -- return all elements (or CAR of element when it's a pair) as type CONSTANTS") (CONS (QUOTE CONSTANTS) (for X in (CDR EXPR) collect (COND ((LISTP X) (CAR X)) (T X))))) ) ) (* ; "Combined listings") (DEFINEQ (MULTIFILEINDEX (LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 20-May-88 14:08 by bvm") (* ;; "Produce a pretty file index listing for each of FILES, plus a master index for the set") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (SETQ FILES (for F inside FILES join (if (STRPOS "*" F) then (* ; "Enumerate a pattern--default extension to null and version to highest") (DIRECTORY (DIRECTORY.FILL.PATTERN F "" "")) elseif (LISTP F) then (* ; "Hack that says don't print these") (for FL in F collect (LIST (OR (FINDFILE FL T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FL)))) else (LIST (OR (FINDFILE F T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME F)))))) (COND (*PFI-DONT-SPAWN* (MULTIFILEINDEX1 FILES PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MULTIFILEINDEX1) FILES PRINTOPTIONS)) FILES)))) ) (MULTIFILEINDEX1 (LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 19-May-88 12:35 by bvm") (* ;; "Pretty list each of the files in FILES, followed by master index") (LET ((CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) INDICES OPTIONS NOTPRINTED) (SETQ PRINTOPTIONS (LIST* (QUOTE MULTIFILEINDEX) T PRINTOPTIONS)) (* ; "Our own option") (for TAIL on FILES as I from 1 do (* ; "Print and gather indices for all but last file") (SETQ OPTIONS (if CONSECUTIVE then (* ; "Tell it which page to start on") (LIST* :FIRSTPAGE (if INDICES then (* ; "One past the end of the last one") (ADD1 (CADDR (CAAR INDICES))) else 1) PRINTOPTIONS) else (* ; "Tell it which part to work on") (LIST* :PART I PRINTOPTIONS))) (push INDICES (if (SETQ NOTPRINTED (LISTP (CAR TAIL))) then (* ; "Go thru the motions but don't print it") (PRETTYFILEINDEX (CAAR TAIL) (LIST* :DONTPRINT T OPTIONS)) else (if (NULL (CDR TAIL)) then (* ; "When printing last file, send along all the indices for a combined listing") (RPLACA (CDR PRINTOPTIONS) (REVERSE INDICES))) (PRETTYFILEINDEX (CAR TAIL) OPTIONS)))) (IF NOTPRINTED THEN (* ; "The last file wasn't printed, so have to make index on our own") (LET* ((*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS (QUOTE %#SIDES)) EMPRESS#SIDES) 2)) (*STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM (LIST* (QUOTE DOCUMENT.NAME) (QUOTE INDEX) PRINTOPTIONS)))) (CL:UNWIND-PROTECT (PFI.PRINT.MULTI.INDEX (REVERSE INDICES) PRINTOPTIONS) (CLOSEF *STANDARD-OUTPUT*)))))) ) (PFI.PRINT.MULTI.INDEX (LAMBDA (INDEXENTRIES PRINTOPTIONS) (* ; "Edited 19-May-88 17:37 by bvm") (* ;; "Print the master index for a set of indexed files. INDEXENTRIES has one element per file, each of the form ((filename creationdate lastpage# env) . indices), the indices having come out of PFI.PRINT.INDEX") (LET ((MAXNAME 0) (MAXDATE 0) (CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) (ENV (LISTGET PRINTOPTIONS :ENVIRONMENT)) BESTPACKAGE BESTREADTABLE MAXPAGE# MASTERINDICES LINESPERPAGE NAMES&DATES) (STREAMPROP *STANDARD-OUTPUT* (QUOTE AFTERNEWPAGEFN) NIL) (* ; "No more header hacking") (IF (NEQ (LISTGET PRINTOPTIONS (QUOTE MULTIFILEINDEX)) T) THEN (* ; "If it was T, then we must be called from MULTFILEINDEX1 to print only the index, so are on the first page right now.") (DSPNEWPAGE) (* ; "Start a new page") (if (AND *PFI-TWO-SIDED* (ODDP *PFI-PAGE-COUNT*)) then (* ; "Ensure that the master index will not be on the back-side of a two-sided listing") (DSPNEWPAGE))) (SETQ LINESPERPAGE (PFI.LINES.REMAINING)) (PFI.CENTER.PRINT (CONCAT "Master index generated on " (DATE (DATEFORMAT NO.SECONDS)))) (TERPRI) (CHANGEFONT BOLDFONT) (for PAIR in INDEXENTRIES as I from 1 bind PREFIX MASTERENTRY FILEINFO E TEM do (push NAMES&DATES (SETQ FILEINFO (CAR PAIR))) (* ; "FILEINFO = (name date last# env)") (SETQ MAXNAME (MAX MAXNAME (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXDATE (MAX MAXDATE (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXPAGE# (POP FILEINFO)) (if (NOT ENV) then (SETQ E (CAR FILEINFO)) (if (SETQ TEM (ASSOC (fetch REPACKAGE of E) BESTPACKAGE)) then (add (CDR TEM) 1) else (push BESTPACKAGE (CONS (fetch REPACKAGE of E) 1))) (if (SETQ TEM (ASSOC (fetch REREADTABLE of E) BESTREADTABLE)) then (add (CDR TEM) 1) else (push BESTREADTABLE (CONS (fetch REREADTABLE of E) 1)))) (if (NOT CONSECUTIVE) then (* ; "This gets in front of all page#s") (SETQ PREFIX (CONCAT I "-"))) (for INDEX in (CDR PAIR) unless (EQ INDEX T) do (* ; "INDEX = (type pairs . shape). T is a separator that we no longer care about.") (if (NOT CONSECUTIVE) then (* ; "Prefix page numbers with file number") (for INDEXITEM in (CADR INDEX) do (RPLACA (CDR INDEXITEM) (CONCAT PREFIX (CADR INDEXITEM))))) (if (NULL (SETQ MASTERENTRY (ASSOC (CAR INDEX) MASTERINDICES))) then (* ; "Haven't seen any yet, just store it") (push MASTERINDICES (CONS (CAR INDEX) (CADR INDEX))) else (* ; "Merge with what's there") (RPLACD MASTERENTRY (PFI.MERGE.INDICES (CDR MASTERENTRY) (CADR INDEX)))))) (LET* ((LEFT (DSPLEFTMARGIN)) (FATSPACE (TIMES (DSPSCALE) 8)) (RANGEWIDTH (if CONSECUTIVE then (+ (STRINGWIDTH "[-]" *STANDARD-OUTPUT*) (TIMES (+ FATSPACE (STRINGWIDTH MAXPAGE# *STANDARD-OUTPUT*)) 2)) else (* ; "No page ranges to print") FATSPACE)) (DIGITSWIDTH (STRINGWIDTH "99." *STANDARD-OUTPUT*)) (MAXWIDTH (+ DIGITSWIDTH RANGEWIDTH MAXNAME FATSPACE FATSPACE MAXDATE)) (LINEWIDTH (- (DSPRIGHTMARGIN) LEFT)) (LASTPAGE 0) TAB1 TAB2 TAB3 TEM) (if (< MAXWIDTH LINEWIDTH) then (SETQ TAB1 (+ LEFT DIGITSWIDTH (IQUOTIENT (- LINEWIDTH MAXWIDTH) 2))) (* ; "Digit flush against here") (SETQ TAB2 (+ TAB1 RANGEWIDTH)) (* ; "Name starts here") (SETQ TAB3 (+ TAB2 MAXNAME FATSPACE FATSPACE MAXDATE)) (* ; "Date flush right here")) (for N&D in (REVERSE NAMES&DATES) as I from 1 do (CHANGEFONT BOLDFONT) (SETQ TEM (CONCAT I ".")) (if TAB1 then (DSPXPOSITION (- TAB1 (STRINGWIDTH TEM *STANDARD-OUTPUT*)))) (PRIN3 TEM) (if CONSECUTIVE then (SETQ TEM (CONCAT "[" (LOGOR (+ LASTPAGE 1) (if *PFI-TWO-SIDED* then 1 else 0)) "-" (SETQ LASTPAGE (CADDR N&D)) "]")) (if TAB2 then (DSPXPOSITION (+ TAB1 (IQUOTIENT (- RANGEWIDTH (STRINGWIDTH TEM *STANDARD-OUTPUT*)) 2)))) (PRIN3 TEM)) (if TAB2 then (DSPXPOSITION TAB2) else (RELMOVETO FATSPACE 0)) (PRIN3 (CAR N&D)) (if TAB3 then (DSPXPOSITION (- TAB3 (STRINGWIDTH (CADR N&D) *STANDARD-OUTPUT*))) else (RELMOVETO FATSPACE 0)) (PRIN3 (CADR N&D)) (CHANGEFONT DEFAULTFONT) (TERPRI))) (for TYPEPAIR in MASTERINDICES do (* ;; "Now that each index is complete, turn (type . indices) into (type indices . shape)") (RPLACD TYPEPAIR (CONS (CDR TYPEPAIR) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) MAXPAGE#)))) (if (NOT ENV) then (SETQ BESTPACKAGE (PFI.CHOOSE.BEST BESTPACKAGE)) (SETQ BESTREADTABLE (PFI.CHOOSE.BEST BESTREADTABLE)) elseif (TYPENAMEP ENV (QUOTE READER-ENVIRONMENT)) then (SETQ BESTPACKAGE (fetch REPACKAGE of ENV)) (SETQ BESTREADTABLE (fetch REREADTABLE of ENV)) else (SETQ BESTPACKAGE (LISTGET ENV :PACKAGE)) (if (LISTP BESTPACKAGE) then (SETQ BESTPACKAGE (EVAL BESTPACKAGE))) (if (NOT (OR (CL:PACKAGEP BESTPACKAGE) (SETQ BESTPACKAGE (CL:FIND-PACKAGE BESTPACKAGE)))) then (SETQ BESTPACKAGE (CL:ERROR "No valid package in environment ~S" ENV))) (SETQ BESTREADTABLE (LISTGET ENV :READTABLE)) (if (LISTP BESTREADTABLE) then (SETQ BESTREADTABLE (EVAL BESTREADTABLE))) (if (NOT (OR (READTABLEP BESTREADTABLE) (SETQ BESTREADTABLE (FIND-READTABLE BESTREADTABLE)))) then (SETQ BESTREADTABLE (CL:ERROR "No valid read table in environment ~S" ENV)))) (LET ((*PACKAGE* BESTPACKAGE) (*READTABLE* BESTREADTABLE)) (PFI.PRINT.INDICES (PFI.SORT.INDICES MASTERINDICES) LINESPERPAGE)))) ) (PFI.CHOOSE.BEST (LAMBDA (LST) (* ; "Edited 19-May-88 12:30 by bvm") (* ;; "Return the car of the element in ALIST having the largest vote, or first such if a tie.") (CAAR (CL:STABLE-SORT LST (QUOTE >) :KEY (QUOTE CDR)))) ) (PFI.MERGE.INDICES (LAMBDA (MASTER NEWINDEX) (* ; "Edited 12-May-88 14:25 by bvm") (* ;; "Merge two lists of index entries. Each is a list (name location). In case of collision, it is known that MASTER locations appear before NEWINDEX locations") (NCONC (while (AND NEWINDEX MASTER) collect (SELECTQ (ALPHORDER (CAAR MASTER) (CAAR NEWINDEX) UPPERCASEARRAY) (EQUAL (* ; "Same name in two places, so merge the locations") (RPLACA (CDAR MASTER) (CONCAT (CADAR MASTER) "," (CADR (pop NEWINDEX)))) (pop MASTER)) (LESSP (* ; "Master less, so take it first") (pop MASTER)) (PROGN (* ; "NEWINDEX less, so take it") (pop NEWINDEX)))) (PROGN (* ; "Plus whichever, if either, is left over") (OR NEWINDEX MASTER)))) ) ) (* ; "Hooks for seeing files pretty elsewhere") (DEFINEQ (PFI.MAYBE.SEE.PRETTY (LAMBDA (FROMFILE TOFILE) (* ; "Edited 1-Apr-88 11:23 by bvm") (* ;; "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) OUTSTREAM INSTREAM) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NULL (SETQ OUTSTREAM (DISPLAYP TOFILE)))) then (* ; "Not a display window, or don't want prettyprinting") (if (STREAMP FROMFILE) then (* ; "Wanted PFCOPYBYTES") (PFCOPYBYTES FROMFILE TOFILE) else (COPYALLBYTES FROMFILE TOFILE)) else (if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ INSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) else (PFCOPYBYTES INSTREAM OUTSTREAM) (FULLNAME INSTREAM)))))) ) (PFI.MAYBE.PP.DEFINITION (LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 1-Apr-88 11:22 by bvm") (LET (ENV) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NOT (DISPLAYP OUTSTREAM)) (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) (WITH-READER-ENVIRONMENT ENV (SETFILEPTR INSTREAM START) (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) (IGNORE-ERRORS (READ INSTREAM)) (LET ((*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT)))) (if CONDITION then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) T else (PFI.PRINT.LAMBDA.BODY DEF) (TERPRI) NIL))))) then (* ;; "Punt to what we were called for in the first place") (PFCOPYBYTES INSTREAM OUTSTREAM START END)))) ) ) (RPAQ? *PRINT-PRETTY-FROM-FILES* T) (* ; "Bitmap hack") (DEFINEQ (PFI.PRINT.BITMAP (LAMBDA (BM STREAM) (* ; "Edited 14-Apr-88 12:44 by bvm") (* ;; "DEFPRINT function for bitmaps that displays the actual bitmap when going to an image stream.") (if (OR (NULL *PRINT-ARRAY*) (NULL *PRINT-PRETTY-BITMAPS*)) then (* ; "do the clunky way") (NON.PFI.PRINT.BITMAP BM STREAM) elseif (IMAGESTREAMP STREAM) then (PROG ((CURX (DSPXPOSITION NIL STREAM)) (CURY (DSPYPOSITION NIL STREAM)) (UNITS (DSPSCALE NIL STREAM)) (LINEHEIGHT (DSPLINEFEED NIL STREAM)) HEIGHT WIDTH MINX NLINESDOWN BOTTOM BMARG BELOWBASELINE SCALE RATIO) (if (NOT (AND CURX CURY UNITS LINEHEIGHT)) then (* ; "Stream doesn't really support it") (RETURN (NON.PFI.PRINT.BITMAP BM STREAM))) (SETQ HEIGHT (TIMES UNITS (BITMAPHEIGHT BM))) (SETQ WIDTH (TIMES UNITS (BITMAPWIDTH BM))) (SETQ BMARG (DSPBOTTOMMARGIN NIL STREAM)) (if (AND (NOT (DISPLAYSTREAMP STREAM)) (< (SETQ RATIO (MIN (FQUOTIENT (- (DSPRIGHTMARGIN NIL STREAM) (DSPLEFTMARGIN NIL STREAM)) (TIMES WIDTH 1.5)) (FQUOTIENT (- (DSPTOPMARGIN NIL STREAM) BMARG) (TIMES HEIGHT 1.5)))) 1.0)) then (* ; "It takes up more than 2/3 the page in some dimension. This code is tuned for Interpress.") (SETQ SCALE (if (> RATIO 0.75) then 0.75 elseif (> RATIO 0.5) then 0.5 elseif (> RATIO 0.25) then 0.25 else RATIO)) (SETQ HEIGHT (FIXR (TIMES SCALE HEIGHT))) (SETQ WIDTH (FIXR (TIMES SCALE WIDTH)))) (if (> CURX (SETQ MINX (- (DSPRIGHTMARGIN NIL STREAM) WIDTH))) then (* ; "Won't fit between here and margin, so start nwe line") (TERPRI STREAM) (SETQ CURX (MAX MINX 0)) (SETQ CURY (DSPYPOSITION NIL STREAM))) (SETQ BELOWBASELINE (MAX 0 (- HEIGHT (FONTPROP STREAM (QUOTE ASCENT))))) (if BMARG then (* ; "We know stream's bottom margin, so can be reasonable") (if (< (- CURY BELOWBASELINE) BMARG) then (* ; "Won't fit on page") (DSPNEWPAGE STREAM) (SETQ CURY (DSPYPOSITION NIL STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL)) else (* ; "Have to use silly terpri method") (SETQ NLINESDOWN (IQUOTIENT HEIGHT (SETQ LINEHEIGHT (- LINEHEIGHT)))) (to NLINESDOWN do (* ; "Do enough cr's so that we have space for bitmap. This might cause scrolling, for example") (TERPRI STREAM) finally (* ; "If this was display, terpri may have scrolled, and Y changed out from under us") (SETQ CURY (+ (DSPYPOSITION NIL STREAM) (TIMES NLINESDOWN LINEHEIGHT))))) (SETQ BOTTOM (- CURY BELOWBASELINE)) (* ; "BOTTOM computed so that bitmap top lines up with font top") (SCALEDBITBLT BM 0 0 STREAM CURX BOTTOM WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL NIL SCALE) (MOVETO (+ CURX WIDTH) (if (AND (< BOTTOM CURY) (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) *PFI-FUNNY-CHARS*) then (* ; "Don't move the baseline down, just remember it for when we hit end of line") (if (OR (NULL *PFI-BITMAP-BASELINE*) (< BOTTOM *PFI-BITMAP-BASELINE*)) then (* ; "Lower than before, or first time") (SETQ *PFI-BITMAP-BASELINE* BOTTOM) (if (NEQ (fetch (STREAM OUTCHARFN) of STREAM) (FUNCTION PFI.OUTCHARFN)) then (* ; "Also have to %"advise%" the outcharfn to notice terpri") (replace (STREAM OUTCHARFN) of STREAM with (FUNCTION PFI.OUTCHARFN)))) CURY else (* ; "Move baseline down to bitmap baseline") BOTTOM) STREAM) (RETURN T)) else (LET ((POS (AND (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) (PNAMESTREAMP STREAM) (STKPOS (QUOTE STRINGWIDTH)))) IMSTREAM) (if (AND POS (IMAGESTREAMP (SETQ IMSTREAM (STKEVAL POS (QUOTE *STANDARD-OUTPUT*) T)))) then (* ;; "Big kludge: This is somebody in the prettyprinter trying to figure out the width of the bitmap--fake them out by printing something about the width of the bitmap. IMSTREAM is the stream to which the real output will go. To be conservative, only do this under PRETTYFILEINDEX.") (RPTQ (CL:CEILING (TIMES (DSPSCALE NIL IMSTREAM) (BITMAPWIDTH BM)) (CHARWIDTH (CHARCODE X) IMSTREAM)) (\OUTCHAR STREAM (CHARCODE X))) T else (NON.PFI.PRINT.BITMAP BM STREAM))))) ) ) (RPAQ? *PRINT-PRETTY-BITMAPS* T) (RPAQ? *PFI-PRINTOPTIONS* '(REGION (72 54 504 702))) (RPAQ? *PFI-DONT-SPAWN* ) (RPAQ? *PFI-MAX-WASTED-LINES* 12) (RPAQ? *PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC)))) (RPAQ? *PFI-INDEX-ORDER* '(FUNCTIONS)) (RPAQ? *PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*)) ) (* ;;  "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN)))) (RPAQ? \PFI.PROCESS.COMMANDS ) (RPAQ? \PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (RPAQ? \PFI.PROCESS ) (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex" ) (RPAQ? *PFI-TITLE* ) (RPAQ? *PFI-PAGE-COUNT* 0) (ADDTOVAR *PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (ADDTOVAR *PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (ADDTOVAR *PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (ADDTOVAR *PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (ADDTOVAR *PFI-FILTERS* (VARIABLES . CONSTANTS)) (* ; "Prettyprint augmentation to mimic system makefile dumping") (DEFINEQ (PUTPROPS.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 30-Mar-88 11:35 by bvm") (* ;; "does prettyprinting for PUTPROPS forms. Main thing we do is embolden the variable.") (if (NLISTP (CDR EXPR)) then (* ; "Degenerate (PUTPROPS) or (PUTPROPS . FOO)") (PRIN2 EXPR) else (PRIN1 (QUOTE %()) (PRIN2 (pop EXPR)) (* ; "Print the PUTPROPS") (SPACES 1) (LET ((TEM (DSPXPOSITION)) PROP) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Print the symbol") (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate illegal form like (PUTPROPS var . foo)") (SPACES 1) (PRINTDEF EXPR T NIL T) elseif (CDDR EXPR) then (* ; "There are multiple prop value pairs") (while EXPR do (* ;; "EXPR looks like (PROP VALUE . tail)") (TERPRI) (* ; "Start next prop on new line") (DSPXPOSITION TEM) (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate tail") (RETURN (PRINTDEF EXPR T NIL T))) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (SPACES 1) (PRINTDEF (pop EXPR) T (MEMB PROP MACROPROPS) NIL FNSLST)) else (* ; "Normal type: (PUTPROPS var prop value)") (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (COND ((AND (LISTP (CAR EXPR)) (NOT (FITP EXPR T NIL NIL *STANDARD-OUTPUT*))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF EXPR T (MEMB PROP MACROPROPS) T FNSLST)) (PRIN1 (QUOTE %))))) NIL) ) (RPAQX.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 8-Apr-88 16:34 by bvm") (* ;; "does prettyprinting for RPAQxx forms and ADDTOVAR. Main thing we do is embolden the variable.") (if (NOT (LISTP (CDR EXPR))) then (* ; "Handle (RPAQ) and (RPAQ . FOO)") EXPR else (DESTRUCTURING-BIND (OP VAR . TAIL) EXPR (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (LET ((TEM (DSPXPOSITION))) (MAYBE.PRETTYPRINT.BOLD VAR) (* ; "Embolden the variable") (COND ((AND (LISTP (CAR TAIL)) (OR (> (COUNT TAIL) 30) (NOT (FITP TAIL T NIL NIL *STANDARD-OUTPUT*)))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF TAIL T NIL T) (PRIN1 (QUOTE %))))) NIL)) ) (COURIERPROGRAM.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 13-Apr-88 10:55 by bvm") (if (NOT (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR))))))) then (* ; "Degenerate") EXPR else (LET* ((TAB1 (+ (DSPXPOSITION) (TIMES 4 SPACEWIDTH))) (TAB2 (+ TAB1 (TIMES 2 SPACEWIDTH)))) (PROGN (* ;; "Print %"(COURIERPROGRAM name (version)%"") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (SPACES 1) (PRIN2 (pop EXPR))) (* ; "Version pair") (while (LISTP EXPR) do (PRINENDLINE TAB1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Property name") (PRINENDLINE TAB2) (AND (LISTP EXPR) (PRINTDEF (pop EXPR) T))) (if EXPR then (* ; "degenerate tail?") (PRINTDEF EXPR T T T)) (PRIN1 ")") NIL))) ) (MAYBE.PRETTYPRINT.BOLD (LAMBDA (VAR) (* ; "Edited 28-Mar-88 11:59 by bvm") (* ;; "Print VAR, in makefile's bold font if enabled") (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT) (PRIN2 VAR) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 VAR)))) ) ) (ADDTOVAR PRETTYPRINTMACROS (RPAQ . RPAQX.PRETTYPRINT) (RPAQQ . RPAQX.PRETTYPRINT) (RPAQ? . RPAQX.PRETTYPRINT) (ADDTOVAR . RPAQX.PRETTYPRINT) (PUTPROPS . PUTPROPS.PRETTYPRINT) (COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (CL:PROCLAIM '(CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG)) (DECLARE%: EVAL@COMPILE (RECORD PFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*) ) ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (OR (GETD 'CODEWRAPPER.PRETTYPRINT) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ;  "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ;  "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE")) (* ; "Also fix SEE") (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ;  "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION) (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP) 'NILL) 'NON.PFI.PRINT.BITMAP NIL T) ) (PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10120 12355 (PFI.NEW.LISTFILES1 10130 . 10624) (PFI.ENQUEUE 10626 . 11250) ( \PFI.DO.HARDCOPY 11252 . 11838) (MAYBE.PRETTYFILEINDEX 11840 . 12353)) (12356 35139 (PRETTYFILEINDEX 12366 . 26413) (PFI.MAKE.LPT.STREAM 26415 . 29720) (PFI.SETUP.TRANSLATIONS 29722 . 31236) ( PFI.OUTCHARFN 31238 . 33212) (PFI.COLLECT.DEFINERS 33214 . 34026) (PFI.AFTER.NEW.PAGE 34028 . 35137)) (35140 37996 (PFI.PRINT.FILECREATED 35150 . 36882) (PFI.PRINT.TO.TAB 36884 . 37249) ( PFI.PRINT.ENVIRONMENT 37251 . 37994)) (37997 44648 (PFI.PROCESS.FILE 38007 . 39237) (PFI.PASS.COMMENT 39239 . 39676) (PFI.HANDLE.EXPR 39678 . 40345) (PFI.DEFAULT.HANDLER 40347 . 42400) (PFI.PRETTYPRINT 42402 . 42737) (PFI.LINES.REMAINING 42739 . 43066) (PFI.MAYBE.NEW.PAGE 43068 . 43571) ( PFI.ESTIMATE.SIZE 43573 . 44104) (PFI.ESTIMATE.SIZE1 44106 . 44646)) (44685 54172 (PFI.HANDLE.RPAQQ 44695 . 46103) (PFI.HANDLE.DECLARE 46105 . 47044) (PFI.HANDLE.EVAL-WHEN 47046 . 47529) ( PFI.HANDLE.DEFDEFINER 47531 . 48821) (PFI.HANDLE.DEFINEQ 48823 . 49067) (PFI.PRINT.LAMBDA 49069 . 49407) (PFI.PRINT.LAMBDA.BODY 49409 . 49744) (PFI.HANDLE.PUTDEF 49746 . 50243) (PFI.HANDLE.PUTPROPS 50245 . 50860) (PFI.HANDLE./DECLAREDATATYPE 50862 . 51409) (PFI.HANDLE.* 51411 . 52673) ( PFI.PRINT.COMMENTS 52675 . 53575) (PFI.HANDLE.FILEMAP 53577 . 53865) (PFI.HANDLE.PACKAGE 53867 . 54170 )) (54200 55192 (PFI.PREVIEW.DECLARE 54210 . 54872) (PFI.PREVIEW.DEFINEQ 54874 . 55190)) (55228 66216 (PFI.PRINT.INDEX 55238 . 56089) (PFI.CONDENSE.INDEX 56091 . 57898) (PFI.SORT.INDICES 57900 . 59039) ( PFI.COMPUTE.INDEX.SHAPE 59041 . 60505) (PFI.PRINT.INDICES 60507 . 65049) (PFI.CENTER.PRINT 65051 . 65621) (PFI.INDEX.BREAK 65623 . 66081) (PFI.LOOKUP.NAME 66083 . 66214)) (66217 67448 (PFI.ADD.TO.INDEX 66227 . 66737) (PFI.VARNAME 66739 . 67149) (PFI.CONSTANTNAMES 67151 . 67446)) (67483 75796 ( MULTIFILEINDEX 67493 . 68289) (MULTIFILEINDEX1 68291 . 69747) (PFI.PRINT.MULTI.INDEX 69749 . 74852) ( PFI.CHOOSE.BEST 74854 . 75081) (PFI.MERGE.INDICES 75083 . 75794)) (75853 77471 (PFI.MAYBE.SEE.PRETTY 75863 . 76793) (PFI.MAYBE.PP.DEFINITION 76795 . 77469)) (77541 81376 (PFI.PRINT.BITMAP 77551 . 81374)) (84221 87335 (PUTPROPS.PRETTYPRINT 84231 . 85642) (RPAQX.PRETTYPRINT 85644 . 86369) ( COURIERPROGRAM.PRETTYPRINT 86371 . 87071) (MAYBE.PRETTYPRINT.BOLD 87073 . 87333))))) STOP \ No newline at end of file diff --git a/lispusers/PRETTYFILEINDEX.~2~ b/lispusers/PRETTYFILEINDEX.~2~ deleted file mode 100644 index 7e07b7e0..00000000 --- a/lispusers/PRETTYFILEINDEX.~2~ +++ /dev/null @@ -1,166 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 17:13:51" {DSK}medley3.5>lispusers>PRETTYFILEINDEX.;3 91069 changes to%: (FNS PRETTYFILEINDEX PFI.PASS.COMMENT) previous date%: "12-Nov-93 09:53:58" {DSK}medley3.5>lispusers>PRETTYFILEINDEX.;2) (* ; " Copyright (c) 1988, 1992, 1993, 1999 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PRETTYFILEINDEXCOMS) (RPAQQ PRETTYFILEINDEXCOMS [(COMS (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX) (FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN PFI.COLLECT.DEFINERS PFI.AFTER.NEW.PAGE) (FNS PFI.PRINT.FILECREATED PFI.PRINT.TO.TAB PFI.PRINT.ENVIRONMENT) (FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE PFI.ESTIMATE.SIZE1)) (COMS (* ; "Expression handlers") (FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE)) (COMS (* ; "Previewers") (FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ)) (COMS (* ; "Printing the index") (FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME) (FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES)) (COMS (* ; "Combined listings") (FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST PFI.MERGE.INDICES)) (COMS (* ;  "Hooks for seeing files pretty elsewhere") (FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION) (INITVARS (*PRINT-PRETTY-FROM-FILES* T))) (COMS (* ; "Bitmap hack") (FNS PFI.PRINT.BITMAP) (INITVARS (*PRINT-PRETTY-BITMAPS* T))) (INITVARS [*PFI-PRINTOPTIONS* '(REGION (72 54 504 702] (*PFI-DONT-SPAWN*) (*PFI-MAX-WASTED-LINES* 12) [*PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC] (*PFI-INDEX-ORDER* '(FUNCTIONS)) [*PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))) (* ;;  "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN] (\PFI.PROCESS.COMMANDS) (\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (\PFI.PROCESS)) (COMS (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex") (INITVARS (*PFI-TITLE*) (*PFI-PAGE-COUNT* 0))) (ADDVARS (*PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (*PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (*PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (*PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (*PFI-FILTERS* (VARIABLES . CONSTANTS))) (COMS (* ;  "Prettyprint augmentation to mimic system makefile dumping") (FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT MAYBE.PRETTYPRINT.BOLD) (ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) [P (CL:PROCLAIM '(CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG] (RECORDS PFITYPE) (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*)) [DECLARE%: EVAL@COMPILE DOCOPY (* ;  "Public variables to declare special") (P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (GETD 'CODEWRAPPER.PRETTYPRINT) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ;  "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ;  "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE" )) (* ; "Also fix SEE") (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ;  "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION) (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP) 'NILL) 'NON.PFI.PRINT.BITMAP NIL T]) (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (DEFINEQ (PFI.NEW.LISTFILES1 -(LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Substitute for LISTFILES1") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FULL (FINDFILE FILENAME T))) (COND ((NOT FULL) (* ; "When called by LISTFILES, FILENAME will already be a full file name") (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FILENAME)) (*PFI-DONT-SPAWN* (MAYBE.PRETTYFILEINDEX FULL PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MAYBE.PRETTYFILEINDEX) FULL PRINTOPTIONS)) FULL)))) -) (PFI.ENQUEUE -(LAMBDA (FORM) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Add FORM to the background hardcopy's task list") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (COND ((AND \PFI.PROCESS (NOT (FIND.PROCESS \PFI.PROCESS))) (* ; "Process died, flush handle and any old listing requests") (SETQ \PFI.PROCESS (SETQ \PFI.PROCESS.COMMANDS NIL)))) (SETQ \PFI.PROCESS.COMMANDS (NCONC1 \PFI.PROCESS.COMMANDS FORM)) (COND ((NULL \PFI.PROCESS) (SETQ \PFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \PFI.DO.HARDCOPY)) (QUOTE BEFOREEXIT) (QUOTE DON'T) (QUOTE NAME) "Do-Hardcopy")))))) -) (\PFI.DO.HARDCOPY -(LAMBDA NIL (* ; "Edited 25-Mar-88 16:49 by bvm") (* ;;; "Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (while \PFI.PROCESS.COMMANDS bind FORM do (SETQ FORM (pop \PFI.PROCESS.COMMANDS)) (RELEASE.MONITORLOCK \PFI.PROCESSLOCK) (* ; "Release lock while listing so that others can add to my queue") (APPLY (CAR FORM) (CDR FORM)) (OBTAIN.MONITORLOCK \PFI.PROCESSLOCK) finally (* ; "Nothing left to do, so exit") (SETQ \PFI.PROCESS NIL)))) -) (MAYBE.PRETTYFILEINDEX -(LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 11-Apr-88 10:50 by bvm") (* ;;; "Performs PRETTYFILEINDEX on FILENAME if it is a file manager file, else calls the old listfiles1.") (COND ((COND ((PRETTYFILEINDEX FILENAME PRINTOPTIONS) T) (T (PFI.ORIGINAL.LISTFILES1 FILENAME PRINTOPTIONS))) (* ;; "Do this here since there is little coordination between the various multiple processes which are listing files") (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FILENAME) NOTLISTEDFILES)) NIL))) -) ) (DEFINEQ (PRETTYFILEINDEX [LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 11-Apr-95 00:02 by rmk:") (* ; "Edited 11-Jun-92 15:58 by cat") (* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.") (RESETLST [PROG ((*STANDARD-OUTPUT* *STANDARD-OUTPUT*) (*STANDARD-INPUT* *STANDARD-INPUT*) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*UPPER-CASE-FILE-NAMES* NIL) (PRETTYFLG T) (*PRINT-PRETTY-BITMAPS* 'PRETTYFILEINDEX) (*PFI-PAGE-COUNT*) (*PFI-PAGE-PREFIX* "Page ") (*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS '%#SIDES) EMPRESS#SIDES) 2)) (*PFI-TITLE*) (*PFI-ITEM*) (*PFI-TYPES* *PFI-TYPES*) (*PFI-FILEVARS*) (*PFI-FNSLST*) (*PFI-LOCATIONS*) (*PFI-MAX-WASTED-LINES* *PFI-MAX-WASTED-LINES*) (*PFI-FUNNY-CHARS*) (*PFI-BITMAP-BASELINE*) (*PFI-PENDING-COMMENTS*) FILECREATED ENV WASOPEN MULTIFILEINDEX CRDATE INDICES PART# FIRSTPAGE LASTPAGE CRDATE) (* ;; "Specials are as follows:") (* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image") (* ;; "*PFI-PAGE-COUNT* -- number of current page") (* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing") (* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers") (* ;; "*PFI-ITEM* -- function, etc currently being printed") (* ;; "*PFI-TYPES* -- list specifying the type associated with an expression") (* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*") (* ;;  "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF") (* ;;  "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences") (* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.") (* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars") (* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default") (* ;;  "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed") (* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.") [if (TYPENAMEP FILENAME 'STREAM) then (* ; "Already have input stream") [SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT] else (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME 'INPUT 'OLD '((SEQUENTIAL T] (SETQ FILENAME (FULLNAME *STANDARD-INPUT*)) [if (LISTGET PRINTOPTIONS :COMMON) then (* ; "Common Lisp file") (SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*) else (* ;  "Figure out if this is a file manager file, and if so get environment") (CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED) (\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T)) (if (NULL FILECREATED) then (* ; "Not a File Manager file") (RETURN NIL) elseif (NEQ (CAR (LISTP FILECREATED)) 'FILECREATED) then (* ;  "File started with open paren, but isn't file manager file.") (RETURN (if WASOPEN then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy") (PRINTDEF FILECREATED T T NIL NIL OUTSTREAM) (PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME)) elseif (LISTP (CADDR FILECREATED)) then (* ;  "A compiled file--just use COPYBYTES to avoid binary hassles.") (RETURN (if WASOPEN then (* ;  "Print environment and filecreated before copying rest") (PRINT-READER-ENVIRONMENT ENV OUTSTREAM) (WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED OUTSTREAM)) (COPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME] (CL:UNLESS DONTINDEX (CL:FORMAT PROMPTWINDOW "~%%Starting index of ~A." FILENAME)) [if OUTSTREAM then (SETQ *PFI-TITLE* FILENAME) (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT)) else (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) (push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME))) (SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT) (if NOPRINT then (* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually") (\CORE.CLOSEFILE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (\GENERIC-UNREGISTER-STREAM (fetch (STREAM DEVICE) of STREAM) STREAM) (\CORE.DELETEFILE (FULLNAME STREAM) (fetch (STREAM DEVICE) of STREAM)) else (CLOSEF? STREAM] *STANDARD-OUTPUT* (LISTGET PRINTOPTIONS :DONTPRINT] (* ;  "Make sure printer knows original name of file") (RESETSAVE (LINELENGTH (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) *STANDARD-OUTPUT*)) (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (PFI.SETUP.TRANSLATIONS)) [if DONTINDEX then (* ; "This is for SEE etc") (SETQ *PFI-MAX-WASTED-LINES* 0) (SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother") (SETQ *PFI-LOCATIONS* :NONE) else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE)) (* ; "Enable header printing") [SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND] (* ; "Says to do something with coms") [if (NOT (FIXP *PFI-MAX-WASTED-LINES*)) then (* ;  "a parameter expressed as a fraction of page") (SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES* (- (PFI.LINES.REMAINING ) 2] [SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES) (PFI.COLLECT.DEFINERS *PFI-TYPES*] (* ;  "Add known record types and definers to the list.") (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE] [SETQ *PFI-PAGE-COUNT* (SETQ FIRSTPAGE (LOGOR (OR (LISTGET PRINTOPTIONS :FIRSTPAGE) 1) (if *PFI-TWO-SIDED* then (* ; "Make first page odd") 1 else 0] (if (SETQ PART# (LISTGET PRINTOPTIONS :PART)) then (SETQ *PFI-PAGE-PREFIX* (CONCAT *PFI-PAGE-PREFIX* PART# "-"))) (RETURN (WITH-READER-ENVIRONMENT ENV (if FILECREATED then (PFI.PRINT.FILECREATED FILECREATED ENV)) (PFI.PROCESS.FILE DONTINDEX) (if (NOT WASOPEN) then (* ;  "We're through with input file now, so release it") (CLOSEF *STANDARD-INPUT*)) (if (SETQ MULTIFILEINDEX (LISTGET PRINTOPTIONS 'MULTIFILEINDEX)) then (* ;  "True on calls from multifileindex-remember the date and last page#") (SETQ LASTPAGE *PFI-PAGE-COUNT*)) (if (NOT DONTINDEX) then (* ;  "Now that we've scanned whole file, print the index") (SETQ INDICES (PFI.PRINT.INDEX CRDATE))) [if (NULL OUTSTREAM) then (CL:FORMAT PROMPTWINDOW "~%%Finished indexing ~A (~D pages)" FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE] (if (NULL MULTIFILEINDEX) then FILENAME else (push INDICES (LIST FILENAME CRDATE LASTPAGE ENV)) (if (NLISTP MULTIFILEINDEX) then (* ;  "More to do yet, so just return this index") INDICES else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX INDICES) PRINTOPTIONS))))])]) (PFI.MAKE.LPT.STREAM - [LAMBDA (PRINTOPTIONS) (* ; "Edited 12-Nov-93 09:53 by rmk:") - (* ; "Edited 19-Aug-92 13:57 by jds") - (LET* ((PRINTER (OR (LISTGET PRINTOPTIONS 'SERVER) - (LISTGET PRINTOPTIONS 'HOST) - (CAR (LISTP DEFAULTPRINTINGHOST)) - DEFAULTPRINTINGHOST)) - [IMAGETYPE (COND - [(AND PRINTER (CADDR (LISTP PRINTER] - (T (CAR (MKLIST (PRINTERPROP (PRINTERTYPE PRINTER) - 'CANPRINT] - (DEFAULTOPTIONS *PFI-PRINTOPTIONS*) - REG S TEMPS SCALE DEFREGION) - - (* ;; "Get a dummy stream of the right image type, so we can get scaling right, etc. The IMAGETYPE ... code is stolen from OPENIMAGESTREAM's decision for IMAGETYPE.") - - (SETQ TEMPS (OPENIMAGESTREAM "{NODIRCORE}" IMAGETYPE)) - (SETQ SCALE (DSPSCALE NIL TEMPS)) - (CLOSEF TEMPS) - - (* ;; "Scale the region from points to the stream's real units right up front. Also, copy the options so can smash with LISTPUTs here and below.") - - (CL:WHEN (SETQ REG (LISTGET PRINTOPTIONS 'REGION)) - (LISTPUT (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS)) - 'REGION - (SCALEREGION SCALE REG))) - (CL:WHEN (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION)) - (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS)) - 'REGION - (SCALEREGION SCALE REG))) - - (* ;; "Set up the margins (REGION) for the page correctly.") - - [COND - ((AND (LISTGET PRINTOPTIONS 'LANDSCAPE) - (LISTGET DEFAULTOPTIONS 'REGION)) (* ; - "Don't use default region when caller specified landscape (tee hee)") - (LISTPUT DEFAULTOPTIONS 'REGION NIL)) - ([AND *PFI-TWO-SIDED* (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION)) - (NOT (LISTGET PRINTOPTIONS 'REGION] (* ; "Shift image to the left 1/4%" so that it is balanced. Default region is assumed to be 1%" on left and 1/2%" on right. No adjustment if user gave region explicitly") - (LISTPUT DEFAULTOPTIONS 'REGION (create REGION - using REG LEFT _ (- (fetch (REGION LEFT) - of REG) - (FIXR (FTIMES 18 SCALE] - (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS DEFAULTOPTIONS)) - (SETQ S (OPENIMAGESTREAM (CONCAT "{LPT}" (OR (CADR (LISTP PRINTER)) - PRINTER "")) - IMAGETYPE PRINTOPTIONS)) - [STREAMPROP S 'PRINTOPTIONS (APPEND PRINTOPTIONS (STREAMPROP S 'PRINTOPTIONS] - S]) (PFI.SETUP.TRANSLATIONS -(LAMBDA NIL (* ; "Edited 14-Apr-88 11:51 by bvm") (* ;; "Prepare character translation table for this output stream") (* ;; "*PFI-CHARACTER-TRANSLATIONS* is an alist of (imagetype . charpairs), where each char pair is (sourcecode destcode . fontplist) describing the translation and optional font change for a specified input character. We set *PFI-FUNNY-CHARS* to (oldoutcharfn . triples), where each triple is (sourcecode destcode fontplist . fontcacheplist). ") (LET ((CHARPAIRS (CDR (ASSOC (IMAGESTREAMTYPE *STANDARD-OUTPUT*) *PFI-CHARACTER-TRANSLATIONS*)))) (SETQ *PFI-FUNNY-CHARS* (CONS (fetch (STREAM OUTCHARFN) of *STANDARD-OUTPUT*) (AND CHARPAIRS (LET ((FONT (DSPFONT))) (if (NEQ (CHARWIDTH (CHARCODE i) FONT) (CHARWIDTH (CHARCODE W) FONT)) then (* ; "Font is not fixed width, so don't need this kludge when substituting fonts") (SETQ FONT NIL)) (for PAIR in CHARPAIRS collect (* ;; "Each entry is (oldchar newchar . fontspec), where fontspec is optional plist to give to FONTCOPY to get a font derived from current font to print the char. Here we copy each entry, preparing cache for font change entries") (LIST* (pop PAIR) (pop PAIR) PAIR (if FONT then (* ; "First oldfont-newfont pair designates a fixed-width font") (LIST FONT (CL:APPLY (FUNCTION FONTCOPY) FONT PAIR)) else (* ; "Just waste this fixed-width entry") (LIST NIL NIL)))))))) (if CHARPAIRS then (* ; "Yes, want translation") (replace (STREAM OUTCHARFN) of *STANDARD-OUTPUT* with (FUNCTION PFI.OUTCHARFN))))) -) (PFI.OUTCHARFN -(LAMBDA (STREAM CHAR) (* ; "Edited 14-Apr-88 12:40 by bvm") (* ;; "Our own OUTCHARFN that does character translation.") (DESTRUCTURING-BIND (FN . CASES) *PFI-FUNNY-CHARS* (do (if (NULL CASES) then (* ; "Not funny, just do it regular") (if (AND (EQ CHAR (CHARCODE EOL)) *PFI-BITMAP-BASELINE*) then (* ; "End of line on a line where we have printed bitmaps below the baseline--make sure we terpri far enough") (if (AND *PFI-BITMAP-BASELINE* (< *PFI-BITMAP-BASELINE* (DSPYPOSITION NIL STREAM))) then (* ; "Could be false if new page in between") (MOVETO (DSPXPOSITION NIL STREAM) *PFI-BITMAP-BASELINE* STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL) (if (NULL (CDR *PFI-FUNNY-CHARS*)) then (* ; "We existed only for this kludge--restore normal outcharfn") (replace (STREAM OUTCHARFN) of STREAM with FN))) (RETURN (CL:FUNCALL FN STREAM CHAR)) elseif (EQ (CAAR CASES) CHAR) then (* ; "Yes, it's a special char") (RETURN (DESTRUCTURING-BIND (C . FONTINFO) (CDAR CASES) (if (NULL FONTINFO) then (* ; "Simple translation in this font") (CL:FUNCALL FN STREAM C) else (* ; "Want to use char from another font") (LET* ((FONT (DSPFONT NIL STREAM)) (NEWFONT (LISTGET (CDR FONTINFO) FONT)) EXTRASPACE) (if (NOT NEWFONT) then (* ; "Other font not cached yet. FONTINFO = (spec . fontplist), where SPEC is something to give to FONTCOPY to modify the current font.") (NCONC FONTINFO (LIST FONT (SETQ NEWFONT (CL:APPLY (FUNCTION FONTCOPY) FONT (CAR FONTINFO)))))) (DSPFONT NEWFONT STREAM) (if (AND (EQ FONT (CADR FONTINFO)) (> (SETQ EXTRASPACE (- (CHARWIDTH C FONT) (CHARWIDTH C NEWFONT))) 0)) then (* ; "We were in a fixed width font, but substitution is from a font where the char is narrower, so make some space to maintain the fixed-width illusion.") (RELMOVETO (IQUOTIENT EXTRASPACE 2) 0 STREAM) (CL:FUNCALL FN STREAM C) (RELMOVETO (- EXTRASPACE (IQUOTIENT EXTRASPACE 2)) 0 STREAM) else (CL:FUNCALL FN STREAM C)) (DSPFONT FONT STREAM))))) else (SETQ CASES (CDR CASES)))))) -) (PFI.COLLECT.DEFINERS -(LAMBDA (KNOWNTYPES) (* ; "Edited 11-Apr-88 12:26 by bvm") (* ;; "Scan all the definers in the system, creating PFITYPE entries for them if they're not already in the entries in KNOWNTYPES (e.g., might want DEFMACRO to be MACROS not FUNCTIONS). Bunch of conditionals in here because between Lyric and Medley the prop names changed from IL symbols to keywords. *PFI-DEFINER-PROPS* = (:definer-for :defined-by :definition-name)") (for TYPE in FILEPKGTYPES bind (BYPROP _ (CADR *PFI-DEFINER-PROPS*)) (NAMEPROP _ (CADDR *PFI-DEFINER-PROPS*)) when (LITATOM TYPE) join (for DEFINER in (GET TYPE BYPROP) collect (create PFITYPE NAME _ TYPE PATTERNS _ DEFINER TESTFN _ (GET DEFINER NAMEPROP)) unless (for ENTRY in KNOWNTYPES thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))))) -) (PFI.AFTER.NEW.PAGE -(LAMBDA (STREAM) (* ; "Edited 12-May-88 09:58 by bvm") (DECLARE (USEDFREE *PFI-TITLE* *PFI-ITEM* *PFI-PAGE-COUNT*)) (* ;; "Called after the output image stream has turned the page. Bump our page count and print a suitable header.") (add *PFI-PAGE-COUNT* 1) (if *PFI-TITLE* then (LET ((*PRINT-BASE* 10) (LEFT *PFI-TITLE*) (RIGHT) (OLDFONT (DSPFONT))) (CHANGEFONT DEFAULTFONT) (* ; "Get back to canonical font for the header, saving whatever font was in effect at the page turn") (if (EQ *PFI-ITEM* :INDEX) then (* ; "In the index, omit page numbers") (SETQ *PFI-ITEM* NIL) else (SETQ RIGHT (CONCAT *PFI-PAGE-PREFIX* *PFI-PAGE-COUNT*))) (if (AND *PFI-TWO-SIDED* (EVENP *PFI-PAGE-COUNT*)) then (* ; "On even pages, print page numbers on outside (left)") (swap LEFT RIGHT)) (if LEFT then (PRIN3 LEFT)) (if (AND *PFI-ITEM* (NEQ *PFI-ITEM* :INDEX)) then (printout NIL " (" .FONT BOLDFONT |.P2| *PFI-ITEM* .FONT ITALICFONT " cont." .FONT DEFAULTFONT ")")) (if RIGHT then (DSPXPOSITION (- (DSPRIGHTMARGIN) (STRINGWIDTH RIGHT STREAM))) (PRIN3 RIGHT)) (TERPRI) (TERPRI) (DSPFONT OLDFONT)))) -) ) (DEFINEQ (PFI.PRINT.FILECREATED -(LAMBDA (EXPR ENV) (* ; "Edited 13-Apr-88 11:14 by bvm") (* ;; "Display the FILECREATED expression and environment prettily") (* ;; "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") (pop EXPR) (CHANGEFONT ITALICFONT) (LET* ((STRINGS (QUOTE ("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"))) (FONT (DSPFONT)) (STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT))) (TABSTOP (+ (DSPLEFTMARGIN) (APPLY (FUNCTION MAX) STRWIDTHS)))) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "File created:") (PRINTOUT NIL (pop EXPR) " " .FONT LAMBDAFONT (pop EXPR) T T) (* ; "date and file name") (if (OR (NULL (CAR EXPR)) (FIXP (CAR EXPR))) then (* ; "Skip over filemaploc") (pop EXPR)) (if (EQ (CAR EXPR) (QUOTE changes)) then (* ; "handle %"Changes to:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) T NIL T) (TERPRI) (TERPRI) else (pop STRINGS) (pop STRWIDTHS)) (if (EQ (CAR EXPR) (QUOTE previous)) then (* ; "Handle %"Previous date:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTOUT NIL (pop EXPR) " " (pop EXPR) T T) else (pop STRINGS) (pop STRWIDTHS)) (LET ((SPEC (fetch RESPEC of ENV))) (* ; "Show environment") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Read table") (PFI.PRINT.ENVIRONMENT SPEC :READTABLE) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Package") (PFI.PRINT.ENVIRONMENT SPEC :PACKAGE) (if (NEQ *PRINT-BASE* 10) then (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (PFI.PRINT.ENVIRONMENT SPEC :BASE))))) -) (PFI.PRINT.TO.TAB -(LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT)) -) (PFI.PRINT.ENVIRONMENT -(LAMBDA (SPEC KEYWORD) (* ; "Edited 29-Mar-88 12:46 by bvm") (* ;; "Display the KEYWORD component of a reader environment spec") (LET ((VALUE (LISTGET SPEC KEYWORD))) (if (LISTP VALUE) then (* ; "An expression to create it--show pretty. Use IL package, since that's what they appear in at beginning of file") (LET ((*PACKAGE* *INTERLISP-PACKAGE*)) (PRINTDEF VALUE T T)) else (* ; "Just show the value, sans quotations, etc. The selectq is just in case this environment has no spec, something that shouldn't happen if it came from a define-file-info") (PRIN3 (OR VALUE (SELECTQ KEYWORD (:READTABLE (READTABLEPROP *READTABLE* (QUOTE NAME))) (:PACKAGE (CL:PACKAGE-NAME *PACKAGE*)) (SHOULDNT))))) (TERPRI) (TERPRI))) -) ) (DEFINEQ (PFI.PROCESS.FILE -(LAMBDA (DONTINDEX) (* ; "Edited 13-Apr-88 12:59 by bvm") (* ;; "The main loop for PRETTYFILEINDEX--process expressions on the file until we're done.") (bind CH FN EXPR while (SETQ CH (SKIPSEPRCODES)) do (if (EQ CH (CHARCODE ";")) then (PFI.PASS.COMMENT) elseif (AND DONTINDEX (EQ CH (CHARCODE "("))) then (* ;; "From SEE. Want to have a look at the car so we don't take a long time reading the WHOLE expression that we can easily process in pieces, like DEFINEQ") (READCCODE) (* ; "Eat the paren") (if (AND (NOT (SYNTAXP (SKIPSEPRCODES) (QUOTE RIGHTPAREN))) (LITATOM (SETQ FN (CL:READ))) (SETQ EXPR (ASSOC FN *PFI-PREVIEWERS*))) then (* ; "Next thing was a symbol, and we have a previewer for this kind of expression--do it. SYNTAXP is just in case we encountered ( ).") (if *PFI-PENDING-COMMENTS* then (* ; "First dispose of pending comments") (PFI.PRINT.COMMENTS)) (CL:FUNCALL (CDR EXPR) FN) else (* ; "Failed--fall back on reading the whole thing") (PFI.HANDLE.EXPR (CONS FN (CL:READ-DELIMITED-LIST #\))))) elseif (OR (EQ (SETQ EXPR (CL:READ *STANDARD-INPUT* NIL *STANDARD-INPUT*)) *STANDARD-INPUT*) (EQ EXPR (QUOTE STOP))) then (* ; "Hit end of file") (RETURN) else (PFI.HANDLE.EXPR EXPR)) (BLOCK))) -) (PFI.PASS.COMMENT [LAMBDA NIL (* ; "Edited 12-Mar-93 11:09 by rmk:") (* ; "Edited 15-Apr-88 18:16 by bvm") (* ;; "Copy a semi-colon comment to the output stream") (TERPRI) (CHANGEFONT COMMENTFONT) [BIND CH DO (SETQ CH (READCCODE *STANDARD-INPUT*)) (IF [NOT (MEMB CH (CHARCODE (EOL LINEFEED] THEN (* ; "Pass a character") (\OUTCHAR *STANDARD-OUTPUT* CH) ELSE (TERPRI) (IF (NEQ (PEEKCCODE *STANDARD-INPUT* T) (CHARCODE ";")) THEN (* ; "End of comment") (RETURN] (CHANGEFONT DEFAULTFONT]) (PFI.HANDLE.EXPR -(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:56 by bvm") (* ;; "Prettyprint the expression we just read to the output file, and also do any appropriate indexing") (if (AND *PFI-PENDING-COMMENTS* (NEQ (CAR (LISTP EXPR)) COMMENTFLG)) then (* ; "Dispose of pending comments") (PFI.PRINT.COMMENTS EXPR)) (if (NLISTP EXPR) then (* ; "Not a form") (TERPRI) (PRINT EXPR) elseif (NOT (LITATOM (CAR EXPR))) then (* ; "Odd random form on file. I hope the car is actually a lambda expression") (TERPRI) (PFI.MAYBE.NEW.PAGE EXPR) (PFI.PRETTYPRINT EXPR NIL T) else (CL:FUNCALL (OR (CDR (ASSOC (CAR EXPR) *PFI-HANDLERS*)) (FUNCTION PFI.DEFAULT.HANDLER)) EXPR))) -) (PFI.DEFAULT.HANDLER -(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:54 by bvm") (* ;; "The default handler for an expression. Looks up in *PFI-TYPES* for matching entries, then prettyprints the expression.") (LET ((CAR-OF-FORM (CAR EXPR)) PAT ITEMNAME MAINITEM TESTFN TEMPLATE) (if (GET CAR-OF-FORM (CAR *PFI-DEFINER-PROPS*)) then (* ; "Put a little extra space before definers") (TERPRI)) (PFI.MAYBE.NEW.PAGE EXPR) (SETQ TEMPLATE (GET CAR-OF-FORM :DEFINITION-PRINT-TEMPLATE)) (for ENTRY in *PFI-TYPES* when (COND ((EQ (SETQ PAT (fetch (PFITYPE PATTERNS) of ENTRY)) T) (* ; "Matches anything -- TESTFN must be doing all the work") T) ((LISTP PAT) (MEMB CAR-OF-FORM PAT)) (T (EQ CAR-OF-FORM PAT))) do (SETQ TESTFN (fetch (PFITYPE TESTFN) of ENTRY)) (COND ((NULL TESTFN) (* ; "Extract default name") (if (NLISTP (SETQ ITEMNAME (if (AND TEMPLATE (MEMB :NAME TEMPLATE)) then (* ; "We're told more explicitly where the name is") (CL:NTH (CL:POSITION :NAME TEMPLATE) (CDR EXPR)) else (* ; "Name defaultly is second elt") (CADR EXPR)))) then (if (AND ITEMNAME (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) elseif (EQ (CAR ITEMNAME) (QUOTE QUOTE)) then (* ; "A quoted form, like (I.S.OPR 'COLLECT ...)") (PFI.ADD.TO.INDEX (SETQ MAINITEM (CADR ITEMNAME)) ENTRY) elseif (AND (SETQ ITEMNAME (CAR ITEMNAME)) (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (* ; "Some definer that takes a (name . options) slot here") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY))) ((SETQ ITEMNAME (CAR (NLSETQ (CL:FUNCALL TESTFN EXPR ENTRY)))) (COND ((NLISTP ITEMNAME) (* ; "Single object to be indexed as the type in ENTRY") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) (T (* ; "Index as some other type") (for PAIR in (COND ((LITATOM (CAR ITEMNAME)) (* ; "a single pair") (LIST ITEMNAME)) (T (* ; "many") ITEMNAME)) do (for NAME in (CDR PAIR) do (push *PFI-LOCATIONS* (LIST (CAR PAIR) NAME *PFI-PAGE-COUNT*)))))) (COND ((NOT (fetch (PFITYPE AMBIGUOUS?) of ENTRY)) (RETURN)))))) (PFI.PRETTYPRINT EXPR MAINITEM T))) -) (PFI.PRETTYPRINT -(LAMBDA (EXPR NAME FORMFLG) (* ; "Edited 7-Apr-88 11:06 by bvm") (* ;; "Prettyprints EXPR. NAME is the %"name%" of the thing being prettyprinted, for benefit of header hackers. FORMFLG is true if thing should be printed as code.") (LET ((*PFI-ITEM* NAME)) (PRINTDEF EXPR T FORMFLG NIL *PFI-FNSLST*)) (TERPRI)) -) (PFI.LINES.REMAINING -(LAMBDA NIL (* ; "Edited 11-Apr-88 17:23 by bvm") (* ;; "Returns number of lines left on this page, or a large number if stream does not tell us") (LET ((BOTTOM (DSPBOTTOMMARGIN))) (if (NULL BOTTOM) then 999 else (ADD1 (IQUOTIENT (- (DSPYPOSITION) BOTTOM) (- (DSPLINEFEED NIL *STANDARD-OUTPUT*))))))) -) (PFI.MAYBE.NEW.PAGE -(LAMBDA (EXPR MINLINES) (* ; "Edited 13-Apr-88 14:32 by bvm") (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") (LET (REMAINING) (if (OR (DISPLAYSTREAMP *STANDARD-OUTPUT*) (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) *PFI-MAX-WASTED-LINES*) (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR)))) then (TERPRI) else (* ; "put it on a new page") (DSPNEWPAGE)))) -) (PFI.ESTIMATE.SIZE -(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:37 by bvm") (* ;; "Guess how many lines EXPR will take, so that we can try getting it all on one page if we're near the bottom. Heuristic is that after the first list element in any element, each subsequent element gets its own line") (+ (LET ((TEMPLATE (AND (LITATOM (CAR EXPR)) (GET (CAR EXPR) :DEFINITION-PRINT-TEMPLATE)))) (if (AND TEMPLATE (MEMB :BODY TEMPLATE)) then (* ; "Make extra space for things that have body") 2 else 1)) (PFI.ESTIMATE.SIZE1 EXPR 0))) -) (PFI.ESTIMATE.SIZE1 -(LAMBDA (EXPR INITSUM) (* ; "Edited 13-Apr-88 11:24 by bvm") (* ;; "Recursive part of PFI.ESTIMATE.SIZE's heuristic. We add on to INITSUM, and stop when it looks pointless to dive deeper. Heuristic says we have a new line every time there's a list element with something after it.") (if (LISTP EXPR) then (LET ((TAIL (SOME EXPR (FUNCTION LISTP)))) (add INITSUM (LENGTH (CDR TAIL))) (until (OR (NLISTP TAIL) (> INITSUM *PFI-MAX-WASTED-LINES*)) do (SETQ INITSUM (PFI.ESTIMATE.SIZE1 (pop TAIL) INITSUM))))) INITSUM) -) ) (* ; "Expression handlers") (DEFINEQ (PFI.HANDLE.RPAQQ -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET* ((NAME (CADR EXPR)) (COMSINFO (ASSOC NAME *PFI-FILEVARS*))) (COND ((AND COMSINFO (EQ (CDR COMSINFO) (QUOTE NOBIND))) (* ; "We don't yet know the value of this filevar, so here it is.") (RPLACD COMSINFO (CADDR EXPR)) (LET ((*MAINFILECOMS* (CDAR *PFI-FILEVARS*)) VARS VALUES) (* ;; "*PFI-FILEVARS* is an alist of (filevar . value), for all filevars we've discovered so far and any values of same. Since we have newly discovered the value of this var, the INFILECOMS? below may have changed some, so reevaluate them.") (for PAIR in (CDR *PFI-FILEVARS*) unless (EQ (CDR PAIR) (QUOTE NOBIND)) do (push VARS (CAR PAIR)) (push VALUES (CDR PAIR))) (CL:PROGV VARS VALUES (SETQ *PFI-FNSLST* (APPEND (INFILECOMS? NIL (QUOTE FNS) *MAINFILECOMS*) (INFILECOMS? NIL (QUOTE FUNCTIONS) *MAINFILECOMS*))) (for FV in (INFILECOMS? NIL (QUOTE FILEVARS) *MAINFILECOMS*) unless (OR (ASSOC FV *PFI-FILEVARS*) (BOUNDP FV)) do (* ;; "Add to the list any new filevars uncovered by this evaluation. Don't bother if they're already bound in the sysout, since then their values have already been made use of.") (push (CDR *PFI-FILEVARS*) (CONS FV (QUOTE NOBIND)))))))) (if (NEQ NAME (CAAR *PFI-FILEVARS*)) then (* ; "Don't bother indexing the main COMS") (PFI.ADD.TO.INDEX NAME (QUOTE VARIABLES))) (PFI.PRETTYPRINT EXPR NAME))) -) (PFI.HANDLE.DECLARE -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:33 by bvm") (* ;; "Handle (DECLARE: tags coms ...)") (if (NOT (LET ((TAIL (CDR EXPR))) (* ;; "Filter out (DECLARE: DONTCOPY (FILEMAP --))") (AND (LISTP TAIL) (EQ (pop TAIL) (QUOTE DONTCOPY)) (LISTP TAIL) (EQ (CAR (LISTP (pop TAIL))) (QUOTE FILEMAP)) (NULL TAIL)))) then (TERPRI) (PRIN1 "(") (PROG (STARTOFLINE NEXT) TOP (SETQ STARTOFLINE T) NEXTITEM (if (NLISTP EXPR) then (* ; "Done, except for possible malformed dotted tail") (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI) (RETURN)) (if (NLISTP (SETQ NEXT (pop EXPR))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) (GO NEXTITEM)) (* ;; "Have an interesting com, so go to new line and process it") (TERPRI) (do (PFI.HANDLE.EXPR NEXT) repeatwhile (AND (LISTP EXPR) (LISTP (SETQ NEXT (pop EXPR))))) (GO TOP)))) -) (PFI.HANDLE.EVAL-WHEN -(LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:51 by bvm") (* ;; "Handle EVAL-WHEN. This is a lot like DECLARE: -- the inner expressions get treated as top-level.") (PFI.MAYBE.NEW.PAGE NIL (+ 2 (PFI.ESTIMATE.SIZE (CADDR EXPR)))) (* ; "Make space for the first expression, plus the eval-when & .. line") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (PRINT (pop EXPR)) (while (LISTP EXPR) do (PFI.HANDLE.EXPR (pop EXPR))) (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI)) -) (PFI.HANDLE.DEFDEFINER -(LAMBDA (EXPR) (* ; "Edited 12-Apr-88 11:16 by bvm") (* ;; "Notice DEFDEFINER expressions. We don't actually evaluate them (let's not side-effect the environment too much), but notice that we should index them and that they should prettyprint interestingly.") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((DEFINER (CADR EXPR)) OPTIONS) (if (LISTP DEFINER) then (SETQ OPTIONS (CDR DEFINER)) (SETQ DEFINER (CAR DEFINER))) (if (NOT (LITATOM DEFINER)) then (* ; "Bogus") (SETQ DEFINER NIL) elseif *PFI-TYPES* then (* ; "We're indexing, maybe add this type") (if (NOT (for ENTRY in *PFI-TYPES* thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))) then (* ; "We don't know about this one yet") (push *PFI-TYPES* (create PFITYPE NAME _ (CADDR EXPR) PATTERNS _ DEFINER TESTFN _ (CADR (ASSOC :NAME OPTIONS))))) (if (NOT (ASSOC DEFINER PRETTYPRINTMACROS)) then (* ; "Help it prettyprint better") (push PRETTYPRINTMACROS (CONS DEFINER (CL:INTERN "PPRINT-DEFINER" (CL:FIND-PACKAGE (if (EQ MAKESYSNAME :LYRIC) then "IL" else "XCL"))))) (if (AND (SETQ OPTIONS (ASSOC :TEMPLATE OPTIONS)) (NOT (GET DEFINER :DEFINITION-PRINT-TEMPLATE))) then (PUT DEFINER :DEFINITION-PRINT-TEMPLATE (CADR OPTIONS)))) (PFI.ADD.TO.INDEX DEFINER (QUOTE DEFINERS))) (PFI.PRETTYPRINT EXPR DEFINER T))) -) (PFI.HANDLE.DEFINEQ -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:34 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...)") (TERPRI) (PRIN1 "(") (PRINT (CAR EXPR)) (for DEF in (CDR EXPR) do (PFI.PRINT.LAMBDA DEF)) (PRIN1 ")") (TERPRI)) -) (PFI.PRINT.LAMBDA -(LAMBDA (DEF) (* ; "Edited 11-Apr-88 17:21 by bvm") (* ;; "Print one piece of a DEFINEQ. DEF is (fn (lambda ...)).") (PFI.MAYBE.NEW.PAGE NIL (PFI.ESTIMATE.SIZE1 (CDR DEF) 3)) (LET ((*PFI-ITEM* (CAR DEF))) (PFI.ADD.TO.INDEX *PFI-ITEM* (QUOTE FUNCTIONS)) (PFI.PRINT.LAMBDA.BODY DEF *PFI-FNSLST*)) (TERPRI) (TERPRI)) -) (PFI.PRINT.LAMBDA.BODY -(LAMBDA (DEF FNSLST) (* ; "Edited 29-Mar-88 18:46 by bvm") (* ;; "Just the stuff that prints a lambda form. DEF = (name (lambda ...))") (PRIN1 "(") (CHANGEFONT (OR LAMBDAFONT BOLDFONT)) (PRIN2 (CAR DEF)) (CHANGEFONT DEFAULTFONT) (TERPRI) (SPACES 2) (PRINTDEF (CDR DEF) T (QUOTE FNS) T FNSLST) (PRIN1 ")")) -) (PFI.HANDLE.PUTDEF -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:10 by bvm") (* ;; "Called to handle PUTDEF. If in form (PUTDEF 'name 'type 'value), we can index name by type.") (PFI.MAYBE.NEW.PAGE EXPR) (DESTRUCTURING-BIND (NAME TYPE) EXPR (PFI.PRETTYPRINT EXPR (if (AND (LISTP NAME) (EQ (CAR NAME) (QUOTE QUOTE)) (LISTP TYPE) (EQ (CAR TYPE) (QUOTE QUOTE)) (LITATOM (SETQ TYPE (CADR TYPE)))) then (PFI.ADD.TO.INDEX (SETQ NAME (CADR NAME)) TYPE) (* ; "Yes, it is a quoted form we like") NAME)))) -) (PFI.HANDLE.PUTPROPS -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((NAME (CADR EXPR)) (PROP (CADDR EXPR)) TYPE) (* ; "See if PROP means something more specific than 'property'") (PFI.PRETTYPRINT EXPR (if (AND (LITATOM NAME) (SETQ TYPE (COND ((MEMB PROP MACROPROPS) (QUOTE MACRO)) (T (for PAIR in *PFI-PROPERTIES* when (EQ (CAR PAIR) PROP) do (* ; "Index it under this other type") (RETURN (CADR PAIR)) finally (* ; "Nothing better, so index it as having a property") (RETURN (QUOTE PROPERTY))))))) then (PFI.ADD.TO.INDEX NAME TYPE) (* ; "Yes, can name it this") NAME)))) -) (PFI.HANDLE./DECLAREDATATYPE -(LAMBDA (EXPR) (* ; "Edited 13-Apr-88 11:29 by bvm") (* ;; "No point in wasting space printing the entirely redundant list of field descriptors from (/DECLAREDATATYPE typename fieldspecs fielddescriptors len supertype)") (PFI.MAYBE.NEW.PAGE EXPR 2) (PFI.PRETTYPRINT (if (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR)))))) then (* ; "Well-formed--bash the third argument") (LIST* (pop EXPR) (pop EXPR) (pop EXPR) (LIST (QUOTE *) (QUOTE ;;) "---field descriptor list elided by lister---") (CDR EXPR)) else EXPR) NIL T)) -) (PFI.HANDLE.* -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:38 by bvm") (* ;; "Handle * comments found at top level. Turn single-semis into double semis so that they print at the left. Save all comments until the next non-comment so we can achieve some locality.") (LET* ((NSEMIS (SEMI-COLON-COMMENT-P EXPR)) (LINEGUESS (+ (CL:CEILING (STRINGWIDTH (if NSEMIS then (CADDR EXPR) else (CDR EXPR)) *STANDARD-OUTPUT*) (TIMES (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) 0.9)) (if (AND NSEMIS (< NSEMIS 3)) then 1 else 2)))) (CASE NSEMIS (1 (* ; "Make it 2 semis") (SETQ EXPR (LIST* (QUOTE *) (QUOTE ;;) (CDDR EXPR)))) ((NIL) (* ; "Interlisp style") (if (NLISTP (CDR EXPR)) elseif (AND (NULL (CDDR EXPR)) (STRINGP (CADR EXPR))) then (* ; "Body is a string, so can print with superior semi-colon printer") (SETQ EXPR (LIST (QUOTE *) (QUOTE ;;) (CADR EXPR))) elseif (NEQ (CADR EXPR) COMMENTFLG) then (* ; "Turn single * into double star so it prints centered") (SETQ EXPR (LIST* (QUOTE *) (QUOTE *) (CDR EXPR)))))) (* ;; "Now don't print the comment yet, since we'd like it to attach to what follows") (if *PFI-PENDING-COMMENTS* then (add (CAR *PFI-PENDING-COMMENTS*) LINEGUESS) (NCONC1 *PFI-PENDING-COMMENTS* EXPR) else (SETQ *PFI-PENDING-COMMENTS* (LIST LINEGUESS EXPR))))) -) (PFI.PRINT.COMMENTS -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:27 by bvm") (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") (TERPRI) (DESTRUCTURING-BIND (LINES . BODIES) *PFI-PENDING-COMMENTS* (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (LET ((REMAINING (PFI.LINES.REMAINING))) (if (OR (>= LINES REMAINING) (AND (< REMAINING *PFI-MAX-WASTED-LINES*) (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) LINES)))) then (* ; "put it on a new page") (DSPNEWPAGE)))) (for B in BODIES do (PRINTDEF B T T) (if (> (DSPXPOSITION) (DSPLEFTMARGIN)) then (* ; "Go to new line for next comment. Usually this has already been done") (TERPRI))) (SETQ *PFI-PENDING-COMMENTS* NIL))) -) (PFI.HANDLE.FILEMAP -(LAMBDA (EXPR) (* ; "Edited 31-Mar-88 15:28 by bvm") (* ;; "Only get here from declare: previewer (during SEE), since declare: expression handler filters out the whole thing.") (PFI.PRETTYPRINT (LIST (QUOTE *) (QUOTE ;;) "---Filemap elided by lister---") NIL T)) -) (PFI.HANDLE.PACKAGE -(LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:38 by bvm") (* ;; "Handler for package-related functions, such as in-package, import, export, etc. Eval the form so that the package environment is set correctly for what follows.") (CL:EVAL EXPR) (TERPRI) (PFI.PRETTYPRINT EXPR NIL T)) -) ) (* ; "Previewers") (DEFINEQ (PFI.PREVIEW.DECLARE -(LAMBDA (FN) (* ; "Edited 1-Apr-88 11:27 by bvm") (* ;; "Handle (DECLARE: tags coms ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRIN2 FN) (bind STARTOFLINE NEXT until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (if (NLISTP (SETQ NEXT (READ))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) else (* ; "Have an interesting com") (if (NOT STARTOFLINE) then (TERPRI) (* ; "Start expressions on new line") (SETQ STARTOFLINE T)) (PFI.HANDLE.EXPR NEXT)) finally (READCCODE) (* ; "Eat the closing paren") (PRIN1 ")") (TERPRI))) -) (PFI.PREVIEW.DEFINEQ -(LAMBDA (FN) (* ; "Edited 8-Apr-88 16:38 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRINT FN) (until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (PFI.PRINT.LAMBDA (READ))) (READCCODE) (* ; "Consume the paren") (PRIN1 ")") (TERPRI)) -) ) (* ; "Printing the index") (DEFINEQ (PFI.PRINT.INDEX -(LAMBDA (CRDATE) (* ; "Edited 16-May-88 15:48 by bvm") (* ;; "Compute the indices from the entries we have accumulated, print them, and return them (for multifileindex)") (LET ((LASTPAGE *PFI-PAGE-COUNT*) (*PFI-ITEM* :INDEX)) (LET ((*PFI-TITLE* NIL)) (* ; "Leave off the heading on the first index page, since it is intended to be the cover page--will have the title centered.") (DSPNEWPAGE) (COND ((AND *PFI-TWO-SIDED* (ODDP LASTPAGE)) (* ; "Ensure that the index will not be on the back-side of a two-sided listing") (DSPNEWPAGE)))) (PROGN (* ; "Print title.") (PFI.CENTER.PRINT (LIST *PFI-TITLE* CRDATE) T) (PFI.CENTER.PRINT (CONCAT "-- Listed on " (DATE) " --"))) (LET ((LINESPERPAGE (PFI.LINES.REMAINING)) (INDICES (PFI.CONDENSE.INDEX *PFI-LOCATIONS* LASTPAGE))) (PFI.PRINT.INDICES (APPEND INDICES) LINESPERPAGE) INDICES))) -) (PFI.CONDENSE.INDEX -(LAMBDA (TRIPLES LASTPAGE) (* ; "Edited 12-May-88 13:07 by bvm") (* ;; "Condense TRIPLES into a set of indices, one per type. Each element is of the form (type name page), while the resulting indices are of the form (type entries . shape), with each entry looking like (name . pagenumbers). LASTPAGE is maximum page number (for gauging space).") (LET (*PFI-INDEX-ALIST* INDEX OLDNAME) (* ; "*PFI-INDEX-ALIST* is special so filters can look up entries") (for TRIP in TRIPLES do (* ; "Distribute to the correct type") (COND ((NULL (SETQ INDEX (ASSOC (CAR TRIP) *PFI-INDEX-ALIST*))) (push *PFI-INDEX-ALIST* (SETQ INDEX (LIST (CAR TRIP)))))) (COND ((SETQ OLDNAME (ASSOC (CADR TRIP) INDEX)) (* ; "Duplicate entry, so add a page number") (RPLACD OLDNAME (SORT (UNION (CDDR TRIP) (CDR OLDNAME))))) (T (push (CDR INDEX) (CDR TRIP))))) (* ;; "Now remove redundancies") (for TYPEPAIR in *PFI-INDEX-ALIST* bind FILTERS when (SETQ FILTERS (for FILTER in *PFI-FILTERS* collect (CDR FILTER) when (EQ (CAR FILTER) (CAR TYPEPAIR)))) do (* ; "Each filter is either a type name or a list whose car is a function") (RPLACD TYPEPAIR (for PAIR in (CDR TYPEPAIR) collect PAIR unless (for F in FILTERS thereis (COND ((NLISTP F) (* ; "Name exists as another type") (PFI.LOOKUP.NAME (CAR PAIR) F)) (T (CL:FUNCALL (CAR F) PAIR))))))) (PFI.SORT.INDICES (for TYPEPAIR in *PFI-INDEX-ALIST* when (CDR TYPEPAIR) collect (* ;; "Sort them and lay them out, changing format to (type entries . shape). Shape = (#rows #columns colwidth). WHEN is because filters could have removed everyone from a type.") (RPLACD TYPEPAIR (CONS (SORT (CDR TYPEPAIR) (FUNCTION (LAMBDA (X Y) (* ; "Sort case-insensitively by CAR") (ALPHORDER (CAR X) (CAR Y) UPPERCASEARRAY)))) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) LASTPAGE))))))) -) (PFI.SORT.INDICES -(LAMBDA (INDICES) (* ; "Edited 12-May-88 12:37 by bvm") (* ;; "INDICES is a list of (TYPE INDEXPAIRS . SHAPE). Sort them into a preferred order of printing.") (if (NULL (CDR INDICES)) then INDICES else (LET ((RESULT (for X in INDICES bind PRIORITY when (SETQ PRIORITY (CL:POSITION (CAR X) *PFI-INDEX-ORDER*)) collect (* ; "Gather up the types that the user-specified order handles") (CONS PRIORITY X)))) (if RESULT then (* ; "Sort them by priority") (SETQ RESULT (MAPCAR (SORT RESULT (FUNCTION (LAMBDA (X Y) (< (CAR X) (CAR Y))))) (FUNCTION CDR))) (* ; "Then remove them from the master list") (SETQ INDICES (CL:SET-DIFFERENCE INDICES RESULT))) (* ;; "Finally, sort remaining indices by decreasing size to facilitate indexer's selection. Leave a marker in between so we can tell the difference between required order and optional.") (NCONC RESULT (LIST T) (SORT INDICES (FUNCTION (LAMBDA (X Y) (LET ((ROWDIF (- (CADDR X) (CADDR Y)))) (if (> ROWDIF 0) then (* ; "X has more rows than Y") T elseif (EQ ROWDIF 0) then (* ; "If same number of rows, go for more items") (> (LENGTH (CADR X)) (LENGTH (CADR Y)))))))))))) -) (PFI.COMPUTE.INDEX.SHAPE -(LAMBDA (INDEXPAIRS MAXINDEXNO) (* ; "Edited 11-May-88 19:06 by bvm") (* ;; "Figures out how to lay out INDEXPAIRS, given that the largest possible page number is MAXINDEXNO. Returns a list (nrows ncolumns colwidth).") (LET ((INDEXNOWIDTH (AND MAXINDEXNO (COND ((< MAXINDEXNO 10) 1) ((< MAXINDEXNO 100) 2) (T (NCHARS MAXINDEXNO))))) (INDEXLEN (LENGTH INDEXPAIRS)) NROWS NCOLUMNS WIDTH) (SETQ WIDTH (+ (for PAIR in INDEXPAIRS largest (+ (NCHARS (CAR PAIR) T) (COND ((CDDR PAIR) (* ;; "Multiple page nos--turn into printed rep") (PROG1 (NCHARS (CAR (RPLACA (CDR PAIR) (CONCATLIST (CDR (for P in (CDR PAIR) join (LIST "," P))))))) (RPLACD (CDR PAIR) NIL))) ((STRINGP (CADR PAIR)) (* ; "It's already a string") (NCHARS (CADR PAIR))) (T INDEXNOWIDTH))) finally (RETURN $$EXTREME)) 1)) (* ; "WIDTH is the widest any entry gets: name plus page numbers. Conservative in that we assume page numbers can take up as much space as the largest") (SETQ NCOLUMNS (MAX 1 (MIN INDEXLEN (IQUOTIENT (LINELENGTH) (+ WIDTH 2))))) (* ; "Number of columns that fit if you allow 2 spaces between columns") (SETQ NROWS (CL:CEILING INDEXLEN NCOLUMNS)) (* ;; "Finally recompute NCOLUMNS. This might reduce the number of columns if all the items, printed in NROWS rows, take fewer columns than originally allocated. E.g. 11 items in 5 cols take 3 rows, but in 3 rows you only need 4 cols to print 11 items.") (LIST NROWS (CL:CEILING INDEXLEN NROWS) WIDTH))) -) (PFI.PRINT.INDICES -(LAMBDA (INDICES LINESPERPAGE) (* ; "Edited 16-May-88 15:45 by bvm") (* ;; "Print a set of INDICES. LINESPERPAGE is number of lines we expect to fit per page not counting page headers.") (PROG ((HALFPAGE (IQUOTIENT LINESPERPAGE 2)) (LINELEN (LINELENGTH)) (SPACEWIDTH (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) (LINESREMAINING (- (PFI.LINES.REMAINING) 2)) ITEM FREECHOICE PREVITEM) NEWPAGE (* ;; "At this point we are at the top of a page") (TERPRI) (PFI.INDEX.BREAK) TOP (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (NULL FREECHOICE) then (* ; "Have to take the first batch in order") (SETQ ITEM (pop INDICES)) (if (EQ ITEM T) then (* ; "Marks start of optional order. Items from here on are sorted by decreasing size, but we can print them in any order we want") (SETQ FREECHOICE T) (GO TOP)) elseif (SETQ ITEM (find X in INDICES suchthat (<= (CADDR X) (- LINESREMAINING 5)))) then (* ; "Found an item that fits") (SETQ INDICES (DREMOVE ITEM INDICES)) elseif (OR (> LINESREMAINING HALFPAGE) (> (+ (CADDR (CAR (LAST INDICES))) 7) LINESPERPAGE)) then (* ; "Print something here anyway, since we're either less than halfway down the page, or the smallest index doesn't fit on a page") (SETQ ITEM (pop INDICES)) else (* ; "Start a new page and try again") (GO STARTNEWPAGE)) (DESTRUCTURING-BIND (TYPE INDEXPAIRS NROWS NCOLUMNS COLWIDTH) ITEM (PROG ((NROWSREMAINING NROWS) LASTITEM SPACING) (if (AND (EQ NROWS 1) PREVITEM (<= COLWIDTH (CADR PREVITEM)) (<= NCOLUMNS (CAR PREVITEM))) then (* ; "There's only one row, so it would be nice if it could line up with another index. Can do this if this column width is not larger than previous. PREVITEM = (ncolumns colwidth spacing ...)") (SETQ COLWIDTH (CADR PREVITEM)) (SETQ SPACING (CADDR PREVITEM)) else (LET ((NC NCOLUMNS)) (if (OR (NEQ NC 1) (if (< COLWIDTH (IQUOTIENT LINELEN 2)) then (* ; "format as if 2 columns") (SETQ NC 2) else (* ; "Too wide for 2 columns, so use whole width") (SETQ COLWIDTH LINELEN) (SETQ SPACING 0) NIL)) then (* ; "Divide the excess space up between dots and intercolumn spacing") (SETQ COLWIDTH (MIN (PROGN (* ; "Add to COLWIDTH half the excess space") (+ COLWIDTH (IQUOTIENT (- LINELEN (TIMES (+ COLWIDTH 2) NC)) 2))) (PROGN (* ; "Allow 2 spaces between columns") (- (IQUOTIENT LINELEN NC) 2)))) (SETQ SPACING (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN) (TIMES COLWIDTH NC SPACEWIDTH)) (SUB1 NC)))) (SETQ PREVITEM (LIST NC COLWIDTH SPACING)))) (if (AND (> (+ NROWS 5) LINESREMAINING) (< LINESREMAINING HALFPAGE) (<= (+ NROWS 8) LINESPERPAGE)) then (* ;; "This index doesn't fit on the page, we've filled less than half the page, and the index would fit starting on a new page. Each index takes 5 additional lines: blank, heading, blank blank breakline. If on a new page it would take 3 more (blank breakline blank).") (DSPNEWPAGE) (* ; "Start new page") (TERPRI) (* ; "Make top breaklines line up on all index pages") (PFI.INDEX.BREAK) (SETQ LINESREMAINING (- LINESPERPAGE 2))) (TERPRI) (PFI.CENTER.PRINT (CONCAT (if (AND (EQ (NTHCHARCODE TYPE -1) (CHARCODE S)) (NEQ (NTHCHARCODE TYPE -2) (CHARCODE S)) (NOT (STRPOS "IE" TYPE -3))) then (* ; "Turn plural type into singular. Second clause filters out DROSS and CANDIES.") (SUBSTRING TYPE 1 -2) else TYPE) " INDEX") T) (CHANGEFONT DEFAULTFONT) (TERPRI) (SETQ LINESREMAINING (- LINESREMAINING 3)) (while INDEXPAIRS do (SETQ NROWS (IMIN NROWSREMAINING (- LINESREMAINING 1))) (for ROW from 1 to NROWS bind NEXTINDEX do (SETQ NEXTINDEX ROW) (for COLUMN from 1 to NCOLUMNS do (COND ((SETQ LASTITEM (FNTH INDEXPAIRS NEXTINDEX)) (DESTRUCTURING-BIND (LABEL PAGENO) (CAR LASTITEM) (PRIN2 LABEL) (SPACES 1) (FRPTQ (- COLWIDTH (ADD1 (NCHARS LABEL T)) (NCHARS PAGENO)) (\OUTCHAR *STANDARD-OUTPUT* (CHARCODE %.))) (PRIN1 PAGENO) (COND ((NEQ COLUMN NCOLUMNS) (RELMOVETO SPACING 0)))))) (add NEXTINDEX NROWS)) (TERPRI)) (COND ((SETQ INDEXPAIRS (CDR LASTITEM)) (DSPNEWPAGE) (TERPRI) (SETQ LINESREMAINING (- LINESPERPAGE 1)) (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) NCOLUMNS)))) (T (SETQ LINESREMAINING (- LINESREMAINING NROWS))))) (TERPRI) (PFI.INDEX.BREAK T) (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (< (SETQ LINESREMAINING (- LINESREMAINING 2)) 6) then (* ; "No room left here, go to new page. ") (GO STARTNEWPAGE) else (* ; "T in PFI.INDEX.BREAK told it to hold the terpri") (TERPRI)))) (GO TOP) STARTNEWPAGE (DSPNEWPAGE) (SETQ LINESREMAINING (- LINESPERPAGE 2)) (* ; "Account for the break line and blank line we are about to print") (GO NEWPAGE))) -) (PFI.CENTER.PRINT -(LAMBDA (STR BOLDFLG) (* ; "Edited 30-Mar-88 14:31 by bvm") (LET ((LMAR (DSPLEFTMARGIN)) GAP) (if BOLDFLG then (CHANGEFONT BOLDFONT)) (DSPXPOSITION (+ LMAR (IQUOTIENT (- (DSPRIGHTMARGIN) LMAR (if (LISTP STR) then (+ (TIMES (SUB1 (LENGTH STR)) (SETQ GAP (TIMES (DSPSCALE) 16))) (for X in STR sum (STRINGWIDTH X *STANDARD-OUTPUT*))) else (STRINGWIDTH STR *STANDARD-OUTPUT*))) 2))) (if (LISTP STR) then (for TAIL on STR do (PRIN3 (CAR TAIL)) (AND (CDR TAIL) (RELMOVETO GAP 0))) else (PRIN3 STR)) (if BOLDFLG then (CHANGEFONT DEFAULTFONT)) (TERPRI))) -) (PFI.INDEX.BREAK -(LAMBDA (NOTERPRI) (* ; "Edited 11-Apr-88 16:47 by bvm") (* ;; "Draw the line separating one type index from the next. NOTERPRI suppresses the new line") (LET* ((OLDY (DSPYPOSITION)) (Y (+ (- OLDY (FONTPROP *STANDARD-OUTPUT* (QUOTE DESCENT))) (IQUOTIENT (- (DSPLINEFEED)) 2)))) (* ; "Draw a horizontal line centered on this line") (DRAWLINE (DSPLEFTMARGIN) Y (DSPRIGHTMARGIN) Y (DSPSCALE)) (DSPYPOSITION OLDY)) (OR NOTERPRI (TERPRI))) -) (PFI.LOOKUP.NAME -(LAMBDA (NAME TYPE) (* ; "Edited 25-Mar-88 14:07 by bvm") (ASSOC NAME (CDR (ASSOC TYPE *PFI-INDEX-ALIST*)))) -) ) (DEFINEQ (PFI.ADD.TO.INDEX -(LAMBDA (NAME TYPE/ENTRY) (* ; "Edited 6-Apr-88 16:15 by bvm") (* ;; "Add to the index an entry for NAME of type TYPE/ENTRY. TYPE/ENTRY can be an element of *pfi-types*, in which case we use its type name component.") (if (NEQ *PFI-LOCATIONS* :NONE) then (push *PFI-LOCATIONS* (LIST (if (NLISTP TYPE/ENTRY) then (* ; "the type directly") TYPE/ENTRY else (* ; "a types triple") (LET ((TYPE (fetch (PFITYPE NAME) of TYPE/ENTRY))) (OR (CAR (LISTP TYPE)) TYPE))) NAME *PFI-PAGE-COUNT*)))) -) (PFI.VARNAME -(LAMBDA (EXPR) (* ; "Edited 24-Mar-88 16:09 by bvm") (* ;;; "Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR. Filters after the fact will remove duplications with other variable types") (LET ((NAME (CADR EXPR))) (* ; "Ignore compiler-internal vars") (AND (LITATOM NAME) (NEQ NAME T) (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA)))) NAME))) -) (PFI.CONSTANTNAMES -(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 14:24 by bvm") (* ;;; "Called when expression is (CONSTANTS --) -- return all elements (or CAR of element when it's a pair) as type CONSTANTS") (CONS (QUOTE CONSTANTS) (for X in (CDR EXPR) collect (COND ((LISTP X) (CAR X)) (T X))))) -) ) (* ; "Combined listings") (DEFINEQ (MULTIFILEINDEX -(LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 20-May-88 14:08 by bvm") (* ;; "Produce a pretty file index listing for each of FILES, plus a master index for the set") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (SETQ FILES (for F inside FILES join (if (STRPOS "*" F) then (* ; "Enumerate a pattern--default extension to null and version to highest") (DIRECTORY (DIRECTORY.FILL.PATTERN F "" "")) elseif (LISTP F) then (* ; "Hack that says don't print these") (for FL in F collect (LIST (OR (FINDFILE FL T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FL)))) else (LIST (OR (FINDFILE F T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME F)))))) (COND (*PFI-DONT-SPAWN* (MULTIFILEINDEX1 FILES PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MULTIFILEINDEX1) FILES PRINTOPTIONS)) FILES)))) -) (MULTIFILEINDEX1 -(LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 19-May-88 12:35 by bvm") (* ;; "Pretty list each of the files in FILES, followed by master index") (LET ((CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) INDICES OPTIONS NOTPRINTED) (SETQ PRINTOPTIONS (LIST* (QUOTE MULTIFILEINDEX) T PRINTOPTIONS)) (* ; "Our own option") (for TAIL on FILES as I from 1 do (* ; "Print and gather indices for all but last file") (SETQ OPTIONS (if CONSECUTIVE then (* ; "Tell it which page to start on") (LIST* :FIRSTPAGE (if INDICES then (* ; "One past the end of the last one") (ADD1 (CADDR (CAAR INDICES))) else 1) PRINTOPTIONS) else (* ; "Tell it which part to work on") (LIST* :PART I PRINTOPTIONS))) (push INDICES (if (SETQ NOTPRINTED (LISTP (CAR TAIL))) then (* ; "Go thru the motions but don't print it") (PRETTYFILEINDEX (CAAR TAIL) (LIST* :DONTPRINT T OPTIONS)) else (if (NULL (CDR TAIL)) then (* ; "When printing last file, send along all the indices for a combined listing") (RPLACA (CDR PRINTOPTIONS) (REVERSE INDICES))) (PRETTYFILEINDEX (CAR TAIL) OPTIONS)))) (IF NOTPRINTED THEN (* ; "The last file wasn't printed, so have to make index on our own") (LET* ((*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS (QUOTE %#SIDES)) EMPRESS#SIDES) 2)) (*STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM (LIST* (QUOTE DOCUMENT.NAME) (QUOTE INDEX) PRINTOPTIONS)))) (CL:UNWIND-PROTECT (PFI.PRINT.MULTI.INDEX (REVERSE INDICES) PRINTOPTIONS) (CLOSEF *STANDARD-OUTPUT*)))))) -) (PFI.PRINT.MULTI.INDEX -(LAMBDA (INDEXENTRIES PRINTOPTIONS) (* ; "Edited 19-May-88 17:37 by bvm") (* ;; "Print the master index for a set of indexed files. INDEXENTRIES has one element per file, each of the form ((filename creationdate lastpage# env) . indices), the indices having come out of PFI.PRINT.INDEX") (LET ((MAXNAME 0) (MAXDATE 0) (CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) (ENV (LISTGET PRINTOPTIONS :ENVIRONMENT)) BESTPACKAGE BESTREADTABLE MAXPAGE# MASTERINDICES LINESPERPAGE NAMES&DATES) (STREAMPROP *STANDARD-OUTPUT* (QUOTE AFTERNEWPAGEFN) NIL) (* ; "No more header hacking") (IF (NEQ (LISTGET PRINTOPTIONS (QUOTE MULTIFILEINDEX)) T) THEN (* ; "If it was T, then we must be called from MULTFILEINDEX1 to print only the index, so are on the first page right now.") (DSPNEWPAGE) (* ; "Start a new page") (if (AND *PFI-TWO-SIDED* (ODDP *PFI-PAGE-COUNT*)) then (* ; "Ensure that the master index will not be on the back-side of a two-sided listing") (DSPNEWPAGE))) (SETQ LINESPERPAGE (PFI.LINES.REMAINING)) (PFI.CENTER.PRINT (CONCAT "Master index generated on " (DATE (DATEFORMAT NO.SECONDS)))) (TERPRI) (CHANGEFONT BOLDFONT) (for PAIR in INDEXENTRIES as I from 1 bind PREFIX MASTERENTRY FILEINFO E TEM do (push NAMES&DATES (SETQ FILEINFO (CAR PAIR))) (* ; "FILEINFO = (name date last# env)") (SETQ MAXNAME (MAX MAXNAME (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXDATE (MAX MAXDATE (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXPAGE# (POP FILEINFO)) (if (NOT ENV) then (SETQ E (CAR FILEINFO)) (if (SETQ TEM (ASSOC (fetch REPACKAGE of E) BESTPACKAGE)) then (add (CDR TEM) 1) else (push BESTPACKAGE (CONS (fetch REPACKAGE of E) 1))) (if (SETQ TEM (ASSOC (fetch REREADTABLE of E) BESTREADTABLE)) then (add (CDR TEM) 1) else (push BESTREADTABLE (CONS (fetch REREADTABLE of E) 1)))) (if (NOT CONSECUTIVE) then (* ; "This gets in front of all page#s") (SETQ PREFIX (CONCAT I "-"))) (for INDEX in (CDR PAIR) unless (EQ INDEX T) do (* ; "INDEX = (type pairs . shape). T is a separator that we no longer care about.") (if (NOT CONSECUTIVE) then (* ; "Prefix page numbers with file number") (for INDEXITEM in (CADR INDEX) do (RPLACA (CDR INDEXITEM) (CONCAT PREFIX (CADR INDEXITEM))))) (if (NULL (SETQ MASTERENTRY (ASSOC (CAR INDEX) MASTERINDICES))) then (* ; "Haven't seen any yet, just store it") (push MASTERINDICES (CONS (CAR INDEX) (CADR INDEX))) else (* ; "Merge with what's there") (RPLACD MASTERENTRY (PFI.MERGE.INDICES (CDR MASTERENTRY) (CADR INDEX)))))) (LET* ((LEFT (DSPLEFTMARGIN)) (FATSPACE (TIMES (DSPSCALE) 8)) (RANGEWIDTH (if CONSECUTIVE then (+ (STRINGWIDTH "[-]" *STANDARD-OUTPUT*) (TIMES (+ FATSPACE (STRINGWIDTH MAXPAGE# *STANDARD-OUTPUT*)) 2)) else (* ; "No page ranges to print") FATSPACE)) (DIGITSWIDTH (STRINGWIDTH "99." *STANDARD-OUTPUT*)) (MAXWIDTH (+ DIGITSWIDTH RANGEWIDTH MAXNAME FATSPACE FATSPACE MAXDATE)) (LINEWIDTH (- (DSPRIGHTMARGIN) LEFT)) (LASTPAGE 0) TAB1 TAB2 TAB3 TEM) (if (< MAXWIDTH LINEWIDTH) then (SETQ TAB1 (+ LEFT DIGITSWIDTH (IQUOTIENT (- LINEWIDTH MAXWIDTH) 2))) (* ; "Digit flush against here") (SETQ TAB2 (+ TAB1 RANGEWIDTH)) (* ; "Name starts here") (SETQ TAB3 (+ TAB2 MAXNAME FATSPACE FATSPACE MAXDATE)) (* ; "Date flush right here")) (for N&D in (REVERSE NAMES&DATES) as I from 1 do (CHANGEFONT BOLDFONT) (SETQ TEM (CONCAT I ".")) (if TAB1 then (DSPXPOSITION (- TAB1 (STRINGWIDTH TEM *STANDARD-OUTPUT*)))) (PRIN3 TEM) (if CONSECUTIVE then (SETQ TEM (CONCAT "[" (LOGOR (+ LASTPAGE 1) (if *PFI-TWO-SIDED* then 1 else 0)) "-" (SETQ LASTPAGE (CADDR N&D)) "]")) (if TAB2 then (DSPXPOSITION (+ TAB1 (IQUOTIENT (- RANGEWIDTH (STRINGWIDTH TEM *STANDARD-OUTPUT*)) 2)))) (PRIN3 TEM)) (if TAB2 then (DSPXPOSITION TAB2) else (RELMOVETO FATSPACE 0)) (PRIN3 (CAR N&D)) (if TAB3 then (DSPXPOSITION (- TAB3 (STRINGWIDTH (CADR N&D) *STANDARD-OUTPUT*))) else (RELMOVETO FATSPACE 0)) (PRIN3 (CADR N&D)) (CHANGEFONT DEFAULTFONT) (TERPRI))) (for TYPEPAIR in MASTERINDICES do (* ;; "Now that each index is complete, turn (type . indices) into (type indices . shape)") (RPLACD TYPEPAIR (CONS (CDR TYPEPAIR) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) MAXPAGE#)))) (if (NOT ENV) then (SETQ BESTPACKAGE (PFI.CHOOSE.BEST BESTPACKAGE)) (SETQ BESTREADTABLE (PFI.CHOOSE.BEST BESTREADTABLE)) elseif (TYPENAMEP ENV (QUOTE READER-ENVIRONMENT)) then (SETQ BESTPACKAGE (fetch REPACKAGE of ENV)) (SETQ BESTREADTABLE (fetch REREADTABLE of ENV)) else (SETQ BESTPACKAGE (LISTGET ENV :PACKAGE)) (if (LISTP BESTPACKAGE) then (SETQ BESTPACKAGE (EVAL BESTPACKAGE))) (if (NOT (OR (CL:PACKAGEP BESTPACKAGE) (SETQ BESTPACKAGE (CL:FIND-PACKAGE BESTPACKAGE)))) then (SETQ BESTPACKAGE (CL:ERROR "No valid package in environment ~S" ENV))) (SETQ BESTREADTABLE (LISTGET ENV :READTABLE)) (if (LISTP BESTREADTABLE) then (SETQ BESTREADTABLE (EVAL BESTREADTABLE))) (if (NOT (OR (READTABLEP BESTREADTABLE) (SETQ BESTREADTABLE (FIND-READTABLE BESTREADTABLE)))) then (SETQ BESTREADTABLE (CL:ERROR "No valid read table in environment ~S" ENV)))) (LET ((*PACKAGE* BESTPACKAGE) (*READTABLE* BESTREADTABLE)) (PFI.PRINT.INDICES (PFI.SORT.INDICES MASTERINDICES) LINESPERPAGE)))) -) (PFI.CHOOSE.BEST -(LAMBDA (LST) (* ; "Edited 19-May-88 12:30 by bvm") (* ;; "Return the car of the element in ALIST having the largest vote, or first such if a tie.") (CAAR (CL:STABLE-SORT LST (QUOTE >) :KEY (QUOTE CDR)))) -) (PFI.MERGE.INDICES -(LAMBDA (MASTER NEWINDEX) (* ; "Edited 12-May-88 14:25 by bvm") (* ;; "Merge two lists of index entries. Each is a list (name location). In case of collision, it is known that MASTER locations appear before NEWINDEX locations") (NCONC (while (AND NEWINDEX MASTER) collect (SELECTQ (ALPHORDER (CAAR MASTER) (CAAR NEWINDEX) UPPERCASEARRAY) (EQUAL (* ; "Same name in two places, so merge the locations") (RPLACA (CDAR MASTER) (CONCAT (CADAR MASTER) "," (CADR (pop NEWINDEX)))) (pop MASTER)) (LESSP (* ; "Master less, so take it first") (pop MASTER)) (PROGN (* ; "NEWINDEX less, so take it") (pop NEWINDEX)))) (PROGN (* ; "Plus whichever, if either, is left over") (OR NEWINDEX MASTER)))) -) ) (* ; "Hooks for seeing files pretty elsewhere") (DEFINEQ (PFI.MAYBE.SEE.PRETTY -(LAMBDA (FROMFILE TOFILE) (* ; "Edited 1-Apr-88 11:23 by bvm") (* ;; "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) OUTSTREAM INSTREAM) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NULL (SETQ OUTSTREAM (DISPLAYP TOFILE)))) then (* ; "Not a display window, or don't want prettyprinting") (if (STREAMP FROMFILE) then (* ; "Wanted PFCOPYBYTES") (PFCOPYBYTES FROMFILE TOFILE) else (COPYALLBYTES FROMFILE TOFILE)) else (if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ INSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) else (PFCOPYBYTES INSTREAM OUTSTREAM) (FULLNAME INSTREAM)))))) -) (PFI.MAYBE.PP.DEFINITION -(LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 1-Apr-88 11:22 by bvm") (LET (ENV) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NOT (DISPLAYP OUTSTREAM)) (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) (WITH-READER-ENVIRONMENT ENV (SETFILEPTR INSTREAM START) (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) (IGNORE-ERRORS (READ INSTREAM)) (LET ((*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT)))) (if CONDITION then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) T else (PFI.PRINT.LAMBDA.BODY DEF) (TERPRI) NIL))))) then (* ;; "Punt to what we were called for in the first place") (PFCOPYBYTES INSTREAM OUTSTREAM START END)))) -) ) (RPAQ? *PRINT-PRETTY-FROM-FILES* T) (* ; "Bitmap hack") (DEFINEQ (PFI.PRINT.BITMAP -(LAMBDA (BM STREAM) (* ; "Edited 14-Apr-88 12:44 by bvm") (* ;; "DEFPRINT function for bitmaps that displays the actual bitmap when going to an image stream.") (if (OR (NULL *PRINT-ARRAY*) (NULL *PRINT-PRETTY-BITMAPS*)) then (* ; "do the clunky way") (NON.PFI.PRINT.BITMAP BM STREAM) elseif (IMAGESTREAMP STREAM) then (PROG ((CURX (DSPXPOSITION NIL STREAM)) (CURY (DSPYPOSITION NIL STREAM)) (UNITS (DSPSCALE NIL STREAM)) (LINEHEIGHT (DSPLINEFEED NIL STREAM)) HEIGHT WIDTH MINX NLINESDOWN BOTTOM BMARG BELOWBASELINE SCALE RATIO) (if (NOT (AND CURX CURY UNITS LINEHEIGHT)) then (* ; "Stream doesn't really support it") (RETURN (NON.PFI.PRINT.BITMAP BM STREAM))) (SETQ HEIGHT (TIMES UNITS (BITMAPHEIGHT BM))) (SETQ WIDTH (TIMES UNITS (BITMAPWIDTH BM))) (SETQ BMARG (DSPBOTTOMMARGIN NIL STREAM)) (if (AND (NOT (DISPLAYSTREAMP STREAM)) (< (SETQ RATIO (MIN (FQUOTIENT (- (DSPRIGHTMARGIN NIL STREAM) (DSPLEFTMARGIN NIL STREAM)) (TIMES WIDTH 1.5)) (FQUOTIENT (- (DSPTOPMARGIN NIL STREAM) BMARG) (TIMES HEIGHT 1.5)))) 1.0)) then (* ; "It takes up more than 2/3 the page in some dimension. This code is tuned for Interpress.") (SETQ SCALE (if (> RATIO 0.75) then 0.75 elseif (> RATIO 0.5) then 0.5 elseif (> RATIO 0.25) then 0.25 else RATIO)) (SETQ HEIGHT (FIXR (TIMES SCALE HEIGHT))) (SETQ WIDTH (FIXR (TIMES SCALE WIDTH)))) (if (> CURX (SETQ MINX (- (DSPRIGHTMARGIN NIL STREAM) WIDTH))) then (* ; "Won't fit between here and margin, so start nwe line") (TERPRI STREAM) (SETQ CURX (MAX MINX 0)) (SETQ CURY (DSPYPOSITION NIL STREAM))) (SETQ BELOWBASELINE (MAX 0 (- HEIGHT (FONTPROP STREAM (QUOTE ASCENT))))) (if BMARG then (* ; "We know stream's bottom margin, so can be reasonable") (if (< (- CURY BELOWBASELINE) BMARG) then (* ; "Won't fit on page") (DSPNEWPAGE STREAM) (SETQ CURY (DSPYPOSITION NIL STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL)) else (* ; "Have to use silly terpri method") (SETQ NLINESDOWN (IQUOTIENT HEIGHT (SETQ LINEHEIGHT (- LINEHEIGHT)))) (to NLINESDOWN do (* ; "Do enough cr's so that we have space for bitmap. This might cause scrolling, for example") (TERPRI STREAM) finally (* ; "If this was display, terpri may have scrolled, and Y changed out from under us") (SETQ CURY (+ (DSPYPOSITION NIL STREAM) (TIMES NLINESDOWN LINEHEIGHT))))) (SETQ BOTTOM (- CURY BELOWBASELINE)) (* ; "BOTTOM computed so that bitmap top lines up with font top") (SCALEDBITBLT BM 0 0 STREAM CURX BOTTOM WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL NIL SCALE) (MOVETO (+ CURX WIDTH) (if (AND (< BOTTOM CURY) (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) *PFI-FUNNY-CHARS*) then (* ; "Don't move the baseline down, just remember it for when we hit end of line") (if (OR (NULL *PFI-BITMAP-BASELINE*) (< BOTTOM *PFI-BITMAP-BASELINE*)) then (* ; "Lower than before, or first time") (SETQ *PFI-BITMAP-BASELINE* BOTTOM) (if (NEQ (fetch (STREAM OUTCHARFN) of STREAM) (FUNCTION PFI.OUTCHARFN)) then (* ; "Also have to %"advise%" the outcharfn to notice terpri") (replace (STREAM OUTCHARFN) of STREAM with (FUNCTION PFI.OUTCHARFN)))) CURY else (* ; "Move baseline down to bitmap baseline") BOTTOM) STREAM) (RETURN T)) else (LET ((POS (AND (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) (PNAMESTREAMP STREAM) (STKPOS (QUOTE STRINGWIDTH)))) IMSTREAM) (if (AND POS (IMAGESTREAMP (SETQ IMSTREAM (STKEVAL POS (QUOTE *STANDARD-OUTPUT*) T)))) then (* ;; "Big kludge: This is somebody in the prettyprinter trying to figure out the width of the bitmap--fake them out by printing something about the width of the bitmap. IMSTREAM is the stream to which the real output will go. To be conservative, only do this under PRETTYFILEINDEX.") (RPTQ (CL:CEILING (TIMES (DSPSCALE NIL IMSTREAM) (BITMAPWIDTH BM)) (CHARWIDTH (CHARCODE X) IMSTREAM)) (\OUTCHAR STREAM (CHARCODE X))) T else (NON.PFI.PRINT.BITMAP BM STREAM))))) -) ) (RPAQ? *PRINT-PRETTY-BITMAPS* T) (RPAQ? *PFI-PRINTOPTIONS* '(REGION (72 54 504 702))) (RPAQ? *PFI-DONT-SPAWN* ) (RPAQ? *PFI-MAX-WASTED-LINES* 12) (RPAQ? *PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC)))) (RPAQ? *PFI-INDEX-ORDER* '(FUNCTIONS)) (RPAQ? *PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*)) ) (* ;;  "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN)))) (RPAQ? \PFI.PROCESS.COMMANDS ) (RPAQ? \PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (RPAQ? \PFI.PROCESS ) (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex" ) (RPAQ? *PFI-TITLE* ) (RPAQ? *PFI-PAGE-COUNT* 0) (ADDTOVAR *PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (ADDTOVAR *PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (ADDTOVAR *PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (ADDTOVAR *PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (ADDTOVAR *PFI-FILTERS* (VARIABLES . CONSTANTS)) (* ; "Prettyprint augmentation to mimic system makefile dumping") (DEFINEQ (PUTPROPS.PRETTYPRINT -(LAMBDA (EXPR) (* ; "Edited 30-Mar-88 11:35 by bvm") (* ;; "does prettyprinting for PUTPROPS forms. Main thing we do is embolden the variable.") (if (NLISTP (CDR EXPR)) then (* ; "Degenerate (PUTPROPS) or (PUTPROPS . FOO)") (PRIN2 EXPR) else (PRIN1 (QUOTE %()) (PRIN2 (pop EXPR)) (* ; "Print the PUTPROPS") (SPACES 1) (LET ((TEM (DSPXPOSITION)) PROP) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Print the symbol") (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate illegal form like (PUTPROPS var . foo)") (SPACES 1) (PRINTDEF EXPR T NIL T) elseif (CDDR EXPR) then (* ; "There are multiple prop value pairs") (while EXPR do (* ;; "EXPR looks like (PROP VALUE . tail)") (TERPRI) (* ; "Start next prop on new line") (DSPXPOSITION TEM) (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate tail") (RETURN (PRINTDEF EXPR T NIL T))) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (SPACES 1) (PRINTDEF (pop EXPR) T (MEMB PROP MACROPROPS) NIL FNSLST)) else (* ; "Normal type: (PUTPROPS var prop value)") (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (COND ((AND (LISTP (CAR EXPR)) (NOT (FITP EXPR T NIL NIL *STANDARD-OUTPUT*))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF EXPR T (MEMB PROP MACROPROPS) T FNSLST)) (PRIN1 (QUOTE %))))) NIL) -) (RPAQX.PRETTYPRINT -(LAMBDA (EXPR) (* ; "Edited 8-Apr-88 16:34 by bvm") (* ;; "does prettyprinting for RPAQxx forms and ADDTOVAR. Main thing we do is embolden the variable.") (if (NOT (LISTP (CDR EXPR))) then (* ; "Handle (RPAQ) and (RPAQ . FOO)") EXPR else (DESTRUCTURING-BIND (OP VAR . TAIL) EXPR (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (LET ((TEM (DSPXPOSITION))) (MAYBE.PRETTYPRINT.BOLD VAR) (* ; "Embolden the variable") (COND ((AND (LISTP (CAR TAIL)) (OR (> (COUNT TAIL) 30) (NOT (FITP TAIL T NIL NIL *STANDARD-OUTPUT*)))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF TAIL T NIL T) (PRIN1 (QUOTE %))))) NIL)) -) (COURIERPROGRAM.PRETTYPRINT -(LAMBDA (EXPR) (* ; "Edited 13-Apr-88 10:55 by bvm") (if (NOT (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR))))))) then (* ; "Degenerate") EXPR else (LET* ((TAB1 (+ (DSPXPOSITION) (TIMES 4 SPACEWIDTH))) (TAB2 (+ TAB1 (TIMES 2 SPACEWIDTH)))) (PROGN (* ;; "Print %"(COURIERPROGRAM name (version)%"") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (SPACES 1) (PRIN2 (pop EXPR))) (* ; "Version pair") (while (LISTP EXPR) do (PRINENDLINE TAB1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Property name") (PRINENDLINE TAB2) (AND (LISTP EXPR) (PRINTDEF (pop EXPR) T))) (if EXPR then (* ; "degenerate tail?") (PRINTDEF EXPR T T T)) (PRIN1 ")") NIL))) -) (MAYBE.PRETTYPRINT.BOLD -(LAMBDA (VAR) (* ; "Edited 28-Mar-88 11:59 by bvm") (* ;; "Print VAR, in makefile's bold font if enabled") (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT) (PRIN2 VAR) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 VAR)))) -) ) (ADDTOVAR PRETTYPRINTMACROS (RPAQ . RPAQX.PRETTYPRINT) (RPAQQ . RPAQX.PRETTYPRINT) (RPAQ? . RPAQX.PRETTYPRINT) (ADDTOVAR . RPAQX.PRETTYPRINT) (PUTPROPS . PUTPROPS.PRETTYPRINT) (COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (CL:PROCLAIM '(CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG)) (DECLARE%: EVAL@COMPILE (RECORD PFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*) ) ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (OR (GETD 'CODEWRAPPER.PRETTYPRINT) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ;  "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ;  "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE")) (* ; "Also fix SEE") (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ;  "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY) (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION) (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP) 'NILL) 'NON.PFI.PRINT.BITMAP NIL T) ) (PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10096 12331 (PFI.NEW.LISTFILES1 10106 . 10600) (PFI.ENQUEUE 10602 . 11226) ( \PFI.DO.HARDCOPY 11228 . 11814) (MAYBE.PRETTYFILEINDEX 11816 . 12329)) (12332 34987 (PRETTYFILEINDEX 12342 . 26515) (PFI.MAKE.LPT.STREAM 26517 . 29568) (PFI.SETUP.TRANSLATIONS 29570 . 31084) ( PFI.OUTCHARFN 31086 . 33060) (PFI.COLLECT.DEFINERS 33062 . 33874) (PFI.AFTER.NEW.PAGE 33876 . 34985)) (34988 37844 (PFI.PRINT.FILECREATED 34998 . 36730) (PFI.PRINT.TO.TAB 36732 . 37097) ( PFI.PRINT.ENVIRONMENT 37099 . 37842)) (37845 45029 (PFI.PROCESS.FILE 37855 . 39085) (PFI.PASS.COMMENT 39087 . 40057) (PFI.HANDLE.EXPR 40059 . 40726) (PFI.DEFAULT.HANDLER 40728 . 42781) (PFI.PRETTYPRINT 42783 . 43118) (PFI.LINES.REMAINING 43120 . 43447) (PFI.MAYBE.NEW.PAGE 43449 . 43952) ( PFI.ESTIMATE.SIZE 43954 . 44485) (PFI.ESTIMATE.SIZE1 44487 . 45027)) (45066 54553 (PFI.HANDLE.RPAQQ 45076 . 46484) (PFI.HANDLE.DECLARE 46486 . 47425) (PFI.HANDLE.EVAL-WHEN 47427 . 47910) ( PFI.HANDLE.DEFDEFINER 47912 . 49202) (PFI.HANDLE.DEFINEQ 49204 . 49448) (PFI.PRINT.LAMBDA 49450 . 49788) (PFI.PRINT.LAMBDA.BODY 49790 . 50125) (PFI.HANDLE.PUTDEF 50127 . 50624) (PFI.HANDLE.PUTPROPS 50626 . 51241) (PFI.HANDLE./DECLAREDATATYPE 51243 . 51790) (PFI.HANDLE.* 51792 . 53054) ( PFI.PRINT.COMMENTS 53056 . 53956) (PFI.HANDLE.FILEMAP 53958 . 54246) (PFI.HANDLE.PACKAGE 54248 . 54551 )) (54581 55573 (PFI.PREVIEW.DECLARE 54591 . 55253) (PFI.PREVIEW.DEFINEQ 55255 . 55571)) (55609 66597 (PFI.PRINT.INDEX 55619 . 56470) (PFI.CONDENSE.INDEX 56472 . 58279) (PFI.SORT.INDICES 58281 . 59420) ( PFI.COMPUTE.INDEX.SHAPE 59422 . 60886) (PFI.PRINT.INDICES 60888 . 65430) (PFI.CENTER.PRINT 65432 . 66002) (PFI.INDEX.BREAK 66004 . 66462) (PFI.LOOKUP.NAME 66464 . 66595)) (66598 67829 (PFI.ADD.TO.INDEX 66608 . 67118) (PFI.VARNAME 67120 . 67530) (PFI.CONSTANTNAMES 67532 . 67827)) (67864 76177 ( MULTIFILEINDEX 67874 . 68670) (MULTIFILEINDEX1 68672 . 70128) (PFI.PRINT.MULTI.INDEX 70130 . 75233) ( PFI.CHOOSE.BEST 75235 . 75462) (PFI.MERGE.INDICES 75464 . 76175)) (76234 77852 (PFI.MAYBE.SEE.PRETTY 76244 . 77174) (PFI.MAYBE.PP.DEFINITION 77176 . 77850)) (77922 81757 (PFI.PRINT.BITMAP 77932 . 81755)) (84602 87716 (PUTPROPS.PRETTYPRINT 84612 . 86023) (RPAQX.PRETTYPRINT 86025 . 86750) ( COURIERPROGRAM.PRETTYPRINT 86752 . 87452) (MAYBE.PRETTYPRINT.BOLD 87454 . 87714))))) STOP \ No newline at end of file diff --git a/lispusers/READBRUSH.LCOM.~2~ b/lispusers/READBRUSH.LCOM.~2~ deleted file mode 100644 index f409905834aec75f699d7588e016e747192f1f89..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4299 zcmbtY&2JmW6(=btwN=otR3iuk!+mBQg$gW!yGv3eBQRQWm*h&z9g4d&MaL*BiL@z+ z5?xU;Y&b@dHZ722T?7c4_LAh%LjkL?fPN$;dg!5dxrzUP-W|B-s=t{fMaou-2IXP) z&D%F`-n@_Bn`KbbvxcQlXAM)IHmoe8izQvv95rp~6fi7DFPVm24A8}*npseD$Cy+8 zAYYfk3P;x{AjhY*#_Dt;PLh%gD@jEPP%yCC-n_NeYSgK{MFF~}*$ek)Z*8~N8>>61 z%|^Y|xT}Pssn%NO)^4Y<-AVEN)1|VV54|Z*kw2hF)AP$)LTe%^g_DtZfOfdj*6Vdz zgU*6bLeN4*wUnXkZmUK1-A;RVha`F0YTxFIL!nTB>dQMY#2*;2B{?ZeNks`fe;A6n zD`g5Nl5$jRdy?^TD15T<5+!2c8M?LIxV_fi?TEc!OJZ|bnV#R>nvTaQEGOZqh}?I} z+UBkH_Kr~3bIp+I?Z$F_WqY^N4818$`7?ROY&~RXrXETgPC+eFQj7b8MT!s)3Kc0# zYB(H|C`(Zi4lU?b8MBx>(~OdyaagGe)(p9dSlP-LRxXrgOH<_e)k`BD&uI^S<^B2( z`18A0+x#JhZ*!_SAji~G`7@k%eSgjvAM^Q)`uzD*-SPTO&OA@u9&w?&Uf=rBVZAwl zUr%hbJH9$97S}(!bgn+~fvZT2f12Mvv(TKl_J@ZbFHHXN;jabLyLz^H&J&a(2|CIb zacoJBlcg4r)w-!6{4!;jl~J7x({!68DNMo(Sa&_ATY3qZYw1glSQ`lsn4DpgoS-8& zg}^dHMb$w~Sn#rHnyeB^mmP;$A^oauIW}@=1}pTeS~eZNPaZ~OEt&~a#w-;}tWb1d z6TNe4guivFMg4p4U=b-%3fipXOpzR+K!BtK1w^comdDT63vvv{&LPH8Dya4XhzO+% zcqo*|C{qQaM4S^Q+bNNOr#NGl;?IR2f&R^Dug5!ASLUAn?mKgT@%_ysLiYOp$dC6t z4+K3Y#>zSI5QG0^9@fEJq{G+`zm+KYm$gMF^VkoA_4CQqrmv;y;uNaz>Kk{XXF{fx` zoN`HbJ=#xucp^utdlZ?RykYmUA7CJn!#>fr@Ja|Z2M(ne8pEE zlU`mJ5wQ4CVO$-|J}Hbh=R}2#W&B$GfSojD@&b`dyEcN*B zEc7Ky9n`|mSbIb0)Si7HBFROPY}OT-J*dgps&=I(^2m*L7l&XMFt|q%A=o-R^t(XG za8!0ds~d!Q`C6qg~e8AuT8 zRi1lGm2g8scM*L>LSu1d-PQnzP>y#3^!NmCBtkrad#q5>lg9ZpyO=SJVi8E#>qG#Y zUY`ND#w3)zbybIE0wZw=v~_f_7&!oI-a8ao>B~xxbvK16eQQO-2?F9B zr<%c~4i^MxU^h7YCRi$}i;Ks(6bxo98(rmvySuo%^xNNHk)Vd)-}U4W^!ukse1q9N zBcUD~RnxAjC7XhxQ)F?echICU59C^F^|h^=w9>wVZ?nZRbMzN<@{g{~_U%T8);5=K z;<3El-rW-4Z#&Hfbyl|3J{S`m=!`3#Lstq~T&mHS9807lwn>+S@@~i*=Zg>wocs-aj1N^81MHz>&#+<@w-em#f`KI-Aj-72 g@kPA6v(`q!Nr`xb4^ckE_<%ne5(ydMvJBJzZ{&?ctpET3 diff --git a/lispusers/READBRUSH.~1~ b/lispusers/READBRUSH.~1~ deleted file mode 100644 index 0ec35642..00000000 --- a/lispusers/READBRUSH.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Jun-88 02:13:42" {ERINYES}MEDLEY>READBRUSH.;2 9683 changes to%: (VARS READBRUSHCOMS) (FNS CHOOSE.IDLE.BITMAP IDLE.GLIDING.BOX) previous date%: "23-Jul-86 21:26:54" {ERINYES}MEDLEY>READBRUSH.;1) (* " Copyright (c) 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT READBRUSHCOMS) (RPAQQ READBRUSHCOMS ((FNS CHOOSE.IDLE.BITMAP READBRUSHFILE READBRUSH READROOTPICTURE IDLE.GLIDING.BOX) (FILES BITMAPFNS) [ADDVARS (IDLE.FUNCTIONS ("Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen" (SUBITEMS ("Pick image from MesaHacks" (PROGN ( CHOOSE.IDLE.BITMAP ) ' IDLE.GLIDING.BOX ] (INITVARS (IDLE.BITMAP) (BRUSHMENU) (ROOTPICTUREMENU) (BRUSHDIRECTORY "{goofy:osbu north:xerox}data>brushes>")))) (DEFINEQ (CHOOSE.IDLE.BITMAP [LAMBDA NIL (* ; "Edited 23-Jun-88 01:51 by masinter") (PROG NIL (ALLOW.BUTTON.EVENTS) (SETQ IDLE.BOUNCING.BOX (CAR (READBRUSHFILE (OR [MENU (OR BRUSHMENU (SETQ BRUSHMENU (create MENU ITEMS _ (for FILE infiles ( DIRECTORY.FILL.PATTERN BRUSHDIRECTORY "brush" "") collect (NAMEFIELD FILE] (RETURN]) (READBRUSHFILE [LAMBDA (FILE) (* lmm "23-Jul-86 21:26") (OR (AND (LITATOM FILE) (GET FILE 'BRUSH)) (PROG ((STR (OPENSTREAM (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY BRUSHDIRECTORY 'EXTENSION 'BRUSH) 'INPUT 'OLD)) M W H BM MASK REG) (BIN STR) (SETQ M (SELECTQ (BIN STR) (1 T) (0 NIL) NIL)) (SETQ W (BIN16 STR)) (SETQ H (BIN16 STR)) (RPTQ 10 (BIN STR)) (SETQ BM (READBINARYBITMAP W H STR)) (if M then (SETQ MASK (READBINARYBITMAP W H STR))) (CLOSEF STR) (SETQ BM (CONS BM MASK)) (IF (LITATOM FILE) THEN (PUT FILE 'BRUSH BM)) (RETURN BM]) (READBRUSH [LAMBDA (FILE) (* lmm " 4-Aug-85 07:31") (PROG ((BMS (READBRUSHFILE FILE)) WIN REG) (if (CDR BMS) then (SETQ WIN (ICONW (CAR BMS) (CDR BMS))) else (MOVEW (SETQ WIN (CREATEWFROMIMAGE (CAR BMS))) [fetch (REGION LEFT) of (SETQ REG (GETBOXREGION (WINDOWPROP WIN 'WIDTH) (WINDOWPROP WIN 'HEIGHT] (fetch (REGION BOTTOM) of REG)) (OPENW WIN)) (WINDOWPROP WIN 'BUTTONEVENTFN 'MOVEW) (RETURN WIN]) (READROOTPICTURE [LAMBDA (FILE) (* edited%: "17-May-85 19:21") (CHANGEBACKGROUND (READPRESS (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY "{GOOFY:OSBU NORTH}DATA>ROOTPICTURES>" 'EXTENSION 'PRESS]) (IDLE.GLIDING.BOX [LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 23-Jun-88 01:53 by masinter") (OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX)) [OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW] (OR MAXD (SETQ MAXD 4)) [SETQ BITMAPS (for X inside BITMAPS collect (if (LITATOM X) then [OR (GETPROP X 'BITMAP) (PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE X)) (BITMAPCREATE 10 10] else (IDLE.BITMAP NIL X] (LET ((W (for X in BITMAPS largest (BITMAPWIDTH X) finally (RETURN $$EXTREME))) (H (for X in BITMAPS largest (BITMAPHEIGHT X) finally (RETURN $$EXTREME))) (REG (DSPCLIPPINGREGION NIL WIN))) (LET ((XBM (BITMAPCREATE (PLUS MAXD MAXD W) (PLUS MAXD MAXD H))) (MAXX (MAX (DIFFERENCE (fetch WIDTH REG) (ADD1 W)) 10)) (MAXY (MAX (DIFFERENCE (fetch HEIGHT REG) (ADD1 W)) 10)) (MAXDD (FIX (SQRT MAXD))) X Y (CNT 0) DX DY STEPS NEWX NEWY REALX REALY ORIGX ORIGY TOY TOX THISBITMAP) (SETQ X (RAND 1 MAXX)) (SETQ Y (RAND 1 MAXY)) (BITBLT (SETQ THISBITMAP (CAR BITMAPS)) NIL NIL WIN X Y NIL NIL NIL 'INVERT) (while T do [COND ((ILEQ CNT 0) (SETQ ORIGX X) (SETQ ORIGY Y) (SETQ TOX (RAND 1 (SUB1 MAXX))) (SETQ TOY (RAND 1 (SUB1 MAXY))) (SETQ CNT (SETQ STEPS (QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X)) (ABS (DIFFERENCE TOY Y))) MAXD -1) MAXD))) (QUOTIENT (PLUS (ABS (DIFFERENCE TOX X)) STEPS -1) STEPS)) (T (SETQ CNT (SUB1 CNT] (SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX)) STEPS) TOX)) (if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X))) MAXD) then (SHOULDNT)) (SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY)) STEPS) TOY)) (if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y))) MAXD) then (SHOULDNT)) (BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE) (BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT) (BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX) (PLUS MAXD DY) NIL NIL NIL 'INVERT) (BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD) (DIFFERENCE Y MAXD) NIL NIL NIL 'INVERT) (add X DX) (add Y DY) (DISMISS WAIT]) ) (FILESLOAD BITMAPFNS) (ADDTOVAR IDLE.FUNCTIONS ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen" (SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP ) 'IDLE.GLIDING.BOX]) (RPAQ? IDLE.BITMAP ) (RPAQ? BRUSHMENU ) (RPAQ? ROOTPICTUREMENU ) (RPAQ? BRUSHDIRECTORY "{goofy:osbu north:xerox}data>brushes>") (PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1525 9021 (CHOOSE.IDLE.BITMAP 1535 . 2533) (READBRUSHFILE 2535 . 3581) (READBRUSH 3583 . 4395) (READROOTPICTURE 4397 . 4736) (IDLE.GLIDING.BOX 4738 . 9019))))) STOP \ No newline at end of file diff --git a/lispusers/READBRUSH.~2~ b/lispusers/READBRUSH.~2~ deleted file mode 100644 index 50959032..00000000 --- a/lispusers/READBRUSH.~2~ +++ /dev/null @@ -1,183 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 6-Nov-92 09:25:48" {DSK}medley2.0>lispusers>READBRUSH.;1 9607 - - previous date%: "23-Jun-88 02:13:42" {DSK}lisp>medley>lispusers>readbrush.;1) - - -(* ; " -Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT READBRUSHCOMS) - -(RPAQQ READBRUSHCOMS - ((FNS CHOOSE.IDLE.BITMAP READBRUSHFILE READBRUSH READROOTPICTURE IDLE.GLIDING.BOX) - (FILES BITMAPFNS) - [ADDVARS (IDLE.FUNCTIONS ("Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen" - (SUBITEMS ("Pick image from MesaHacks" (PROGN ( - CHOOSE.IDLE.BITMAP - ) - - ' - IDLE.GLIDING.BOX - ] - (INITVARS (IDLE.BITMAP) - (BRUSHMENU) - (ROOTPICTUREMENU) - (BRUSHDIRECTORY "{goofy:osbu north:xerox}data>brushes>")))) -(DEFINEQ - -(CHOOSE.IDLE.BITMAP - [LAMBDA NIL (* ; "Edited 23-Jun-88 01:51 by masinter") - (PROG NIL - (ALLOW.BUTTON.EVENTS) - (SETQ IDLE.BOUNCING.BOX - (CAR (READBRUSHFILE (OR [MENU (OR BRUSHMENU - (SETQ BRUSHMENU - (create MENU - ITEMS _ (for FILE - infiles ( - DIRECTORY.FILL.PATTERN - BRUSHDIRECTORY - "brush" "") - collect (NAMEFIELD FILE] - (RETURN]) - -(READBRUSHFILE - [LAMBDA (FILE) (* lmm "23-Jul-86 21:26") - (OR (AND (LITATOM FILE) - (GET FILE 'BRUSH)) - (PROG ((STR (OPENSTREAM (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY BRUSHDIRECTORY - 'EXTENSION - 'BRUSH) - 'INPUT - 'OLD)) - M W H BM MASK REG) - (BIN STR) - (SETQ M (SELECTQ (BIN STR) - (1 T) - (0 NIL) - NIL)) - (SETQ W (BIN16 STR)) - (SETQ H (BIN16 STR)) - (RPTQ 10 (BIN STR)) - (SETQ BM (READBINARYBITMAP W H STR)) - (if M - then (SETQ MASK (READBINARYBITMAP W H STR))) - (CLOSEF STR) - (SETQ BM (CONS BM MASK)) - (IF (LITATOM FILE) - THEN (PUT FILE 'BRUSH BM)) - (RETURN BM]) - -(READBRUSH - [LAMBDA (FILE) (* lmm " 4-Aug-85 07:31") - (PROG ((BMS (READBRUSHFILE FILE)) - WIN REG) - (if (CDR BMS) - then (SETQ WIN (ICONW (CAR BMS) - (CDR BMS))) - else (MOVEW (SETQ WIN (CREATEWFROMIMAGE (CAR BMS))) - [fetch (REGION LEFT) of (SETQ REG (GETBOXREGION - (WINDOWPROP WIN 'WIDTH) - (WINDOWPROP WIN 'HEIGHT] - (fetch (REGION BOTTOM) of REG)) - (OPENW WIN)) - (WINDOWPROP WIN 'BUTTONEVENTFN 'MOVEW) - (RETURN WIN]) - -(READROOTPICTURE - [LAMBDA (FILE) (* edited%: "17-May-85 19:21") - (CHANGEBACKGROUND (READPRESS (PACKFILENAME.STRING 'BODY FILE 'DIRECTORY - "{GOOFY:OSBU NORTH}DATA>ROOTPICTURES>" 'EXTENSION - 'PRESS]) - -(IDLE.GLIDING.BOX - [LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 23-Jun-88 01:53 by masinter") - (OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX)) - [OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW] - (OR MAXD (SETQ MAXD 4)) - [SETQ BITMAPS (for X inside BITMAPS - collect (if (LITATOM X) - then [OR (GETPROP X 'BITMAP) - (PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE - X)) - (BITMAPCREATE 10 10] - else (IDLE.BITMAP NIL X] - (LET ((W (for X in BITMAPS largest (BITMAPWIDTH X) finally (RETURN $$EXTREME))) - (H (for X in BITMAPS largest (BITMAPHEIGHT X) finally (RETURN $$EXTREME))) - (REG (DSPCLIPPINGREGION NIL WIN))) - (LET ((XBM (BITMAPCREATE (PLUS MAXD MAXD W) - (PLUS MAXD MAXD H))) - (MAXX (MAX (DIFFERENCE (fetch WIDTH REG) - (ADD1 W)) - 10)) - (MAXY (MAX (DIFFERENCE (fetch HEIGHT REG) - (ADD1 W)) - 10)) - (MAXDD (FIX (SQRT MAXD))) - X Y (CNT 0) - DX DY STEPS NEWX NEWY REALX REALY ORIGX ORIGY TOY TOX THISBITMAP) - (SETQ X (RAND 1 MAXX)) - (SETQ Y (RAND 1 MAXY)) - (BITBLT (SETQ THISBITMAP (CAR BITMAPS)) - NIL NIL WIN X Y NIL NIL NIL 'INVERT) - (while T do [COND - ((ILEQ CNT 0) - (SETQ ORIGX X) - (SETQ ORIGY Y) - (SETQ TOX (RAND 1 (SUB1 MAXX))) - (SETQ TOY (RAND 1 (SUB1 MAXY))) - (SETQ CNT (SETQ STEPS - (QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X)) - (ABS (DIFFERENCE TOY Y))) - MAXD -1) - MAXD))) - (QUOTIENT (PLUS (ABS (DIFFERENCE TOX X)) - STEPS -1) - STEPS)) - (T (SETQ CNT (SUB1 CNT] - (SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX)) - STEPS) - TOX)) - (if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X))) - MAXD) - then (SHOULDNT)) - (SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY)) - STEPS) - TOY)) - (if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y))) - MAXD) - then (SHOULDNT)) - (BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE) - (BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT) - (BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX) - (PLUS MAXD DY) - NIL NIL NIL 'INVERT) - (BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD) - (DIFFERENCE Y MAXD) - NIL NIL NIL 'INVERT) - (add X DX) - (add Y DY) - (DISMISS WAIT]) -) - -(FILESLOAD BITMAPFNS) - -(ADDTOVAR IDLE.FUNCTIONS ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen" - (SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP - ) - 'IDLE.GLIDING.BOX]) - -(RPAQ? IDLE.BITMAP ) - -(RPAQ? BRUSHMENU ) - -(RPAQ? ROOTPICTUREMENU ) - -(RPAQ? BRUSHDIRECTORY "{goofy:osbu north:xerox}data>brushes>") -(PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988 1992)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1444 8940 (CHOOSE.IDLE.BITMAP 1454 . 2452) (READBRUSHFILE 2454 . 3500) (READBRUSH 3502 - . 4314) (READROOTPICTURE 4316 . 4655) (IDLE.GLIDING.BOX 4657 . 8938))))) -STOP diff --git a/lispusers/SETDEFAULTPRINTER.LCOM.~2~ b/lispusers/SETDEFAULTPRINTER.LCOM.~2~ deleted file mode 100644 index e8c18ec7b909d1cccf5a795293c06955c0947052..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3044 zcmdT`&2Jl35ch{#MB9z}#aEEZXc1*y)mC=>8K(-_+M9S2d+m5P4OCU7jrTcTV(*&W zbwfZsAP$^3RN~5|oRBy)0ZWAz^$Pz3cdog?t;~D2lhkp50~exXv!3_-do%O<&Abtc z%A%?%@kO<)#8qvv3RmiiTr}jHWd(RuGn9H+)oVOlsmX;EdFcgXj1%bh3iu5}DFQD_ zam~FKpUr`o&8Nh?l;c6*8*Zm-w}}O=13Yk_7WI|;H@cqtA!!8j9b&b~PBM|6Z`*#i z=M&GL*A)Z3lGn;cteaClu0UY|4NF;c$%m6()>amoU#C$Tzj|TpC2ZxKOR=F%T9t9q#y6H_;(ZFX8t#?0|Iq7<4^y z&vtu03jmJ zwtsG5S)Y0}LQi|L+&{C@n!f$x?(>gUuKu+9d@Ce~(k!gS3$m`DTtrw>P=M7Mh@v<$ zXOmE@`~vd!R_9g+aJ(eUPB+YVY($ArSz&L&#~bHnulf2b*x zwU`5e(Rbub5SB=wk?q<5bYglKo7zZNyPz_qdqct%k{^&P{v}cfPOal~Tt*WU7 zxjbZcsD&9YFiR@Tz|hVVFhLnH2*+Luhr;VqR`eU|L2J4(wO~Em4ecY%Z-f^jVa8ei z6uvDW&y=Pw2Bzr3M(El4RCvLPK8S=b;Cgg#t`zORh6V)qYJKX0e0n+BFRfhM4Lt}i zg!lJ;FChel+28w3Esd}*6p?O#&0 zp#$0>%DEBBqhBb_iBxp9#pR+$1ZO-SNFKPE*TRE)pKj zk5>kY6ap8kNKB)I$5$OU7?y-Z+j*_77{&+KQkgtYXttbCugR;clUG3yuEE^g9NsZl zE#Q&OUfc9W%}-yusTxXUQGYgRvY9xe>rVqRfRhKU&Uk7mzl1h(t={E2r747&Z1 zqCWuT_^~Dqw$D84w#^2iakO1`3wm8NVngyVf-Q2;yV`EUq-S3TI{>ro4|e->2%yo? z);5a#z+G&F=3yVj5ur=GV233@)l`FBmBP4FsFK)$&%EvUw$sDQ9emPm;#h!gZkUa& zP0#H)7SMZ?CPOY32WZ^QgT)H272Hn8bSxjo79Dvg4jb~Yb>cMhubV4M OA6b0NCNb%>hyDfCz<28a diff --git a/lispusers/SETDEFAULTPRINTER.~1~ b/lispusers/SETDEFAULTPRINTER.~1~ deleted file mode 100644 index d2bb41db..00000000 --- a/lispusers/SETDEFAULTPRINTER.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 4-Mar-87 15:57:29" {PHYLUM}LYRIC>SETDEFAULTPRINTER.;1 4454 previous date%: " 8-Jul-86 12:37:19" {PHYLUM}KOTO>SETDEFAULTPRINTER.;1) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SETDEFAULTPRINTERCOMS) (RPAQQ SETDEFAULTPRINTERCOMS ((* * the regular DEFAULTSUBITEMFN modified to recognize EVAL as a key to EVAL the CADR of the list to get the subitems) (FILES DEFAULTSUBITEMFN) (* * the setdefaultprinter functions) (FNS \sdp.get.printer \sdp.menu.subitems \sdp.set.printer) (* * SDP.PRINTERINFO is the place to look up things like printer location, it also looks on the name of the printer for a LOCATION property) (INITVARS (SDP.PRINTERINFO NIL) (\\sdp.read.table (COPYREADTABLE (QUOTE ORIG)))) (* * the variables that signal recreating the menu subitems) (VARS (\\sdp.known.printers) (\\sdp.menu.subitems)) (* * insinuate self into background menu) (ADDVARS (BackgroundMenuCommands ("Set Default Printer" (\sdp.set.printer (\sdp.get.printer)) "Asks for (new) default printer name. without entering name aborts change." (EVAL (\sdp.menu.subitems))))) (* * reset the background menu so our change takes effect, and remove space from the separators when reading printer names) (P (SETQ BackgroundMenu) (SETSYNTAX 32 (QUOTE OTHER) \\sdp.read.table))) ) (* * the regular DEFAULTSUBITEMFN modified to recognize EVAL as a key to EVAL the CADR of the list to get the subitems) (FILESLOAD DEFAULTSUBITEMFN) (* * the setdefaultprinter functions) (DEFINEQ (\sdp.get.printer (LAMBDA NIL (* N.H.Briggs "24-Mar-86 16:24") (* TBigham " 2-Dec-85 07:48") (DECLARE (GLOBALVARS LASTMOUSEX LASTMOUSEY \\sdp.read.table)) (LET* ((font (DEFAULTFONT (QUOTE DISPLAY))) (prompt "Enter printer name: ") (window (CREATEW (MAKEWITHINREGION (CREATEREGION LASTMOUSEX LASTMOUSEY (WIDTHIFWINDOW (IPLUS (STRINGWIDTH prompt font) (ITIMES 40 (CHARWIDTH (CHARCODE M) font)))) (HEIGHTIFWINDOW (FONTPROP font (QUOTE HEIGHT))))) NIL NIL T))) (RESETLST (RESETSAVE (OPENW window) (BQUOTE (CLOSEW %, window))) (SETQ input (PROMPTFORWORD prompt NIL NIL window NIL NIL (CHARCODE EOL))) (AND input (CAR (NLSETQ (READ (OPENSTRINGSTREAM input (QUOTE INPUT)) \\sdp.read.table))))))) ) (\sdp.menu.subitems (LAMBDA NIL (* N.H.Briggs "24-Mar-86 16:09") (if (AND \\sdp.menu.subitems (EQUAL \\sdp.known.printers DEFAULTPRINTINGHOST)) then \\sdp.menu.subitems else (SETQ \\sdp.known.printers (COPY DEFAULTPRINTINGHOST)) (SETQ \\sdp.menu.subitems (NCONC1 (for printer inside \\sdp.known.printers collect (LIST printer (LIST (QUOTE \sdp.set.printer) (KWOTE printer)) (OR (GETPROP (U-CASE printer) (QUOTE LOCATION)) (CDR (ASSOC (U-CASE printer) SDP.PRINTERINFO))))) (LIST "Other..." (QUOTE (\sdp.set.printer (\sdp.get.printer))) "Asks for (new) default printer name. without entering name aborts change."))))) ) (\sdp.set.printer (LAMBDA (printer) (* N.H.Briggs " 8-Jul-86 12:29") (LET ((canonicalprintername (CANONICAL.HOSTNAME printer))) (if (AND printer (NOT (STRING-EQUAL canonicalprintername (CANONICAL.HOSTNAME (CAR (SETQ DEFAULTPRINTINGHOST (MKLIST DEFAULTPRINTINGHOST))))))) then (SETQ DEFAULTPRINTINGHOST (CONS printer (SUBSET DEFAULTPRINTINGHOST (FUNCTION (LAMBDA (x) (NOT (STRING-EQUAL (CANONICAL.HOSTNAME x) canonicalprintername))))))) (PROMPTPRINT "default printer set to " printer) else (PROMPTPRINT "default printer not changed"))) NIL) ) ) (* * SDP.PRINTERINFO is the place to look up things like printer location, it also looks on the name of the printer for a LOCATION property) (RPAQ? SDP.PRINTERINFO NIL) (RPAQ? \\sdp.read.table (COPYREADTABLE (QUOTE ORIG))) (* * the variables that signal recreating the menu subitems) (RPAQQ \\sdp.known.printers NIL) (RPAQQ \\sdp.menu.subitems NIL) (* * insinuate self into background menu) (ADDTOVAR BackgroundMenuCommands ("Set Default Printer" (\sdp.set.printer (\sdp.get.printer)) "Asks for (new) default printer name. without entering name aborts change." (EVAL (\sdp.menu.subitems))) ) (* * reset the background menu so our change takes effect, and remove space from the separators when reading printer names) (SETQ BackgroundMenu) (SETSYNTAX 32 (QUOTE OTHER) \\sdp.read.table) (PUTPROPS SETDEFAULTPRINTER COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1632 3514 (\sdp.get.printer 1642 . 2336) (\sdp.menu.subitems 2338 . 2965) ( \sdp.set.printer 2967 . 3512))))) STOP \ No newline at end of file diff --git a/lispusers/SETDEFAULTPRINTER.~2~ b/lispusers/SETDEFAULTPRINTER.~2~ deleted file mode 100644 index 7253ba35..00000000 --- a/lispusers/SETDEFAULTPRINTER.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Jun-93 15:34:58" {DSK}medley2.0>lispusers>SETDEFAULTPRINTER.;7 7525 changes to%: (VARS SETDEFAULTPRINTERCOMS) (FNS \sdp.menu.subitems) previous date%: "29-May-93 15:44:06" {DSK}medley2.0>lispusers>SETDEFAULTPRINTER.;6) (* ; " Copyright (c) 1985, 1986, 1987, 1993 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SETDEFAULTPRINTERCOMS) (RPAQQ SETDEFAULTPRINTERCOMS ( (* ;;; "the regular DEFAULTSUBITEMFN modified to recognize EVAL as a key to EVAL the CADR of the list to get the subitems") (FILES DEFAULTSUBITEMFN) (* ;;; "the setdefaultprinter functions") (FNS \sdp.menu.subitems \sdp.set.printer) (* ;;; "SDP.PRINTERINFO is the place to look up things like printer location, it also looks on the name of the printer for a LOCATION property") (INITVARS (SDP.PRINTERINFO NIL)) (* ;;; "insinuate self into background menu") [ADDVARS (BackgroundMenuCommands ("Set Default Printer" (\sdp.set.printer ( GetNewPrinterFromUser )) "Asks for (new) default printer name. without entering name aborts change." (EVAL (\sdp.menu.subitems] (* ;;; "reset the background menu so our change takes effect, and remove space from the separators when reading printer names") (P (SETQ BackgroundMenu)))) (* ;;; "the regular DEFAULTSUBITEMFN modified to recognize EVAL as a key to EVAL the CADR of the list to get the subitems" ) (FILESLOAD DEFAULTSUBITEMFN) (* ;;; "the setdefaultprinter functions") (DEFINEQ (\sdp.menu.subitems [LAMBDA NIL (* ; "Edited 7-Jun-93 15:30 by rmk:") (* N.H.Briggs "24-Mar-86 16:09") (NCONC1 [FOR P PNAME INSIDE DEFAULTPRINTINGHOST COLLECT (LIST (IF (NLISTP P) THEN P ELSEIF (CADDR P) THEN (CONCAT (CADR P) " " (CADDR P)) ELSE (CADR P)) (LIST '\sdp.set.printer (KWOTE P)) (OR (GETPROP (U-CASE P) 'LOCATION) (CDR (ASSOC (U-CASE P) SDP.PRINTERINFO] (LIST "Other..." '(\sdp.set.printer (GetNewPrinterFromUser)) "Asks for (new) default printer name. without entering name aborts change."]) (\sdp.set.printer [LAMBDA (PRINTER) (* ; "Edited 29-May-93 15:11 by rmk:") (* N.H.Briggs " 8-Jul-86 12:29") (* ;; "CANONICAL.HOSTNAME is NIL except for XNS hosts") (SETQ DEFAULTPRINTINGHOST (MKLIST DEFAULTPRINTINGHOST)) [IF PRINTER THEN (* ;; "Convert to canonical name") (SETQ PRINTER (IF (LISTP PRINTER) THEN (LIST (CAR PRINTER) (OR (CANONICAL.HOSTNAME (CADR PRINTER)) (CADR PRINTER)) (CADDR PRINTER)) ELSE (OR (CANONICAL.HOSTNAME PRINTER) PRINTER))) (LET ((TOP (CAR DEFAULTPRINTINGHOST)) (CANONICALPRINTERNAME (IF (LISTP PRINTER) THEN (CADR PRINTER) ELSE PRINTER))) (IF (IF (LISTP PRINTER) THEN [AND (LISTP TOP) (EQ (CAR TOP) (CAR PRINTER)) (EQ (CADDR TOP) (CADDR PRINTER)) (STRING-EQUAL CANONICALPRINTERNAME (OR (CANONICAL.HOSTNAME (CADR TOP)) (CADR TOP] ELSE (AND (NLISTP TOP) (STRING-EQUAL (OR (CANONICAL.HOSTNAME TOP) TOP) CANONICALPRINTERNAME))) THEN (PROMPTPRINT "default printer not changed") ELSE [SETQ DEFAULTPRINTINGHOST (CONS PRINTER (IF (LISTP PRINTER) THEN (FOR P IN DEFAULTPRINTINGHOST UNLESS [AND (LISTP P) (EQ (CAR P) (CAR PRINTER)) (EQ (CADDR P) (CADDR PRINTER)) (STRING-EQUAL CANONICALPRINTERNAME (OR (CANONICAL.HOSTNAME (CADR P)) (CADR P] COLLECT P) ELSE (FOR P IN DEFAULTPRINTINGHOST UNLESS (AND (NLISTP P) (STRING-EQUAL CANONICALPRINTERNAME (OR (CANONICAL.HOSTNAME P) P))) COLLECT P] (PROMPTPRINT "default printer set to " PRINTER] NIL]) ) (* ;;; "SDP.PRINTERINFO is the place to look up things like printer location, it also looks on the name of the printer for a LOCATION property" ) (RPAQ? SDP.PRINTERINFO NIL) (* ;;; "insinuate self into background menu") (ADDTOVAR BackgroundMenuCommands ("Set Default Printer" (\sdp.set.printer (GetNewPrinterFromUser) ) "Asks for (new) default printer name. without entering name aborts change." (EVAL (\sdp.menu.subitems)))) (* ;;; "reset the background menu so our change takes effect, and remove space from the separators when reading printer names" ) (SETQ BackgroundMenu) (PUTPROPS SETDEFAULTPRINTER COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1960 6625 (\sdp.menu.subitems 1970 . 3132) (\sdp.set.printer 3134 . 6623))))) STOP \ No newline at end of file diff --git a/lispusers/SIMPLIFY.LCOM.~2~ b/lispusers/SIMPLIFY.LCOM.~2~ deleted file mode 100644 index d75990d5562386adc8ee98404b9d0034fb537610..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1714 zcmaJ?&u`;I6!wo5yReFs>;a()p{J|_4pJgJKbjv@l_!bQc;ncv?UV)((r%n?j8Ytu zbVY?$VmZK-3WN{`#0Bkft1LNG0`cRw&ns<#Z+?UDs00 zwuTR~l`_cHS}|WM%E*0p@9~z=+S$f?T+P{b^{#E`tv)h^Vp%D|WIB8lghw-WQ4Q5@ zW=(4^Tdq>>`BJSUrxUPc=&s$v^X?UZLMCy62Cp?M3CRFShL+`YGa2ASj^lVW$(g#5 zpg$>-AhvDv>Gx>64GOeOwzdHen#9=w9fLS3IH4f~8VDRGq<~j_k$;Gw+-hO_g2;;t z-4}S_c|+j&eZQct7M1p*r22v&e0R<^s)DfbnIQ0IO@bHwtkx~ zlPVc)Y$Q3UDudgryWSo#pj-mWY-q4q2BuN7G1;X&*p9Vhf}(&yy7eZ(U?#yfvIOXm zhn5kEV7jOX;#pmkaR;vwRl*q5BORj^-nz*yQV>bO!vwwAT%#(NiPBkS43-uGt>_|z z)dZdsNGip*#pR7rl0S1I?C1aJ;xeV`tHoVs@d}HbzO1s_pQ%wEK4;Ovjq|p!fBGvY zl?o9RD57|q?DjOOxf&&+P>#u=Ew0gI8`t$$V2?PoaE9>{waZrD^iH=i(m4qul42ML6VaEi@8ZER9GFbQ^1Vs0Lo@u5h%lM&+;hs*q)jl zv15j!w19K47Q8xIExYRY7R$*=kW|Gr&AS(TH{!{&|M33y9GOzjJvkpOZ>h{)SW9dg z*K>4p2d$ll_q@KXb&1=__0Y(e$_g}^O$SOcGzgBxJgyxm6maQKF;|FR_>kGkh62`| zwu|L99Gu8t(h0L0Z713^meFM9FtxW);YT;oZFOHF++D;zfOV`{L^toz+*Pv-YQ*J3n`qH;vK8 z`%jG5e-XsxZ)UQdB&)>_*y|Fu&ANrqMeDgDuN@V?1(NM(p4V?!T^keTMO}vP5(Zq% zm4mk0y%q#XdK0`b9M9k&oWkt*@Ig2Z1`t2J!QlQpz}GrF0Qy$ZJ%_UlNG;P{!^F$= zGn9y|P5T$~7a2M3_BC}pQ#Y(e#|3G94lZY`_x~RtlgOYTyXWECVPBGghGq91eW&f= b|IPkz8h#9oa5@R6Oh+1&YNd<^X}bOecGas~ diff --git a/lispusers/TEDITDORADOKEYS.~1~ b/lispusers/TEDITDORADOKEYS.~1~ deleted file mode 100644 index 29ff1053..00000000 --- a/lispusers/TEDITDORADOKEYS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "28-Oct-87 19:53:12" {ERINYES}LYRIC>TEDITDORADOKEYS.\;2 22990 |changes| |to:| (FNS \\TEDIT.FIND \\TEDIT.DK.ABORT \\TEDIT.DK.FIND \\TEDIT.DK.SUBSTITUTE \\TEDIT.DK.INSERT-PARENS \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES) (VARS TEDITDORADOKEYSCOMS) |previous| |date:| "28-Oct-87 10:35:15" {ERINYES}LYRIC>TEDITDORADOKEYS.\;1) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TEDITDORADOKEYSCOMS) (RPAQQ TEDITDORADOKEYSCOMS ((FILES TEDITDECLS TEDITFNKEYS) (COMS (* |;;|  "These functions were fixed after Lyric went out so they'll ignore the meta key being down.") (FNS \\TEDIT.BOLD.SEL.OFF \\TEDIT.BOLD.SEL.ON \\TEDIT.CENTER.SEL \\TEDIT.CENTER.SEL.REV \\TEDIT.DEFAULTS.CARET \\TEDIT.DEFAULTSSEL \\TEDIT.SETDEFAULT.FROM.SEL \\TEDIT.FIND \\TEDIT.ITALIC.SEL.OFF \\TEDIT.ITALIC.SEL.ON \\TEDIT.LARGERSEL \\TEDIT.LCASE.SEL \\TEDIT.SHOWCARETLOOKS \\TEDIT.SMALLERSEL \\TEDIT.SUBSCRIPTSEL \\TEDIT.SUPERSCRIPTSEL \\TEDIT.UCASE.SEL \\TEDIT.UNDERLINE.SEL.OFF \\TEDIT.UNDERLINE.SEL.ON \\TEDIT.STRIKEOUT.SEL.ON \\TEDIT.STRIKEOUT.SEL.OFF)) (COMS (* |;;| "Specialized functions for this module") (FNS \\TEDIT.DK.ABORT \\TEDIT.DK.FIND \\TEDIT.DK.SUBSTITUTE \\TEDIT.DK.INSERT-PARENS \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)) (VARS (\\TEDIT.DORADO.KEYS '(("1,a" FN \\TEDIT.DK.ABORT) ("1,A" FN \\TEDIT.DK.ABORT) ("1,U" UNDO) ("1,u" UNDO) ("1,f" FN \\TEDIT.DK.FIND) ("1,F" FN \\TEDIT.DK.FIND) (ESC REDO) ("1,n" NEXT) ("1,N" NEXT) ("1,S" FN \\TEDIT.DK.SUBSTITUTE) ("1,s" FN \\TEDIT.DK.SUBSTITUTE) ("1,x" EXPAND) ("1,X" EXPAND) ("1,c" FN \\TEDIT.CENTER.SEL) ("1,C" FN \\TEDIT.CENTER.SEL.REV) ("1,b" FN \\TEDIT.BOLD.SEL.ON) ("1,B" FN \\TEDIT.BOLD.SEL.OFF) ("1,i" FN \\TEDIT.ITALIC.SEL.ON) ("1,I" FN \\TEDIT.ITALIC.SEL.OFF) ("1,=" FN \\TEDIT.STRIKEOUT.SEL.ON) ("1,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) ("1,-" FN \\TEDIT.UNDERLINE.SEL.ON) ("1,_" FN \\TEDIT.UNDERLINE.SEL.OFF) ("1,^" FN \\TEDIT.SUBSCRIPTSEL) ("1,|" FN \\TEDIT.SUPERSCRIPTSEL) ("1,SPACE" FN \\TEDIT.DEFAULTSSEL) ("1,?" FN \\TEDIT.SHOWCARETLOOKS) ("1,(" FN \\TEDIT.DK.INSERT-PARENS) ("1,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) ("1,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)))) (P (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))))) (FILESLOAD TEDITDECLS TEDITFNKEYS) (* |;;| "These functions were fixed after Lyric went out so they'll ignore the meta key being down.") (DEFINEQ (\\TEDIT.BOLD.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* \; "Edited 20-Oct-87 10:42 by jds") (\\TEDIT.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL))) (\\TEDIT.BOLD.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 10:42 by jds") (\\TEDIT.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL))) (\\TEDIT.CENTER.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 24-Sep-87 10:07 by jds") (* |;;| "makes the current paragraph centered") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (|fetch| CH# |of| SEL)) (SAVEDCH (|fetch| DCH |of| SEL))) (|for| PARA |in| (\\PARAS.IN.SEL SEL TEXTOBJ) |do| (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) (SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT))))) (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (|push| NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T)))))) (\\TEDIT.CENTER.SEL.REV (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 24-Sep-87 10:07 by jds") (* |;;| "acts like center.sel but cycles in the opposite direction") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (|fetch| CH# |of| SEL)) (SAVEDCH (|fetch| DCH |of| SEL))) (|for| PARA |in| (\\PARAS.IN.SEL SEL TEXTOBJ) |do| (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) (SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT))))) (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (|push| NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T)))))) (\\TEDIT.DEFAULTS.CARET (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 11:24") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (|create| CHARLOOKS |using| TEDIT.DEFAULT.CHARLOOKS)) (\\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)))) (\\TEDIT.DEFAULTSSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:12 by jds") (* |acts| |on| |the| |selection|) (TEDIT.LOOKS TEXTSTREAM (|create| CHARLOOKS |using| TEDIT.DEFAULT.CHARLOOKS) SEL))) (\\TEDIT.SETDEFAULT.FROM.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| " 8-Nov-85 15:22") (* |Set| |the| |defaults| |from| |the|  |current| |selection.|) (PROG ((LOOKS (TEDIT.GET.LOOKS TEXTSTREAM SEL))) (SETQ TEDIT.DEFAULT.CHARLOOKS (\\TEDIT.PARSE.CHARLOOKS.LIST LOOKS))))) (\\TEDIT.FIND (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 28-Oct-87 19:35 by jds") (* |;;| "ENCAPSULATION FOR FIND KEY") (* |;;| "just calls the normal tedit.find starting at the right of the current selection") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* \;  "Case sensitive search, with * and # wildcards") (SETQ W (CAR (|fetch| \\WINDOW |of| TEXTOBJ))) (SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING ) (CHARCODE (EOL LF ESC)))) (COND (TARGET (SETQ SEL (|fetch| SEL |of| TEXTOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* \; "We found the target text.") (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (|replace| CH# |of| SEL |with| (CAR CH)) (* \;  "Set up SELECTION to be the found text") (|replace| CHLIM |of| SEL |with| (ADD1 (CADR CH))) (|replace| DCH |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (|replace| POINT |of| SEL |with| 'RIGHT) (|replace| CARETLOOKS |of| TEXTOBJ |with| (\\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \; "And never pending a deletion.") (\\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* \; "And get it into the window") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\\SHOWSEL SEL NIL T))))) (|replace| \\INSERTNEXTCH |of| TEXTOBJ |with| -1)))) (\\TEDIT.ITALIC.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* \; "Edited 20-Oct-87 10:43 by jds") (\\TEDIT.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL))) (\\TEDIT.ITALIC.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 10:43 by jds") (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL))) (\\TEDIT.LARGERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\\TEDIT.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT 2) SEL))))) (\\TEDIT.LCASE.SEL (LAMBDA (STREAM TEXTOBJ SEL) (* \; "Edited 3-Sep-87 10:49 by jds") (* |;;| "LOWER-CASEs the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (|fetch| CH# |of| SEL)) (LEN (|fetch| DCH |of| SEL)) (POINT (|fetch| POINT |of| SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (|replace| (TEDITHISTORYEVENT THACTION) |of| (|fetch| (TEXTOBJ TXTHISTORY) |of| TEXTOBJ) |with| '|LowerCase|)))) (\\TEDIT.SHOWCARETLOOKS (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |gbn| "30-Jan-85 16:06") (* * |comment|) (PROG ((LOOKS (|fetch| CARETLOOKS |of| TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\\TK.DESCRIBEFONT (|fetch| CLFONT |of| LOOKS)) (COND ((AND (|fetch| CLOFFSET |of| LOOKS) (NEQ (|fetch| CLOFFSET |of| LOOKS) 0)) (CONCAT " offset " (|fetch| CLOFFSET |of| LOOKS))) (T "")) (COND ((|fetch| CLOLINE |of| LOOKS) " overlined") (T "")) (COND ((|fetch| CLULINE |of| LOOKS) " underlined") (T ""))) T) (RETURN)))) (\\TEDIT.SMALLERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\\TEDIT.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT -2) SEL))))) (\\TEDIT.SUBSCRIPTSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:12 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT -2) SEL))) (\\TEDIT.SUPERSCRIPTSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:13 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT 2) SEL))) (\\TEDIT.UCASE.SEL (LAMBDA (STREAM TEXTOBJ SEL) (* \; "Edited 3-Sep-87 10:53 by jds") (* \; "uppercasifies the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (|fetch| CH# |of| SEL)) (LEN (|fetch| DCH |of| SEL)) (POINT (|fetch| POINT |of| SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (|replace| (TEDITHISTORYEVENT THACTION) |of| (|fetch| (TEXTOBJ TXTHISTORY) |of| TEXTOBJ) |with| '|UpperCase|)))) (\\TEDIT.UNDERLINE.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:26 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL))) (\\TEDIT.UNDERLINE.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL))) (\\TEDIT.STRIKEOUT.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT ON) SEL))) (\\TEDIT.STRIKEOUT.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT OFF) SEL))) ) (* |;;| "Specialized functions for this module") (DEFINEQ (\\TEDIT.DK.ABORT (LAMBDA (TEXTOBJ) (TEDIT.GET TEXTOBJ))) (\\TEDIT.DK.FIND (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 28-Oct-87 18:25 by jds") (* |;;| "FIND command for TEDITDORADOKEYS: Offers you the current selected text if there is not any other cached text to offer. Otherwise, behaves just like the FIND button of the 1186.") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* |;;| "Case sensitive search, with * and # wildcards") (SETQ W (CAR (MKLIST (|fetch| \\WINDOW |of| TEXTOBJ)))) (SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (OR (WINDOWPROP W ' TEDIT.LAST.FIND.STRING) (TEDIT.SEL.AS.STRING TEXTSTREAM SEL)) (CHARCODE (EOL LF ESC)))) (COND (TARGET (SETQ SEL (|fetch| SEL |of| TEXTOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* \; "We found the target text.") (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (|replace| CH# |of| SEL |with| (CAR CH)) (* \;  "Set up SELECTION to be the found text") (|replace| CHLIM |of| SEL |with| (ADD1 (CADR CH))) (|replace| DCH |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (|replace| POINT |of| SEL |with| 'RIGHT) (|replace| CARETLOOKS |of| TEXTOBJ |with| (\\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \; "And never pending a deletion.") (\\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* \; "And get it into the window") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\\SHOWSEL SEL NIL T))))) (|replace| \\INSERTNEXTCH |of| TEXTOBJ |with| -1)))) (\\TEDIT.DK.SUBSTITUTE (LAMBDA (TEXTSTREAM) (* \; "Edited 28-Oct-87 19:35 by jds") (* |;;| "KEYBOARD SUBSTITUTE INTERFACE for TEDITDORADOKEYS") (TEDIT.SUBSTITUTE TEXTSTREAM))) (\\TEDIT.DK.INSERT-PARENS (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:42 by jds") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM ")" CHLIM) (TEDIT.INSERT TEXTSTREAM "(" CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) (\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:45 by jds") (* |;;| "Insert ASCII double-quotes (\") around the selection") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM "\"" CHLIM) (TEDIT.INSERT TEXTSTREAM "\"" CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:44 by jds") (* |;;| "Insert NS double quotes around the selection.") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,252) CHLIM) (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,272) CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) ) (RPAQQ \\TEDIT.DORADO.KEYS (("1,a" FN \\TEDIT.DK.ABORT) ("1,A" FN \\TEDIT.DK.ABORT) ("1,U" UNDO) ("1,u" UNDO) ("1,f" FN \\TEDIT.DK.FIND) ("1,F" FN \\TEDIT.DK.FIND) (ESC REDO) ("1,n" NEXT) ("1,N" NEXT) ("1,S" FN \\TEDIT.DK.SUBSTITUTE) ("1,s" FN \\TEDIT.DK.SUBSTITUTE) ("1,x" EXPAND) ("1,X" EXPAND) ("1,c" FN \\TEDIT.CENTER.SEL) ("1,C" FN \\TEDIT.CENTER.SEL.REV) ("1,b" FN \\TEDIT.BOLD.SEL.ON) ("1,B" FN \\TEDIT.BOLD.SEL.OFF) ("1,i" FN \\TEDIT.ITALIC.SEL.ON) ("1,I" FN \\TEDIT.ITALIC.SEL.OFF) ("1,=" FN \\TEDIT.STRIKEOUT.SEL.ON) ("1,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) ("1,-" FN \\TEDIT.UNDERLINE.SEL.ON) ("1,_" FN \\TEDIT.UNDERLINE.SEL.OFF) ("1,^" FN \\TEDIT.SUBSCRIPTSEL) ("1,|" FN \\TEDIT.SUPERSCRIPTSEL) ("1,SPACE" FN \\TEDIT.DEFAULTSSEL) ("1,?" FN \\TEDIT.SHOWCARETLOOKS) ("1,(" FN \\TEDIT.DK.INSERT-PARENS) ("1,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) ("1,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES))) (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY)))) (PUTPROPS TEDITDORADOKEYS COPYRIGHT ("Xerox Corporation" 1987)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4289 15977 (\\TEDIT.BOLD.SEL.OFF 4299 . 4537) (\\TEDIT.BOLD.SEL.ON 4539 . 4773) ( \\TEDIT.CENTER.SEL 4775 . 5845) (\\TEDIT.CENTER.SEL.REV 5847 . 6942) (\\TEDIT.DEFAULTS.CARET 6944 . 7236) (\\TEDIT.DEFAULTSSEL 7238 . 7576) (\\TEDIT.SETDEFAULT.FROM.SEL 7578 . 8035) (\\TEDIT.FIND 8037 . 10898) (\\TEDIT.ITALIC.SEL.OFF 10900 . 11142) (\\TEDIT.ITALIC.SEL.ON 11144 . 11330) ( \\TEDIT.LARGERSEL 11332 . 11627) (\\TEDIT.LCASE.SEL 11629 . 12345) (\\TEDIT.SHOWCARETLOOKS 12347 . 13730) (\\TEDIT.SMALLERSEL 13732 . 14030) (\\TEDIT.SUBSCRIPTSEL 14032 . 14239) (\\TEDIT.SUPERSCRIPTSEL 14241 . 14449) (\\TEDIT.UCASE.SEL 14451 . 15207) (\\TEDIT.UNDERLINE.SEL.OFF 15209 . 15400) ( \\TEDIT.UNDERLINE.SEL.ON 15402 . 15591) (\\TEDIT.STRIKEOUT.SEL.ON 15593 . 15782) ( \\TEDIT.STRIKEOUT.SEL.OFF 15784 . 15975)) (16035 20829 (\\TEDIT.DK.ABORT 16045 . 16112) ( \\TEDIT.DK.FIND 16114 . 19143) (\\TEDIT.DK.SUBSTITUTE 19145 . 19402) (\\TEDIT.DK.INSERT-PARENS 19404 . 19791) (\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES 19793 . 20285) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES 20287 . 20827))))) STOP \ No newline at end of file diff --git a/lispusers/TEDITDORADOKEYS.~2~ b/lispusers/TEDITDORADOKEYS.~2~ deleted file mode 100644 index 5516a9f2..00000000 --- a/lispusers/TEDITDORADOKEYS.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "19-Apr-2018 12:27:21"  |{DSK}kaplan>Local>medley3.5>lispcore>lispusers>TEDITDORADOKEYS.;2| 22264 |changes| |to:| (VARS TEDITDORADOKEYSCOMS) |previous| |date:| "28-Oct-87 19:53:12" |{DSK}kaplan>Local>medley3.5>lispcore>lispusers>TEDITDORADOKEYS.;1|) ; Copyright (c) 1987, 2018 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TEDITDORADOKEYSCOMS) (RPAQQ TEDITDORADOKEYSCOMS ((FILES TEDITDCL TEDITFNKEYS) (COMS (* |;;|  "These functions were fixed after Lyric went out so they'll ignore the meta key being down.") (FNS \\TEDIT.BOLD.SEL.OFF \\TEDIT.BOLD.SEL.ON \\TEDIT.CENTER.SEL \\TEDIT.CENTER.SEL.REV \\TEDIT.DEFAULTS.CARET \\TEDIT.DEFAULTSSEL \\TEDIT.SETDEFAULT.FROM.SEL \\TEDIT.FIND \\TEDIT.ITALIC.SEL.OFF \\TEDIT.ITALIC.SEL.ON \\TEDIT.LARGERSEL \\TEDIT.LCASE.SEL \\TEDIT.SHOWCARETLOOKS \\TEDIT.SMALLERSEL \\TEDIT.SUBSCRIPTSEL \\TEDIT.SUPERSCRIPTSEL \\TEDIT.UCASE.SEL \\TEDIT.UNDERLINE.SEL.OFF \\TEDIT.UNDERLINE.SEL.ON \\TEDIT.STRIKEOUT.SEL.ON \\TEDIT.STRIKEOUT.SEL.OFF)) (COMS (* |;;| "Specialized functions for this module") (FNS \\TEDIT.DK.ABORT \\TEDIT.DK.FIND \\TEDIT.DK.SUBSTITUTE \\TEDIT.DK.INSERT-PARENS \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)) (VARS (\\TEDIT.DORADO.KEYS '(("1,a" FN \\TEDIT.DK.ABORT) ("1,A" FN \\TEDIT.DK.ABORT) ("1,U" UNDO) ("1,u" UNDO) ("1,f" FN \\TEDIT.DK.FIND) ("1,F" FN \\TEDIT.DK.FIND) (ESC REDO) ("1,n" NEXT) ("1,N" NEXT) ("1,S" FN \\TEDIT.DK.SUBSTITUTE) ("1,s" FN \\TEDIT.DK.SUBSTITUTE) ("1,x" EXPAND) ("1,X" EXPAND) ("1,c" FN \\TEDIT.CENTER.SEL) ("1,C" FN \\TEDIT.CENTER.SEL.REV) ("1,b" FN \\TEDIT.BOLD.SEL.ON) ("1,B" FN \\TEDIT.BOLD.SEL.OFF) ("1,i" FN \\TEDIT.ITALIC.SEL.ON) ("1,I" FN \\TEDIT.ITALIC.SEL.OFF) ("1,=" FN \\TEDIT.STRIKEOUT.SEL.ON) ("1,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) ("1,-" FN \\TEDIT.UNDERLINE.SEL.ON) ("1,_" FN \\TEDIT.UNDERLINE.SEL.OFF) ("1,^" FN \\TEDIT.SUBSCRIPTSEL) ("1,|" FN \\TEDIT.SUPERSCRIPTSEL) ("1,SPACE" FN \\TEDIT.DEFAULTSSEL) ("1,?" FN \\TEDIT.SHOWCARETLOOKS) ("1,(" FN \\TEDIT.DK.INSERT-PARENS) ("1,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) ("1,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)))) (P (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))))) (FILESLOAD TEDITDCL TEDITFNKEYS) (* |;;| "These functions were fixed after Lyric went out so they'll ignore the meta key being down." ) (DEFINEQ (\\TEDIT.BOLD.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* \; "Edited 20-Oct-87 10:42 by jds") (\\TEDIT.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL))) (\\TEDIT.BOLD.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 10:42 by jds") (\\TEDIT.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL))) (\\TEDIT.CENTER.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 24-Sep-87 10:07 by jds") (* |;;| "makes the current paragraph centered") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (|fetch| CH# |of| SEL)) (SAVEDCH (|fetch| DCH |of| SEL))) (|for| PARA |in| (\\PARAS.IN.SEL SEL TEXTOBJ) |do| (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) (SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT))))) (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (|push| NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T)))))) (\\TEDIT.CENTER.SEL.REV (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 24-Sep-87 10:07 by jds") (* |;;| "acts like center.sel but cycles in the opposite direction") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (|fetch| CH# |of| SEL)) (SAVEDCH (|fetch| DCH |of| SEL))) (|for| PARA |in| (\\PARAS.IN.SEL SEL TEXTOBJ) |do| (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) (SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT))))) (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (|push| NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (COND (TEDIT.FNKEY.VERBOSE (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T)))))) (\\TEDIT.DEFAULTS.CARET (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 11:24") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (|create| CHARLOOKS |using| TEDIT.DEFAULT.CHARLOOKS)) (\\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)))) (\\TEDIT.DEFAULTSSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:12 by jds") (* |acts| |on| |the| |selection|) (TEDIT.LOOKS TEXTSTREAM (|create| CHARLOOKS |using| TEDIT.DEFAULT.CHARLOOKS) SEL))) (\\TEDIT.SETDEFAULT.FROM.SEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| " 8-Nov-85 15:22") (* |Set| |the| |defaults| |from| |the|  |current| |selection.|) (PROG ((LOOKS (TEDIT.GET.LOOKS TEXTSTREAM SEL))) (SETQ TEDIT.DEFAULT.CHARLOOKS (\\TEDIT.PARSE.CHARLOOKS.LIST LOOKS))))) (\\TEDIT.FIND (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 28-Oct-87 19:35 by jds") (* |;;| "ENCAPSULATION FOR FIND KEY") (* |;;| "just calls the normal tedit.find starting at the right of the current selection") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* \;  "Case sensitive search, with * and # wildcards") (SETQ W (CAR (|fetch| \\WINDOW |of| TEXTOBJ))) (SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING ) (CHARCODE (EOL LF ESC)))) (COND (TARGET (SETQ SEL (|fetch| SEL |of| TEXTOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* \; "We found the target text.") (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (|replace| CH# |of| SEL |with| (CAR CH)) (* \;  "Set up SELECTION to be the found text") (|replace| CHLIM |of| SEL |with| (ADD1 (CADR CH))) (|replace| DCH |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (|replace| POINT |of| SEL |with| 'RIGHT) (|replace| CARETLOOKS |of| TEXTOBJ |with| (\\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \; "And never pending a deletion.") (\\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* \; "And get it into the window") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\\SHOWSEL SEL NIL T))))) (|replace| \\INSERTNEXTCH |of| TEXTOBJ |with| -1)))) (\\TEDIT.ITALIC.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* \; "Edited 20-Oct-87 10:43 by jds") (\\TEDIT.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL))) (\\TEDIT.ITALIC.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 10:43 by jds") (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL))) (\\TEDIT.LARGERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\\TEDIT.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT 2) SEL))))) (\\TEDIT.LCASE.SEL (LAMBDA (STREAM TEXTOBJ SEL) (* \; "Edited 3-Sep-87 10:49 by jds") (* |;;| "LOWER-CASEs the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (|fetch| CH# |of| SEL)) (LEN (|fetch| DCH |of| SEL)) (POINT (|fetch| POINT |of| SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (|replace| (TEDITHISTORYEVENT THACTION) |of| (|fetch| (TEXTOBJ TXTHISTORY) |of| TEXTOBJ) |with| '|LowerCase|)))) (\\TEDIT.SHOWCARETLOOKS (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |gbn| "30-Jan-85 16:06") (* * |comment|) (PROG ((LOOKS (|fetch| CARETLOOKS |of| TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\\TK.DESCRIBEFONT (|fetch| CLFONT |of| LOOKS)) (COND ((AND (|fetch| CLOFFSET |of| LOOKS) (NEQ (|fetch| CLOFFSET |of| LOOKS) 0)) (CONCAT " offset " (|fetch| CLOFFSET |of| LOOKS))) (T "")) (COND ((|fetch| CLOLINE |of| LOOKS) " overlined") (T "")) (COND ((|fetch| CLULINE |of| LOOKS) " underlined") (T ""))) T) (RETURN)))) (\\TEDIT.SMALLERSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* |jds| "21-Sep-85 08:58") (COND ((SHIFTDOWNP 'META) (\\TEDIT.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT -2) SEL))))) (\\TEDIT.SUBSCRIPTSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:12 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT -2) SEL))) (\\TEDIT.SUPERSCRIPTSEL (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:13 by jds") (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT 2) SEL))) (\\TEDIT.UCASE.SEL (LAMBDA (STREAM TEXTOBJ SEL) (* \; "Edited 3-Sep-87 10:53 by jds") (* \; "uppercasifies the selection") (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (|fetch| CH# |of| SEL)) (LEN (|fetch| DCH |of| SEL)) (POINT (|fetch| POINT |of| SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ) (|replace| (TEDITHISTORYEVENT THACTION) |of| (|fetch| (TEXTOBJ TXTHISTORY) |of| TEXTOBJ) |with| '|UpperCase|)))) (\\TEDIT.UNDERLINE.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:26 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL))) (\\TEDIT.UNDERLINE.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL))) (\\TEDIT.STRIKEOUT.SEL.ON (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT ON) SEL))) (\\TEDIT.STRIKEOUT.SEL.OFF (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 20-Oct-87 11:27 by jds") (TEDIT.LOOKS TEXTSTREAM '(STRIKEOUT OFF) SEL))) ) (* |;;| "Specialized functions for this module") (DEFINEQ (\\TEDIT.DK.ABORT (LAMBDA (TEXTOBJ) (TEDIT.GET TEXTOBJ))) (\\TEDIT.DK.FIND (LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* \; "Edited 28-Oct-87 18:25 by jds") (* |;;| "FIND command for TEDITDORADOKEYS: Offers you the current selected text if there is not any other cached text to offer. Otherwise, behaves just like the FIND button of the 1186.") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* |;;| "Case sensitive search, with * and # wildcards") (SETQ W (CAR (MKLIST (|fetch| \\WINDOW |of| TEXTOBJ)))) (SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (OR (WINDOWPROP W ' TEDIT.LAST.FIND.STRING) (TEDIT.SEL.AS.STRING TEXTSTREAM SEL)) (CHARCODE (EOL LF ESC)))) (COND (TARGET (SETQ SEL (|fetch| SEL |of| TEXTOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* \; "We found the target text.") (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (|replace| CH# |of| SEL |with| (CAR CH)) (* \;  "Set up SELECTION to be the found text") (|replace| CHLIM |of| SEL |with| (ADD1 (CADR CH))) (|replace| DCH |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CH) (CAR CH)))) (|replace| POINT |of| SEL |with| 'RIGHT) (|replace| CARETLOOKS |of| TEXTOBJ |with| (\\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \; "And never pending a deletion.") (\\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* \; "And get it into the window") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\\SHOWSEL SEL NIL T))))) (|replace| \\INSERTNEXTCH |of| TEXTOBJ |with| -1)))) (\\TEDIT.DK.SUBSTITUTE (LAMBDA (TEXTSTREAM) (* \; "Edited 28-Oct-87 19:35 by jds") (* |;;| "KEYBOARD SUBSTITUTE INTERFACE for TEDITDORADOKEYS") (TEDIT.SUBSTITUTE TEXTSTREAM))) (\\TEDIT.DK.INSERT-PARENS (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:42 by jds") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM ")" CHLIM) (TEDIT.INSERT TEXTSTREAM "(" CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) (\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:45 by jds") (* |;;| "Insert ASCII double-quotes (\") around the selection") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM "\"" CHLIM) (TEDIT.INSERT TEXTSTREAM "\"" CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES (LAMBDA (TEXTOBJ TEXTSTREAM SEL) (* \; "Edited 28-Oct-87 19:44 by jds") (* |;;| "Insert NS double quotes around the selection.") (LET ((CH1 (|fetch| CH# |of| SEL)) (CHLIM (|fetch| CHLIM |of| SEL))) (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,252) CHLIM) (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,272) CH1) (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1)))))) ) (RPAQQ \\TEDIT.DORADO.KEYS (("1,a" FN \\TEDIT.DK.ABORT) ("1,A" FN \\TEDIT.DK.ABORT) ("1,U" UNDO) ("1,u" UNDO) ("1,f" FN \\TEDIT.DK.FIND) ("1,F" FN \\TEDIT.DK.FIND) (ESC REDO) ("1,n" NEXT) ("1,N" NEXT) ("1,S" FN \\TEDIT.DK.SUBSTITUTE) ("1,s" FN \\TEDIT.DK.SUBSTITUTE) ("1,x" EXPAND) ("1,X" EXPAND) ("1,c" FN \\TEDIT.CENTER.SEL) ("1,C" FN \\TEDIT.CENTER.SEL.REV) ("1,b" FN \\TEDIT.BOLD.SEL.ON) ("1,B" FN \\TEDIT.BOLD.SEL.OFF) ("1,i" FN \\TEDIT.ITALIC.SEL.ON) ("1,I" FN \\TEDIT.ITALIC.SEL.OFF) ("1,=" FN \\TEDIT.STRIKEOUT.SEL.ON) ("1,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) ("1,-" FN \\TEDIT.UNDERLINE.SEL.ON) ("1,_" FN \\TEDIT.UNDERLINE.SEL.OFF) ("1,^" FN \\TEDIT.SUBSCRIPTSEL) ("1,|" FN \\TEDIT.SUPERSCRIPTSEL) ("1,SPACE" FN \\TEDIT.DEFAULTSSEL) ("1,?" FN \\TEDIT.SHOWCARETLOOKS) ("1,(" FN \\TEDIT.DK.INSERT-PARENS) ("1,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) ("1,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES))) (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY)))) (PUTPROPS TEDITDORADOKEYS COPYRIGHT ("Xerox Corporation" 1987 2018)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4082 15770 (\\TEDIT.BOLD.SEL.OFF 4092 . 4330) (\\TEDIT.BOLD.SEL.ON 4332 . 4566) ( \\TEDIT.CENTER.SEL 4568 . 5638) (\\TEDIT.CENTER.SEL.REV 5640 . 6735) (\\TEDIT.DEFAULTS.CARET 6737 . 7029) (\\TEDIT.DEFAULTSSEL 7031 . 7369) (\\TEDIT.SETDEFAULT.FROM.SEL 7371 . 7828) (\\TEDIT.FIND 7830 . 10691) (\\TEDIT.ITALIC.SEL.OFF 10693 . 10935) (\\TEDIT.ITALIC.SEL.ON 10937 . 11123) ( \\TEDIT.LARGERSEL 11125 . 11420) (\\TEDIT.LCASE.SEL 11422 . 12138) (\\TEDIT.SHOWCARETLOOKS 12140 . 13523) (\\TEDIT.SMALLERSEL 13525 . 13823) (\\TEDIT.SUBSCRIPTSEL 13825 . 14032) (\\TEDIT.SUPERSCRIPTSEL 14034 . 14242) (\\TEDIT.UCASE.SEL 14244 . 15000) (\\TEDIT.UNDERLINE.SEL.OFF 15002 . 15193) ( \\TEDIT.UNDERLINE.SEL.ON 15195 . 15384) (\\TEDIT.STRIKEOUT.SEL.ON 15386 . 15575) ( \\TEDIT.STRIKEOUT.SEL.OFF 15577 . 15768)) (15828 20622 (\\TEDIT.DK.ABORT 15838 . 15905) ( \\TEDIT.DK.FIND 15907 . 18936) (\\TEDIT.DK.SUBSTITUTE 18938 . 19195) (\\TEDIT.DK.INSERT-PARENS 19197 . 19584) (\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES 19586 . 20078) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES 20080 . 20620))))) STOP \ No newline at end of file diff --git a/lispusers/TEDITKEY.~1~ b/lispusers/TEDITKEY.~1~ deleted file mode 100644 index 3c84e4d9..00000000 --- a/lispusers/TEDITKEY.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Nov-87 14:55:24" {ERINYES}LISPCORE>TEDITKEY.;1 95396 changes to%: (VARS TEDITKEYCOMS) previous date%: " 1-Apr-86 22:36:26" {ERINYES}LYRIC>LISPUSERS>TEDITKEY.;1) (* " Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITKEYCOMS) (RPAQQ TEDITKEYCOMS [(COMS (* ;;; "This is the Lyric-and-later version of TEditKey") ) (COMS (* ;  "functions for affecting the selection") (FNS NTHCAR \TEXTOBJ.WINDEX \TK.PREVSCREEN \TK.UNDERLINE.SEL.ON \TK.UNDERLINE.SEL.OFF \TK.BOLD.SEL.ON \TK.BOLD.SEL.OFF \TK.ITALIC.SEL.ON \TK.ITALIC.SEL.OFF \TK.SMALLERSEL \TK.LARGERSEL \TK.SUPERSCRIPTSEL \TK.SUBSCRIPTSEL \TK.DEFAULTSSEL \TK.DEL.WORD.FORWARD \TK.UCASE.SEL \TK.CAPITALISE.SEL \CAPITALISE \TK.LCASE.SEL) (* ;  "functions for affecting the paralooks of the selection") (FNS \TK.CENTER.SEL \TK.CENTER.SEL.REV \TK.NEST \TK.UNNEST)) (COMS (* ;  "functions for affecting (and displaying) the caret character looks") (FNS \TK.SHOWCARETLOOKS \TK.BOLD.CARET.ON \TK.BOLD.CARET.OFF \TK.ITALIC.CARET.ON \TK.ITALIC.CARET.OFF \TK.UNDERLINE.CARET.ON \TK.UNDERLINE.CARET.OFF \TK.SUPERSCRIPT.CARET \TK.SUBSCRIPT.CARET \TK.SMALLER.CARET \TK.LARGER.CARET \TK.DEFAULTS.CARET \TK.FONT1 \TK.FONT2 \TK.FONT3 \TK.SETCARETFONT \TK.FONT4 \TK.FONT5 \TK.FONT6 \TK.FONT7 \TK.FONT8) (* ;  "the functions which aren't currently used, which toggle the caret looks") (FNS \TK.BOLDTOGGLE \TK.ITALICTOGGLE \TK.UNDERLINETOGGLE)) (COMS (* ;  "functions dealing with the default looks") (FNS \TK.SETDEFAULTLOOKS)) (COMS (* ;  "functions for positioning within a document") (FNS GOTONEXTTTYWINDOW \TK.NEXTLINE \TK.PREVLINE \TK.GOTODOCBEGIN \TK.GOTODOCEND \TK.GOTOLINEBEGIN \TK.GOTOLINEEND \TK.PREVCHAR \TK.NEXTCHAR \TK.FORWARD.WORD \TK.BACK.WORD \TK.SELECT.ALL)) (COMS (* ; "other utilities") (FNS \TK.FIND \TK.REDISPLAY \TK.DELLINEFORWARD \TK.OPENLINE \TK.DELCHARFORWARD \TK.TRANSPOSECHARS)) (COMS (* ;  "little selection utilities etc., for building hacks") (FNS \SEL.LIMIT \TK.SETFILEPTR.TO.CARET \SEL.LINEDESC) (MACROS \SEL.LIMIT.FORWARD \TK.ONOROFF \LINEDESC.LAST.REAL.CHAR)) (COMS (* ; "fns for the key interface itself") (FNS \SHIFTACTION \ACTION TEDITKEY.INSTALL TEDITKEY.DEINSTALL \TK.ACTIONTOCHARCODE \TK.BUILD.MENU \TK.HELP \TK.SETFONTINLOOKS WRITE.CHARDESC.AUX CHARDESC TEDITKEY.CONFIGURE \TK.ADDKEY \TK.CHANGEKEY \TK.APPLYPENDING \TK.NTHFONT) (* ; "redefinition of system junk") (FNS METASHIFT)) (* ;; "(\TK.BOLDTOGGLE (##H ##h) 'toggle Bold caret looks') (\TK.ITALICTOGGLE (##i ##I) 'toggle Italic caret looks') (\TK.SUPERSCRIPT.CARET (##^) 'Superscript the caret looks') (\TK.SUBSCRIPT.CARET (##_) 'Subscript the caret looks')") (FNS TEDIT.FULL.FIND) [VARS \TK.WHITESPACE (TEDIT.INTERRUPTS `((%, (CHARCODE ^G) ERROR) (%, (CHARCODE ^C) HELP] (CONSTANTS (\TK.WHITESPACE 22)) (INITVARS (TEDITKEY.VERBOSE T) (TEDITKEY.METAKEY 'TAB) (TEDITKEY.LOCKTOGGLEKEY NIL) (TEDITKEY.NESTWIDTH 36) (\TK.SIZEINCREMENT 2) (TEDITKEY.OFFSETINCREMENT 3) (TEDITKEY.FONTS '(TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL SYMBOL HIPPO)) (TEDITKEY.FNKEYFLG T)) (MACROS METACODE CONTROLCODE LCMETACODE) (INITVARS (\TK.SELKEY 'OPEN) (\TK.PENDING)) [INITVARS [TEDITKEY.KEYBINDINGS `((\TK.FONT1 (%##1) %, (CONCAT "change to font " (\TK.NTHFONT 1))) (\TK.FONT2 (%##2) %, (CONCAT "change to font " (\TK.NTHFONT 2))) (\TK.FONT3 (%##3) %, (CONCAT "change to font " (\TK.NTHFONT 3))) (\TK.FONT4 (%##4) %, (CONCAT "change to font " (\TK.NTHFONT 4))) (\TK.FONT5 (%##5) %, (CONCAT "change to font " (\TK.NTHFONT 5))) (\TK.FONT6 (%##6) %, (CONCAT "change to font " (\TK.NTHFONT 6))) (\TK.FONT7 (%##7) %, (CONCAT "change to font " (\TK.NTHFONT 7))) (\TK.FONT8 (%##8) %, (CONCAT "change to font " (\TK.NTHFONT 8))) NIL (\TK.DEFAULTS.CARET (%##/) "restore the default caret looks") (\TK.SMALLER.CARET (%##9) "decrease the caret font size") (\TK.LARGER.CARET (%##0) "increase the caret font size") (\TK.SHOWCARETLOOKS (%##=) "display the current caret looks") NIL (\TK.REDISPLAY (%##R %##r) "Restore the display") (\TK.HELP (%##?) "displays the current key bindings") NIL (\TK.PREVCHAR (^B ^b) "Back one character") (\TK.NEXTCHAR (^F ^f) "Forward one character") (\TK.FORWARD.WORD (%##F %##f) "Forward one word") (\TK.BACK.WORD (%##B %##b) "Back one word") (\TK.GOTOLINEBEGIN (^A ^a) "go to stArt of line") (\TK.GOTOLINEEND (^E ^e) "go to End of line") (\TK.PREVLINE (^P ^p) "go to Previous line") (\TK.NEXTLINE (^N ^n) "go to Next line") (\TK.GOTODOCBEGIN (%##<) "start of document") (\TK.GOTODOCEND (%##>) "end of document") (\TK.SELECT.ALL (%##S %##s) "Select whole document") NIL (\TK.DELLINEFORWARD (^K ^k) "Kill line") (\TK.OPENLINE (^O ^o) "Open up blank line") (\TK.DELCHARFORWARD (^D ^d) "Delete character forward") (\TK.DEL.WORD.FORWARD (%##D %##d) "Delete word forward") (\TK.TRANSPOSECHARS (^T ^t) "Transpose characters") NIL NIL (\TK.NEST (|##[|) "indents margins (nest)") (\TK.UNNEST (|##]|) "exdents margins (unnest)") (\TK.CENTER.SEL (%##J %##j) "alter Justification") (\TK.UCASE.SEL (%##U %##u) "Uppercasify selection") (\TK.CAPITALISE.SEL (%##C %##c) "Capitalize selection") (\TK.LCASE.SEL (%##L %##l) "Lowercasify selection") (GET.OBJ.FROM.USER (%##O %##o) "insert Object"] [TEDITKEY.DLION.KEYACTIONS `((STOP (%, (CHARCODE ^G) %, (CHARCODE ^C) NOLOCKSHIFT)) (OPEN (%, (CHARCODE 2,1) %, (CHARCODE 2,41) NOLOCKSHIFT)) (FONT FONTDOWN . FONTUP) (KEYBOARD USERMODE1DOWN . USERMODE1UP] (COMS (* ;; "(TEDITKEY.FNKEYACTIONS (BQUOTE ((CENTER (, (CHARCODE ##^B), (CHARCODE ##^C))) (BOLD (, (CHARCODE ##^D), (CHARCODE ##^E) NOLOCKSHIFT)) (ITALICS (, (CHARCODE ##^F), (CHARCODE ##^G) NOLOCKSHIFT)) (UNDERLINE (, (CHARCODE ##^H), (CHARCODE ##^I) NOLOCKSHIFT)) (SUPERSCRIPT (, (CHARCODE ##^J), (CHARCODE ##^K) NOLOCKSHIFT)) (SUBSCRIPT (, (CHARCODE ##^L), (CHARCODE ##^N) NOLOCKSHIFT)) (LARGER (, (CHARCODE ##^O), (CHARCODE ##^P) NOLOCKSHIFT)) (DEFAULTS (, (CHARCODE ##^Q), (CHARCODE ##^R) NOLOCKSHIFT)) (BS (, (CHARCODE ^H), (CHARCODE ^D) NOLOCKSHIFT)))))") ) [TEDITKEY.DLION.KEYBINDINGS '(((\ACTION 'OPEN) \TK.OPENLINE) ((\ACTION 'HELP) \TK.HELP) ((\ACTION 'MARGINS) \TK.NEST) ((\SHIFTACTION 'MARGINS) \TK.UNNEST) ((\SHIFTACTION 'NEXT) GOTONEXTTTYWINDOW] [TEDITKEY.FNKEYBINDINGS '(((\ACTION 'DEFAULTS) \TK.DEFAULTSSEL) ((\SHIFTACTION 'DEFAULTS) \TK.SETDEFAULTLOOKS] (COMS (* ;; "NOT NEEDED (TEDITKEY.DLION.KEYSYNTAX (QUOTE (((\ACTION (QUOTE NEXT)) NEXT) ((\ACTION (QUOTE UNDO)) UNDO) ((\ACTION (QUOTE BS)) CHARDELETE))))") ) [TEDITKEY.DORADO.KEYACTIONS `((BS (%, (CHARCODE ^H) %, (CHARCODE ^H))) (BLANK-BOTTOM (%, (CHARCODE %##^A) %, (CHARCODE %##^A))) (BLANK-TOP FONTDOWN . FONTUP) (BLANK-MIDDLE USERMODE1DOWN . USERMODE1UP) (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] (TEDITKEY.DORADO.KEYSYNTAX '(((CHARCODE %##N) NEXT) ((CHARCODE %##n) NEXT) ((\ACTION 'BLANK-BOTTOM) UNDO) ((\ACTION 'BS) CHARDELETE] (P (TEDITKEY.INSTALL)) (P (\TK.BUILD.MENU)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA METASHIFT]) (* ;;; "This is the Lyric-and-later version of TEditKey") (* ; "functions for affecting the selection") (DEFINEQ (NTHCAR [LAMBDA (LIST N) (* gbn "10-Oct-85 20:54") (CAR (NTH LIST N]) (\TEXTOBJ.WINDEX [LAMBDA (TEXTOBJ) (* gbn "10-Oct-85 20:51") (* * returns the number which is the position in the list textobj%:\window  indicating which window had the last selection in it.  This number is then an index into line descriptor lists etc.) (bind (CURW _ (fetch SELWINDOW of TEXTOBJ)) for J from 1 as W in (fetch \WINDOW of TEXTOBJ) until (EQ W CURW) do NIL finally (RETURN J]) (\TK.PREVSCREEN [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "10-Oct-85 00:10") (* moves the selection up one line) (PROG (THIS PREV) (* get the selection on the screen so that it has a line descriptor) (TEDIT.NORMALIZECARET STREAM SEL) (if [SETQ THIS (CAR (MKLIST (fetch L1 of SEL] then (* empty docs have no line descriptors) (SETQ PREV (fetch PREVLINE of THIS)) [if (ZEROP (fetch CHARLIM of PREV)) then (* we need to back format because this is a fake line descriptor) (\BACKFORMAT (CAR (fetch LINES of TEXTOBJ)) TEXTOBJ (fetch SELWINDOW of TEXTOBJ)) (SETQ PREV (fetch PREVLINE of THIS)) (* (SETQ PREV (replace PREVLINE of  THIS with (\FORMATLINE TEXTOBJ NIL  (ADD1 (fetch CHARLIM of THIS))))))] (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of PREV) (IDIFFERENCE (\SEL.LIMIT SEL) (fetch CHAR1 of THIS))) (fetch CHARLIM of PREV)) 0]) (\TK.UNDERLINE.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:01") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT4 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.UNDERLINE.CARET.ON TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.underlineon which happens when neither Keyboard  nor font is held) (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL]) (\TK.UNDERLINE.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:01") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT4 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.UNDERLINE.CARET.OFF TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.underlineon which happens when neither Keyboard  nor font is held) (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL]) (\TK.BOLD.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:01") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT2 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.boldon which happens when neither Keyboard nor  font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL]) (\TK.BOLD.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* gbn "19-Mar-85 12:02") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT2 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \tk.boldon which happens when neither Keyboard nor  font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL]) (\TK.ITALIC.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:02") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT3 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.ITALIC.CARET.ON TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL]) (\TK.ITALIC.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* gbn "19-Mar-85 12:02") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT3 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (\TK.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL)) (T (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL]) (\TK.SMALLERSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:47") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT7 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither  Keyboard nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT (IMINUS \TK.SIZEINCREMENT)) SEL]) (\TK.LARGERSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:47") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT7 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.LARGER.SEL which happens when neither Keyboard  nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT \TK.SIZEINCREMENT) SEL]) (\TK.SUPERSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:56") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT5 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither  Keyboard nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT TEDITKEY.OFFSETINCREMENT) SEL]) (\TK.SUBSCRIPTSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:42") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT6 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither  Keyboard nor font is held) (* acts on the selection) (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT (MINUS TEDITKEY.OFFSETINCREMENT)) SEL]) (\TK.DEFAULTSSEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:55") (* acts on the selection) (COND ((SHIFTDOWNP 'FONT) (\TK.FONT8 TEXTSTREAM TEXTOBJ SEL)) ((SHIFTDOWNP 'USERMODE1) (* do the caret looks case) (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL)) (T (* acts on the selection) (PROG ((LOOKS (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS))) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (TEDIT.LOOKS TEXTSTREAM LOOKS SEL]) (\TK.DEL.WORD.FORWARD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:45") (* * Deletes from here to the end of the first word Refers to the syntax  classes of the characters according to the TEDIT.WORDBOUND.READTABLE) (PROG (HERE) (* position the file ptr at the (character after the) caret of the selection) (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL) (* record this position as the beginning of the word  (to make the beginning of the selection)) (SETQ HERE (ADD1 (GETFILEPTR TEXTSTREAM))) (* skip the whitespace) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ \TK.WHITESPACE (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM)) (* find out what syntax class the first letter of the word has.  The end of the word is marked by a change of syntax classes) (if (NOT (EOFP TEXTSTREAM)) then (SETQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T))) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM))) (TEDIT.SETSEL TEXTSTREAM HERE (ADD1 (IDIFFERENCE (GETFILEPTR TEXTSTREAM) HERE)) 'RIGHT) (TEDIT.DELETE TEXTSTREAM) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.UCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:46") (* uppercasifies the selection) (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch CH# of SEL)) (LEN (fetch DCH of SEL)) (POINT (fetch POINT of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (U-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.CAPITALISE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "24-Feb-86 16:57") (* capitalises the selection) (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch (SELECTION CH#) of SEL)) (LEN (fetch (SELECTION DCH) of SEL)) (POINT (fetch (SELECTION POINT) of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (\CAPITALISE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\CAPITALISE [LAMBDA (STR) (* gbn "24-Feb-86 16:56") (* * capitalises a string) (SELECTQ (NCHARS STR) (0 STR) (1 (U-CASE STR)) (CONCAT (U-CASE (NTHCHAR STR 1)) (L-CASE (SUBSTRING STR 2]) (\TK.LCASE.SEL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:46") (* uppercasifies the selection) (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL)) (POS (fetch CH# of SEL)) (LEN (fetch DCH of SEL)) (POINT (fetch POINT of SEL))) (TEDIT.DELETE STREAM SEL) (TEDIT.INSERT STREAM (L-CASE STR)) (TEDIT.SETSEL STREAM POS LEN POINT) (TEDIT.NORMALIZECARET TEXTOBJ]) ) (* ; "functions for affecting the paralooks of the selection") (DEFINEQ (\TK.CENTER.SEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Feb-85 18:17") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT1 TEXTSTREAM TEXTOBJ SEL)) (T (* makes the current paragraph  centered) (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) (\TK.CENTER.SEL.REV [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn " 7-Jun-85 21:34") (COND ((SHIFTDOWNP 'FONT) (\TK.FONT1 TEXTSTREAM TEXTOBJ SEL)) (T (* * acts like center.sel but cycles in the opposite direction) (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (SETQ OLDQUAD (LISTGET LOOKS 'QUAD)) [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT] (LISTPUT LOOKS 'QUAD NEWQUAD) (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1)) (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL) (push NEWQUADS NEWQUAD)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS) T]) (\TK.NEST [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Feb-85 18:24") (PROG (LOOKS (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (LISTPUT LOOKS 'LEFTMARGIN (IPLUS (LISTGET LOOKS 'LEFTMARGIN) TEDITKEY.NESTWIDTH)) (LISTPUT LOOKS '1STLEFTMARGIN (IPLUS (LISTGET LOOKS '1STLEFTMARGIN) TEDITKEY.NESTWIDTH)) (LISTPUT LOOKS 'RIGHTMARGIN (IMAX 0 (IDIFFERENCE (LISTGET LOOKS 'RIGHTMARGIN) TEDITKEY.NESTWIDTH))) (TEDIT.SETSEL TEXTSTREAM PARA 1) (TEDIT.PARALOOKS TEXTOBJ LOOKS)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH]) (\TK.UNNEST [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Feb-85 18:26") (PROG (LOOKS RIGHT (SAVECH# (fetch CH# of SEL)) (SAVEDCH (fetch DCH of SEL))) (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ) do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA)) (LISTPUT LOOKS 'LEFTMARGIN (IMAX (IDIFFERENCE (LISTGET LOOKS 'LEFTMARGIN) TEDITKEY.NESTWIDTH) 0)) (LISTPUT LOOKS '1STLEFTMARGIN (IMAX (IDIFFERENCE (LISTGET LOOKS '1STLEFTMARGIN) TEDITKEY.NESTWIDTH) 0)) (SETQ RIGHT (LISTGET LOOKS 'RIGHTMARGIN)) (if (NOT (ZEROP RIGHT)) then (LISTPUT LOOKS 'RIGHTMARGIN (IPLUS (LISTGET LOOKS 'RIGHTMARGIN) TEDITKEY.NESTWIDTH))) (TEDIT.SETSEL TEXTSTREAM PARA 1) (TEDIT.PARALOOKS TEXTOBJ LOOKS)) (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH]) ) (* ; "functions for affecting (and displaying) the caret character looks") (DEFINEQ (\TK.SHOWCARETLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "30-Jan-85 16:06") (* * comment) (PROG ((LOOKS (fetch CARETLOOKS of TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\TK.DESCRIBEFONT (fetch CLFONT of LOOKS)) (if (AND (fetch CLOFFSET of LOOKS) (NEQ (fetch CLOFFSET of LOOKS) 0)) then (CONCAT " offset " (fetch CLOFFSET of LOOKS)) else "") (if (fetch CLOLINE of LOOKS) then " overlined" else "") (if (fetch CLULINE of LOOKS) then " underlined" else "")) T) (RETURN]) (\TK.BOLD.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 20:54") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLBOLD of LOOKS with T) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.BOLD.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 20:54") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLBOLD of LOOKS with NIL) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.ITALIC.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:20") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLITAL of LOOKS with T) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.ITALIC.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:19") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLITAL of LOOKS with NIL) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN) else (RETURN]) (\TK.UNDERLINE.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 17:59") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLULINE of LOOKS with T) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.UNDERLINE.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 18:01") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLULINE of LOOKS with NIL) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.SUPERSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:25") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (if (fetch CLOFFSET of LOOKS) then (add (fetch CLOFFSET of LOOKS) TEDITKEY.OFFSETINCREMENT) else (replace CLOFFSET of LOOKS with TEDITKEY.OFFSETINCREMENT)) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.SUBSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:26") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (if (fetch CLOFFSET of LOOKS) then (add (fetch CLOFFSET of LOOKS) (IMINUS TEDITKEY.OFFSETINCREMENT)) else (replace CLOFFSET of LOOKS with (IMINUS TEDITKEY.OFFSETINCREMENT))) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.SMALLER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:45") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLSIZE of LOOKS with (IMAX 4 (IDIFFERENCE (fetch CLSIZE of LOOKS) 2))) (if (NOT (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)) then (RETURN)) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.LARGER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 22:37") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLSIZE of LOOKS with (IPLUS \TK.SIZEINCREMENT (fetch CLSIZE of LOOKS))) (if (NOT (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)) then (RETURN)) (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) (\TK.DEFAULTS.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 21:54") (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS)) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TK.FONT1 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:39") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 1]) (\TK.FONT2 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:43") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 2]) (\TK.FONT3 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:40") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 3]) (\TK.SETCARETFONT [LAMBDA (TEXTOBJ FONTNAME) (* gbn "19-Mar-85 12:02") (* temporary hack. If this function is called when the keyboard shift is down,  then it refers to the caret looks, otherwise the selection) (if (SHIFTDOWNP 'USERMODE1) then [PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLNAME of LOOKS with FONTNAME) (if (\TK.SETFONTINLOOKS TEXTOBJ LOOKS) then (* we found the font, install it as the caret font and tell the user) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTOBJ FONTNAME T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS] else (TEDIT.LOOKS TEXTSTREAM (LIST 'FAMILY FONTNAME) SEL]) (\TK.FONT4 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:40") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 4]) (\TK.FONT5 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:41") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 5]) (\TK.FONT6 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:41") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 6]) (\TK.FONT7 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:42") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 7]) (\TK.FONT8 [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 17:43") (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 8]) ) (* ; "the functions which aren't currently used, which toggle the caret looks") (DEFINEQ (\TK.BOLDTOGGLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 20:54") (* * toggles boldness in the caret looks) (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLBOLD of LOOKS with (NOT (fetch CLBOLD of LOOKS))) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "bold: " (\TK.ONOROFF (fetch CLBOLD of LOOKS))) T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)) else (RETURN]) (\TK.ITALICTOGGLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 19:23") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLITAL of LOOKS with (NOT (fetch CLITAL of LOOKS))) (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS) then (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "italic: " (\TK.ONOROFF (fetch CLITAL of LOOKS))) T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)) else (RETURN]) (\TK.UNDERLINETOGGLE [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "27-Jan-85 19:23") (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] (replace CLULINE of LOOKS with (NOT (fetch CLULINE of LOOKS))) (if TEDITKEY.VERBOSE then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "underline: " (\TK.ONOROFF (fetch CLULINE of LOOKS))) T)) (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS]) ) (* ; "functions dealing with the default looks") (DEFINEQ (\TK.SETDEFAULTLOOKS [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "16-Feb-85 23:00") (* * sets TEDIT.DEFAULT.CHARLOOKS to have the looks of the current selection) (PROG NIL (SETQ TEDIT.DEFAULT.CHARLOOKS (COPY (fetch CARETLOOKS of TEXTOBJ))) (if TEDITKEY.VERBOSE then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL)) (RETURN]) ) (* ; "functions for positioning within a document") (DEFINEQ (GOTONEXTTTYWINDOW [LAMBDA NIL (* gbn " 7-May-85 16:19") (* * puts the tty in the next appropriate process in the chain) (PROG ((CURRENT (TTY.PROCESS))) (SETQ CANDIDATES (LIST NIL)) [MAP.PROCESSES (FUNCTION (LAMBDA (PROC) (PROG (W) (if (AND (SETQ W (PROCESSPROP PROC 'WINDOW)) (OPENWP W) (WINDOWPROP W 'PROCESS)) then (NCONC1 CANDIDATES PROC] (SETQ NEW (CDR (MEMBER CURRENT CANDIDATES))) (SETQ NEW (if NEW then (CAR NEW) else (CADR CANDIDATES))) (TTY.PROCESS NEW) (FLASHWINDOW (PROCESSPROP NEW 'WINDOW) 1 1 GRAYSHADE) (* for (PROC _ CURRENT) repeatwhile  (NEQ PROC CURRENT) do  (SETQ W (PROCESSPROP  (SETQ PROC (fetch NEXTPROCHANDLE of  PROC)) (QUOTE WINDOW)))  (PRINTOUT T (PROCESSPROP PROC  (QUOTE NAME))) (if (AND W  (OPENWP W) (WINDOWPROP W  (QUOTE PROCESS))) then  (* this window would probably be  willing to take the tty if clicked in,  so give the process the tty)  (TTY.PROCESS PROC) (FLASHWINDOW W 1  NIL GRAYSHADE) (RETURN))) ]) (\TK.NEXTLINE [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "10-Oct-85 22:47") (* moves the selection down one line) (PROG (THIS NEXT) (* get the selection on the screen so that it has a line descriptor) (TEDIT.NORMALIZECARET STREAM SEL) (SETQ THIS (\SEL.LINEDESC SEL)) (if THIS then (* an empty doc has no line descriptors, even after normalizing) (SETQ NEXT (fetch NEXTLINE of THIS)) [if (NOT NEXT) then (* there isn't already a descriptor  for this line) (SETQ NEXT (replace NEXTLINE of THIS with (\FORMATLINE TEXTOBJ NIL (ADD1 (fetch CHARLIM of THIS] (if NEXT then (* if there are no more characters, then there still may not be a descriptor  when we call \formatline) (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of NEXT) (IDIFFERENCE (\SEL.LIMIT SEL) (fetch CHAR1 of THIS))) (ADD1 (\LINEDESC.LAST.REAL.CHAR NEXT))) 0 'LEFT]) (\TK.PREVLINE [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "10-Oct-85 22:15") (* moves the selection up one line) (PROG (THIS PREV) (* get the selection on the screen so that it has a line descriptor) (TEDIT.NORMALIZECARET STREAM SEL) (if (SETQ THIS (\SEL.LINEDESC SEL)) then (* empty docs have no line descriptors) (SETQ PREV (fetch PREVLINE of THIS)) [if (ZEROP (fetch CHARLIM of PREV)) then (* we need to back format because this is a fake line descriptor) [\BACKFORMAT (NTHCAR (fetch LINES of TEXTOBJ) (\TEXTOBJ.WINDEX TEXTOBJ)) TEXTOBJ (fetch PTOP of (DSPCLIPPINGREGION NIL (fetch SELWINDOW of TEXTOBJ] (SETQ PREV (fetch PREVLINE of THIS)) (* (SETQ PREV (replace PREVLINE of  THIS with (\FORMATLINE TEXTOBJ NIL  (ADD1 (fetch CHARLIM of THIS))))))] (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of PREV) (IDIFFERENCE (\SEL.LIMIT SEL) (fetch CHAR1 of THIS))) (fetch CHARLIM of PREV)) 0]) (\TK.GOTODOCBEGIN [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "13-Dec-84 11:24") (* positions at the beginning of a  document) (TEDIT.SETSEL STREAM 0 0) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.GOTODOCEND [LAMBDA (STREAM TEXTOBJ SEL) (* gbn " 7-Jun-85 16:32") (* positions at the end of a document) (TEDIT.SETSEL STREAM (ADD1 (fetch TEXTLEN of TEXTOBJ)) 0 'LEFT) (TEDIT.NORMALIZECARET STREAM]) (\TK.GOTOLINEBEGIN [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "11-Mar-85 15:04") (* * positions the cursor at the beginning of line) (PROG (CH) (TEDIT.NORMALIZECARET TEXTOBJ SEL) (SETQ CH (fetch CHAR1 of (\SEL.LINEDESC SEL))) (* (if (fetch CR\END of  (fetch L1 of SEL)) then  (* there is a CR at the end of this  line, we want to position before it)  (SETQ CH (SUB1 CH)))) (TEDIT.SETSEL TEXTSTREAM CH 0 'LEFT]) (\TK.GOTOLINEEND [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn " 7-Jun-85 15:47") (* * positions the cursor at the end of line) (PROG ((POINT 'RIGHT) LN) (TEDIT.NORMALIZECARET TEXTOBJ SEL) (if (SETQ LN (\SEL.LINEDESC SEL)) then (* empty docs have no linedescriptors) (SETQ CH (fetch CHARLIM of LN)) (if (fetch CR\END of LN) then (* there is not a CR at the end of this line, we want to position to the right  of the last char) (SETQ POINT 'LEFT)) (TEDIT.SETSEL TEXTSTREAM CH 1 POINT]) (\TK.PREVCHAR [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "19-Mar-85 12:16") (* moves the selection back one char) (PROG NIL (TEDIT.SETSEL STREAM (IMAX 0 (SUB1 (\SEL.LIMIT.FORWARD SEL))) 0 'LEFT) (* I don't think this should be necessary, but there are cases where the caret  is not normalised) (TEDIT.NORMALIZECARET TEXTOBJ SEL]) (\TK.NEXTCHAR [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:48") (* moves the selection back one char) (PROG NIL (* Note%: addition. does *not* distribute with Min Do not pessimize this!) (TEDIT.SETSEL STREAM (IMIN (ADD1 (fetch TEXTLEN of TEXTOBJ)) (ADD1 (\SEL.LIMIT.FORWARD SEL))) 0 'LEFT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.FORWARD.WORD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:48") (* * moves the caret one word forward. Refers to the syntax classes of the  characters according to the TEDIT.WORDBOUND.READTABLE) (PROG (HERE) (* position the file ptr at the (character after the) caret of the selection) (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL) (* skip the whitespace) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ \TK.WHITESPACE (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM)) (* record this position as the beginning of the word  (to make the beginning of the selection)) (SETQ HERE (ADD1 (GETFILEPTR TEXTSTREAM))) (* find out what syntax class the first letter of the word has.  The end of the word is marked by a change of syntax classes) (if (NOT (EOFP TEXTSTREAM)) then (SETQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T))) (while [AND (NOT (EOFP TEXTSTREAM)) (EQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T] do (BIN TEXTSTREAM))) (TEDIT.SETSEL TEXTSTREAM HERE (ADD1 (IDIFFERENCE (GETFILEPTR TEXTSTREAM) HERE)) 'RIGHT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.BACK.WORD [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:49") (* * moves the caret one word back Refers to the syntax classes of the  characters according to the TEDIT.WORDBOUND.READTABLE) (PROG (HERE) (* position the file ptr at the (character after the) caret of the selection) (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL) (* skip the whitespace) (while [AND (NOT (ZEROP (GETFILEPTR TEXTSTREAM))) (EQ \TK.WHITESPACE (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T] do (\BACKBIN TEXTSTREAM)) (* record this position as the beginning of the word  (to make the beginning of the selection)) (SETQ HERE (GETFILEPTR TEXTSTREAM)) (* find out what syntax class the last letter of the word has.  The end of the word is marked by a change of syntax classes) (if (NOT (ZEROP (GETFILEPTR TEXTSTREAM))) then (SETQ CLASS (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T))) (while [AND (NOT (ZEROP (GETFILEPTR TEXTSTREAM))) (EQ CLASS (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T] do (\BACKBIN TEXTSTREAM))) (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETFILEPTR TEXTSTREAM)) (IDIFFERENCE HERE (GETFILEPTR TEXTSTREAM)) 'LEFT) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.SELECT.ALL [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "24-Feb-86 17:11") (* positions at the end of a document) (TEDIT.SETSEL STREAM 0 (ADD1 (fetch TEXTLEN of TEXTOBJ)) 'LEFT]) ) (* ; "other utilities") (DEFINEQ (\TK.FIND [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "10-Dec-84 12:38") (* just calls the normal tedit.find starting at the right of the current  selection) (TEDIT.FULL.FIND TEXTSTREAM]) (\TK.REDISPLAY [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "12-Mar-85 14:27") (* * simply redisplays the window in question.) (\TEDIT.REPAINTFN (CAR (MKATOM (fetch \WINDOW of TEXTOBJ]) (\TK.DELLINEFORWARD [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "13-Dec-84 11:56") (* deletes from the caret to the end of this line) (PROG (HERE DESC) (TEDIT.NORMALIZECARET TEXTOBJ) (SETQ HERE (\SEL.LIMIT.FORWARD SEL)) (SETQ DESC (\SEL.LINEDESC SEL)) (SETQ SEL (TEDIT.SETSEL STREAM HERE (IDIFFERENCE (fetch CHARLIM of DESC) HERE))) (TEDIT.DELETE STREAM SEL]) (\TK.OPENLINE [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "30-Jan-85 18:36") (TEDIT.INSERT STREAM (CONSTANT (CHARCODE EOL))) (\TK.PREVCHAR STREAM TEXTOBJ SEL]) (\TK.DELCHARFORWARD [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:50") (* * deletes one character forward from the caret) (PROG (HERE) (SETQ SEL (TEDIT.SETSEL STREAM (\SEL.LIMIT.FORWARD SEL) 1)) (TEDIT.DELETE STREAM SEL) (TEDIT.NORMALIZECARET TEXTOBJ]) (\TK.TRANSPOSECHARS [LAMBDA (STREAM TEXTOBJ SEL) (* gbn "20-Mar-85 00:51") (* * transposes the two characters on either side of the point, unless it is  the end of a line, in which case it transposes the two characters before the  point) (PROG ((KEEPCHARPOS (\SEL.LIMIT.FORWARD SEL)) KEEPCHAR LINEDESC) (TEDIT.NORMALIZECARET TEXTOBJ SEL) (* get the line that the point of the selection is on) (SETQ LINEDESC (\SEL.LINEDESC SEL)) (if (ILESSP (\LINEDESC.LAST.REAL.CHAR LINEDESC) KEEPCHARPOS) then (* the point is after the last real char on this line, so transpose the two  before the point.) (add KEEPCHARPOS -1)) (SETQ KEEPCHAR (TEDIT.SEL.AS.STRING STREAM (TEDIT.SETSEL STREAM KEEPCHARPOS 1))) (if (AND (IGREATERP KEEPCHARPOS 1) (IGEQ (fetch TEXTLEN of TEXTOBJ) KEEPCHARPOS)) then (TEDIT.DELETE STREAM) (TEDIT.INSERT STREAM KEEPCHAR (SUB1 KEEPCHARPOS)) (TEDIT.SETSEL STREAM KEEPCHARPOS 1 'RIGHT)) (TEDIT.NORMALIZECARET TEXTOBJ SEL]) ) (* ; "little selection utilities etc., for building hacks") (DEFINEQ (\SEL.LIMIT [LAMBDA (SEL) (* gbn " 8-Mar-85 12:58") (* returns the character that delimits this selection.  The first char if the point is left else the last) (if (EQ (fetch POINT of SEL) 'LEFT) then (fetch CH# of SEL) else (SUB1 (fetch CHLIM of SEL]) (\TK.SETFILEPTR.TO.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "23-Feb-85 15:24") (* * makes sure that the fileptr is positioned at character on the right of the  CARET of the selection) (* NOTE THAT FILEPTR's are one less than the corresponding char# in a sel) (SETFILEPTR TEXTSTREAM (SUB1 (\SEL.LIMIT.FORWARD SEL]) (\SEL.LINEDESC [LAMBDA (SEL) (* gbn "10-Oct-85 20:57") (* * Returns the line descriptor of the point of the selection in the last  selected window) (NTHCAR (if (EQ (fetch POINT of SEL) 'LEFT) then (fetch L1 of SEL) else (fetch LN of SEL)) (\TEXTOBJ.WINDEX (fetch \TEXTOBJ of SEL]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \SEL.LIMIT.FORWARD MACRO (LAMBDA (SEL) (* gbn "13-Dec-84 11:43") (* returns the character in front of the caret (ch# for left and chlim for right)) (if (EQ (fetch POINT of SEL) 'LEFT) then (fetch CH# of SEL) else (fetch CHLIM of SEL] [PUTPROPS \TK.ONOROFF MACRO (LAMBDA (FLG) (if FLG then "on" else "off"] [PUTPROPS \LINEDESC.LAST.REAL.CHAR MACRO (LAMBDA (LINEDESC) (if (fetch CR\END of LINEDESC) then (* there is a CR at the end so the last real char CHLIM-1) (SUB1 (fetch CHARLIM of LINEDESC)) else (fetch CHARLIM of LINEDESC] ) (* ; "fns for the key interface itself") (DEFINEQ (\SHIFTACTION [LAMBDA (KEYNAME) (* gbn "16-Feb-85 16:55") (* returns the character code generated by this keyname when typed shifted) (CADAR (KEYACTION KEYNAME]) (\ACTION [LAMBDA (KEYNAME) (* gbn "16-Feb-85 16:54") (* RETURNS THE CHARACTER CODE GENERATED BY THIS KEYNAME WHEN TYPED UNSHIFTED) (CAAR (KEYACTION KEYNAME]) (TEDITKEY.INSTALL [LAMBDA (READTABLE) (* gbn " 1-Apr-86 22:36") (* * installs the TEDITKEYBINDINGS on the readtable) (PROG [(READTABLE (OR READTABLE TEDIT.READTABLE)) INTERRUPT (FNKEYITEM '(Function% Keys 'BUILDFNKEYS "Bring up the DLion fn keys window"] (* I think that in Koto, all this is done by the system.  The times, they are a-changin'! (PROGN (* Tell everyone who cares to let ^h be  the backspace character) (if (SETQ INTERRUPT  (GETINTERRUPT (CHARCODE ^H))) then (printout T "Interrupt on ^H disabled")  (SETINTERRUPT (CHARCODE ^H) (QUOTE NIL)))  (SETSYNTAX 8 (QUOTE CHARDELETE) \PROMPTFORWORDTTBL)  (SETSYNTAX 8 (QUOTE CHARDELETE) ASKUSERTTBL)  (SETSYNTAX 8 (QUOTE CHARDELETE) \ORIGTERMTABLE)  (SETSYNTAX 8 (QUOTE CHARDELETE) \PRIMTERMTABLE)  (SETSYNTAX 8 (QUOTE CHARDELETE) DEDITTTBL)  (SETINTERRUPT (CHARCODE ^G) (QUOTE HELP)))) (METASHIFT T) (* TEditKey redefines METASHIFT to operate on TEDITKEY.METAKEY instead of the  swat (bottom-blank) key) (* install the functions on the main keyboard, that is, not the extra dlion  keys) [for TRIPLE in TEDITKEY.KEYBINDINGS do (COND (TRIPLE (* NILs in the list are for formatting  the menu) (for KEY in (CADR TRIPLE) do (APPLY* 'TEDIT.SETFUNCTION (EVAL `(CHARCODE %, KEY)) (CAR TRIPLE) READTABLE] (* the function keys are set up by  default (MODIFY.KEYACTIONS  TEDITKEY.FNKEYACTIONS)) (PROGN (* install the nextttywindow hack) (* INTERRUPTCHAR (\SHIFTACTION  (QUOTE NEXT)) (QUOTE  (GOTONEXTTTYWINDOW))) (* So that non-tedits know about the  game) ) (SELECTQ (MACHINETYPE) (DANDELION [if TEDITKEY.LOCKTOGGLEKEY then (KEYACTION TEDITKEY.LOCKTOGGLEKEY '(LOCKTOGGLE] (if (AND (BOUNDP 'DLIONFNKEYS) (OPENWP DLIONFNKEYS)) then (* this machine has real fn keys so close the fake ones) (CLOSEW DLIONFNKEYS)) (* adjust so that the dlion extra keys return meta control codes) (MODIFY.KEYACTIONS TEDITKEY.DLION.KEYACTIONS) (for PAIR in TEDITKEY.DLION.KEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (* hang functions off the dlion extra  keys (e.g. italics, bold)) (for PAIR in TEDITKEY.FNKEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (* set next to do next, undo to do undo etc) (* unnecessary in KOTO  (for PAIR in TEDITKEY.DLION.KEYSYNTAX  do (TEDIT.SETSYNTAX (EVAL  (CAR PAIR)) (CADR PAIR) READTABLE))) (* remove the menu item that may have already been installed) (* you can remove non-existent items  with impunity) (TEDIT.REMOVE.MENUITEM TEDIT.DEFAULT.MENU FNKEYITEM) (PROGN (* install the nextttywindow hack) (INTERRUPTCHAR (\SHIFTACTION 'NEXT) '(GOTONEXTTTYWINDOW)) (* So that non-tedits know about the  game) )) (PROGN (MODIFY.KEYACTIONS TEDITKEY.DORADO.KEYACTIONS) (for PAIR in TEDITKEY.DORADO.KEYSYNTAX do (TEDIT.SETSYNTAX (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (for PAIR in TEDITKEY.FNKEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR)) (CADR PAIR) READTABLE)) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU FNKEYITEM))) (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (* bring up the fake function keys) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) DLIONFNKEYS) (COND ([AND TEDITKEY.FNKEYFLG (NOT (AND (BOUNDP 'DLIONFNKEYS) (OPENWP DLIONFNKEYS] (* if he has the flag set to do so, then check if there is a fnkey window up  yet, and build one if there isn't) (BUILDFNKEYS)))) (PROGN NIL)) (* install the forms necessary to re-establish the correct bindings on a new  machine if this is sysout'ed) (* if (NOT (ASSOC (QUOTE  TEDITKEY.INSTALL) AFTERMAKESYSFORMS))  then (push AFTERMAKESYSFORMS  (QUOTE (TEDITKEY.INSTALL)))) [COND ((NOT (ASSOC 'TEDITKEY.INSTALL AFTERSYSOUTFORMS)) (push AFTERSYSOUTFORMS '(TEDITKEY.INSTALL] (RETURN (CONCAT TEDITKEY.METAKEY "'s action is now Meta. TEditKey actions and key bindings installed. Type #? or press the HELP key to see keybindings" ]) (TEDITKEY.DEINSTALL [LAMBDA (ARGS |...|) (* gbn "10-Oct-85 00:04") (MODIFY.KEYACTIONS \ORIGKEYACTIONS) (SELECTQ (MACHINETYPE) (DANDELION (MODIFY.KEYACTIONS \DLIONKEYACTIONS)) (PROGN NIL]) (\TK.ACTIONTOCHARCODE [LAMBDA (FN) (* gbn "23-Feb-85 17:17") (* takes the name of the function and looks in TEDITKEY.KEYBINDINGS to find out  which CHARCODE generates that behaviour) (PROG ((PAIR (ASSOC FN TEDITKEY.KEYBINDINGS))) (RETURN (if PAIR then [EVAL `(CHARCODE %, (CAADR PAIR] else NIL]) (\TK.BUILD.MENU [LAMBDA (KEYBINDINGS) (* gbn "23-Feb-85 17:17") (* builds a menu to display the key  bindings) (PROG (ITEMS) [for TRIPLE in TEDITKEY.KEYBINDINGS do (COND (TRIPLE (push ITEMS (LIST (CADDR TRIPLE) `(QUOTE %, TRIPLE) "Function which is performed by the key(s) to the right of the mouse" )) (push ITEMS (LIST (for DESC in (CADR TRIPLE) collect (CHARDESC DESC)) NIL))) (T (* insert a space since NIL marks logical divisions in the list) (push ITEMS '("" NIL "")) (push ITEMS '("" NIL ""] (SETQ \TK.MENU (create MENU ITEMS _ (DREVERSE ITEMS) MENUCOLUMNS _ 2 CENTERFLG _ T MENUFONT _ (FONTCREATE 'HELVETICA 10]) (\TK.HELP [LAMBDA (WHATEVER) (* gbn " 5-Nov-84 18:17") (* brings up a menu of the available  key bindings) (MENU \TK.MENU]) (\TK.SETFONTINLOOKS [LAMBDA (TEXTSTREAM LOOKS) (* gbn "11-Oct-85 07:12") (* * rebuilds the font field of looks according to the values in the fields) (PROG (NEWFONT) (SETQ NEWFONT (FONTCREATE (OR (fetch CLNAME of LOOKS) (FONTPROP (fetch CLFONT of LOOKS) 'FAMILY)) (fetch CLSIZE of LOOKS) (LIST (if (fetch CLBOLD of LOOKS) then 'BOLD else 'MEDIUM) (if (fetch CLITAL of LOOKS) then 'ITALIC else 'REGULAR) 'REGULAR) NIL NIL T)) (if (CAR NEWFONT) then (* we got the font, so now replace it) (RETURN (replace CLFONT of LOOKS with NEWFONT)) else (* we lost, print a msg and return NIL so that the caller knows.) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "Font not found: " (CONCAT [L-CASE (OR (fetch CLNAME of LOOKS) (FONTPROP (fetch CLFONT of LOOKS) 'FAMILY] " " (fetch CLSIZE of LOOKS) (if (fetch CLBOLD of LOOKS) then 'BOLD " bold" else "") (if (fetch CLITAL of LOOKS) then " italic" else ""))) T) (RETURN NIL]) (WRITE.CHARDESC.AUX [LAMBDA (TOKENS) (* gbn "10-Oct-85 00:20") (COND ((EQ (LENGTH TOKENS) 1) (CONS (CAR TOKENS) NIL)) (T (SELECTQ (CAR TOKENS) (%# [CONS "meta " (WRITE.CHARDESC.AUX (COND ((AND (CDR TOKENS) (EQ (CADR TOKENS) '%#)) (CDDR TOKENS]) (^ (CONS "control " (WRITE.CHARDESC.AUX (CDR TOKENS)))) (ERROR CHARDESC " is a misunderstood character descriptor"]) (CHARDESC [LAMBDA (CHARDESC) (* gbn " 7-Nov-84 14:21") (* takes a description in the form taken as input to charcode and writes out a  human readable form) (PACK (WRITE.CHARDESC.AUX (UNPACK CHARDESC]) (TEDITKEY.CONFIGURE [LAMBDA NIL (* gbn " 5-Nov-84 18:58") (PROMPTPRINT "not implemented"]) (\TK.ADDKEY [LAMBDA (TRIPLE) (* gbn " 5-Nov-84 18:41") (* dummy for now) ]) (\TK.CHANGEKEY [LAMBDA (THIS) (* gbn " 5-Nov-84 18:42") (* DUMMY) ]) (\TK.APPLYPENDING [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* gbn "10-Dec-84 15:58") (* * takes the entries on \TK.PENDING, reverses them and applies them as  incremental changes to the selection.) (PROG ((PENDING (DREVERSE \TK.PENDING)) (LOOKS (LIST NIL))) (for ENTRY in PENDING do (SELECTQ ENTRY (BOLDON (LISTPUT LOOKS 'WEIGHT 'BOLD)) (BOLDOFF (LISTPUT LOOKS 'WEIGHT 'MEDIUM)) (ITALICON (LISTPUT LOOKS 'SLOPE 'ITALIC)) (ITALICOFF (LISTPUT LOOKS 'SLOPE 'REGULAR)) (UNDERLINEON (LISTPUT LOOKS 'UNDERLINE 'ON)) (UNDERLINEOFF (LISTPUT LOOKS 'UNDERLINE 'OFF)) (SUPERSCRIPT (* nothing for the moment) NIL) (SUBSCRIPT (* nothing for the moment) NIL) (LARGER (* nothing for the moment) NIL) (SMALLER (* nothing for the moment) NIL) (DEFAULTS (SETQ LOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST TEDIT.DEFAULT.CHARLOOKS))) ((TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL HIPPO MATH) (LISTPUT LOOKS 'FAMILY ENTRY)) (\LISPERROR "Illegal pending operation in \TK.PENDING" ENTRY)) ) (SETQ \TK.PENDING NIL) (RETURN (TEDIT.LOOKS TEXTSTREAM LOOKS SEL]) (\TK.NTHFONT [LAMBDA (N) (* gbn "27-Jan-85 17:51") (* returns the name of the nth  teditkey font) (CAR (NTH TEDITKEY.FONTS N]) ) (* ; "redefinition of system junk") (DEFINEQ (METASHIFT [LAMBDA FLG (* gbn " 6-Mar-85 15:43") (* Sets interpretation of TEDITKEY.METAKEY key to first arg, where T means  meta-shift, NIL means original setting. Returns previous setting) (PROG ((METASTATUS '(METADOWN . METAUP)) OLDSETTING) [SETQ OLDSETTING (KEYACTION TEDITKEY.METAKEY (AND (IGREATERP FLG 0) (COND ((EQ (ARG FLG 1) T) METASTATUS) (T (OR (ARG FLG 1) (CDR (ASSOC TEDITKEY.METAKEY \ORIGKEYACTIONS] (RETURN (COND ((EQUAL OLDSETTING METASTATUS) T) (T OLDSETTING]) ) (* ;; "(\TK.BOLDTOGGLE (##H ##h) 'toggle Bold caret looks') (\TK.ITALICTOGGLE (##i ##I) 'toggle Italic caret looks') (\TK.SUPERSCRIPT.CARET (##^) 'Superscript the caret looks') (\TK.SUBSCRIPT.CARET (##_) 'Subscript the caret looks')" ) (DEFINEQ (TEDIT.FULL.FIND [LAMBDA (TEXTSTREAM SEARCHSTRING) (* gbn " 8-Mar-85 12:56") (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM)) SEL CH W) (* Case sensitive search, with * and  %# wildcards) [SETQ W (CAR (MKLIST (fetch \WINDOW of TEXTOBJ] [SETQ TARGET (OR SEARCHSTRING (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W ' TEDIT.LAST.FIND.STRING ) (CHARCODE (EOL LF ESC] [COND (TARGET (SETQ SEL (fetch SEL of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET) NIL NIL T)) (COND (CH (* We found the target text.) (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (replace CH# of SEL with (CAR CH))(* Set up SELECTION to be the found  text) (replace CHLIM of SEL with (ADD1 (CADR CH))) [replace DCH of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH] (replace POINT of SEL with 'RIGHT) (replace CARETLOOKS of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* And never pending a deletion.) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET) (* And get it into the window) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (\SHOWSEL SEL NIL T] (replace \INSERTNEXTCH of TEXTOBJ with -1]) ) (RPAQQ \TK.WHITESPACE 22) (RPAQ TEDIT.INTERRUPTS `((%, (CHARCODE ^G) ERROR) (%, (CHARCODE ^C) HELP))) (DECLARE%: EVAL@COMPILE (RPAQQ \TK.WHITESPACE 22) (CONSTANTS (\TK.WHITESPACE 22)) ) (RPAQ? TEDITKEY.VERBOSE T) (RPAQ? TEDITKEY.METAKEY 'TAB) (RPAQ? TEDITKEY.LOCKTOGGLEKEY NIL) (RPAQ? TEDITKEY.NESTWIDTH 36) (RPAQ? \TK.SIZEINCREMENT 2) (RPAQ? TEDITKEY.OFFSETINCREMENT 3) (RPAQ? TEDITKEY.FONTS '(TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL SYMBOL HIPPO)) (RPAQ? TEDITKEY.FNKEYFLG T) (DECLARE%: EVAL@COMPILE [PUTPROPS METACODE MACRO (LAMBDA (CHARCODE) (LOGOR CHARCODE 128] [PUTPROPS CONTROLCODE MACRO (LAMBDA (CHARCODE) (LOGAND CHARCODE 31] [PUTPROPS LCMETACODE MACRO (LAMBDA (CHARCODE) (LOGOR 160 CHARCODE] ) (RPAQ? \TK.SELKEY 'OPEN) (RPAQ? \TK.PENDING ) (RPAQ? TEDITKEY.KEYBINDINGS `((\TK.FONT1 (%##1) %, (CONCAT "change to font " (\TK.NTHFONT 1))) (\TK.FONT2 (%##2) %, (CONCAT "change to font " (\TK.NTHFONT 2))) (\TK.FONT3 (%##3) %, (CONCAT "change to font " (\TK.NTHFONT 3))) (\TK.FONT4 (%##4) %, (CONCAT "change to font " (\TK.NTHFONT 4))) (\TK.FONT5 (%##5) %, (CONCAT "change to font " (\TK.NTHFONT 5))) (\TK.FONT6 (%##6) %, (CONCAT "change to font " (\TK.NTHFONT 6))) (\TK.FONT7 (%##7) %, (CONCAT "change to font " (\TK.NTHFONT 7))) (\TK.FONT8 (%##8) %, (CONCAT "change to font " (\TK.NTHFONT 8))) NIL (\TK.DEFAULTS.CARET (%##/) "restore the default caret looks") (\TK.SMALLER.CARET (%##9) "decrease the caret font size") (\TK.LARGER.CARET (%##0) "increase the caret font size") (\TK.SHOWCARETLOOKS (%##=) "display the current caret looks") NIL (\TK.REDISPLAY (%##R %##r) "Restore the display") (\TK.HELP (%##?) "displays the current key bindings") NIL (\TK.PREVCHAR (^B ^b) "Back one character") (\TK.NEXTCHAR (^F ^f) "Forward one character") (\TK.FORWARD.WORD (%##F %##f) "Forward one word") (\TK.BACK.WORD (%##B %##b) "Back one word") (\TK.GOTOLINEBEGIN (^A ^a) "go to stArt of line") (\TK.GOTOLINEEND (^E ^e) "go to End of line") (\TK.PREVLINE (^P ^p) "go to Previous line") (\TK.NEXTLINE (^N ^n) "go to Next line") (\TK.GOTODOCBEGIN (%##<) "start of document") (\TK.GOTODOCEND (%##>) "end of document") (\TK.SELECT.ALL (%##S %##s) "Select whole document") NIL (\TK.DELLINEFORWARD (^K ^k) "Kill line") (\TK.OPENLINE (^O ^o) "Open up blank line") (\TK.DELCHARFORWARD (^D ^d) "Delete character forward") (\TK.DEL.WORD.FORWARD (%##D %##d) "Delete word forward") (\TK.TRANSPOSECHARS (^T ^t) "Transpose characters") NIL NIL (\TK.NEST (|##[|) "indents margins (nest)") (\TK.UNNEST (|##]|) "exdents margins (unnest)") (\TK.CENTER.SEL (%##J %##j) "alter Justification") (\TK.UCASE.SEL (%##U %##u) "Uppercasify selection") (\TK.CAPITALISE.SEL (%##C %##c) "Capitalize selection") (\TK.LCASE.SEL (%##L %##l) "Lowercasify selection") (GET.OBJ.FROM.USER (%##O %##o) "insert Object"))) (RPAQ? TEDITKEY.DLION.KEYACTIONS `((STOP (%, (CHARCODE ^G) %, (CHARCODE ^C) NOLOCKSHIFT)) (OPEN (%, (CHARCODE 2,1) %, (CHARCODE 2,41) NOLOCKSHIFT)) (FONT FONTDOWN . FONTUP) (KEYBOARD USERMODE1DOWN . USERMODE1UP))) (RPAQ? COMS (* ;; "(TEDITKEY.FNKEYACTIONS (BQUOTE ((CENTER (, (CHARCODE ##^B), (CHARCODE ##^C))) (BOLD (, (CHARCODE ##^D), (CHARCODE ##^E) NOLOCKSHIFT)) (ITALICS (, (CHARCODE ##^F), (CHARCODE ##^G) NOLOCKSHIFT)) (UNDERLINE (, (CHARCODE ##^H), (CHARCODE ##^I) NOLOCKSHIFT)) (SUPERSCRIPT (, (CHARCODE ##^J), (CHARCODE ##^K) NOLOCKSHIFT)) (SUBSCRIPT (, (CHARCODE ##^L), (CHARCODE ##^N) NOLOCKSHIFT)) (LARGER (, (CHARCODE ##^O), (CHARCODE ##^P) NOLOCKSHIFT)) (DEFAULTS (, (CHARCODE ##^Q), (CHARCODE ##^R) NOLOCKSHIFT)) (BS (, (CHARCODE ^H), (CHARCODE ^D) NOLOCKSHIFT)))))") ) (RPAQ? TEDITKEY.DLION.KEYBINDINGS '(((\ACTION 'OPEN) \TK.OPENLINE) ((\ACTION 'HELP) \TK.HELP) ((\ACTION 'MARGINS) \TK.NEST) ((\SHIFTACTION 'MARGINS) \TK.UNNEST) ((\SHIFTACTION 'NEXT) GOTONEXTTTYWINDOW))) (RPAQ? TEDITKEY.FNKEYBINDINGS '(((\ACTION 'DEFAULTS) \TK.DEFAULTSSEL) ((\SHIFTACTION 'DEFAULTS) \TK.SETDEFAULTLOOKS))) (RPAQ? COMS (* ;; "NOT NEEDED (TEDITKEY.DLION.KEYSYNTAX (QUOTE (((\ACTION (QUOTE NEXT)) NEXT) ((\ACTION (QUOTE UNDO)) UNDO) ((\ACTION (QUOTE BS)) CHARDELETE))))") ) (RPAQ? TEDITKEY.DORADO.KEYACTIONS `((BS (%, (CHARCODE ^H) %, (CHARCODE ^H))) (BLANK-BOTTOM (%, (CHARCODE %##^A) %, (CHARCODE %##^A))) (BLANK-TOP FONTDOWN . FONTUP) (BLANK-MIDDLE USERMODE1DOWN . USERMODE1UP) (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)))) (RPAQ? TEDITKEY.DORADO.KEYSYNTAX '(((CHARCODE %##N) NEXT) ((CHARCODE %##n) NEXT) ((\ACTION 'BLANK-BOTTOM) UNDO) ((\ACTION 'BS) CHARDELETE))) (TEDITKEY.INSTALL) (\TK.BUILD.MENU) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA METASHIFT) ) (PUTPROPS TEDITKEY COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (15418 27849 (NTHCAR 15428 . 15557) (\TEXTOBJ.WINDEX 15559 . 16116) (\TK.PREVSCREEN 16118 . 18028) (\TK.UNDERLINE.SEL.ON 18030 . 18510) (\TK.UNDERLINE.SEL.OFF 18512 . 18995) ( \TK.BOLD.SEL.ON 18997 . 19589) (\TK.BOLD.SEL.OFF 19591 . 20187) (\TK.ITALIC.SEL.ON 20189 . 20537) ( \TK.ITALIC.SEL.OFF 20539 . 20890) (\TK.SMALLERSEL 20892 . 21529) (\TK.LARGERSEL 21531 . 22162) ( \TK.SUPERSCRIPTSEL 22164 . 22809) (\TK.SUBSCRIPTSEL 22811 . 23460) (\TK.DEFAULTSSEL 23462 . 24181) ( \TK.DEL.WORD.FORWARD 24183 . 25779) (\TK.UCASE.SEL 25781 . 26347) (\TK.CAPITALISE.SEL 26349 . 26963) ( \CAPITALISE 26965 . 27279) (\TK.LCASE.SEL 27281 . 27847)) (27921 32598 (\TK.CENTER.SEL 27931 . 29199) (\TK.CENTER.SEL.REV 29201 . 30379) (\TK.NEST 30381 . 31361) (\TK.UNNEST 31363 . 32596)) (32682 42410 ( \TK.SHOWCARETLOOKS 32692 . 34003) (\TK.BOLD.CARET.ON 34005 . 34568) (\TK.BOLD.CARET.OFF 34570 . 35136) (\TK.ITALIC.CARET.ON 35138 . 35703) (\TK.ITALIC.CARET.OFF 35705 . 36273) (\TK.UNDERLINE.CARET.ON 36275 . 36714) (\TK.UNDERLINE.CARET.OFF 36716 . 37158) (\TK.SUPERSCRIPT.CARET 37160 . 37802) ( \TK.SUBSCRIPT.CARET 37804 . 38462) (\TK.SMALLER.CARET 38464 . 39106) (\TK.LARGER.CARET 39108 . 39695) (\TK.DEFAULTS.CARET 39697 . 40022) (\TK.FONT1 40024 . 40196) (\TK.FONT2 40198 . 40370) (\TK.FONT3 40372 . 40544) (\TK.SETCARETFONT 40546 . 41538) (\TK.FONT4 41540 . 41712) (\TK.FONT5 41714 . 41886) ( \TK.FONT6 41888 . 42060) (\TK.FONT7 42062 . 42234) (\TK.FONT8 42236 . 42408)) (42499 44831 ( \TK.BOLDTOGGLE 42509 . 43384) (\TK.ITALICTOGGLE 43386 . 44197) (\TK.UNDERLINETOGGLE 44199 . 44829)) ( 44889 45351 (\TK.SETDEFAULTLOOKS 44899 . 45349)) (45412 58534 (GOTONEXTTTYWINDOW 45422 . 47701) ( \TK.NEXTLINE 47703 . 49591) (\TK.PREVLINE 49593 . 51693) (\TK.GOTODOCBEGIN 51695 . 52053) ( \TK.GOTODOCEND 52055 . 52406) (\TK.GOTOLINEBEGIN 52408 . 53192) (\TK.GOTOLINEEND 53194 . 54018) ( \TK.PREVCHAR 54020 . 54549) (\TK.NEXTCHAR 54551 . 55115) (\TK.FORWARD.WORD 55117 . 56654) ( \TK.BACK.WORD 56656 . 58224) (\TK.SELECT.ALL 58226 . 58532)) (58567 61606 (\TK.FIND 58577 . 58848) ( \TK.REDISPLAY 58850 . 59108) (\TK.DELLINEFORWARD 59110 . 59650) (\TK.OPENLINE 59652 . 59859) ( \TK.DELCHARFORWARD 59861 . 60248) (\TK.TRANSPOSECHARS 60250 . 61604)) (61675 63029 (\SEL.LIMIT 61685 . 62100) (\TK.SETFILEPTR.TO.CARET 62102 . 62529) (\SEL.LINEDESC 62531 . 63027)) (64449 81285 ( \SHIFTACTION 64459 . 64705) (\ACTION 64707 . 64949) (TEDITKEY.INSTALL 64951 . 72392) ( TEDITKEY.DEINSTALL 72394 . 72657) (\TK.ACTIONTOCHARCODE 72659 . 73122) (\TK.BUILD.MENU 73124 . 74440) (\TK.HELP 74442 . 74753) (\TK.SETFONTINLOOKS 74755 . 77230) (WRITE.CHARDESC.AUX 77232 . 77988) ( CHARDESC 77990 . 78296) (TEDITKEY.CONFIGURE 78298 . 78453) (\TK.ADDKEY 78455 . 78655) (\TK.CHANGEKEY 78657 . 78852) (\TK.APPLYPENDING 78854 . 80960) (\TK.NTHFONT 80962 . 81283)) (81330 82491 (METASHIFT 81340 . 82489)) (82737 85563 (TEDIT.FULL.FIND 82747 . 85561))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-DATE.LCOM.~2~ b/lispusers/TMAX-DATE.LCOM.~2~ deleted file mode 100644 index 44cd6567d1098165c31581557c1cc3ebf28062a4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6476 zcma)BOK%(36&5MQZ`rcrq^=vJC(}nL!=gBRiBtktBXVet#FvLd+XB2Otr=UiMx;QI zPK->@S5Tlpfud;Q1TBgHMK>+FPz-y~l@{H!=(7C<1-ch%uhV|#-kBjSD@iSYbI+Z7 z&z$FX&pnP6^^#H3=SoIJpEGKuI=$Y|3ai>xofM;H>1M@fHWYf@)U~3eEmtsovrxgr zvewi|P0UWmcxwUgExkwz<>pGx?YaB{sp?`nx0pyM6jRoFTiYGiv8mU^67RiYbM^hV zxBI<&&idfWmSellgJfL2;&yhnhdWMx=ZaO;Zq60KGX9q8&C;}zOw1LX^|^eS)P+T` zPGrGnzTkEs@JSp^0xcV{Z4Pli&;o4S5i{xoG@l8 zzo_Q^UkTLNX|`T{d4(2>x#?JgQdHA#Fx{Xe`Jd(`pjG05Rx4UYmFWb*gb)qZx7Hdu z8Q2lbfRM}MO$(;D3OXUS&x_3^O4F@d{-@(c6>$WeXK7+}Dl##-{N!kF0{_lNCYGL@ zI>y7}l8$IkjvM6@l872B<&BFMFIql5xq6phh@X=@TAi7QEvO{eL#2jUZ%`%~(lQt+ zm8C*it6kOOEDy|VRyB)~DXOmeva2~EIvk(PiV@oPRY<5=_;F@JkE9ha~eLAWF616Dca!n-+xCwW{!f z9QsaC5$gV%1W8H04oRk#G$F&%5jNG|CZZ8ZLz-lg8gQCQS>gnXH_KX)V}!*T2@1*= zNEmpzesf$R)3{p3X7j316C(N1d{YF*3j(ECAWb;=aH%vQbVGVs4VRIvJgyra$-r4(TMOqESSoZ)@W4LD3v6JZy+aG z%|^VbTdhXC1dyz?ARH3H&sSJB_*xhOELmV1i3~y<;d%>Epj!+CGCpCsddn>6qZ!{E ztQzv97@YtH2q|TPJo>Jr&Yq1di5VgKpO*tGyHVrJ=@|hTa$%raHbc5;!ogYp3sMG= z81Q-E0|5+bKF|vKi8rIgP#-}PET?3Sq>tc7wgg@iU|eZ+H@m%ex+E2*ok8DeZ_(hv zwu3`MfXi~rvg$ScI&d9_sGq<-=nD7|uv@PbC1C(sT!izWx3KbJk zRBc$4PRfLyw>n!6Rh{n8qf~~xsY%|!q4zD1BPfg}1W`q6%1=sXH}TQgL(l)glB5*c-8Tnx*BQ|Iu-|vO1G>}e z4v;j59L#>5k_10dlayMuLZxYmdgMCltRUpaDiK+EAhQ2B34qp~$l#t4Dhkwi_E1F9 z?nQY7$+?fj+y~-UmLoVKBc1(^mt+AlQx>oGKN2rLkV_&_En>VHjVy6xB7$^9iyoZu z`HRO7@&4d~>6h3uBCcV!daZzZL`9HEm{wt3e*{Cy5vm-N=dv&ZuyH(*>OW;60aGtv z-}17lU#E;pddsX+Izy#ar9#P!|Arl+0_v2@D1FrwFb#is(D=(`NSRkClciX!C_Y!z z)@Hf%;ZIj_qLx9S2m-aHYv$}MrE;icX9@LFOhaiDis<`LrK*9H(3`?}h%!@v)yRv$ zsY;O{YL+5>oC?t;_oRDD)OJhmY4?m60aP@JI{S~_*pr8yFs&he<%Dli>9Jok8@YML zjT<5kp8iHI6vWRr$B2L0oBN;a30|K~{K9slBkD)CJGuX{e7Cz}yHg=?$97)|i8b3j z5)u{LJsJ|dX)b~5q46FF(GhdkCu*& z5yjb@jBv;-W1b^Bg?d0~$G337O99uEZGV^uXF1|k6|a$59P_CJcJ$s{cYEub3N+1= zGT7+!2M<6j$m~esbWjHGIPQH1lbPH!DUR#hceQ{ZVWI^ zWJ%ePi`9GzdA zvIyu5O)HX(PY5-^RzIOPg*~AehkiLneQ+7{{a12Pg88tEyBavJ3|$Z9 zIX~qJZFtv%KRi5#I|H$%>1=zHClAkovvu3)i`n}60CFbC!=M*T)_V6b3F$EyEk!R2 zvs_U+>;9~Nj`9inRZ*7WDD!>s>5_ZQJw9@U4DivUs8xc*6Lqun1qy2kz&Oi8^AkD* zzOzu+h12lLcp-s0MUnlohN)ZDS^@PjP~8$u1<|#`4A;75L%VkE`C0h$5^H_maeLd` ziSveC8}=h_XSluH>%)THoqli2qnc4B?{2@{#gu8zB@zp{OdJlv_8a}q0Pu^Yw;y=Z z2m-9y1a-CJZlTU(4}0w{GjF!HI{esZcY1Ml(j~ey5(qFtp0U-w>(p;^D-tX347=-t zPOrPei@9CL`N7xupr6)|S1Z4RhD(CDX^Em=c1i>-I|^bbZU!tZCdsW zp0mb5i4N<29CGpTIeMjVKX)NLn)bVrP?r0QtaGow)fR!x3Wvp9c+d!#Wr_h%fY1n1 zcqEEKie1-CbT@@^vey<|JY%L_sGCJ;OF5oJwEN-l!Uj(HDy|6|RBS)EOluBjb?jQJ zj%MYkABUc>(M7L#bhTh@sJ%nC6p{awyG&|6lf0!UFoone503MPF+>&nWeijEx%rS2 zc#x3qpln5|%3k4@vBGJ_==7XyES2DRKsL$nD`d;fr$(~z-E?FuiyN0O3NzpftS}T; zAS4SP;-bm7Rc*+ahIaiyc87{GVwXlIeVk9V<8}r>>=*dxUoMuK1tVXU*0zjN3%AK$ z_dYv(&%@ju?QkMHg%@I5RAsguJ jqu+`D!no=5d+$=A*9S>7jRpr|s!@ z;@FYnOw+=n{m^P9;Aubz@c=9B6OT=kmUh?&Kl2~V{sAC_v{JwD48L>ky;Ws9&B8>A zU3Kezp7T4u^HJWY*!xb?-r9HS_LkG!Z;4mhR{796utm~o`nFqlymnH&;@VclxAy92 zJ}TGIuxEL;Fw>if4H{a;bKkCrq}bVNbRTVH(q>VZh23m!H(N}KjpY6D>Dge|?}_mU zof5NeRlLLZzS=qOPtI?hbkBy}(XIOUes_55wBH-{A7xYdTf@Qm+5PdP&leZm({ETu zTXwV3Z25NT?=!PaUeG$5V8L`+n8n?+xtq<<0#jOX_@&-V%m$;GNH%z0fr-Wb#c(LR zN9W^2u?=^~D?n<*xjkDEe0iUna}Ve~3shHtf72d!Pp z@tQ5yukIe%ZtLj1ua-N$?=%l?(HZz7dJvJxm^eUUb~fq1I~ZS_W81WmU2McOx0>U3 z)f%~--SkIV!<=mcwO134FvT6GS!vzDWmL5y7lbTwzD3!?#5yFPsKIP6yAi2+%>~iz1m6d6Pb~J0fY1dZY2QFQ)x( zPIsYuHM^R{(=yD6vgO)-yX85)(`t$~Bnh*@Hukl+Jv64V$0Prbh}w8@4WcedF|Qj{ zmK00$?&aFQ{VeuOK9XX8Vcm$AdffL1Ebf2j&rl0e?mS00QAsH+e)1u!K&mKc{1mCG zG)(ZcJe9iU&Ox^ir8eWnAn`FCVO1R-`cYO3cU&#iPIw_cGtiOQ&MLjak{VXsdDCV| zLw!Z{z_WeNu8T}gBOnTtOjdWRw_1mu$bgh2oECACNoRy>A2clYkkn(soR?IcBGrM= z7RL*7dq)6-TFa^ZR@3){na_%Ht68=%B3BgUs^wZ`P^mDp+tIs>o=xt~OzZo_-R&%F zu24`%h#s_H>IET(ie0y1PytG_88resC0UWNcyM7ld-|JTMO=)oQ?JPwbJ39>;v0(l;O^${nw*b9`>rL zUN6Php8n(*_Gp^h*e21jM5x#Sx+Tze0Qmst%Vq*DZ5%35K{2ZqlV5FvzRk20Hi;D4 z(*nwEhujUEY91$m6rn;PpuuGuP|AbOfEbT#gLNkF7===4cuFi_yKEk43o*Rl6r0y# zF+(vm9AZeY>#wdkM%?&?6UXQO)GjvcEEu0 zMC6=S9pay0(GWWy7BmOLVrv3-DPzh(Y?c17zhWAjiRd8d???_#13E!$@Hw!*62s+s zNkPzHX*|P;@)1_0B{QZrXHZ2ps=3Vsh+I=v%Jc6c&{R6hi>7^tnHB2DiB`R$Z=^O; z{@u16Xj4(}^Ni?s*kfGU&Ns+&eWAzh=f?GUZ*b#Nb9HxZ-s3ae5c=Y8=I``I|NQ&j z@yqyIj~msVbK}MNb?K^;A3N;**Uw@=Ui-Eb$K?yPc-*)rv2e(% z)I?~f_>c9*v!53aqch9t-miUExBhUBnHx9fhw{k}OAQ{cY+KGr&NQd} zKonn@3~bYC2clQ52q75xG8xvx%}E0#w?WO|dF`sAbD4QWLfY?{!rI$&?Kd0>?syPb zpWa5O6fK-hr0m^Cj>-|A0hB9qRGnUAQ8{7Vj(gXyr3>tZ(SW13+f?k@X)h=OU@ z8SY!1x=#yN?RsUuDROC1uDf#INMOY5+8RA26upKR8D0in8UdgQo=J-7m|cXKC1!bh zJeuOmgv^rVA|Upo@CW=*jXtgLq|4*}m)2&2h;%yJHnS{1uOJe&u3=>ZBok#d6J;Q$&KWWvcG5D@6A~3-I3AyzlQuRJD*y_q zNv1I1rZjU?D2J!7$<%}GzQ>jX}_fDWLg zj-_ZQ127)6QXcu+$2^+}EuHXOnsPtS$6|80d`VL-m_-^tP5{2t zsT6arWXTo2B{ZdQDp#xSy3csM-?Dcu|eg9uNAHb=?^|B-8&Nu!_``@b_@h^Hccwqt= zcQ3L0^?@$2&%2TYOa z`JRW$0OzsEOFw(^iX*!Q`4F#K$5MP*=HSe+weddO~YhZsQx zGN>9|5pWm63?D?I%}yc;-a@iuN@XFW5=uxHyQLAyBc1{n%dLtnkVdbLqLcuA$lW_bf$tMIbN9$fe^ll+>XQ{_JcG&1BXBA@%SD^ zQ%x$kox&u zG$VGPtc3Cf-|>-kMAMs7#8Ye1n^6=Mf?N6~gisQZ643HmlF+ep%vj^#%3)K`&P{p( znWi60bAnsojzm=H)fAi5uj!T;-xE7vGo4VQ_CuMmItU_liD5`*F=jz0p}I7!#rX|ZALqYiev zulaj6u^#b{X_L$&e1dBaZm{#^=3%C_eT6yH{)e(xU2Cmq*TFnmrh37td)2-As3 z7vhXcAtD_e%w+^QWkz#=f1Lk6P+>Nd@BQcruMw~Ho_tLa?pGq>)TGN8mm&>~=H^_s zXo;H0m?XXk5a1bE;!!|05hs^hwp&ImQxzY%J{lmscok;BNrWB9$3%evQ=vN77Kk7N znBtAYB5n~?&b;oseIZE;Z(e}pRj*Fg5~Ph_#O16J4rF6#o|*O5crp#<1#lxp<^Zj5 z;6#nYKva67aw2gM%n%Wk2^$OtrT7&4O%IxU)i7f5l7&$DHhZ{$pjhA%#^mC5f}>0C z6c)^az!3x=u0dQtxiCX4Y;Lb+B7e!5Nbf&G4NF9DxV5ko)hmLBu7>9oI$J zdjz2>j0F>uxURj^lUd=*S1tf6)^n4p)C{C4_1XaY`y%a+g`mma&=+xolA0i=f!n5> zCPR`5HALlz0I0y2+kY?^kEkdS9uz#S_puPt(HnsFUH#^Z_NBH+AW|lTEp8HQZc978 zj{GbpS?(p?we|E9(nRAr_X4F^?RNbx@ff`Vra}fqB&gPPPz!1(V?&-BLWLq%X|f9& zr|m^|uFaZj-_Q}9Tp(1)x7C5^hb>AlbUvJ-5;|syxhJnHH@zNZ_Yd~8_=j=lGoSt} zyJXo>9}xahMu6~6EPA;It|>xES{u@K!nYVIVGKLtsCfOLy9)%CQc=(-9Tbm69xpFC zqm$A2;Rt~f9ax-CC;jfJm_9n|BX-ePeol@ik)~74=RmLq2N(Yf;4n7-27R9V>YZoD z&n^pE5YV{AVyGI`xbb6o88=uQ@(m(WM^H87=wkT=EQF@QW1LA{apK)*fwoXi_lZ70 zD}g*9hPvhX{9GQ-BauMph~%iy_7&0SPEPt0F*v7M8e%>Pet{SNJrv$1RMp1|9~;iK zj90-h9$!R%4uD3Q(rsI}Z?8NM8yjDyDD~a`aC}B@_h%P~IZ`c{AXuulM(O&`+kP8qTEQw=t1e0Omp6~tb_c0IxlX+J`b z;UyHHZX)hax3KL9Lp|!-`dEmP%r25@whoF5KY76F=#4GD(KMG#X)(vTD7@ z08udO=&qvIfBp`mIqO0Kt4saSeSPViw##QDob-{iaTMAX>TMAX-ENDNOTE.;2| 22100 |previous| |date:| "11-Nov-87 11:49:07" |{POGO:AISNORTH:XEROX}TMAX>TMAX-ENDNOTE.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-endnotecoms) (rpaqq tmax-endnotecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (fns add.endnote insert.endnotes insert.endnotes.text delete.endnotes notesregionp set.endnote.style map.endnote.looks get.endnote.fonts) (fns endnotep note.putfn note.getfn note.buttoneventinfn note.whenselectedfn ) (vars endnote.notag.items endnote.tag.items) (records endnotefonts) (* * |Allow| |user| |to| |edit| |Endnote| |text| |in| |another| |TEdit| |window.|) (fns aux.tedit aux.tedit.afterquitfn aux.tedit.titlemenufn) (* * |Delimit| |text| |between| |two| |markers| |known| |as| region markers. ) (fns regmarkobj regmarkobjp regmark.displayfn regmark.imageboxfn regmark.putfn regmark.getfn regmark.copyfn regmark.buttoneventinfn) (records regmarkobj))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (defineq (add.endnote (lambda (stream window) (* |fsg| "13-Jul-87 10:44") (* * |Insert| |an| endnote |ImageObject| |as| \a |superscript.|  |Displayed| |as| \a |number| |when| |updated.|) (let ((noteobj (numberobj 'note))) (tedit.insert.object noteobj stream) (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| noteobj) |with| (or (tedit.getinput stream "Endnote text:") "")) (tedit.promptprint stream "" t) (and (update? window) (update.numberobjs window stream 'endnotep))))) (insert.endnotes (lambda (stream window) (* |fsg| "25-Sep-87 10:23") (* * |Inserts| |text| |of| |endnotes| |at| |the| |end| |of| |the| |TEdit|  |document.| |The| |text| |is| |inserted| |between| |two| |Region| |marking|  |imageobjs.|) (let ((textobj (textobj stream)) list.of.endnotes) (and (setq list.of.endnotes (tsp.list.of.objects textobj 'endnotep)) (let ((caretposition (|fetch| ch# |of| (tedit.getsel stream)))) (tedit.promptprint stream (concat (cond ((delete.endnotes stream) "Rei") (t "I")) "nserting Endnotes...") t) (tedit.insert.object (regmarkobj 'endnotes '|Endnotes-START|) stream (add1 (|fetch| textlen |of| textobj))) (tedit.looks stream '(protected on) (|fetch| textlen |of| textobj) 1) (tedit.insert stream (concat (character (charcode eol)) "Notes" (character (charcode eol))) (add1 (|fetch| textlen |of| textobj)) (|fetch| (endnotefonts title.font) |of| (get.endnote.fonts window)) t) (insert.endnotes.text stream window textobj list.of.endnotes) (tedit.insert.object (regmarkobj 'endnotes '|Endnotes-END|) stream (add1 (|fetch| textlen |of| textobj))) (tedit.looks stream '(protected on) (|fetch| textlen |of| textobj) 1) (tedit.promptprint stream "done") (tedit.normalizecaret textobj (tedit.setsel stream caretposition 1))))))) (insert.endnotes.text (lambda (stream window textobj list.of.endnotes) (* |fsg| "18-Jun-87 13:17") (* * |Here| |to| |print| |the| |text| |of| |each| |endnote.|) (let ((textlooks (|fetch| (endnotefonts text.font) |of| (get.endnote.fonts window))) (numblooks (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts window)))) (|for| endnoteobj |in| list.of.endnotes |do| (let ((numstring (mkstring (|fetch| (numberobj numstring) |of| (|fetch| objectdatum |of| (car endnoteobj ))))) (text (|fetch| (numberobj text.after#) |of| (|fetch| objectdatum |of| (car endnoteobj))))) (tedit.insert stream numstring (add1 (|fetch| textlen |of| textobj)) numblooks t) (tedit.insert stream (concat " " text (character (charcode eol))) (add1 (|fetch| textlen |of| textobj)) textlooks t)))))) (delete.endnotes (lambda (stream) (* |fsg| "25-Sep-87 10:12") (* * |Delete| |the| |Endnotes,| |i.e.| |delete| |the| |start/end| regmark  |ImageObjects| |and| |all| |the| |text| |between| |them.|) (let* ((textobj (textobj stream)) (notemarker.list (tsp.list.of.objects textobj 'notesregionp)) (notes.start (cadar notemarker.list)) (notes.end (cadadr notemarker.list))) (and notes.start notes.end (progn (tedit.promptprint stream "Deleting Endnotes..." t) (tedit.delete stream notes.start (idifference (add1 notes.end) notes.start)) (tedit.promptprint stream "done") t))))) (notesregionp (lambda (imobj) (* |ss:| "27-Jun-87 15:29") (and (regmarkobjp imobj) (eq (|fetch| region.use |of| (|fetch| objectdatum |of| imobj)) 'endnotes)))) (set.endnote.style (lambda (stream window) (* |fsg| "18-Aug-87 14:13") (* * |Set| |the| |font| |of| |the| endnote |number,| |title,| |or| |text.|) (let ((note.fonts (get.endnote.fonts window)) (note.type (menu (|create| menu title _ "Endnote Fonts" centerflg _ t items _ '(|Number| |Title| |Text|)))) old.font new.font) (and note.type (progn (setq old.font (selectq note.type (|Number| (|fetch| (endnotefonts number.font) |of| note.fonts)) (|Title| (|fetch| (endnotefonts title.font) |of| note.fonts)) (|Text| (|fetch| (endnotefonts text.font) |of| note.fonts)) nil)) (tedit.promptprint stream (concat "Change Endnote " note.type " font " (abbreviate.font old.font) " to...") t) (setq new.font (fontcreate (get.tsp.font window old.font))) (cond ((neq old.font new.font) (selectq note.type (|Number| (|replace| (endnotefonts number.font) |of| note.fonts |with| new.font)) (|Title| (|replace| (endnotefonts title.font) |of| note.fonts |with| new.font)) (|Text| (|replace| (endnotefonts text.font) |of| note.fonts |with| new.font)) nil) (and (eq note.type '|Number|) (map.endnote.looks stream new.font))) (t nil)) (tedit.promptprint stream "" t)))))) (map.endnote.looks (lambda (stream numberfont) (* |ss:| "27-Jun-87 15:26") (* * |Here| |to| |update| |the| endnote |looks.|  |Only| |the| endnote |superscript| |numbers| |are| |updated.|) (let ((list.of.notes (tsp.list.of.objects (textobj stream) 'endnotep))) (and list.of.notes (progn (tedit.promptprint stream "Updating ENDNOTE Number looks..." t) (|for| note/ch# |in| list.of.notes |do| (tedit.looks stream numberfont (cadr note/ch#) 1)) (tedit.promptprint stream "done")))))) (get.endnote.fonts (lambda (window) (* |ss:| "27-Jun-87 15:24") (* * |Setup| |the| |default| endnote |fonts| |for| |number,| |title,| |and|  |text.|) (or (windowprop window 'endnote.fonts) (progn (windowprop window 'endnote.fonts (|create| endnotefonts number.font _ |GP.DefaultFont| title.font _ |GP.DefaultFont| text.font _ |GP.DefaultFont|)) (windowprop window 'endnote.fonts))))) ) (defineq (endnotep (lambda (imobj) (* |ss:| "27-Jun-87 15:23") (* * |Like| numberobjp |but| |also| |checks| |for| note |ImageObject.|) (and (numberobjp imobj) (eq (|fetch| (numberobj use) |of| (|fetch| objectdatum |of| imobj)) 'note)))) (note.putfn (lambda (numberobj stream window) (* |fsg| "11-Aug-87 10:04") (* * |Used| |to| |put| \a |numberobj| |that| |is| |functioning| |as| |an|  |endnote.|) (|with| numberobj (|fetch| objectdatum |of| numberobj) (setq font (|for| notefont |in| (get.endnote.fonts window) |collect| (list.font.props notefont)))) (prin4 (list '|Endnote| nil (imageobjprop numberobj 'tag) (|fetch| objectdatum |of| numberobj)) stream))) (note.getfn (lambda (newobj note.datum window) (* |fsg| "16-Jul-87 10:49") (* * |Used| |to| |get| \a |numberobj| |that| |is| |functioning| |as| |an|  |endnote.|) (windowprop window 'endnote.fonts (|for| notefont |in| (|fetch| (numberobj font) |of| note.datum) |collect| (fontcreate notefont))) (|replace| (numberobj font) |of| note.datum |with| nil) (|replace| objectdatum |of| newobj |with| note.datum) newobj)) (note.buttoneventinfn (lambda (obj stream window) (* |fsg| " 5-Aug-87 09:31") (* * |Allow| |user| |to| |edit| |Endnote| |text,| |specify| \a tag\, |delete|  |the| tag\, |or| |change| |the| tag.) (let* ((tag (imageobjprop obj 'tag)) (nmenu (|create| menu title _ '|Endnote Menu| items _ (cond (tag endnote.tag.items) (t endnote.notag.items)) centerflg _ t whenselectedfn _ 'note.whenselectedfn))) (putmenuprop nmenu 'note.obj obj) (putmenuprop nmenu 'note.window window) (menu nmenu)))) (note.whenselectedfn (lambda (item menu mb) (* |fsg| "10-Aug-87 13:48") (let* ((window (getmenuprop menu 'note.window)) (obj (getmenuprop menu 'note.obj)) (tstream (textstream window))) (selectq (cadr item) ((|Change Tag| |Define Tag|) (let ((old.tag (imageobjprop obj 'tag)) (new.tag (tsp.get.incode tstream))) (and new.tag (neq new.tag old.tag) (progn (number.delete.tag window obj) (tsp.putcode new.tag obj window) (imageobjprop obj 'tag new.tag))))) (|Delete Tag| (number.delete.tag window obj)) (|Show Tag| (tedit.promptprint tstream (concat "EndNote Tag=\"" (imageobjprop obj 'tag) "\"") t)) (|Edit Text| (aux.tedit obj (concat "Endnote #" (|fetch| numstring |of| (|fetch| objectdatum |of| obj))) tstream)) (error "Undefined EndNote menu item" item)) nil))) ) (rpaqq endnote.notag.items ((|Edit Text| |Edit Text| "Edit the text associated with this EndNote.") (|Define Tag| |Define Tag| "Define a TAG for this EndNote."))) (rpaqq endnote.tag.items ((|Edit Text| |Edit Text| "Edit the text associated with this EndNote.") (|Change Tag| |Change Tag| "Change this EndNote's TAG.") (|Delete Tag| |Delete Tag| "Delete this EndNote's TAG.") (|Show Tag| |Show Tag| "Show this EndNote's TAG."))) (declare\: eval@compile (record endnotefonts (number.font title.font text.font)) ) (* * |Allow| |user| |to| |edit| |Endnote| |text| |in| |another| |TEdit| |window.|) (defineq (aux.tedit (lambda (imobj title stream) (* |ss:| "27-Jun-87 15:22") (* * |Open| \a |TEdit| |window| |where| |the| |user| |can| |view/edit| |the|  |text| |of| |the| |selected| |Endnote.|) (let* ((mainwindow (\\tedit.mainw stream)) (auxwindow (createw (windowprop mainwindow 'auxw.region) title))) (windowprop auxwindow 'main.window mainwindow) (windowprop auxwindow 'note.imageobj imobj) (tedit nil auxwindow nil '(afterquitfn aux.tedit.afterquitfn titlemenufn aux.tedit.titlemenufn)) (tedit.insert (textstream auxwindow) (mkstring (|fetch| (numberobj text.after#) |of| (|fetch| objectdatum |of| imobj))) nil (|fetch| (endnotefonts text.font) |of| (get.endnote.fonts mainwindow)))))) (aux.tedit.afterquitfn (lambda (auxwindow) (* |ss:| "27-Jun-87 15:22") (* * |Here| after |user| |finished| |with| |Endnote| |TEdit| |process.|) (let ((mainwindow (windowprop auxwindow 'main.window))) (windowprop mainwindow 'auxw.region (windowprop auxwindow 'region)) (give.tty.process mainwindow) (tedit.normalizecaret (textobj mainwindow))))) (aux.tedit.titlemenufn (lambda (auxwindow) (* |ss:| "27-Jun-87 15:23") (* * |Here| |when| |left| |or| |middle| |button| |hit| |in| |title| |bar.|) (let ((item (menu (|create| menu centerflg _ t items _ '(|Save Changes| |Abort Changes|))))) (and item (progn (selectq item (|Save Changes| (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| (windowprop auxwindow 'note.imageobj)) |with| (coercetextobj (textstream auxwindow) 'stringp))) nil) (tedit.quit (textstream auxwindow))))))) ) (* * |Delimit| |text| |between| |two| |markers| |known| |as| region markers.) (defineq (regmarkobj (lambda (use marking) (* |fsg| "10-Jul-87 15:58") (let ((newobj (imageobjcreate (|create| regmarkobj region.use _ use marking _ marking) \\regmarkobj.imagefns))) (imageobjprop newobj 'type 'regmarkobj) newobj))) (regmarkobjp (lambda (imobj) (* |ss:| "27-Jun-87 15:31") (and imobj (eq (imageobjprop imobj 'type) 'regmarkobj)))) (regmark.displayfn (lambda (obj stream) (* |fsg| "18-Feb-87 09:18") (* * regmark |is| |just| \a |marker,| |it| |doesn't| |actually| |display|  |anything.|) nil)) (regmark.imageboxfn (lambda (obj stream currentx rightmargin) (* |fsg| "17-Feb-87 10:22") (* * regmark |is| |just| \a |marker,| |it| |doesn't| |actually| |display|  |anything.|) (|create| imagebox xsize _ 0 ysize _ 0 ydesc _ 0 xkern _ 0))) (regmark.putfn (lambda (markobj stream) (* |fsg| "23-Jul-87 14:02") (prin2 (list '|Region| (|fetch| region.use |of| (|fetch| objectdatum |of| markobj)) (|fetch| marking |of| (|fetch| objectdatum |of| markobj))) stream))) (regmark.getfn (lambda (stream copy.object) (* |fsg| "20-Aug-87 14:58") (let ((window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window)) (apply (function regmarkobj) (or copy.object (cdr (read stream)))))) (regmark.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 14:09") (* * |Here| |to| copy \a |RegMark| |Image| |Object.|) (selectq (imagestreamtype target.stream) (text (let ((textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (|fetch| objectdatum |of| image.obj)))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (regmark.buttoneventinfn (lambda (markobj stream) (* |fsg| "18-Feb-87 10:07") (* * |This| |function| |is| |never| |called| |because| |the| regmark  |ImageObjects| |are| |protected| |after| |they| |are| |inserted| |and|  |anything| |protected| |can't| |be| |selected.|) (and (mousestate middle) (let ((markdatum (|fetch| objectdatum |of| markobj))) (tedit.promptprint stream (concat "Region used for " (|fetch| region.use |of| markdatum ) (cond ((|fetch| marking |of| markdatum) (concat ", Marker is " (|fetch| marking |of| markdatum))) (t ""))) t))))) ) (declare\: eval@compile (record regmarkobj (region.use marking)) ) (putprops tmax-endnote copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1726 11353 (add.endnote 1736 . 2404) (insert.endnotes 2406 . 4609) ( insert.endnotes.text 4611 . 6040) (delete.endnotes 6042 . 7033) (notesregionp 7035 . 7297) ( set.endnote.style 7299 . 9972) (map.endnote.looks 9974 . 10741) (get.endnote.fonts 10743 . 11351)) ( 11354 15269 (endnotep 11364 . 11705) (note.putfn 11707 . 12359) (note.getfn 12361 . 12941) ( note.buttoneventinfn 12943 . 13723) (note.whenselectedfn 13725 . 15267)) (15991 18395 (aux.tedit 16001 . 16963) (aux.tedit.afterquitfn 16965 . 17408) (aux.tedit.titlemenufn 17410 . 18393)) (18480 21944 ( regmarkobj 18490 . 18897) (regmarkobjp 18899 . 19093) (regmark.displayfn 19095 . 19341) ( regmark.imageboxfn 19343 . 19694) (regmark.putfn 19696 . 20028) (regmark.getfn 20030 . 20329) ( regmark.copyfn 20331 . 20869) (regmark.buttoneventinfn 20871 . 21942))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-ENDNOTE.~2~ b/lispusers/TMAX-ENDNOTE.~2~ deleted file mode 100644 index c848fa07..00000000 --- a/lispusers/TMAX-ENDNOTE.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:38:37" |{POGO:AISNORTH:XEROX}TMAX>TMAX-ENDNOTE.;2| 22100 |previous| |date:| "11-Nov-87 11:49:07" |{POGO:AISNORTH:XEROX}TMAX>TMAX-ENDNOTE.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-endnotecoms) (rpaqq tmax-endnotecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (fns add.endnote insert.endnotes insert.endnotes.text delete.endnotes notesregionp set.endnote.style map.endnote.looks get.endnote.fonts) (fns endnotep note.putfn note.getfn note.buttoneventinfn note.whenselectedfn ) (vars endnote.notag.items endnote.tag.items) (records endnotefonts) (* * |Allow| |user| |to| |edit| |Endnote| |text| |in| |another| |TEdit| |window.|) (fns aux.tedit aux.tedit.afterquitfn aux.tedit.titlemenufn) (* * |Delimit| |text| |between| |two| |markers| |known| |as| region markers. ) (fns regmarkobj regmarkobjp regmark.displayfn regmark.imageboxfn regmark.putfn regmark.getfn regmark.copyfn regmark.buttoneventinfn) (records regmarkobj))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (defineq (add.endnote (lambda (stream window) (* |fsg| "13-Jul-87 10:44") (* * |Insert| |an| endnote |ImageObject| |as| \a |superscript.|  |Displayed| |as| \a |number| |when| |updated.|) (let ((noteobj (numberobj 'note))) (tedit.insert.object noteobj stream) (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| noteobj) |with| (or (tedit.getinput stream "Endnote text:") "")) (tedit.promptprint stream "" t) (and (update? window) (update.numberobjs window stream 'endnotep))))) (insert.endnotes (lambda (stream window) (* |fsg| "25-Sep-87 10:23") (* * |Inserts| |text| |of| |endnotes| |at| |the| |end| |of| |the| |TEdit|  |document.| |The| |text| |is| |inserted| |between| |two| |Region| |marking|  |imageobjs.|) (let ((textobj (textobj stream)) list.of.endnotes) (and (setq list.of.endnotes (tsp.list.of.objects textobj 'endnotep)) (let ((caretposition (|fetch| ch# |of| (tedit.getsel stream)))) (tedit.promptprint stream (concat (cond ((delete.endnotes stream) "Rei") (t "I")) "nserting Endnotes...") t) (tedit.insert.object (regmarkobj 'endnotes '|Endnotes-START|) stream (add1 (|fetch| textlen |of| textobj))) (tedit.looks stream '(protected on) (|fetch| textlen |of| textobj) 1) (tedit.insert stream (concat (character (charcode eol)) "Notes" (character (charcode eol))) (add1 (|fetch| textlen |of| textobj)) (|fetch| (endnotefonts title.font) |of| (get.endnote.fonts window)) t) (insert.endnotes.text stream window textobj list.of.endnotes) (tedit.insert.object (regmarkobj 'endnotes '|Endnotes-END|) stream (add1 (|fetch| textlen |of| textobj))) (tedit.looks stream '(protected on) (|fetch| textlen |of| textobj) 1) (tedit.promptprint stream "done") (tedit.normalizecaret textobj (tedit.setsel stream caretposition 1))))))) (insert.endnotes.text (lambda (stream window textobj list.of.endnotes) (* |fsg| "18-Jun-87 13:17") (* * |Here| |to| |print| |the| |text| |of| |each| |endnote.|) (let ((textlooks (|fetch| (endnotefonts text.font) |of| (get.endnote.fonts window))) (numblooks (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts window)))) (|for| endnoteobj |in| list.of.endnotes |do| (let ((numstring (mkstring (|fetch| (numberobj numstring) |of| (|fetch| objectdatum |of| (car endnoteobj ))))) (text (|fetch| (numberobj text.after#) |of| (|fetch| objectdatum |of| (car endnoteobj))))) (tedit.insert stream numstring (add1 (|fetch| textlen |of| textobj)) numblooks t) (tedit.insert stream (concat " " text (character (charcode eol))) (add1 (|fetch| textlen |of| textobj)) textlooks t)))))) (delete.endnotes (lambda (stream) (* |fsg| "25-Sep-87 10:12") (* * |Delete| |the| |Endnotes,| |i.e.| |delete| |the| |start/end| regmark  |ImageObjects| |and| |all| |the| |text| |between| |them.|) (let* ((textobj (textobj stream)) (notemarker.list (tsp.list.of.objects textobj 'notesregionp)) (notes.start (cadar notemarker.list)) (notes.end (cadadr notemarker.list))) (and notes.start notes.end (progn (tedit.promptprint stream "Deleting Endnotes..." t) (tedit.delete stream notes.start (idifference (add1 notes.end) notes.start)) (tedit.promptprint stream "done") t))))) (notesregionp (lambda (imobj) (* |ss:| "27-Jun-87 15:29") (and (regmarkobjp imobj) (eq (|fetch| region.use |of| (|fetch| objectdatum |of| imobj)) 'endnotes)))) (set.endnote.style (lambda (stream window) (* |fsg| "18-Aug-87 14:13") (* * |Set| |the| |font| |of| |the| endnote |number,| |title,| |or| |text.|) (let ((note.fonts (get.endnote.fonts window)) (note.type (menu (|create| menu title _ "Endnote Fonts" centerflg _ t items _ '(|Number| |Title| |Text|)))) old.font new.font) (and note.type (progn (setq old.font (selectq note.type (|Number| (|fetch| (endnotefonts number.font) |of| note.fonts)) (|Title| (|fetch| (endnotefonts title.font) |of| note.fonts)) (|Text| (|fetch| (endnotefonts text.font) |of| note.fonts)) nil)) (tedit.promptprint stream (concat "Change Endnote " note.type " font " (abbreviate.font old.font) " to...") t) (setq new.font (fontcreate (get.tsp.font window old.font))) (cond ((neq old.font new.font) (selectq note.type (|Number| (|replace| (endnotefonts number.font) |of| note.fonts |with| new.font)) (|Title| (|replace| (endnotefonts title.font) |of| note.fonts |with| new.font)) (|Text| (|replace| (endnotefonts text.font) |of| note.fonts |with| new.font)) nil) (and (eq note.type '|Number|) (map.endnote.looks stream new.font))) (t nil)) (tedit.promptprint stream "" t)))))) (map.endnote.looks (lambda (stream numberfont) (* |ss:| "27-Jun-87 15:26") (* * |Here| |to| |update| |the| endnote |looks.|  |Only| |the| endnote |superscript| |numbers| |are| |updated.|) (let ((list.of.notes (tsp.list.of.objects (textobj stream) 'endnotep))) (and list.of.notes (progn (tedit.promptprint stream "Updating ENDNOTE Number looks..." t) (|for| note/ch# |in| list.of.notes |do| (tedit.looks stream numberfont (cadr note/ch#) 1)) (tedit.promptprint stream "done")))))) (get.endnote.fonts (lambda (window) (* |ss:| "27-Jun-87 15:24") (* * |Setup| |the| |default| endnote |fonts| |for| |number,| |title,| |and|  |text.|) (or (windowprop window 'endnote.fonts) (progn (windowprop window 'endnote.fonts (|create| endnotefonts number.font _ |GP.DefaultFont| title.font _ |GP.DefaultFont| text.font _ |GP.DefaultFont|)) (windowprop window 'endnote.fonts))))) ) (defineq (endnotep (lambda (imobj) (* |ss:| "27-Jun-87 15:23") (* * |Like| numberobjp |but| |also| |checks| |for| note |ImageObject.|) (and (numberobjp imobj) (eq (|fetch| (numberobj use) |of| (|fetch| objectdatum |of| imobj)) 'note)))) (note.putfn (lambda (numberobj stream window) (* |fsg| "11-Aug-87 10:04") (* * |Used| |to| |put| \a |numberobj| |that| |is| |functioning| |as| |an|  |endnote.|) (|with| numberobj (|fetch| objectdatum |of| numberobj) (setq font (|for| notefont |in| (get.endnote.fonts window) |collect| (list.font.props notefont)))) (prin4 (list '|Endnote| nil (imageobjprop numberobj 'tag) (|fetch| objectdatum |of| numberobj)) stream))) (note.getfn (lambda (newobj note.datum window) (* |fsg| "16-Jul-87 10:49") (* * |Used| |to| |get| \a |numberobj| |that| |is| |functioning| |as| |an|  |endnote.|) (windowprop window 'endnote.fonts (|for| notefont |in| (|fetch| (numberobj font) |of| note.datum) |collect| (fontcreate notefont))) (|replace| (numberobj font) |of| note.datum |with| nil) (|replace| objectdatum |of| newobj |with| note.datum) newobj)) (note.buttoneventinfn (lambda (obj stream window) (* |fsg| " 5-Aug-87 09:31") (* * |Allow| |user| |to| |edit| |Endnote| |text,| |specify| \a tag\, |delete|  |the| tag\, |or| |change| |the| tag.) (let* ((tag (imageobjprop obj 'tag)) (nmenu (|create| menu title _ '|Endnote Menu| items _ (cond (tag endnote.tag.items) (t endnote.notag.items)) centerflg _ t whenselectedfn _ 'note.whenselectedfn))) (putmenuprop nmenu 'note.obj obj) (putmenuprop nmenu 'note.window window) (menu nmenu)))) (note.whenselectedfn (lambda (item menu mb) (* |fsg| "10-Aug-87 13:48") (let* ((window (getmenuprop menu 'note.window)) (obj (getmenuprop menu 'note.obj)) (tstream (textstream window))) (selectq (cadr item) ((|Change Tag| |Define Tag|) (let ((old.tag (imageobjprop obj 'tag)) (new.tag (tsp.get.incode tstream))) (and new.tag (neq new.tag old.tag) (progn (number.delete.tag window obj) (tsp.putcode new.tag obj window) (imageobjprop obj 'tag new.tag))))) (|Delete Tag| (number.delete.tag window obj)) (|Show Tag| (tedit.promptprint tstream (concat "EndNote Tag=\"" (imageobjprop obj 'tag) "\"") t)) (|Edit Text| (aux.tedit obj (concat "Endnote #" (|fetch| numstring |of| (|fetch| objectdatum |of| obj))) tstream)) (error "Undefined EndNote menu item" item)) nil))) ) (rpaqq endnote.notag.items ((|Edit Text| |Edit Text| "Edit the text associated with this EndNote.") (|Define Tag| |Define Tag| "Define a TAG for this EndNote."))) (rpaqq endnote.tag.items ((|Edit Text| |Edit Text| "Edit the text associated with this EndNote.") (|Change Tag| |Change Tag| "Change this EndNote's TAG.") (|Delete Tag| |Delete Tag| "Delete this EndNote's TAG.") (|Show Tag| |Show Tag| "Show this EndNote's TAG."))) (declare\: eval@compile (record endnotefonts (number.font title.font text.font)) ) (* * |Allow| |user| |to| |edit| |Endnote| |text| |in| |another| |TEdit| |window.|) (defineq (aux.tedit (lambda (imobj title stream) (* |ss:| "27-Jun-87 15:22") (* * |Open| \a |TEdit| |window| |where| |the| |user| |can| |view/edit| |the|  |text| |of| |the| |selected| |Endnote.|) (let* ((mainwindow (\\tedit.mainw stream)) (auxwindow (createw (windowprop mainwindow 'auxw.region) title))) (windowprop auxwindow 'main.window mainwindow) (windowprop auxwindow 'note.imageobj imobj) (tedit nil auxwindow nil '(afterquitfn aux.tedit.afterquitfn titlemenufn aux.tedit.titlemenufn)) (tedit.insert (textstream auxwindow) (mkstring (|fetch| (numberobj text.after#) |of| (|fetch| objectdatum |of| imobj))) nil (|fetch| (endnotefonts text.font) |of| (get.endnote.fonts mainwindow)))))) (aux.tedit.afterquitfn (lambda (auxwindow) (* |ss:| "27-Jun-87 15:22") (* * |Here| after |user| |finished| |with| |Endnote| |TEdit| |process.|) (let ((mainwindow (windowprop auxwindow 'main.window))) (windowprop mainwindow 'auxw.region (windowprop auxwindow 'region)) (give.tty.process mainwindow) (tedit.normalizecaret (textobj mainwindow))))) (aux.tedit.titlemenufn (lambda (auxwindow) (* |ss:| "27-Jun-87 15:23") (* * |Here| |when| |left| |or| |middle| |button| |hit| |in| |title| |bar.|) (let ((item (menu (|create| menu centerflg _ t items _ '(|Save Changes| |Abort Changes|))))) (and item (progn (selectq item (|Save Changes| (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| (windowprop auxwindow 'note.imageobj)) |with| (coercetextobj (textstream auxwindow) 'stringp))) nil) (tedit.quit (textstream auxwindow))))))) ) (* * |Delimit| |text| |between| |two| |markers| |known| |as| region markers.) (defineq (regmarkobj (lambda (use marking) (* |fsg| "10-Jul-87 15:58") (let ((newobj (imageobjcreate (|create| regmarkobj region.use _ use marking _ marking) \\regmarkobj.imagefns))) (imageobjprop newobj 'type 'regmarkobj) newobj))) (regmarkobjp (lambda (imobj) (* |ss:| "27-Jun-87 15:31") (and imobj (eq (imageobjprop imobj 'type) 'regmarkobj)))) (regmark.displayfn (lambda (obj stream) (* |fsg| "18-Feb-87 09:18") (* * regmark |is| |just| \a |marker,| |it| |doesn't| |actually| |display|  |anything.|) nil)) (regmark.imageboxfn (lambda (obj stream currentx rightmargin) (* |fsg| "17-Feb-87 10:22") (* * regmark |is| |just| \a |marker,| |it| |doesn't| |actually| |display|  |anything.|) (|create| imagebox xsize _ 0 ysize _ 0 ydesc _ 0 xkern _ 0))) (regmark.putfn (lambda (markobj stream) (* |fsg| "23-Jul-87 14:02") (prin2 (list '|Region| (|fetch| region.use |of| (|fetch| objectdatum |of| markobj)) (|fetch| marking |of| (|fetch| objectdatum |of| markobj))) stream))) (regmark.getfn (lambda (stream copy.object) (* |fsg| "20-Aug-87 14:58") (let ((window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window)) (apply (function regmarkobj) (or copy.object (cdr (read stream)))))) (regmark.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 14:09") (* * |Here| |to| copy \a |RegMark| |Image| |Object.|) (selectq (imagestreamtype target.stream) (text (let ((textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (|fetch| objectdatum |of| image.obj)))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (regmark.buttoneventinfn (lambda (markobj stream) (* |fsg| "18-Feb-87 10:07") (* * |This| |function| |is| |never| |called| |because| |the| regmark  |ImageObjects| |are| |protected| |after| |they| |are| |inserted| |and|  |anything| |protected| |can't| |be| |selected.|) (and (mousestate middle) (let ((markdatum (|fetch| objectdatum |of| markobj))) (tedit.promptprint stream (concat "Region used for " (|fetch| region.use |of| markdatum ) (cond ((|fetch| marking |of| markdatum) (concat ", Marker is " (|fetch| marking |of| markdatum))) (t ""))) t))))) ) (declare\: eval@compile (record regmarkobj (region.use marking)) ) (putprops tmax-endnote copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1726 11353 (add.endnote 1736 . 2404) (insert.endnotes 2406 . 4609) ( insert.endnotes.text 4611 . 6040) (delete.endnotes 6042 . 7033) (notesregionp 7035 . 7297) ( set.endnote.style 7299 . 9972) (map.endnote.looks 9974 . 10741) (get.endnote.fonts 10743 . 11351)) ( 11354 15269 (endnotep 11364 . 11705) (note.putfn 11707 . 12359) (note.getfn 12361 . 12941) ( note.buttoneventinfn 12943 . 13723) (note.whenselectedfn 13725 . 15267)) (15991 18395 (aux.tedit 16001 . 16963) (aux.tedit.afterquitfn 16965 . 17408) (aux.tedit.titlemenufn 17410 . 18393)) (18480 21944 ( regmarkobj 18490 . 18897) (regmarkobjp 18899 . 19093) (regmark.displayfn 19095 . 19341) ( regmark.imageboxfn 19343 . 19694) (regmark.putfn 19696 . 20028) (regmark.getfn 20030 . 20329) ( regmark.copyfn 20331 . 20869) (regmark.buttoneventinfn 20871 . 21942))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-INDEX.LCOM.~2~ b/lispusers/TMAX-INDEX.LCOM.~2~ deleted file mode 100644 index 8c90748fe5b1d55f2eb72b877d94d42267d6f144..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 17838 zcmbVU?QdJxc_%3+ag!>wY}W~dETGfmS&rXj|(a;p0*D`4pREsl(`oTg_L_XL&pm4e>o!)I&fE^Y966lk*I7F~yl!?@h2u-J;iYJVrr)FYZGEwEs1Dnm zLlrFWtP0br?Eco4svhii_xF@{wV_Zbs16(Ty(UKW?PE5+6pb%M;=#eqMrLQS&AT&; z3$)dFynYcg$j)|p-3QH$J-wYsX!eXwx%&i&@@AuYeVbf~7X#j0AX z*tJYZwoHUpa+zGM)k?+8txT~7rWL2v;ZCplX1lwO;k*Zo4~7@b@*?4-`S8+Q)TR6< zUSI5RdYs=`N-nFVbbNfOtY%d)vqtx}3d@49j>>wdY*h+XG|sA(%(}|r;hj5XY{)JE zRM^tA@=g2wzJPV}Ss(sP_X+;Sh7;-Z)~YoKRDnrJ z^JbOakDkvemorwyDyA}c6jim%?V7Coy+8nz{S;ABmVCTgk&B1RZ&0hn+o?39@x9Z8 z#m!9X3)1**!s>kdv9u(le}ZR}>kF+5y0!W=&G>H@{rq$y;LkPuW5<)HcFxalIe8up zc59MvUc7*-7m0#%alnFhP)tWuI6AKinL<*94IP;&6+7*%mi_Yi1h7jLL|Sdn@NRdZIFprIB(n7)Sj`GJOLRHdusY^hjNzy`5Z=uU7U z&dx3x(yCZk>aA`BA{{0 zuG*wG!?Q|r&w~$sDTW(>*x+V`-chhBH|!z+5HWzc&FB~c#;l-k2pE9zJ3hbfoEHq= zE^EHOd-|Z!XtXBr=Ynqfd;Rt= zQ;QKL>{+wZwVaA;7#p6=$5kq4RpjAF7KG;%@h6?BrYd&1Rw76&j-d2xWUwE!@(@FS znW47W&>QAr9$rV|%-&zj%JOQ>aItLEVhD{PaFXRbZPivuq{BoKk931m(SXkvNQgLz z;3ilWnaH3e$=0{+oED{1TT7yE3bI7f5Fr%axl>G)im8Z-M2B=#+*N%FD(ukiG@5T8 z8q|~Sa1>$)@@6(di%pfv>ml^Wq-v~>Wbs(^6(1JO%d}2DCCCWyf=S316(l^r4*6E( zI$-)aM@@R(MU$JCkuKDljB#HB;W9OXiVzEQE3H;i8Mg)4C!wX)VLcTPaV+W8eRFa* zG2!=+^KsI1V`vT# zFk2c0?|Ijns5xy)Lu5N6aZ-Dr473JK0FtR#Tm@G@?w= zjC2i*;h7_wt#v3-+Msbki7x??1NNnA&7t?aTEmQ`H9VOE6TwW@PMJJuBFJ?nkKZG} z{LfGMeCN*-9Z%n&pPN5>@TB$R(b(^Q&-XWm-V@<5e)f3}FCI7S%NI{`-(VK}A^&Vm z{-CjZ`P^xvefiU;qM$A-bMZMSvCi*&EV}7~#>(YqPsI@V&*dM*a^KQc>W}pAJN`#k z?)yFL)A2<%vKm25*F0_KR3 zh0Iu^D8{O`3P&^)rg8qVUZms5PG;c1GPXi8dD9n5X3oDds3M&(q z6JnsJ4$qBISF&DTI3x&}g%FDJR#lcE?5;AR7S+^Yirr47H9}1Vy$!)>6^pu^GH>rS zp*b4Ez5Aa8rwNVKOr@rYrX9zy3qlfFR*Qh8y9@Hc90jukf%YdD2rP@tUCm-&?)Xwp zU;FI@Kffe>+v2+TrpVrB(l%TzrWYwn5G|q`_4>4C>vI@qRbj=dl?voCLZ#lKeIWR$ zhH9ly72#2)DsoA4gS&PSYJPgWXy+lNbBih%gklXcLDfq0V2MT3C58Y-QzSA(5vGw) zggq1OZhL7Ib|uq8u5XNy5jm4wot!)qsxggRf}V`!CN5}N3;j;TF=WE7pFAsLkA8O1 zOXE|Pam8{2{d&8Dh&C1* znlaO%4m6Uc8z-YR_)_kf*UPCuYmilwz;zl^h?5wwbkM+xFCd^zN)WNx9wCP^Y2 z;usnaoFBoA1Q^W>Q*kgRt_E_)Z804Ueh8D%$iYMithwuh56P6A@3R_LjMW%zKFG{y z^U*kdp)vOGQfuyL@Qs zDJ2j9u`IB;H!IL!3o4%}-heypM6^iK)Iya^wyG8tEJc~D43N!4Cnm%fN7)jXA;*?1 zz>u#dk!vV~VA$d7!PrD%{U(KhijD--DDYZqHG54}$KOtuEJAyux%(wAT&O{{J8G}h z-c^n6#{PB_mSgpZ@RHdvocg}91Scewv z=vDos3M0dNV;U0p@PMufc@a)j5CZurSsx++oXOui2WQf9op3lTiN@Ibr`(bV1OitA zubn)Xu##eIa*T+;`bkb>^Ox~j9?N@{?aACEPj_lFjtNTO0WU2KPZCy!uGuXC2&z`K zT1t`Uul%M>B>(ZepXs^XX#`KFV`CZ|7&(2;D0@-G zk~#qU;E$KhIoO0W4K;aq zBn_Tn41_*cnQ<^OMhN+!+$~n%9;Wa;bAiQ)dBi_jlOQYtB<+?(V`mxdD3U;|c^#t- z0ivkbs;O{)tVVS3gj~3##A5JHP$B!ume1=5tIg(tx)X%P@$S&$%8lG+gtn>UkCDF! zIruA-(2f^vb(A4MhDpEswoqOBL2yO-+u83y;N9OUYXvnVn9*}^E>wH2&n`bch-{ zAfP*o4#sVELC$>va_m&+8HgVQY4~=|winLYws?eIcj*r#A`pHC}d>s8J@Pb^-u!}Xn$f1Jc`$LTG+>vet z%Py{wtsEW|oiiYc%qc6GB;OQ~I)@KL&$%Iwy+3cpiJ4FAk4Jz#Xc%_naYl9q4w)fe z+!gnJNGP@7Yrc5!SWH&fW;!_>bD}ZhMI(&bC_D-S#DJ1SM$U-4pnXRW(MaMj0*&Cw zmd_NuzBosOP}|4;_+l28O*;uA4@;nhZqjZ&&Kn~QTh2YaBCXos-yU)c#P*+Dwmdp4 z!MzA`anS41*?Vx$PGzu zDc|OpA2}N)`0<@V``(hc>0-e4+kwZg{X?!Q2Spc;qPb=G)cE5+d4@+V`?*1$F9-a# zTz#6f!uOAURFyL)FeNu?-zf*2-I1u@2&khTmWB7=wME)6{?#o?%ZUNFIrZC`TPq>f>7DNCc%?+2W%(+1BY zJ|cWLz&Kvv1=;*F=g)!J`poHDr`&cV(e)Eq_|a#jBf9YgOW`<@0zRK)>184#oMBMj z@dfDAf_=V4PT-OE2R53do|_oet^#DNSW*z#b;|7NRIb^m!{)L83k~Dm5}fTG3xVfj)pV%%t*@T^ZGCUf}{+eDBH-( zT;y#b33>7i55xvRZHjEM;>9qt4cr@!XXm`}Ea?7o2n{RmO`j7fK(Z-91h66G!67w> z!}&NOi=f}hMi9foLY2Il3agcMxQZA!t+JF?U{Qe-QGXEW863_Atn%cB?}Cr~Z}!25 z<}^Y$$BBwERIbcpqGqGP^}MXWr3d9PDC#zEHa1iH$zqJKjsr-P_js(;nw$uZNf`!f zm1WnPKU!(Pb2yh5EBQJiNWLx^k<+0da#7YDvh$^vOlsK0Wq zR7t}SK=F;_-zXDG=hne$a|;DMs@_opF~jcu-S%E{I|M|GT0OxcVuU5ElA_T;`4=D{ zfkePh|M@Nbo9P3(AgFT}t5x>s`3*#(RJ_6f5dBQ7=lDbnIr--3Kr7@G05Mp@9x^Ba zV)@m8b+k&{9b3^V{Bh0}#cKz|*fLuwBO1v zg!ug3Tp%as!Y+`Q@yKNm_o&2!E6u7%T-ha@agp`aN7+btXiW}g5Buif+4xAr2+bGf z)y>rs+#1At#!n-;hE@nF{7*Sd{6@$N4GD)|@W548+V&Z76KMf)4QRL%c}p&aM#vgc z;iZ~gqpB@Oa&@4jCz6sbn#WCSF?;CH*OAeO;L=mp37w$+0ds-%p@d3uR(+nd?Zmk; z`}nt)k2l39Smv&5AH}s#Kb&z#OAcG?hrV9nX-~~BJC|a2Yh{^v$q$#MMu;1}_wn!A z?|D<-C=BBH2CzFdrPc|=&@RLE5Nz>6my2+x(1l*dbPrYdKIh$9W^AXO+-a=AgrswGr< zpcD^iFmPbG=lna8OeO)3f22Oian&+ znDVNV6F2~KjcxLY`}Oj$T`QprkXS|Pp-A~b_2Ang|{@9*ukJNKP= z+MT_wyasL$tY58nK#$S*Ru5Va*?km}sJB|p4h{kKRIA==%xrXbs1pP$y;{(jMWdyp zoI%50+a|uFYC#W~x#GXX!b5HFvB$!}wCVj`LfNUaIn~D-9=~cIBy6;dbqZ5%!TkA66`MEMt%u zMu<&d;nNhyH3=~}D07Uafv_Wt5Q55csY}r+WGI~Jzeh}_pJi>745;~qfd=@&+0}fW zN0V?$04o4z8~V7B%Py)(kO#>6UE@ScF9V@rkstzvF=o z9r2_g?bRIDv5Y=x+=IV5#;j#X0ZWO7xHzY|!7Ku+(+R)dew0k2sO8I^=MO(GH{$=; z3bv(8rf8tesjn4* z$#+OU0@1-+?dDrr2|>BAk^}z-R<7AU>)@O1CL*D0 zUT+igMN~?FR0?L}m_}VU+)8hx!TX?^G0r$? zf5*(w@BTQ)eSMA;hr1juIUdkYo`DCH`nxxXiFcnqO@AkK_q_Nnassa_Q>~*#@?m|s zv6K0fej;2m-Ev7`XPR9bJ&fa#AGa=0{wa|2OP7g@WA@m|Q|Ba55ezBJuA zP!jTlN@WfoDA1wDo}zk_dxc(j3$FAz4UOci1iLvFelk2*& ztffoib!O@(Nu7ZC`stC>93K6^|AFMAR#@9VUJkr=^dnoWh_Ij4z41rMT{S5xC+$c% z4Z~BgQHYNdP2DkOC=ZIF3WG8eV0^Je1V$1hcpWr`>7_&?RDi-Ch!Xh;nR!L<`0Gp2Wl%6S;n!==ihJ48KPD*pn3`A#Hq{b+0joRO)a>7>|S5 zGu|&785OjnHiT;-;Hhxk9?Obn-xR%7?WLt_$PT7*GnGtjwNjkPA`H03p&UPh16x?1 zff=0PUe^@)rG0KHqF78)%!AA~XLOp#cLkcn*G>Rd6_)wd zX2R(PKNazieH*P1#}ZXuk`!Z81K}+wij?Evvd|d&xqF;e{;Qt}n4<<=99DTcC&v5f z&5ypKFQ47~=yiShBD3Jh-+s^c7Y_=XA58?GEnWCw>G{I{{bQoQAUsW|-@5pe|Kv-B z&7b}-p`&7%`=Kq*j;)epBO6;+o*e)BY5OR|9H!f^pSJ&G>++MoEM451LB;dK4+`5K z|Mcj6G#&qoZaaP`(|sVnzO%CV(Fd0bn;(89QCQjhu<#$e!d9DqjXy)yZsNjoZ_w|x zmnPfnj;yK4iLvKPFY;?I%9b9TD_yzhKj|xgJx`;6w+ISN*e|(?*mYFk9YF**0&F5G z5uAyNF9?7W_rgfeWJ+1E6^06?f}D?X4WDH=r}Jw_u;Bs6=`z%5L8^zxA}+^tX6QoS z9Xuo%g*gN`CWn9qtN_9hflH}H1$ljx#kmsbg*WOs;?R#IQMiN(;g5Hy;u8)n6#_fE zR?xEU4Xl-OL&`OREQV8XDFN?Zv$s8iK)17pDofP3ZP)KNRrfA^^7kqZRZyxjmC7%P zI~ek;Ps=LGqn$U9a$?iPGP#_6fu{hgg|Z%^Ipb+=W~&Z+yoI?9VHm6_Su zh4?%&+{%m{53V8qgRcS9-2;Re_0Fcc(caqL@Ac|POm!NnTHkJ~YOCJvhLkFF8>mml zd(gRpFMwD0i{HNKLd!KYhX6b_Yp< zZ7zLQ^}F;{FZygNRGii~P;t7yMPKydvtvxfX)2nbflrIK>Ie5a+-+xPi`ItO>zu%% z{FR8byyQA>sJ%BhXC1Fl_>gu7>pM{0d%QSS1$uG8aYHboHhqjJ+)*~^ixR5~b#K43 zL3P`^L=L-X*KQGHaRnF;ebuL?B%_T_2B)XdpFR?_Zlq)iGxG-#-uiJJ zT)OqgeZ>|YN{$D!hGxVx`EJ@|Kbvp&l^{3YHY?I~Z?YoqjjTwwc*@>PrC(nSSbsMT zLHe7_DX2@M5)ju@+wI+reqJ;0Ky?bvv<1*y@l!!v-GtW&; zk2;+4P*p1-&bIVnlGZt#O7iA*2Qzcdf+Q*D4f;5d;ccK$&BV87MJre(a*J>)2v?M8 zVwT}to7y~E7!Rhpoj04EHp8)k*1@pVU@QFwOifq(B<7Ovh*yeuHjuT)~wq| zVd02CGz|Tt0`i#32l$_Uz+%Ro5!uzE9M|y}=dO=j%&g&Q`Z&hPMDlo$Jmyo3jr#sB zA2DF{nm=92W6^m7?9FxcR(r2SYToUJ&kFYO$(c5IuL?+hzV3u=Wb}*xl-9ihGVgOq zI4}UUl#>Zw#i0?=cr**q3{>`EWDCWw=>X{D@Z!YkTKCSUsv4-1mOMdv_C`Xn?~=90M~&ymCZhHd4O83P?(= z1X*#;F-A(t_>_a;>L)_IXMjVAUmo-xq<9h|D+u{(oA&LRpJ N!i$Rwz&2<%{{M<_YeoP7 diff --git a/lispusers/TMAX-INDEX.~1~ b/lispusers/TMAX-INDEX.~1~ deleted file mode 100644 index ea837289..00000000 --- a/lispusers/TMAX-INDEX.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:37:35" |{POGO:AISNORTH:XEROX}TMAX>TMAX-INDEX.;2| 35555 |previous| |date:| "11-Nov-87 11:51:31" |{POGO:AISNORTH:XEROX}TMAX>TMAX-INDEX.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-indexcoms) (rpaqq tmax-indexcoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * tmax-indexnil |ImageObject| |functions|) (fns indexobj indexobjp index.displayfn index.imageboxfn index.putfn index.getfn index.copyfn index.buttoneventinfn index.whendeletedfn) (* * |Inserting| |indices|) (fns insert.index insert.indexentry insert.known.index subitem.selectfn add.new.index) (* * |Functions| |to| |change| |the| |Index/Extended| |Index|) (fns change.index change.indexentry change.xindex.key change.xindex.entry change.xindex.font change.xindex.number) (* * |Other| |misc| |functions|) (fns gethash.index index.page.number index.manual.delimiter index.string get.indexentry.number index.list.refs list.of.indexentries) (* * |Index| |file| |functions|) (fns create.index.file view.index.file get.index.file write.index.file write.index.pagenumbers reset.index.pagenumbers) (records index.entry.record))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * tmax-indexnil |ImageObject| |functions|) (defineq (indexobj (lambda (key indexentry.parms) (* |fsg| "10-Jul-87 15:59") (* * |Create| |an| |instance| |of| |an| |Index| |or| |Extended| |Index|  |imageobject.| |The| |difference| |between| |the| |two| |is| |the| objectdatum.  |For| \a |simple| |Index,| objectdatum |is| nil.  |For| |an| |Extended| |Index,| objectdatum |is| \a |record| |containing| |the|  |Entry,| |Entry's| |font,| |and| |Number| |option.|  i\n |either| |case,| |the| index.key |property| |is| |the| |hash| |key| |and|  |is| |also| |the| |text| |to| |index| |for| \a |simple| |Index.|  |NOTE...Extended| |Index| |used| |to| |be| |called| |IndexEntry| |after| |the|  |Scribe| |cmd| |of| |the| |same| |name.|) (let ((newobj (imageobjcreate indexentry.parms \\indexobj.imagefns))) (imageobjprop newobj 'index.key key) (imageobjprop newobj 'type 'indexobj) newobj))) (indexobjp (lambda (obj) (* |ss:| "27-Jun-87 15:53") (* * |Tests| |an| |imageobject| |to| |see| |if| |it| |an| |Index| |or|  |Extended| |Index| |imageobject.| b\y |convention,| |testing| |functions| |for|  |an| |imageobject| |are| |named| .) (and obj (eq (imageobjprop obj 'type) 'indexobj)))) (index.displayfn (lambda (obj stream) (* |fsg| "17-Sep-87 11:14") (* * |Display| |an| |Index| |imageobject.|  i\f |the| |stream-type| |is| |display,| |then| |just| |type| |Index| |or|  |Extended| |Index| |followed| |by| |their| |args.|  |Otherwise| |the| |stream-type| |is| |hardcopy.|  i\n |this| |case,| |type| |nothing| |and| |replace| |the| car |of| |the| |hash|  |array| |entry| |with| \a |list| |of| |page| |numbers| |in| |which| |this|  |index| |appears.|) (selectq (imagestreamtype stream) (display (dspfont |GP.DefaultFont| stream) (tmax.shadeobj obj stream) (prin3 (index.string obj) stream)) (let* ((pgs/imobjs (gethash.index obj)) (current.page (index.page.number (|with| textobj textobj (car \\window))))) (cond (pgs/imobjs (cond ((listp (car pgs/imobjs)) (or (memb current.page (car pgs/imobjs)) (rplaca pgs/imobjs (append (car pgs/imobjs) (list current.page))))) (t (rplaca pgs/imobjs (list current.page))))) (t (error "No array entry for this INDEX" (imageobjprop obj 'index.key)))))))) (index.imageboxfn (lambda (obj stream currentx rightmargin) (* |ss:| "27-Jun-87 15:50") (* * |Return| |the| |ImageBox| |for| |an| |Index| |or| |Extended| |Index.|) (selectq (imagestreamtype stream) (display (|create| imagebox xsize _ (stringwidth (index.string obj) |GP.DefaultFont|) ysize _ (fontprop |GP.DefaultFont| 'height) ydesc _ (fontprop |GP.DefaultFont| 'descent) xkern _ 0)) (|create| imagebox xsize _ 0 ysize _ 0 ydesc _ 0 xkern _ 0)))) (index.putfn (lambda (obj stream) (* |ss:| "27-Jun-87 15:51") (* * |Puts| |the| |Index| |or| |Extended| |Index| |imageobject| |in| \a |file.|) (let ((datum (|fetch| objectdatum |of| obj)) (index.put.arg (list '|Index| (imageobjprop obj 'index.key)))) (and datum (nconc1 index.put.arg datum)) (prin2 index.put.arg stream)))) (index.getfn (lambda (stream copy.object) (* |fsg| "20-Aug-87 14:57") (* * |Create| |the| |Index| |or| |Extended| |Index| |imageobject| |when| |it|  |is| |read| |from| |file.|) (let* ((index.args (or copy.object (cdr (read stream)))) (newobj (apply (function indexobj) index.args)) (window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window) (add.new.index window (car index.args) newobj) newobj))) (index.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 12:01") (* * |Here| |to| copy |an| |Index| |or| |Extended| |Index| |Image| |Object.|) (selectq (imagestreamtype target.stream) (text (let ((textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (list (imageobjprop image.obj 'index.key) (|fetch| objectdatum |of| image.obj))))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (index.buttoneventinfn (lambda (obj stream sel relx rely window hoststream button)(* |fsg| "29-Jul-87 10:50") (* * |Process| |the| |middle| |button| |pressed| |inside| |an| |Index| |or|  |Extended| |Index| |imageobject.| |This| |means| |the| |user| |wants| |to|  |Change| |this| |index.|) (and (mousestate middle) (let* ((datum (|fetch| objectdatum |of| obj)) (new.index (menu (|create| menu title _ '|Index Menu| items _ (list (cond (datum '(|Change Extended Index| t "Change Extended Index")) (t '(|Change Index| t "Change Index")))) centerflg _ t)))) (and new.index (car (setq new.index (cond (datum (change.indexentry obj stream)) (t (change.index obj stream))))) (progn (index.whendeletedfn obj stream) (imageobjprop obj 'index.key (car new.index)) (and datum (|replace| objectdatum |of| obj |with| (cadr new.index))) (add.new.index window (car new.index) obj) 'changed)))))) (index.whendeletedfn (lambda (obj window) (* |ss:| "27-Jun-87 15:52") (* * |Delete| |the| |selected| |Index| |or| |Extended| |Index| |imageobject.|) (let* ((indexkey (imageobjprop obj 'index.key)) (index.array (windowprop window 'tsp.index.array)) (hash.value (gethash indexkey index.array))) (cond ((dremove obj (cond ((|fetch| objectdatum |of| obj) (caddr hash.value)) (t (cadr hash.value)))) nil) (t (dsubst nil (list obj) hash.value) (puthash indexkey (cond ((or (cadr hash.value) (caddr hash.value)) hash.value) (t nil)) index.array))) nil))) ) (* * |Inserting| |indices|) (defineq (insert.index (lambda (stream window) (* |fsg| "10-Mar-87 14:02") (* * |Process| |the| "Index" |function| |in| |the| |ImageObjects| |menu.|) (let ((newindex.key (mkatom (convert.tabs.to.spaces (tedit.getinput stream "Index Key:"))))) (and newindex.key (let ((new.index.obj (indexobj newindex.key))) (add.new.index window newindex.key new.index.obj) (tedit.insert.object new.index.obj stream))) (tedit.promptprint stream "" t)))) (insert.indexentry (lambda (stream window) (* |fsg| "19-Mar-87 11:56") (* * |Process| |the| "Extended Index" |function| |in| |the| |ImageObjects|  |menu.| |NOTE...Extended| |Index| |use| |to| |be| |called| |IndexEntry| |after|  |the| |Scribe| |cmd| |of| |the| |same| |name.|) (let ((newindex.key (mkatom (convert.tabs.to.spaces (tedit.getinput stream "Extended Index Key:") )))) (and newindex.key (let ((new.index.obj (indexobj newindex.key (|create| index.entry.record index.entry _ (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream "Extended Index Entry:" (mkstring newindex.key)))) newindex.key) index.entryfont _ (let (newindex.font) (tedit.promptprint stream "Extended Index Entry font..." t) (|until| (setq newindex.font (get.tsp.font window |GP.DefaultFont|)) |do| (tedit.promptprint stream "Invalid font specification...try again." t)) newindex.font) index.number _ (progn (tedit.promptprint stream "Extended Index Number option..." t) (get.indexentry.number)))))) (add.new.index window newindex.key new.index.obj) (tedit.insert.object new.index.obj stream))) (tedit.promptprint stream "" t)))) (insert.known.index (lambda (stream window) (* |fsg| "16-Sep-87 11:31") (* * |Process| |the| "Known Indices" |function| |in| |the| |ImageObjects|  |menu.| a |menu| |of| |all| |the| |known| |Indices| |and| |Extended| |Indices|  |pops| |up| |and| |the| |user| |may| |button| |one| |of| |these| |to| |insert|  |the| |corrsponding| |Index| |or| |Extended| |Index.|) (let* ((previndices (index.list.refs window)) (newindex.key (cond (previndices (let ((menu.selection (menu (|create| menu title _ "Index Keys" items _ previndices menucolumns _ (fix (sqrt (length previndices ))) centerflg _ t whenselectedfn _ (function subitem.selectfn))))) (and menu.selection (or (listp menu.selection) (list menu.selection))))) (t (tedit.promptprint stream "There are no Indices/Extended Indices in this document." t) nil)))) (and newindex.key (let ((newindex.obj (apply 'indexobj newindex.key))) (add.new.index window (car newindex.key) newindex.obj) (tedit.insert.object newindex.obj stream) (tedit.promptprint stream "" t)))))) (subitem.selectfn (lambda (item menu key) (* |fsg| "16-Sep-87 13:28") (* * |Function| |to| |handle| |multiple| |column| |menu| |when| |some| |items|  |have| |subitems.|) (prog (submenu subitems (submenus (getmenuprop menu 'submenus))) (|if| (and (listp item) (setq subitems (cdr (assoc 'subitems (cdddr item))))) |then| (|if| (setq submenu (cdr (sassoc subitems submenus))) |else| (setq submenu (|create| menu items _ subitems centerflg _ t)) (putmenuprop menu 'submenus (cons (cons subitems submenu) submenus))) (return (menu submenu)) |else| (return (defaultwhenselectedfn item menu key)))))) (add.new.index (lambda (window indexkey obj) (* |ss:| "27-Jun-87 15:44") (* * |Add| |an| |Index| |or| |Extended| |Index| |imageobject| |to| |our|  |index| |array.| i\f |at| |least| |one| |already| |exists| |for| |this| |index|  |key,| |then| |just| |append| |this| |imageobject| |to| |the| |list.|  |Otherwise| |create| \a |new| |array| |entry| |for| |this| |imageobject.|  |The| |list| |contains| |three| |elements;|  \a |string,| \a |list| |of| |Index| |imageobjects,| |and| \a |list| |of|  |Extended| |Index| |imageobjects.|) (let* ((code.array (windowprop window 'tsp.index.array)) (hash.value (gethash indexkey code.array)) (index.objs (cadr hash.value)) (entry.objs (caddr hash.value))) (cond ((|fetch| objectdatum |of| obj) (setq entry.objs (append entry.objs (list obj)))) (t (setq index.objs (append index.objs (list obj))))) (puthash indexkey (list nil index.objs entry.objs) code.array)))) ) (* * |Functions| |to| |change| |the| |Index/Extended| |Index|) (defineq (change.index (lambda (obj stream) (* |ss:| "27-Jun-87 15:44") (* * |Here| |when| change |buttoned| |inside| |an| |Index| |ImageObject.|) (list (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat "Change Index key \"" (imageobjprop obj 'index.key) "\" to:"))))))) (change.indexentry (lambda (obj stream) (* |fsg| "10-Mar-87 11:52") (* * |Here| |when| change |buttoned| |inside| |an| |Extended| |Index|  |ImageObject.| |NOTE...Extended| |Index| |used| |to| |be| |called| |IndexEntry|  |after| |the| |Scribe| |cmd| |of| |the| |same| |name.|) (prog1 (list (change.xindex.key obj stream) (|create| index.entry.record index.entry _ (change.xindex.entry obj stream) index.entryfont _ (change.xindex.font obj stream) index.number _ (change.xindex.number obj stream))) (tedit.promptprint stream "" t)))) (change.xindex.key (lambda (obj stream) (* |ss:| "27-Jun-87 15:45") (* * |Change| |the| |key| |of| |an| |Extended| |Index.|) (let ((oldindex.key (imageobjprop obj 'index.key))) (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat "Change Extended Index Key \"" oldindex.key "\" to:")))) oldindex.key)))) (change.xindex.entry (lambda (obj stream) (* |fsg| "10-Mar-87 11:31") (* * |Change| |the| |entry| |of| |an| |Extended| |Index.|) (let ((oldindex.entry (|fetch| index.entry |of| (|fetch| objectdatum |of| obj)))) (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat "Change Extended Index Entry \"" oldindex.entry "\" to:"))) ) oldindex.entry)))) (change.xindex.font (lambda (obj stream) (* |fsg| " 8-Jul-87 16:42") (* * |Change| |the| |font| |of| |an| |Extended| |Index.|) (let ((oldindex.font (|fetch| index.entryfont |of| (|fetch| objectdatum |of| obj))) newindex.font) (tedit.promptprint stream (concat "Change Extended Index Entry's font " (abbreviate.font oldindex.font) " to...") t) (|until| (setq newindex.font (get.tsp.font (\\tedit.mainw stream) (or oldindex.font |GP.DefaultFont|))) |do| (tedit.promptprint stream "Invalid font specification...try again." t)) newindex.font))) (change.xindex.number (lambda (obj stream) (* |fsg| "19-Mar-87 11:51") (* * |Change| |the| |number| |option| |of| |an| |Extended| |Index.|) (let ((oldindex.nbr (|fetch| index.number |of| (|fetch| objectdatum |of| obj)))) (tedit.promptprint stream (concat "Change Extended Index Number option \"" oldindex.nbr "\" to...") t) (get.indexentry.number oldindex.nbr)))) ) (* * |Other| |misc| |functions|) (defineq (gethash.index (lambda (indexobj) (* |fsg| "13-Jul-87 11:09") (* * |Get| |the| |hash| |array| |entry| |for| |this| |Index| |or| |Extended|  |Index.|) (gethash (imageobjprop indexobj 'index.key) (windowprop (|with| textobj textobj (car \\window)) 'tsp.index.array)))) (index.page.number (lambda (window) (* |fsg| "16-Jul-87 10:08") (* * |Return| |the| |index| |page| |number;|  |either| |the| |page| |number| |or| |manual-style| |page| |number.|) (mkatom (cond ((manualindex.enabled? window) (let ((index.page "") (template.list (append (windowprop window 'manualtemplates))) index.template) (|while| (setq index.template (|pop| template.list)) |do| (|with| ngtemplate index.template (setq index.page (concat index.page (or ng.text-before "") (ngroup.chartype.convert ng.chartype ng.currentval) (index.manual.delimiter ng.text-after (car template.list)))))) (concat index.page (car formattingstate)))) (t (car formattingstate)))))) (index.manual.delimiter (lambda (after.delimiter next.template) (* |fsg| "16-Jul-87 10:00") (* * |Return| |the| |delimiter| |between| |NGroups| |and| |the| |page| |number|  |for| \a |Manual| |Index| |page| |reference.|) (or (cond (next.template (cond ((|fetch| (ngtemplate ng.text-before) |of| next.template) "") (t nil))) (t (cond ((or (null after.delimiter) (strequal after.delimiter "")) ".") (t nil)))) after.delimiter))) (index.string (lambda (index.obj) (* |ss:| "27-Jun-87 15:52") (* * |Returns| |the| |display| |imagestream| |text| |for| |an| |Index| |or|  |Extended| |Index| |ImageObject.|) (let ((objdatum (|fetch| objectdatum |of| index.obj)) (indexkey (mkatom (imageobjprop index.obj 'index.key)))) (cond (objdatum (|with| index.entry.record objdatum (concat "{Index Key=" indexkey ",Entry=" index.entry (selectq index.number (yes ",Yes}") (no ",No}") (concat "," index.number "}")))) ) (t (concat "{Index " indexkey "}")))))) (get.indexentry.number (lambda (defaultnumber) (* |ss:| "27-Jun-87 15:47") (* * |Get| |the| number |argument| |for| |an| |IndexEntry| |ImageObject.|  |The| number |can| |be| "YES" \, "NO" \, |or| |an| |integer.|) (or (menu (|create| menu title _ "Number?" centerflg _ t items _ '(yes no value) whenselectedfn _ (function (lambda (item) (cond ((eq item 'value) (numberpad.read (create.numberpad.reader "NUMBER value?" nil nil nil t))) (t item)))))) defaultnumber 'yes))) (index.list.refs (lambda (window) (* |ss:| "27-Jun-87 15:51") (* * |Return| \a |sorted| |list| |of| |the| |Index| |and| |Extended| |Index|  |keys.| |Simple| |Index| |keys| |are| |just| |added| |to| |the| |list.|  |For| |an| |Extended| |Index| |key,| |there| |are| subitems |for| |each|  |Extended| |Index| |for| |this| |key.| |This| |list| |can| |be| |used| |as|  |the| items |field| |in| |the| |Known| |Indices| |menu| |or| |for| |creating|  |the| |index| |file.|) (let ((index.array (windowprop window 'tsp.index.array)) (index.keylist nil) (index.items (cons)) index.value) (maphash index.array (function (lambda (val ky) (setq index.keylist (cons ky index.keylist))))) (|for| key |in| (sort index.keylist 'ualphorder) |do| (setq index.value (gethash key index.array)) (and (cadr index.value) (nconc index.items (list key))) (and (caddr index.value) (nconc index.items (list (list key nil "Select an Extended Index subitem." (cons 'subitems (list.of.indexentries key (caddr index.value)))))))) (cdr index.items)))) (list.of.indexentries (lambda (key objlist) (* |fsg| " 8-Jul-87 16:46") (* * |Returns| \a |list| |of| |the| |Extended| |Indices| |of| |the| |given|  |key| |sorted| |by| |Entry.|) (let ((entry.list (cons)) datum) (|for| obj |in| objlist |do| (setq datum (|fetch| objectdatum |of| obj)) (nconc entry.list (list (list (concat (|fetch| index.entry |of| datum) " " (abbreviate.font (|fetch| index.entryfont |of| datum)) " " (|fetch| index.number |of| datum)) (kwote (list key datum)))))) (sort (intersection (cdr entry.list) (cdr entry.list)) (function (lambda (a b) (ualphorder (caadr (cadadr a)) (caadr (cadadr b))))))))) ) (* * |Index| |file| |functions|) (defineq (create.index.file (lambda (stream window) (* |fsg| "13-Aug-87 09:05") (* * |Writes| |the| |indices| |and| |their| |corresponding| |page| |numbers|  |to| |the| |index| |file.| |The| |indices| |are| |sorted| |alphabetically|  |regardless| |of| |case.|) (let* ((index.array (windowprop window 'tsp.index.array)) (index.list (index.list.refs window)) (index.file (get.index.file (windowprop window 'imageobj.menuw))) index.stream) (cond ((and index.list index.file) (tedit.promptprint stream (concat "Putting Indices into file " index.file "...") t) (write.index.file (setq index.stream (opentextstream)) index.list index.array) (tedit.promptprint stream "done") (tedit.put index.stream index.file) (closef? index.file) index.file) (index.list (tedit.promptprint stream "Specify a file name for the Indices first." t) nil) (t (tedit.promptprint stream "There are no Indices/Extended Indices in this document." t ) nil))))) (view.index.file (lambda (stream window) (* |fsg| "12-Aug-87 16:34") (* * |Writes| |out| |the| |index| |file| |via| create.index.file |and| |then|  |opens| |another| |TEdit| |window| |where| |this| |new| |file| |is|  |displayed.|) (let ((index.file (create.index.file stream window))) (and index.file (progn (or (windowprop window 'index.window) (windowprop window 'index.window (createw nil (concat "Viewing Index file " index.file)) )) (tedit index.file (windowprop window 'index.window))))))) (get.index.file (lambda (menuw) (* \; "Edited 29-Sep-87 14:34 by fsg") (* * |Return| |the| |user| |specified| |index| |file| |name.|) (let ((filename (fm.itemprop (fm.getitem 'index.file nil menuw) 'label))) (and (not (strequal filename "")) (mkatom filename))))) (write.index.file (lambda (index.stream index.list index.array) (* |fsg| "13-Aug-87 10:43") (* * |For| |each| |Index,| |the| |Key| |is| |printed| |followed| |by| |the|  |list| |of| |page| |numbers| |in| |which| |this| |Index| |Key| |appears.|  |Each| |Extended| |Index| |is| |printed| |on| \a |separate| |line| |and| |the|  |page| |number| |depends| |on| |the| |Extended| |Index| |Number| |option.|) (dspfont (fontcreate '(helvetica 14 brr)) index.stream) (printout index.stream "Index" t t) (|for| index.item |in| index.list |do| (cond ((listp index.item) (* * |Extended| |Index|) (let ((pgs.and.imobjs (gethash (car index.item) index.array))) (|for| index.subitem |in| (cdr (cadddr index.item)) |do| (|for| (index.entryargs index.font) |in| (cdr (cadadr index.subitem)) |do| (dspfont (setq index.font (fontcreate (cadr index.entryargs))) index.stream) (printout index.stream (mkstring (car index.entryargs))) (write.index.pagenumbers index.stream pgs.and.imobjs (caddr index.entryargs)) (dspfont index.font index.stream) (printout index.stream t))))) (t (* * |Simple| |Index|) (dspfont |GP.DefaultFont| index.stream) (let ((pgs.and.imobjs (gethash index.item index.array))) (printout index.stream (mkstring index.item)) (write.index.pagenumbers index.stream pgs.and.imobjs nil) (printout index.stream t))))))) (write.index.pagenumbers (lambda (stream pages/imobjs number.option) (* |fsg| "11-Mar-87 11:04") (* * |Here| |to| |write| |the| |actual| |pages| |nubers| |that| |this| |Index|  |or| |Extended| |Index| |appears| |in.| number.option |is| |the| |Number|  |field| |of| |an| |Extended| |Index.|) (dspfont |GP.DefaultFont| stream) (let ((page.nbrs (cond (number.option (selectq number.option (no "") (yes (car pages/imobjs)) (mkstring number.option))) (t (car pages/imobjs)))) (page.string " ")) (cond ((listp page.nbrs) (setq page.string (concat page.string (car page.nbrs))) (|for| page |in| (cdr page.nbrs) |do| (setq page.string (concat page.string ", " page)) |finally| (printout stream page.string))) (t (printout stream (concat page.string page.nbrs))))))) (reset.index.pagenumbers (lambda (window) (* |fsg| "13-Aug-87 10:43") (* * |Here| |before| |hardcopying| |the| |TMAX/TEdit| |window.|  |Reset| |the| |page| |number| |list| |to| nil |so| |the| |hardcopy| displayfn  |will| |create| \a |new| |list| |of| |index| |page| |numbers.|) (let ((index.array (windowprop window 'tsp.index.array))) (and index.array (maphash index.array (function (lambda (val key) (rplaca val nil)))))))) ) (declare\: eval@compile (record index.entry.record (index.entry index.entryfont index.number)) ) (putprops tmax-index copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1955 9950 (indexobj 1965 . 2988) (indexobjp 2990 . 3438) (index.displayfn 3440 . 4944) (index.imageboxfn 4946 . 5666) (index.putfn 5668 . 6098) (index.getfn 6100 . 6694) (index.copyfn 6696 . 7331) (index.buttoneventinfn 7333 . 8931) (index.whendeletedfn 8933 . 9948)) (9985 17606 ( insert.index 9995 . 10581) (insert.indexentry 10583 . 13290) (insert.known.index 13292 . 15445) ( subitem.selectfn 15447 . 16441) (add.new.index 16443 . 17604)) (17676 21607 (change.index 17686 . 18254) (change.indexentry 18256 . 19006) (change.xindex.key 19008 . 19566) (change.xindex.entry 19568 . 20201) (change.xindex.font 20203 . 21072) (change.xindex.number 21074 . 21605)) (21647 29018 ( gethash.index 21657 . 22047) (index.page.number 22049 . 23486) (index.manual.delimiter 23488 . 24179) (index.string 24181 . 25191) (get.indexentry.number 25193 . 26213) (index.list.refs 26215 . 27774) ( list.of.indexentries 27776 . 29016)) (29058 35371 (create.index.file 29068 . 30362) (view.index.file 30364 . 31250) (get.index.file 31252 . 31642) (write.index.file 31644 . 33652) ( write.index.pagenumbers 33654 . 34772) (reset.index.pagenumbers 34774 . 35369))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-INDEX.~2~ b/lispusers/TMAX-INDEX.~2~ deleted file mode 100644 index afbee165..00000000 --- a/lispusers/TMAX-INDEX.~2~ +++ /dev/null @@ -1,186 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "20-Feb-97 17:58:09" |{DSK}medley2.0>lispusers>TMAX-INDEX.;38| 46100 |changes| |to:| (FNS WRITE.INDEX.FILE INDEX.BUTTONEVENTINFN) |previous| |date:| "19-Feb-97 21:51:43" |{DSK}medley2.0>lispusers>TMAX-INDEX.;36|) ; Copyright (c) 1987, 1997 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-INDEXCOMS) (RPAQQ TMAX-INDEXCOMS ( (* |;;| "Developed under support from NIH grant RR-00785.") (* |;;| "Written by Frank Gilmurray and Sami Shaio. Modified by Ron Kaplan") (* |;;| "INDEX objects are simply inserted into the text stream. Information about them is accumulated only when the displayfn is applied to a hardcopy imagestream, and it is accumulated as a property of the imagestream.") (* |;;;| "TMAX-INDEX ImageObject functions") (INITVARS (INDEXDISPLAYAPPEARANCE 'BOX)) (FNS INDEXOBJ INDEXOBJP INDEX.DISPLAYFN INDEX.IMAGEBOXFN INDEX.PUTFN INDEX.GETFN INDEX.COPYFN INDEX.BUTTONEVENTINFN) (* |;;;| "Inserting indices") (FNS INSERT.INDEX INSERT.INDEXENTRY INSERT.KNOWN.INDEX SUBITEM.SELECTFN ADD.NEW.INDEX) (* |;;;| "Functions to change the Index/Extended Index") (FNS CHANGE.INDEX CHANGE.INDEXENTRY CHANGE.XINDEX.KEY CHANGE.XINDEX.ENTRY CHANGE.XINDEX.FONT CHANGE.XINDEX.NUMBER) (* |;;;| "Other misc functions") (FNS GETHASH.INDEX INDEX.PAGE.NUMBER INDEX.MANUAL.DELIMITER INDEX.STRING GET.INDEXENTRY.NUMBER INDEX.LIST.REFS LIST.OF.INDEXENTRIES) (* |;;;| "Index file functions") (FNS CREATE.INDEX.FILE DUMP.INDEX VIEW.INDEX.FILE GET.INDEX.FILE WRITE.INDEX.FILE WRITE.INDEX.PAGENUMBERS RESET.INDEX.PAGENUMBERS) (RECORDS INDEX.ENTRY.RECORD) (* |;;;| "Convenient interface--depress the props key to index the current selection") (FNS SELECTION.TO.STRING SELECTION.TO.INDEX) (MACROS MAKE.INDEXOBJ.IMAGEFNS) (VARS (\\INDEXOBJ.IMAGEFNS (MAKE.INDEXOBJ.IMAGEFNS))) (ADDVARS (IMAGEOBJGETFNS (INDEX.GETFN))) (P (* \;  "533 is the PROPS key on Sun keyboards") (TEDIT.SETSYNTAX 533 'FN TEDIT.READTABLE) (TEDIT.SETFUNCTION 533 (FUNCTION SELECTION.TO.INDEX) TEDIT.READTABLE)) (* |;;;| "IMAGE OBJECT for causing the index to be written, without using the menu") )) (* |;;| "Developed under support from NIH grant RR-00785.") (* |;;| "Written by Frank Gilmurray and Sami Shaio. Modified by Ron Kaplan") (* |;;| "INDEX objects are simply inserted into the text stream. Information about them is accumulated only when the displayfn is applied to a hardcopy imagestream, and it is accumulated as a property of the imagestream." ) (* |;;;| "TMAX-INDEX ImageObject functions") (RPAQ? INDEXDISPLAYAPPEARANCE 'BOX) (DEFINEQ (indexobj - (lambda (key indexentry.parms) (* |fsg| "10-Jul-87 15:59") - (* * |Create| |an| |instance| |of| |an| |Index| |or| |Extended| |Index| - |imageobject.| |The| |difference| |between| |the| |two| |is| |the| objectdatum. - |For| \a |simple| |Index,| objectdatum |is| nil. - |For| |an| |Extended| |Index,| objectdatum |is| \a |record| |containing| |the| - |Entry,| |Entry's| |font,| |and| |Number| |option.| - i\n |either| |case,| |the| index.key |property| |is| |the| |hash| |key| |and| - |is| |also| |the| |text| |to| |index| |for| \a |simple| |Index.| - |NOTE...Extended| |Index| |used| |to| |be| |called| |IndexEntry| |after| |the| - |Scribe| |cmd| |of| |the| |same| |name.|) - - (let ((newobj (imageobjcreate indexentry.parms \\indexobj.imagefns))) - (imageobjprop newobj 'index.key key) - (imageobjprop newobj 'type 'indexobj) - newobj))) (indexobjp - (lambda (obj) (* |ss:| "27-Jun-87 15:53") - (* * |Tests| |an| |imageobject| |to| |see| |if| |it| |an| |Index| |or| - |Extended| |Index| |imageobject.| b\y |convention,| |testing| |functions| |for| - |an| |imageobject| |are| |named| .) - - (and obj (eq (imageobjprop obj 'type) - 'indexobj)))) (INDEX.DISPLAYFN (LAMBDA (OBJ IMAGESTREAM) (* \; "Edited 14-Feb-97 09:30 by rmk:") (* |fsg| "17-Sep-87 11:14") (* |;;| "Display an Index imageobject. If the stream-type is display, then just type Index or Extended Index followed by their args. Otherwise the stream-type is hardcopy. In this case, type nothing and replace the CAR of the hash array entry with a list of page numbers in which this index appears.") (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM) (DISPLAY (CL:UNLESS (EQ 'INVISIBLE INDEXDISPLAYAPPEARANCE) (DSPFONT |GP.DefaultFont| IMAGESTREAM) (SELECTQ INDEXDISPLAYAPPEARANCE (BOX (TMAX.SHADEOBJ OBJ IMAGESTREAM GRAYSHADE)) (HIGHLIGHT (TMAX.SHADEOBJ OBJ IMAGESTREAM BLACKSHADE)) (PROGN (TMAX.SHADEOBJ OBJ IMAGESTREAM) (PRIN3 (INDEX.STRING OBJ) IMAGESTREAM))))) (LET ((PGS/IMOBJS (GETHASH.INDEX OBJ IMAGESTREAM)) (CURRENT.PAGE (INDEX.PAGE.NUMBER (WITH TEXTOBJ TEXTOBJ (CAR \\WINDOW))))) (COND ((LISTP (CAR PGS/IMOBJS)) (OR (MEMB CURRENT.PAGE (CAR PGS/IMOBJS)) (RPLACA PGS/IMOBJS (APPEND (CAR PGS/IMOBJS) (LIST CURRENT.PAGE))))) (T (RPLACA PGS/IMOBJS (LIST CURRENT.PAGE)))))))) (INDEX.IMAGEBOXFN (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* \; "Edited 14-Feb-97 09:23 by rmk:") (* |ss:| "27-Jun-87 15:50") (* |;;| "Return the ImageBox for an Index or Extended Index.") (SELECTQ (IMAGESTREAMTYPE STREAM) (DISPLAY (SELECTQ INDEXDISPLAYAPPEARANCE (INVISIBLE (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0)) ((BOX HIGHLIGHT) (CREATE IMAGEBOX XSIZE _ (CHARWIDTH (CHARCODE SPACE) STREAM) YSIZE _ (LRSH (FONTPROP STREAM 'HEIGHT) 1) YDESC _ 0 XKERN _ 0)) (CREATE IMAGEBOX XSIZE _ (STRINGWIDTH (INDEX.STRING OBJ) |GP.DefaultFont|) YSIZE _ (FONTPROP |GP.DefaultFont| 'HEIGHT) YDESC _ (FONTPROP |GP.DefaultFont| 'DESCENT) XKERN _ 0))) (CREATE IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0)))) (index.putfn - (lambda (obj stream) (* |ss:| "27-Jun-87 15:51") - (* * |Puts| |the| |Index| |or| |Extended| |Index| |imageobject| |in| \a |file.|) - - (let ((datum (|fetch| objectdatum |of| obj)) - (index.put.arg (list '|Index| (imageobjprop obj 'index.key)))) - (and datum (nconc1 index.put.arg datum)) - (prin2 index.put.arg stream)))) (INDEX.GETFN (LAMBDA (STREAM COPY.OBJECT) (* \; "Edited 14-Feb-97 10:10 by rmk:") (* |fsg| "20-Aug-87 14:57") (* |;;| "Create the Index or Extended Index imageobject when it is read from file.") (APPLY (FUNCTION INDEXOBJ) (OR COPY.OBJECT (CDR (READ STREAM)))))) (index.copyfn - (lambda (image.obj source.stream target.stream) (* |fsg| "23-Jul-87 12:01") - (* * |Here| |to| copy |an| |Index| |or| |Extended| |Index| |Image| |Object.|) - - (selectq (imagestreamtype target.stream) - (text (let ((textobj (textobj target.stream))) - (apply* (imageobjprop image.obj 'getfn) - target.stream - (list (imageobjprop image.obj 'index.key) - (|fetch| objectdatum |of| image.obj))))) - (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (INDEX.BUTTONEVENTINFN (LAMBDA (OBJ STREAM SEL RELX RELY WINDOW HOSTSTREAM BUTTON) (* \; "Edited 20-Feb-97 13:53 by rmk:") (* |fsg| "29-Jul-87 10:50") (* |;;| "Process the middle button pressed inside an Index or Extended Index imageobject. This means the user wants to Change this index.") (AND (MOUSESTATE MIDDLE) (LET* ((DATUM (FETCH OBJECTDATUM OF OBJ)) (NEW.INDEX (MENU (CREATE MENU TITLE _ (IMAGEOBJPROP OBJ 'INDEX.KEY) ITEMS _ (LIST (COND (DATUM '(|Change Extended Index| T "Change Extended Index")) (T '(|Change Index| T "Change Index")))) CENTERFLG _ T)))) (CL:WHEN (AND NEW.INDEX (CAR (SETQ NEW.INDEX (COND (DATUM (CHANGE.INDEXENTRY OBJ STREAM)) (T (CHANGE.INDEX OBJ STREAM)))))) (IMAGEOBJPROP OBJ 'INDEX.KEY (CAR NEW.INDEX)) (AND DATUM (REPLACE OBJECTDATUM OF OBJ WITH (CADR NEW.INDEX))) 'CHANGED))))) ) (* |;;;| "Inserting indices") (DEFINEQ (INSERT.INDEX (LAMBDA (STREAM) (* \; "Edited 14-Feb-97 09:15 by rmk:") (* |fsg| "10-Mar-87 14:02") (* |;;| "Process the 'Index' function in the ImageObjects menu.") (LET ((NEWINDEX.KEY (MKATOM (CONVERT.TABS.TO.SPACES (TEDIT.GETINPUT STREAM "Index Key:"))))) (AND NEWINDEX.KEY (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY))) (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))) (TEDIT.PROMPTPRINT STREAM "" T)))) (INSERT.INDEXENTRY (LAMBDA (STREAM WINDOW) (* \; "Edited 14-Feb-97 09:15 by rmk:") (* |fsg| "19-Mar-87 11:56") (* |;;| "Process the 'Extended Index' function in the ImageObjects menu. NOTE...Extended Index use to be called IndexEntry after the Scribe cmd of the same name.") (LET ((NEWINDEX.KEY (MKATOM (CONVERT.TABS.TO.SPACES (TEDIT.GETINPUT STREAM "Extended Index Key:") )))) (AND NEWINDEX.KEY (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY (CREATE INDEX.ENTRY.RECORD INDEX.ENTRY _ (OR (MKATOM (CONVERT.TABS.TO.SPACES (TEDIT.GETINPUT STREAM "Extended Index Entry:" (MKSTRING NEWINDEX.KEY)))) NEWINDEX.KEY) INDEX.ENTRYFONT _ (LET (NEWINDEX.FONT) (TEDIT.PROMPTPRINT STREAM "Extended Index Entry font..." T) (UNTIL (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW |GP.DefaultFont| )) DO (TEDIT.PROMPTPRINT STREAM "Invalid font specification...try again." T)) NEWINDEX.FONT) INDEX.NUMBER _ (PROGN (TEDIT.PROMPTPRINT STREAM "Extended Index Number option..." T) (GET.INDEXENTRY.NUMBER))))) ) (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))) (TEDIT.PROMPTPRINT STREAM "" T)))) (INSERT.KNOWN.INDEX (LAMBDA (STREAM WINDOW) (* \; "Edited 14-Feb-97 17:24 by rmk:") (* |fsg| "16-Sep-87 11:31") (* |;;| "Process the 'Known Indices' function in the ImageObjects menu. A menu of all the known Indices and Extended Indices pops up and the user may button one of these to insert the corrsponding Index or Extended Index.") (HELP "NEED TO DO TEDIT.MAPPIECES INSTEAD OF INDEX.LIST.REFS") (LET* ((PREVINDICES (INDEX.LIST.REFS STREAM)) (NEWINDEX.KEY (COND (PREVINDICES (LET ((MENU.SELECTION (MENU (|create| MENU TITLE _ "Index Keys" ITEMS _ PREVINDICES MENUCOLUMNS _ (FIX (SQRT (LENGTH PREVINDICES ))) CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION SUBITEM.SELECTFN))))) (AND MENU.SELECTION (OR (LISTP MENU.SELECTION) (LIST MENU.SELECTION))))) (T (TEDIT.PROMPTPRINT STREAM "There are no Indices/Extended Indices in this document." T) NIL)))) (AND NEWINDEX.KEY (LET ((NEWINDEX.OBJ (APPLY 'INDEXOBJ NEWINDEX.KEY))) (TEDIT.INSERT.OBJECT NEWINDEX.OBJ STREAM) (TEDIT.PROMPTPRINT STREAM "" T)))))) (subitem.selectfn - (lambda (item menu key) (* |fsg| "16-Sep-87 13:28") - (* * |Function| |to| |handle| |multiple| |column| |menu| |when| |some| |items| - |have| |subitems.|) - - (prog (submenu subitems (submenus (getmenuprop menu 'submenus))) - (|if| (and (listp item) - (setq subitems (cdr (assoc 'subitems (cdddr item))))) - |then| (|if| (setq submenu (cdr (sassoc subitems submenus))) - |else| (setq submenu (|create| menu - items _ subitems - centerflg _ t)) - (putmenuprop menu 'submenus (cons (cons subitems submenu) - submenus))) - (return (menu submenu)) - |else| (return (defaultwhenselectedfn item menu key)))))) (ADD.NEW.INDEX (LAMBDA (IMAGESTREAM INDEXKEY OBJ) (* \; "Edited 14-Feb-97 09:08 by rmk:") (* |ss:| "27-Jun-87 15:44") (* |;;| "Add an Index or Extended Index imageobject to our index array. If at least one already exists for this index key, then just append this imageobject to the list. Otherwise create a new array entry for this imageobject. The list contains three elements; a string, a list of Index imageobjects, and a list of Extended Index imageobjects.") (LET ((CODE.ARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)) HASH.VALUE INDEX.OBJS ENTRY.OBJS) (CL:UNLESS (HASHARRAYP CODE.ARRAY) (SETQ CODE.ARRAY (HASHARRAY 100)) (STREAMPROP IMAGESTREAM 'TSP.CODE.ARRAY CODE.ARRAY) (CL:UNLESS (HASHARRAYP (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)) (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY (HASHARRAY 100)))) (SETQ HASH.VALUE (GETHASH INDEXKEY CODE.ARRAY)) (SETQ INDEX.OBJS (CADR HASH.VALUE)) (SETQ ENTRY.OBJS (CADDR HASH.VALUE)) (COND ((FETCH OBJECTDATUM OF OBJ) (SETQ ENTRY.OBJS (APPEND ENTRY.OBJS (LIST OBJ)))) (T (SETQ INDEX.OBJS (APPEND INDEX.OBJS (LIST OBJ))))) (PUTHASH INDEXKEY (LIST NIL INDEX.OBJS ENTRY.OBJS) CODE.ARRAY)))) ) (* |;;;| "Functions to change the Index/Extended Index") (DEFINEQ (change.index - (lambda (obj stream) (* |ss:| "27-Jun-87 15:44") - (* * |Here| |when| change |buttoned| |inside| |an| |Index| |ImageObject.|) - - (list (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat "Change Index key \"" - (imageobjprop obj - 'index.key) - "\" to:"))))))) (change.indexentry - (lambda (obj stream) (* |fsg| "10-Mar-87 11:52") - (* * |Here| |when| change |buttoned| |inside| |an| |Extended| |Index| - |ImageObject.| |NOTE...Extended| |Index| |used| |to| |be| |called| |IndexEntry| - |after| |the| |Scribe| |cmd| |of| |the| |same| |name.|) - - (prog1 (list (change.xindex.key obj stream) - (|create| index.entry.record - index.entry _ (change.xindex.entry obj stream) - index.entryfont _ (change.xindex.font obj stream) - index.number _ (change.xindex.number obj stream))) - (tedit.promptprint stream "" t)))) (change.xindex.key - (lambda (obj stream) (* |ss:| "27-Jun-87 15:45") - (* * |Change| |the| |key| |of| |an| |Extended| |Index.|) - - (let ((oldindex.key (imageobjprop obj 'index.key))) - (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat - "Change Extended Index Key \"" - oldindex.key "\" to:")))) - oldindex.key)))) (change.xindex.entry - (lambda (obj stream) (* |fsg| "10-Mar-87 11:31") - (* * |Change| |the| |entry| |of| |an| |Extended| |Index.|) - - (let ((oldindex.entry (|fetch| index.entry |of| (|fetch| objectdatum |of| obj)))) - (or (mkatom (convert.tabs.to.spaces (tedit.getinput stream (concat - "Change Extended Index Entry \"" - oldindex.entry "\" to:"))) - ) - oldindex.entry)))) (change.xindex.font - (lambda (obj stream) (* |fsg| " 8-Jul-87 16:42") - (* * |Change| |the| |font| |of| |an| |Extended| |Index.|) - - (let ((oldindex.font (|fetch| index.entryfont |of| (|fetch| objectdatum |of| obj))) - newindex.font) - (tedit.promptprint stream (concat "Change Extended Index Entry's font " (abbreviate.font - oldindex.font) - " to...") - t) - (|until| (setq newindex.font (get.tsp.font (\\tedit.mainw stream) - (or oldindex.font |GP.DefaultFont|))) - |do| (tedit.promptprint stream "Invalid font specification...try again." t)) - newindex.font))) (change.xindex.number - (lambda (obj stream) (* |fsg| "19-Mar-87 11:51") - (* * |Change| |the| |number| |option| |of| |an| |Extended| |Index.|) - - (let ((oldindex.nbr (|fetch| index.number |of| (|fetch| objectdatum |of| obj)))) - (tedit.promptprint stream (concat "Change Extended Index Number option \"" oldindex.nbr - "\" to...") - t) - (get.indexentry.number oldindex.nbr)))) ) (* |;;;| "Other misc functions") (DEFINEQ (GETHASH.INDEX (LAMBDA (OBJ IMAGESTREAM) (* \; "Edited 14-Feb-97 09:28 by rmk:") (* |fsg| "13-Jul-87 11:09") (* |;;| "Get the hash array entry for this Index or Extended Index.") (LET ((HARRAY (HASHARRAYP (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)))) (CL:UNLESS HARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY (SETQ HARRAY (HASHARRAY 100)))) (OR (GETHASH (IMAGEOBJPROP OBJ 'INDEX.KEY) HARRAY) (ADD.NEW.INDEX IMAGESTREAM (IMAGEOBJPROP OBJ 'INDEX.KEY) OBJ))))) (INDEX.PAGE.NUMBER (LAMBDA (WINDOW) (* \; "Edited 14-Feb-97 09:58 by rmk:") (* |fsg| "16-Jul-87 10:08") (* |;;| "Return the index page number; either the page number or manual-style page number.") (MKATOM (COND ((MANUALINDEX.ENABLED? WINDOW) (LET ((INDEX.PAGE "") (TEMPLATE.LIST (APPEND (WINDOWPROP WINDOW 'MANUALTEMPLATES))) INDEX.TEMPLATE) (WHILE (SETQ INDEX.TEMPLATE (POP TEMPLATE.LIST)) DO (WITH NGTEMPLATE INDEX.TEMPLATE (SETQ INDEX.PAGE (CONCAT INDEX.PAGE (OR NG.TEXT-BEFORE "") (NGROUP.CHARTYPE.CONVERT NG.CHARTYPE NG.CURRENTVAL ) (INDEX.MANUAL.DELIMITER NG.TEXT-AFTER (CAR TEMPLATE.LIST)))))) (CONCAT INDEX.PAGE (CAR FORMATTINGSTATE)))) (T (CAR FORMATTINGSTATE)))))) (index.manual.delimiter - (lambda (after.delimiter next.template) (* |fsg| "16-Jul-87 10:00") - (* * |Return| |the| |delimiter| |between| |NGroups| |and| |the| |page| |number| - |for| \a |Manual| |Index| |page| |reference.|) - - (or (cond - (next.template (cond - ((|fetch| (ngtemplate ng.text-before) |of| next.template) - "") - (t nil))) - (t (cond - ((or (null after.delimiter) - (strequal after.delimiter "")) - ".") - (t nil)))) - after.delimiter))) (index.string - (lambda (index.obj) (* |ss:| "27-Jun-87 15:52") - (* * |Returns| |the| |display| |imagestream| |text| |for| |an| |Index| |or| - |Extended| |Index| |ImageObject.|) - - (let ((objdatum (|fetch| objectdatum |of| index.obj)) - (indexkey (mkatom (imageobjprop index.obj 'index.key)))) - (cond - (objdatum (|with| index.entry.record objdatum (concat "{Index Key=" indexkey ",Entry=" - index.entry - (selectq index.number - (yes ",Yes}") - (no ",No}") - (concat "," index.number "}")))) - ) - (t (concat "{Index " indexkey "}")))))) (get.indexentry.number - (lambda (defaultnumber) (* |ss:| "27-Jun-87 15:47") - (* * |Get| |the| number |argument| |for| |an| |IndexEntry| |ImageObject.| - |The| number |can| |be| "YES" \, "NO" \, |or| |an| |integer.|) - - (or (menu (|create| menu - title _ "Number?" - centerflg _ t - items _ '(yes no value) - whenselectedfn _ (function (lambda (item) - (cond - ((eq item 'value) - (numberpad.read (create.numberpad.reader - "NUMBER value?" nil nil - nil t))) - (t item)))))) - defaultnumber - 'yes))) (INDEX.LIST.REFS (LAMBDA (IMAGESTREAM) (* \; "Edited 14-Feb-97 09:09 by rmk:") (* |ss:| "27-Jun-87 15:51") (* |;;| "Return a sorted list of the Index and Extended Index keys. Simple Index keys are just added to the list. For an Extended Index key, there are SUBITEMS for each Extended Index for this key. This list can be used as the ITEMS field in the Known Indices menu or for creating the index file.") (LET ((INDEX.ARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY)) (INDEX.KEYLIST NIL) (INDEX.ITEMS (CONS)) INDEX.VALUE) (MAPHASH INDEX.ARRAY (FUNCTION (LAMBDA (VAL KY) (SETQ INDEX.KEYLIST (CONS KY INDEX.KEYLIST))))) (FOR KEY IN (SORT INDEX.KEYLIST 'UALPHORDER) DO (SETQ INDEX.VALUE (GETHASH KEY INDEX.ARRAY)) (AND (CADR INDEX.VALUE) (NCONC INDEX.ITEMS (LIST KEY))) (AND (CADDR INDEX.VALUE) (NCONC INDEX.ITEMS (LIST (LIST KEY NIL "Select an Extended Index subitem." (CONS 'SUBITEMS (LIST.OF.INDEXENTRIES KEY (CADDR INDEX.VALUE)))))))) (CDR INDEX.ITEMS)))) (list.of.indexentries - (lambda (key objlist) (* |fsg| " 8-Jul-87 16:46") - (* * |Returns| \a |list| |of| |the| |Extended| |Indices| |of| |the| |given| - |key| |sorted| |by| |Entry.|) - - (let ((entry.list (cons)) - datum) - (|for| obj |in| objlist - |do| (setq datum (|fetch| objectdatum |of| obj)) - (nconc entry.list (list (list (concat (|fetch| index.entry |of| datum) - " " - (abbreviate.font (|fetch| index.entryfont - |of| datum)) - " " - (|fetch| index.number |of| datum)) - (kwote (list key datum)))))) - (sort (intersection (cdr entry.list) - (cdr entry.list)) - (function (lambda (a b) - (ualphorder (caadr (cadadr a)) - (caadr (cadadr b))))))))) ) (* |;;;| "Index file functions") (DEFINEQ (CREATE.INDEX.FILE (LAMBDA (TEXTSTREAM IMAGESTREAM INDEXFILE INDEX.FONT NOTITLE) (* \; "Edited 14-Feb-97 11:10 by rmk:") (* |fsg| "13-Aug-87 09:05") (* |;;| "Writes the indices and their corresponding page numbers to the index file. The indices are sorted alphabetically regardless of case.") (LET ((INDEX.ARRAY (IF IMAGESTREAM THEN (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY) ELSE (* |;;| "Menu call should do a hardcopy to a nodircore image stream, which can then be passed in for us to interrogate.") (* |;;| "(STREAMPROP WINDOW 'TSP.INDEX.ARRAY)") (HELP "Trying to write index when not hard-copying"))) (INDEX.LIST (INDEX.LIST.REFS IMAGESTREAM)) (INDEX.FILE (OUTFILEP INDEXFILE)) (INDEX.STREAM (OPENTEXTSTREAM))) (COND ((AND INDEX.LIST INDEX.FILE) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "Putting Indices into file " INDEX.FILE "... ") T) (CL:UNLESS NOTITLE (DSPFONT (FONTCREATE '(HELVETICA 14 BRR)) INDEX.STREAM) (PRINTOUT INDEX.STREAM "Index" T T)) (WRITE.INDEX.FILE INDEX.STREAM INDEX.LIST INDEX.ARRAY INDEX.FONT) (CLOSEF? (TEDIT.PUT INDEX.STREAM INDEX.FILE)) INDEX.FILE) (INDEX.LIST (TEDIT.PROMPTPRINT TEXTSTREAM "Specify a file name for the Indices first." T) NIL) (T (TEDIT.PROMPTPRINT TEXTSTREAM "There are no Indices/Extended Indices in this document." T) NIL))))) (DUMP.INDEX (LAMBDA (INDEXFILE) (* \; "Edited 14-Feb-97 11:12 by rmk:") (* |;;| "Dumps the current index to INDEXFILE without a title and in the font of the current image stream. Convenient to call in an EVALOBJect context. By default, indexfile will be placed on the same directory as the text file underlying the textstream") (DECLARE (USEDFREE TEXTSTREAM WINDOW IMAGESTREAM)) (LET ((TEXTFILE (FETCH (TEXTOBJ TXTFILE) OF (TEXTOBJ TEXTSTREAM)))) (IF TEXTFILE THEN (SETQ TEXTFILE (FULLNAME TEXTFILE))) (CREATE.INDEX.FILE TEXTSTREAM IMAGESTREAM (IF INDEXFILE THEN (PACKFILENAME 'VERSION NIL 'BODY INDEXFILE 'HOST (FILENAMEFIELD TEXTFILE 'HOST) 'DIRECTORY (FILENAMEFIELD TEXTFILE 'DIRECTORY)) ELSEIF TEXTFILE THEN (PACKFILENAME 'VERSION NIL 'EXTENSION 'INDEX 'BODY TEXTFILE) ELSEIF (GET.INDEX.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW)) ELSE (HELP "No file for index")) (DSPFONT NIL IMAGESTREAM) T)))) (VIEW.INDEX.FILE (LAMBDA (STREAM WINDOW DONTSHOW) (* \; "Edited 14-Feb-97 17:15 by rmk:") (* |fsg| "12-Aug-87 16:34") (* |;;| "Writes out the index file via CREATE.INDEX.FILE and then opens another TEdit window where this new file is displayed.") (* |;;| "First, do a dummy hardcopy to get the page numbers. Use the type of the current defaultprintinghost as the imagestream type") (LET* ((IMAGESTREAM (OPENIMAGESTREAM '{NULL})) (INDEX.FILE (CREATE.INDEX.FILE STREAM (PROGN (TEDIT.FORMAT.HARDCOPY STREAM IMAGESTREAM ) IMAGESTREAM) (GET.INDEX.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW))))) (AND INDEX.FILE (NOT DONTSHOW) (PROGN (OR (WINDOWPROP WINDOW 'INDEX.WINDOW) (WINDOWPROP WINDOW 'INDEX.WINDOW (CREATEW NIL (CONCAT "Viewing Index file " INDEX.FILE)))) (TEDIT INDEX.FILE (WINDOWPROP WINDOW 'INDEX.WINDOW))))))) (get.index.file - (lambda (menuw) (* \; "Edited 29-Sep-87 14:34 by fsg") - - (* * |Return| |the| |user| |specified| |index| |file| |name.|) - - (let ((filename (fm.itemprop (fm.getitem 'index.file nil menuw) - 'label))) - (and (not (strequal filename "")) - (mkatom filename))))) (WRITE.INDEX.FILE (LAMBDA (INDEX.STREAM INDEX.LIST INDEX.ARRAY INDEX.FONT PAGE.FONT) (* \; "Edited 20-Feb-97 17:58 by rmk:") (* |fsg| "13-Aug-87 10:43") (* |;;| "For each Index, the Key is printed followed by the list of page numbers in which this Index Key appears. Each Extended Index is printed on a separate line and the page number depends on the Extended Index Number option.") (CL:UNLESS INDEX.FONT (SETQ INDEX.FONT |GP.DefaultFont|)) (CL:UNLESS PAGE.FONT (SETQ PAGE.FONT INDEX.FONT)) (* |;;| "For some reason, the first line doesn't format properly after an Include object. Kludge to fix it here: put out a blank line. Perhaps a better thing would be to somehow fix the include object, or perhaps to have the DUMP.INDEX take a flag to control this.") (PRINTOUT INDEX.STREAM " " T) (FOR INDEX.ITEM IN INDEX.LIST DO (COND ((LISTP INDEX.ITEM) (* |;;| "Extended Index") (FOR INDEX.SUBITEM (PGS.AND.IMOBJS _ (GETHASH (CAR INDEX.ITEM) INDEX.ARRAY)) IN (CDR (CADDDR INDEX.ITEM)) DO (FOR INDEX.ENTRYARGS FONT IN (CDR (CADADR INDEX.SUBITEM)) DO (DSPFONT (SETQ FONT (FONTCREATE (CADR INDEX.ENTRYARGS))) INDEX.STREAM) (PRINTOUT INDEX.STREAM (MKSTRING (CAR INDEX.ENTRYARGS))) (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS (CADDR INDEX.ENTRYARGS) PAGE.FONT) (DSPFONT FONT INDEX.STREAM) (PRINTOUT INDEX.STREAM T)))) (T (* |;;| "Simple Index") (DSPFONT INDEX.FONT INDEX.STREAM) (PRINTOUT INDEX.STREAM (MKSTRING INDEX.ITEM)) (WRITE.INDEX.PAGENUMBERS INDEX.STREAM (GETHASH INDEX.ITEM INDEX.ARRAY) NIL PAGE.FONT) (PRINTOUT INDEX.STREAM T)))))) (WRITE.INDEX.PAGENUMBERS (LAMBDA (STREAM PAGES/IMOBJS NUMBER.OPTION PAGEFONT) (* \; "Edited 2-Feb-97 17:04 by rmk:") (* |fsg| "11-Mar-87 11:04") (* |;;| "Here to write the actual pages nubers that this Index or Extended Index appears in. NUMBER.OPTION is the Number field of an Extended Index.") (DSPFONT PAGEFONT STREAM) (LET ((PAGE.NBRS (COND (NUMBER.OPTION (SELECTQ NUMBER.OPTION (NO "") (YES (CAR PAGES/IMOBJS)) (MKSTRING NUMBER.OPTION))) (T (CAR PAGES/IMOBJS)))) (PAGE.STRING " ")) (COND ((LISTP PAGE.NBRS) (SETQ PAGE.STRING (CONCAT PAGE.STRING (CAR PAGE.NBRS))) (|for| PAGE |in| (CDR PAGE.NBRS) |do| (SETQ PAGE.STRING (CONCAT PAGE.STRING ", " PAGE)) |finally| (PRINTOUT STREAM PAGE.STRING))) (T (PRINTOUT STREAM (CONCAT PAGE.STRING PAGE.NBRS))))))) (RESET.INDEX.PAGENUMBERS (LAMBDA (IMAGESTREAM) (* \; "Edited 14-Feb-97 09:11 by rmk:") (* |fsg| "13-Aug-87 10:43") (* |;;| "Here before hardcopying the TMAX/TEdit window. Reset the page number list to NIL so the hardcopy DISPLAYFN will create a new list of index page numbers.") (LET ((INDEX.ARRAY (STREAMPROP IMAGESTREAM 'TSP.INDEX.ARRAY))) (AND INDEX.ARRAY (MAPHASH INDEX.ARRAY (FUNCTION (LAMBDA (VAL KEY) (RPLACA VAL NIL)))))))) ) (DECLARE\: EVAL@COMPILE (RECORD INDEX.ENTRY.RECORD (INDEX.ENTRY INDEX.ENTRYFONT INDEX.NUMBER)) ) (* |;;;| "Convenient interface--depress the props key to index the current selection") (DEFINEQ (SELECTION.TO.STRING (LAMBDA (TEXTSTREAM) (* \; "Edited 27-Jan-97 12:53 by rmk:") (LET (PREFIX ENDPOS NEXTESCAPE (SEL (TEDIT.GETSEL TEXTSTREAM)) (POINT (TEDIT.GETPOINT TEXTSTREAM)) STARTPOS ENDPOS) (SETQ STARTPOS (SUB1 (FETCH CH# OF SEL))) (SETQ ENDPOS (SUB1 (FETCH CHLIM OF SEL))) (IF (EQ 'CHAR (FETCH SELKIND OF SEL)) THEN (* |;;| "Stretch out to at least a word selection.") (* |;;|  "Look backwards, then forwards. 22 seems to be white-space, 21 is alphabetic, 20 is punctuation") (FOR OLD STARTPOS C BC FROM (SUB1 STARTPOS) BY -1 TO 0 WHILE (PROGN (SETFILEPTR TEXTSTREAM STARTPOS) (AND (SMALLP (SETQ C (BIN TEXTSTREAM))) (SELECTQ (TEDIT.WORDGET C) (22 NIL) (20 (* \; "Include hyphens as alphabetics") (EQ C (CHARCODE -))) T))) FINALLY (ADD STARTPOS 1) (* \; "Fileptr of first character") (SETFILEPTR TEXTSTREAM ENDPOS) (WHILE (PROGN (AND (NOT (EOFP TEXTSTREAM)) (SMALLP (SETQ C (BIN TEXTSTREAM))) (SELECTQ (TEDIT.WORDGET C) (22 NIL) (20 (* \; "Include hyphens as alphabetics") (EQ C (CHARCODE -))) T)))) (SETQ ENDPOS (GETFILEPTR TEXTSTREAM)) (CL:UNLESS (EOFP TEXTSTREAM) (* \;  "Have to back up over the ending space") (SETQ ENDPOS (SUB1 ENDPOS))))) (* |;;|  "Always move the point to the right, so that the insert happens after the selection") (SETQ STARTPOS (ADD1 STARTPOS)) (TEDIT.SETSEL TEXTSTREAM STARTPOS (- (ADD1 ENDPOS) STARTPOS) 'RIGHT NIL T 'NORMAL) (IF (CAR (NLSETQ (TEDIT.SEL.AS.STRING TEXTSTREAM))) ELSE (TEDIT.PROMPTPRINT TEXTSTREAM "Invalid index term--contains image object?" T) (ERROR!))))) (SELECTION.TO.INDEX (LAMBDA (STREAM) (* \; "Edited 14-Feb-97 09:56 by rmk:") (* |fsg| "10-Mar-87 14:02") (* |;;| "The index key has been depressed. Index on the current selection") (LET ((NEWINDEX.KEY (MKATOM (CL:STRING-TRIM '(#\Space) (CONVERT.TABS.TO.SPACES (SELECTION.TO.STRING STREAM))))) (TEXTOBJ (TEXTOBJ STREAM))) (IF (AND NEWINDEX.KEY (NEQ 0 (NCHARS NEWINDEX.KEY))) THEN (LET ((OBJ (INDEXOBJ NEWINDEX.KEY))) (REPLACE BLUEPENDINGDELETE OF TEXTOBJ WITH NIL) (TEDIT.INSERT.OBJECT OBJ STREAM (TEDIT.GETPOINT STREAM)) (TEDIT.SETSEL STREAM (ADD1 (TEDIT.GETPOINT STREAM)) 0 'RIGHT NIL T 'NORMAL) (TEDIT.PROMPTPRINT STREAM (CONCAT "Index term: " NEWINDEX.KEY) T)) ELSE (TEDIT.PROMPTPRINT STREAM "No index term selected" T) (ERROR!))))) ) (DECLARE\: EVAL@COMPILE (PUTPROPS MAKE.INDEXOBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION INDEX.DISPLAYFN) (FUNCTION INDEX.IMAGEBOXFN) (FUNCTION INDEX.PUTFN) (FUNCTION INDEX.GETFN) (FUNCTION INDEX.COPYFN) (FUNCTION INDEX.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) ) (RPAQ \\INDEXOBJ.IMAGEFNS (MAKE.INDEXOBJ.IMAGEFNS)) (ADDTOVAR IMAGEOBJGETFNS (INDEX.GETFN)) (* \;  "533 is the PROPS key on Sun keyboards") (TEDIT.SETSYNTAX 533 'FN TEDIT.READTABLE) (TEDIT.SETFUNCTION 533 (FUNCTION SELECTION.TO.INDEX) TEDIT.READTABLE) (* |;;;| "IMAGE OBJECT for causing the index to be written, without using the menu") (PUTPROPS TMAX-INDEX COPYRIGHT ("Xerox Corporation" 1987 1997)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3149 10825 (INDEXOBJ 3159 . 4182) (INDEXOBJP 4184 . 4632) (INDEX.DISPLAYFN 4634 . 6204) (INDEX.IMAGEBOXFN 6206 . 7752) (INDEX.PUTFN 7754 . 8184) (INDEX.GETFN 8186 . 8577) (INDEX.COPYFN 8579 . 9214) (INDEX.BUTTONEVENTINFN 9216 . 10823)) (10864 18737 (INSERT.INDEX 10874 . 11461) ( INSERT.INDEXENTRY 11463 . 14230) (INSERT.KNOWN.INDEX 14232 . 16309) (SUBITEM.SELECTFN 16311 . 17305) ( ADD.NEW.INDEX 17307 . 18735)) (18803 22734 (CHANGE.INDEX 18813 . 19381) (CHANGE.INDEXENTRY 19383 . 20133) (CHANGE.XINDEX.KEY 20135 . 20693) (CHANGE.XINDEX.ENTRY 20695 . 21328) (CHANGE.XINDEX.FONT 21330 . 22199) (CHANGE.XINDEX.NUMBER 22201 . 22732)) (22776 30497 (GETHASH.INDEX 22786 . 23453) ( INDEX.PAGE.NUMBER 23455 . 25034) (INDEX.MANUAL.DELIMITER 25036 . 25727) (INDEX.STRING 25729 . 26739) ( GET.INDEXENTRY.NUMBER 26741 . 27761) (INDEX.LIST.REFS 27763 . 29253) (LIST.OF.INDEXENTRIES 29255 . 30495)) (30539 40743 (CREATE.INDEX.FILE 30549 . 32428) (DUMP.INDEX 32430 . 34850) (VIEW.INDEX.FILE 34852 . 36116) (GET.INDEX.FILE 36118 . 36508) (WRITE.INDEX.FILE 36510 . 38911) ( WRITE.INDEX.PAGENUMBERS 38913 . 40113) (RESET.INDEX.PAGENUMBERS 40115 . 40741)) (40941 44995 ( SELECTION.TO.STRING 40951 . 43783) (SELECTION.TO.INDEX 43785 . 44993))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-NGRAPH.LCOM.~2~ b/lispusers/TMAX-NGRAPH.LCOM.~2~ deleted file mode 100644 index b66b2b60305196f073696102bc299f079373db5e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9537 zcmbtaU5q2yRd%^2JDUYVH zgKkHRhUk=-e6!L#{??aU7v1s2y@&1dL3?=59X)6d?mg;u2HhtaJ$rA^zc_y|8h82O zihKH1^K_?n=$Q>$|Mm1_o7XeX$5=0w5=LP^W$b6tH2)DB3@n`8-_2r% zZ#L?O^?lQ6*6N;b@1I&;{q$R3F1LK&sU6-U5%@<$4w24ga)y|kkGqfiqpOQaLhfT9 z`!I~1+UT)bBAbJRKgANpWIMrHt6H^|*sl~4TMdyG+;k!u!VsQy=+tX?OvzT^pwT~Z zYL)s4o>Rha`Z(k2wut@1S}Ybf-;LqlYxLtUBhS-U%}-O?h8DBU{?Euq%^A@{um7|1 zJudrvAb;H)@l-wTd?e@M7XFd=6pgWEA8z4EWH&iRJ|FRT`E1L%X0t@z&B$|+pVwns z=~P-YT1wo8SBFOSQj0D5!eUEqX;gM;RAy;ZIwzWT{e+bd3)&N=@0(>?>AH|xSS6nk zWw+k6bl|?;YUpxYE+^zWov3cr$TTZ&ifmp;Q#=v7IKO6td#l6Eq=Zv*e8+U>=Sl+! zmJ+_zv^=Q*0AaBa@Hh5y0Tf_wyCFmjY%{t+o%eiD6GpBe_fOB+VAo0tV|Q1LIuS-D z4HTAIj$4sm58OjxqzzHF&DvogJ`61fDX>dl2>}&mgj+A0E-xwe3gW2M^qqqMdV_rC_N z@9drc_oJP5Ns6w!U~*r#&8BU7o_U7DBMj*PLNHji2dAc2&0|XsB!%MgDN(adf|JPt z6X6@FwNMaSk(TX*g3R1B%uhAP6|panXfrE@y!x&Y$K&{~F%0hFiQeK`smvnYwISVZ z1{-${ZQxqX2^u+ZD!v^y7zP@Mua&uHC6miHsM>K8Tib~hT%u%C%&$lGtVjX7-qL{E zBI}(&Mg-4qlH_gPy8KCJ0U9FCIuRK|9C#Lj1EM&q66`&@Kyt>**hYYipt-8#6IiQ6 z%n6P(L=S5=B%Dy1sP~dxN85EXUjDQ3=AV91Z zC<_M@RXD48o;#{_-?ltS8lhGAb+WxCn?MH`=s7j4GT+0-aX$MNEW zn^(zOe7n=@n7vIITYj%tI_hn1+PzIS@*C%m9c}tr>G^G^^PSRN2!_ZUu^|a2cISLd zCJcGz{g(mewd8>8O8*Hhq`_qK4u_oVfmg4R2Ac9LNyG>n*A7|8JCGn=G+DM8G-;zt z&_UFXSp)Qkry4Y@p8vBr--Y=#qWez#eb(%{GDXjN%kq!}u39$4@J|wCT?)dJN@-|j zxUoQctD}$5;8%twEF^JENcIUV6Lnp*#tI(Bp~%xx$m2+d@k;Bs)}iTwy+R$TUQB3) zkjW7Pu>rj(Y&T&o7HQL*8NUQ4)G5QcKeyLSTcPuP?)AH~zN{1;aC-fZINx1SJvRM% zRUmRhw(a=rHEKYo$nL`8YGu<$E*WwOo@9T>JKrC2QM?pIpxE6**4rM8yY0>s(fvmM z;_?D1u?&BQ?ML1HBsr&~=wFDo7+oL`)zwy?+KDs}yH;bkEm*=dWUaCrzTHp#LW~ zjQZ=($TN*v0)ODsRiWnf;`ck znX*-@P>+Vl1j$+h14TNO6UokK*iCZ!o~(^7yPwB1V%6kt;&-+nl3z`VTwWx(9)=Rf zTp|qHA9jQ_>zMe@B2$JS2|MS|hl^mUmB+==2tdpm&V#>TDUF<^JB$@oIOpb2dR zOzl|a@b{17+KXqubR2i@-tdQb9|$}O5a`6uuHT32LNdP^U|BBX=rvXxVq^p1GU7LI zO~q;e4ixp4U9;IlcwwMix{N`j=blxqzh&vB>*{KrrpO17jsl&^I?~~M61<|yH3Mfh z0?r`NV{q;Pgc6%MI2y(u;W1i>S;8L>H^Uz?o%!BLN}ZAnJHj7O_cD!y3>+$pS^ixo{-g}ezKh(i9eM;?l_y!u#BwUD2}LtGVH zEp!QYj`XqNQkqF|@=xA)jy5ifr7xa;rX&H(RL5K?1t{5EYqh7ZyodA)Kz;b}^^bY~ z!S>z+pM=pG!roO88CWOC+VLnO(qQ~7oC-keP>Nsjbm@W|)MX-4A;XZ#C&Ty?hvrhZ5o=YC;oMNX7g^-_ z(6DdSbX3DR(^OvyB9Q4#ND0o9tjrRJUzWtxIebKw@{^z3cOcR&bHRs|W=`^YGwMSB zfIrAwfgfifC1F%1NYnkIt<>?|@>G8>z{P8&o~)3|%t+>Y64h#?0>uv~`^&0`8zh0q zAze_f$jW64GFurJs8?jb^HE_wAMF4Sq=HwtAjLFbILq_uo&dASCg|5d`8uSkz0e)v zPDVLKO4G3Yo>YSn)xw9hh7X6MuMdR`hs5QRb9l&IRDqQr#nlihq)Ge& z%#(5=9dz;%I4GOk4P#k$WYn2~gSWIWOC=Z%BkT=_1Vt1IWN==Ki-+Wi!o5>c!)W@leI2~1CvSk4L`%YX_Us&DH zCBjRkO4J+|gwgQ@DY-8Yh6O1!Dod+K8G&Qi1-ayk8h@a-03KreI|eK|&SG7)=eF&T`$-W@+^Uv$NI^r(%iYlQkOz}hS0!u`J7 z0@aZt9S7aZ%kCI=7`xG)YDWnF=NEx*3bsH@NW>koUk6w2gZ2|ee+E$=a zLBAvV!^`fw-7#T+)5eJ8%8(4<`W}c1oCbpTJ-Q9!(5Wmf3-KP01Rmao#l#0@@!`jV z&42wDE_3h?ZurqgTyx%g@$8Gvr`D!#3`~dmJp7nDNU!zRX!_CF^}lh`(|g0N7&!oeNjgtBY6&ctdxX z4IgpT_>bC@@1K>Cu5z*(`Ev@iHPOLqm|yvdSZEhpTVE8DO80ShFgm9{j+k5xI|R7N z#nt)wXncvMcYxLjYBjc)ygP0W(d2nMsZ_p@)wcx=KN+th~C5mM}7L$YxhSw{>B5NF+Q-G30IaTs#ZUF=W6)ivOgMLP{)H>Q$+sG zVdY(|;>`JqEeMcr4AjlpiaWBvam?Q}z5Hfm`7&auAg*regGvxrzPVmIs{&J@C@9v3 z6{VGQ&5c2ka=|q&6}NbmKoJ~KFKPL~=xTV$q_nK!Rkfq#Wd5a@)(wqcNb~ QCafU_+$-cUmhMmf7aEX(C;$Ke diff --git a/lispusers/TMAX-NGRAPH.~2~ b/lispusers/TMAX-NGRAPH.~2~ deleted file mode 100644 index d1df4519..00000000 --- a/lispusers/TMAX-NGRAPH.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:35:45" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NGRAPH.;2| 25361 |previous| |date:| "11-Nov-87 11:56:01" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NGRAPH.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-ngraphcoms) (rpaqq tmax-ngraphcoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Number| |Group| graph |functions|) (fns graphmenu initial.ngroup.graph ngroup.make.rootnode tspgraphregion close.ngroup.graph ngroup.graph.closefn add.ngroup.to.mother.node add.node.to.graph collect.hasharray create.ngroup.node get.fromnodes get.tonodes find.node tsp.get.ngroup.array tsp.legalid list.ancestors toplevel.sisters get.ngroup.mother) (* * |Number| |counting| |functions|) (fns downdate.numberobjs update.numberobjs reset.dependent.classes reset.ncounter get.ncounter ncounter? flatten.tree.to.string ngroup.chartype ngroup.chartype.convert number.to.letter remove.all.counters))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Number| |Group| graph |functions|) (defineq (graphmenu (lambda (tstream twindow) (* |fsg| "11-Jul-87 12:17") (let* ((graph (or (and (not (windowprop twindow 'rebuild.graphflg)) (windowprop twindow 'ngroup.graph)) (initial.ngroup.graph twindow))) (region (tspgraphregion graph twindow t)) (graphw (createw region "Number Group Graph" nil t))) (and (ngroupmenu.enabled? twindow) (close.ngroup.graph twindow)) (windowprop graphw 'repaintfn nil) (attachwindow graphw twindow 'top 'justify 'localclose) (showgraph graph graphw (function insert.ngroup) (function change.ngroup)) (windowprop twindow 'rebuild.graphflg nil) (windowprop twindow 'ngroupw graphw) (windowprop twindow 'ngroup.graph graph) (windowprop graphw 'closefn (function ngroup.graph.closefn)) (windowprop graphw 'twindow twindow) (windowprop graphw 'tstream tstream)))) (initial.ngroup.graph (lambda (window) (* |ss:| "27-Jun-87 16:56") (let* ((rootnode (ngroup.make.rootnode)) (nodelst (|for| node |in| (collect.hasharray (tsp.get.ngroup.array window)) |collect| (cadr node)))) (or (find.node 'new.ngroup window) (progn (setq nodelst (cons rootnode nodelst)) (add.ngroup.to.dbase 'new.ngroup nil nil nil rootnode window))) (layoutgraph nodelst '(new.ngroup))))) (ngroup.make.rootnode (lambda nil (* |ss:| "27-Jun-87 16:14") (nodecreate 'new.ngroup '|NGroups| nil nil nil (fontcreate 'helvetica 10 'brr) 1))) (tspgraphregion (lambda (graph main.window titleflg border) (* |ss:| " 2-Apr-86 16:28") (let ((r (graphregion graph)) (main.r (windowregion main.window))) (|replace| (region width) |of| r |with| (widthifwindow (|fetch| (region width) |of| r))) (|replace| (region height) |of| r |with| (heightifwindow (|fetch| (region height) |of| r) titleflg border)) r))) (close.ngroup.graph (lambda (twindow) (* |fsg| "11-Jul-87 12:51") (* * |Program| |invoked| |close| |of| |the| |NGroup| |menu| |graph| |window.|  program.close |is| |used| |to| |distinguish| |between| |our| |closing| |the|  |window| |and| |the| |user| |buttoning| |the| |Window| |Menu| close |command.|) (let ((graph.window (windowprop twindow 'ngroupw))) (windowprop graph.window 'program.close t) (freeattachedwindow graph.window) (closew graph.window)))) (ngroup.graph.closefn (lambda (graph.window) (* \; "Edited 29-Sep-87 15:04 by fsg") (* * |Clean| |up| \a |few| |things| |when| |user| close\s |the| |NGroup| |menu|  |graph| |window.|) (or (windowprop graph.window 'program.close) (let ((twindow (windowprop graph.window 'twindow))) (fm.changestate (fm.getitem 'ngroup.menu nil (windowprop twindow 'imageobj.menuw)) nil (windowprop twindow 'imageobj.menuw)) (freeattachedwindow graph.window))))) (add.ngroup.to.mother.node (lambda (id motherid w) (* |ss:| " 3-Apr-86 17:50") (let* ((mother.node (find.node motherid w)) (tonodes (|fetch| (graphnode tonodes) |of| mother.node))) (or (member id tonodes) (|replace| (graphnode tonodes) |of| mother.node |with| (cons id tonodes)))))) (add.node.to.graph (lambda (node graph window) (* |ss:| "27-Jun-87 15:57") (let* ((parent.node (find.node (car (|fetch| (graphnode fromnodes) |of| node)) window)) (tonodes (|fetch| (graphnode tonodes) |of| node))) (or (member (|fetch| (graphnode nodeid) |of| node) tonodes) (progn (|replace| (graphnode tonodes) |of| parent.node |with| (cons (|fetch| (graphnode nodeid) |of| node) (|fetch| (graphnode tonodes) |of| parent.node))) (|replace| (graph graphnodes) |of| graph |with| (cons node (|fetch| (graph graphnodes) |of| graph))))) (layoutgraph (|fetch| (graph graphnodes) |of| graph) '(new.ngroup))))) (collect.hasharray (lambda (harray) (* |ss:| "27-Jun-87 16:03") (let ((result nil)) (maphash harray (function (lambda (val ky) (setq result (cons val result))))) result))) (create.ngroup.node (lambda (id mother userdata w) (* |fsg| "22-Jun-87 13:27") (let* ((ngroup.harray (tsp.get.ngroup.array w)) (node (gethash id ngroup.harray))) (or node (let ((new.node (selectq id (new.ngroup (ngroup.make.rootnode)) (nodecreate id id nil nil (list mother))))) (puthash id (list userdata new.node) (list ngroup.harray)) new.node)) (or (and node (car node)) (and userdata node (rplaca node userdata)))))) (get.fromnodes (lambda (ngid window) (* |ss:| " 3-Apr-86 16:00") (car (|fetch| (graphnode fromnodes) |of| (find.node ngid window))))) (get.tonodes (lambda (ngid window) (* |fsg| "28-Jul-87 10:54") (* * i\f ngid |has| |only| |one| |child| |then| |return| |that| |child's|  |name| |as| |an| |atom.| |Else| |return| |the| |list| |of| |NGID's| |children.|) (* * a\s |of| |the| |date| |above,| |this| |function| |is| not |called.|) (let ((tonodes (|fetch| (graphnode tonodes) |of| (find.node ngid window)))) (cond ((cdr tonodes) (reverse tonodes)) (t (car tonodes)))))) (find.node (lambda (ngid window) (* |fsg| " 4-Mar-87 10:22") (cadr (gethash ngid (tsp.get.ngroup.array window))))) (tsp.get.ngroup.array (lambda (window) (* |ss:| "27-Jun-87 16:21") (windowprop window 'tsp.ngroup.array))) (tsp.legalid (lambda (prev.ngroups stream) (* |fsg| " 3-Aug-87 17:04") (* * |Get| \a |new| |NGroup| id |and| |make| |sure| |it's| |not| |already|  |defined.|) (let ((ngroup.id (mkatom (tedit.getinput stream "Group name:")))) (|while| (member ngroup.id prev.ngroups) |do| (setq ngroup.id (mkatom (tedit.getinput stream (concat ngroup.id (cond ((eq ngroup.id 'new.ngroup) " is a reserved name...Group name:" ) (t " already exists...Group name:" ))))))) ngroup.id))) (list.ancestors (lambda (nid ancestors window) (* |ss:| "27-Jun-87 16:09") (* * |Return| \a |list| |of| |the| |parents| |of| |the| |given| |node.|) (let ((mother (get.fromnodes nid window))) (cond ((and mother (neq mother 'new.ngroup)) (list.ancestors mother (cons mother ancestors) window)) (t ancestors))))) (toplevel.sisters (lambda (window) (* |ss:| "27-Jun-87 16:21") (* * |Returns| \a |list| |of| |the| |top| |level| |NGroup| |nodes.|  a |top| |level| |node| |is| \a |node| |whose| |mother| |is| new.ngroup.) (reverse (|fetch| (graphnode tonodes) |of| (find.node 'new.ngroup window))))) (get.ngroup.mother (lambda (ngid window) (* |fsg| " 4-Mar-87 11:24") (* * |Return| |the| |top| |level| |mother| |of| \a |branch| |of| |the| |Ngroup|  |tree.|) (let ((ancestors (list.ancestors ngid nil window))) (cond (ancestors (car ancestors)) (t (cond ((find.node ngid window) ngid) (t nil))))))) ) (* * |Number| |counting| |functions|) (defineq (downdate.numberobjs (lambda (window stream objselectfn) (* |fsg| "25-Sep-87 09:45") (* * |Undoes| |what| update.numberobjs |does.|) (let ((nbrobj.list (tsp.list.of.objects (textobj window) objselectfn))) (and nbrobj.list (progn (tedit.promptprint stream (concat "Undoing Update of " (selectq objselectfn (ngroupp "Number Groups") (endnotep "Endnotes") "Number Groups and Endnotes" ) "...") t) (|for| nbrobj |in| nbrobj.list |do| (let ((datum (|fetch| objectdatum |of| (car nbrobj)))) (|with| numberobj datum (setq page.number nil) (and updated.obj (progn (setq updated.obj nil) (|replace| (ngtemplate ng.currentval) |of| template |with| nil) (setq numstring (selectq use (ngroup (concat "[" ref.type "]")) (note "Note#") nil)) (tedit.object.changed stream (car nbrobj))))))) (tedit.promptprint stream "done")))))) (update.numberobjs (lambda (window stream objselectfn) (* |fsg| "25-Sep-87 09:34") (* * |Convert| |the| |NGroup| |and| |Endnote| |markers| |to| |their|  |corresponding| |numeric| |values.|) (let ((nbrobj.list (tsp.list.of.objects (textobj window) objselectfn))) (and nbrobj.list (progn (tedit.promptprint stream (concat "Updating " (selectq objselectfn (ngroupp "Number Groups") (endnotep "Endnotes") "Number Groups and Endnotes" ) "...") t) (|for| nbrobj |in| nbrobj.list |do| (let ((datum (|fetch| objectdatum |of| (car nbrobj))) new.count) (|with| numberobj datum (reset.dependent.classes window use ref.type) (setq new.count (get.ncounter window use ref.type ngroup.mother template datum)) (and (neq new.count numstring) (progn (setq numstring new.count) (setq updated.obj t) (tedit.object.changed stream (car nbrobj)))))) |finally| (remove.all.counters window)) (tedit.promptprint stream "done")))))) (reset.dependent.classes (lambda (window use ref.type) (* |fsg| "12-Dec-86 10:50") (|for| dependent |in| (|fetch| (graphnode tonodes) |of| (find.node ref.type window)) |do| (progn (reset.ncounter window use dependent) (reset.dependent.classes window use dependent))))) (reset.ncounter (lambda (window use ref.type) (* |fsg| "12-Dec-86 11:07") (let* ((template (selectq use (ngroup (|fetch| (numberobj template) |of| (car (gethash ref.type (tsp.get.ngroup.array window))))) nil)) (counter (ncounter? window use ref.type template))) (|replace| ncount |of| counter |with| (cond (template (sub1 (|fetch| ng.start |of| template))) (t 0)))))) (get.ncounter (lambda (window use ref.type mother.class template nbr.datum) (* |fsg| "11-Aug-87 15:26") (let ((counter (ncounter? window use ref.type template))) (and counter (progn (|with| ngcounter counter (|add| ncount 1) (and (eq use 'ngroup) template (|replace| (ngtemplate ng.currentval) |of| template |with| ncount))) (cond (mother.class (flatten.tree.to.string window use ref.type nbr.datum)) (t (mkstring (|fetch| ncount |of| counter))))))))) (ncounter? (lambda (window use ref.type template) (* |fsg| "14-Jul-87 14:10") (* * |Return| |the| |record| |for| |this| |number| |counter.|  i\f |the| |record| |doesn't| |exist,| |we| |create| |one| |based| |on| |the|  use |value.|) (let ((counter.id (mkatom (concat (selectq use (ngroup (concat "NGROUP." ref.type ".")) (note "ENDNOTE.") (error "Unknown NUMBER type" use)) "COUNTER")))) (or (windowprop window counter.id) (progn (windowprop window counter.id (|create| ngcounter ncount _ (cond ((and (eq use 'ngroup) template) (sub1 (|fetch| ng.start |of| template))) (t 0)) ancestry _ (selectq use (ngroup (list.ancestors ref.type nil window)) nil))) (windowaddprop window 'counters counter.id) (windowprop window counter.id)))))) (flatten.tree.to.string (lambda (window use ref.type nbr.datum) (* |fsg| " 5-Aug-87 14:12") (let* ((ngroup.counter (ncounter? window use ref.type)) (ngroup.list (append (|fetch| (ngcounter ancestry) |of| ngroup.counter))) (abbrevval (|with| numberobj nbr.datum (and abbrev-val (list.ancestors abbrev-val nil window)))) (flat.tree "") ancestor) (and ngroup.list (|while| (setq ancestor (|pop| ngroup.list)) |do| (or (and abbrevval (memb ancestor abbrevval)) (setq flat.tree (concat flat.tree (ngroup.chartype window ancestor (|fetch| (ngcounter ncount) |of| (ncounter? window use ancestor)) (or (car ngroup.list) ref.type))))))) (setq flat.tree (concat flat.tree (ngroup.chartype window ref.type (|fetch| (ngcounter ncount) |of| ngroup.counter) nil)))))) (ngroup.chartype (lambda (window ref.type ncount next.ngroup) (* |fsg| "11-Aug-87 15:23") (* * |Convert| |the| |number| ncount |to| |the| |format| |specified| |in|  template. delimitflg |is| |the| |next| |NGroup's| |preceding| |delimiter| |or|  nil |if| |either| |the| |next| |NGroup| |has| |no| |preceding| |delimiter| |or|  |there| |is| |no| |next| |NGroup.|) (let ((delimitflg (and next.ngroup (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash next.ngroup (tsp.get.ngroup.array window)))) ng.text-before)))) (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash ref.type (  tsp.get.ngroup.array window)))) (concat (or ng.text-before "") (ngroup.chartype.convert ng.chartype ncount) (cond (delimitflg "") (t (or ng.text-after "")))))))) (ngroup.chartype.convert (lambda (chartype ncount) (* |fsg| "28-Jul-87 11:12") (* * |Convert| |the| |value| ncount |to| |the| |type| |specified| |by|  chartype. i\f ncount < 1 |and| chartype |is| |Letter/Roman| |then| |we|  |return| nil. |This| |anomaly| |is| |usually| |caused| |by| |out-of-order|  |NGroups.|) (cond ((fixp ncount) (cond ((or (igreaterp ncount 0) (eq chartype '|Number|) (eq chartype '|Null String|)) (selectq chartype (uppercase\ letter (number.to.letter ncount t)) (|lowercase letter| (number.to.letter ncount)) (uppercase\ roman (romannumerals ncount t)) (|lowercase roman| (romannumerals ncount)) (|Null String| "") (|Number| (mkstring ncount)) (error "Unknown display type" chartype))) (t (mkstring nil)))) (t (error "Invalid integer" ncount))))) (number.to.letter (lambda (number ucflg) (* |fsg| " 5-Dec-86 10:18") (* * |Convert| number |to| |equivalent| |letter| |code.|) (let ((ltrlst (mkstring (character (iplus (charcode a) (iremainder (sub1 number) 26))))) (ltrnbr (iquotient (sub1 number) 26))) (|until| (zerop ltrnbr) |do| (setq ltrlst (concat (character (sub1 (iplus (charcode a) (iremainder ltrnbr 26)))) ltrlst)) (setq ltrnbr (iquotient ltrnbr 26))) (cond (ucflg (u-case ltrlst)) (t (l-case ltrlst)))))) (remove.all.counters (lambda (window) (* |ss:| "30-Sep-85 09:38") (|for| counter |in| (windowprop window 'counters) |do| (windowprop window counter nil) |finally| (windowprop window 'counters nil)))) ) (putprops tmax-ngraph copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1425 11144 (graphmenu 1435 . 2488) (initial.ngroup.graph 2490 . 3059) ( ngroup.make.rootnode 3061 . 3282) (tspgraphregion 3284 . 3876) (close.ngroup.graph 3878 . 4462) ( ngroup.graph.closefn 4464 . 5065) (add.ngroup.to.mother.node 5067 . 5461) (add.node.to.graph 5463 . 6568) (collect.hasharray 6570 . 6856) (create.ngroup.node 6858 . 7535) (get.fromnodes 7537 . 7737) ( get.tonodes 7739 . 8326) (find.node 8328 . 8501) (tsp.get.ngroup.array 8503 . 8669) (tsp.legalid 8671 . 9832) (list.ancestors 9834 . 10278) (toplevel.sisters 10280 . 10662) (get.ngroup.mother 10664 . 11142)) (11189 25278 (downdate.numberobjs 11199 . 13348) (update.numberobjs 13350 . 15883) ( reset.dependent.classes 15885 . 16258) (reset.ncounter 16260 . 17044) (get.ncounter 17046 . 17876) ( ncounter? 17878 . 19663) (flatten.tree.to.string 19665 . 21370) (ngroup.chartype 21372 . 22825) ( ngroup.chartype.convert 22827 . 24000) (number.to.letter 24002 . 24992) (remove.all.counters 24994 . 25276))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-NGROUP.LCOM.~2~ b/lispusers/TMAX-NGROUP.LCOM.~2~ deleted file mode 100644 index e11ee495abc3eeb8f166ad159b2c01c9afa5083e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 17978 zcmc&+Yiwi3b>@}U-o%bl$-7N9n>d*;FUhDFT~hDVHZRG`<>lKXRnQ}kbfD(H{?biZ@X z%;n`nj@_iF5=-~a%$+-T=A7?*=ggU%Pq}HY=q{$cyu0WX(A z_p0Tv`f$Z{QZ*-$NAZMDC_VP>8lO`^W$rc_vMEEei_7o$t|y0X_cV=J4s z9ai(<>)qRTTJ2^-bvtM@)BmMZHTTOuzqQ-!?LKj8bUi%!wb7Nu zY`wF%v8HT$b9rNPWeq*Zr`_pwpKD&<)87+~ES>%tYI$vA$yWXAJN3@Z=5C*c-`(u1 z`E;?WlBMF)ZlxB%?bskP^c{7UP zn5ll-m^mY>=jd`%gR%>x>Rw>8M<6j#Zt;$P@x~34TYxS_ou)3a_H}!n<4x> zM8D?dtf9NK%F13{QkPt_jFFmqg;vBXUQ+goJ)z%aTlwQq zb~MHhrz@obtr7-iFOxJTotj!(p}LGy&8Ri3ZM7T;yvM0joNa}7Yehv>x>T&G;N_h@(7+ zE`eJcD*V|n{>D`J8L0K7<?+?ibCD^mU78yS|JlY5Wm4_#@*1$maH?dhZU?;I{l zIm>U0%V(|EGFeN%!8-YJ_TIm?4u0rO9eh8~)QmvHKf{mDU}&L`bRtcqlYD#1h^@VD zt8^Y~tS8)FUGrzwUNr)Qr7M(cWr!6daAn0vh#g(##(Mg(SR%*4=ICF`B%#DA)(wIL zdsB;)(h(8rs#+PmG`gZYf$U%{pg)13Q&sCBN0nO#2}J@&6$uD(gJn= z0jK;UU=2QkTb37Qie7$ZeqqK*r8K-mxMm2>Bc$38=M|N5%Wg5{76CO_bHVkRTPWuN zPb~eUV%&k3V)>_mM?5s40oqD0G|9hFG-b`6C0u7=zZYe3-ih-cmNAy#)@Z@86X)7v zc@8SWPh>7STr8SnKbT`{@y*Qr?B^lKp^r3Jtj|AkEPBLkUu}5j&m1@S`SZ$LeCYVO zM(0=GZ0uab&ufkB`G=0VQ~q^ymRo;2fA1n+aId#oJB>zzn&ant^N z$`jQ2y0Nk>Mw@$BURCKr1kzc&az?DN4Lj36GfmBF+hzA-eYHB&B@n@2NQ4?)hNT`W zF*b=?5LiS3H-rHjfCz$$r8N~U*L%&*o?`fT5-`B4KC+V9_!!d{5u@rsQH}lcK)m!M zu@ZZ*P;6&CP_I#KCJptqnTgjxn*kzW(g)v`iyp;SjvmsLO;2}pgyfgU9BpJ)RA zPC<<_I~TB7vY zL~4`_fK6!SOekapl+T*8r!&(>XS`XfVeyxo{2BP;(M)dV;??cr%+!^Gf6IOH>cM}9 z=IseeMuS-o%G9t-@~GHY(WC>$OXaFSD@`wzfiq!hKMioQ1j_DzDlodqmxM_`h-K-4 zXN~j-y~zx&53b?JP%*{r=>-)NnD zD>i%dFxSU1FElmgKSuY1jfMpeA!F#ztI4l2jZYptDlc&|Q`RkJ?#DjAcP^Zpnm+p5 zz@WJ=%(=Z`xHhJGKxvqPGjS%8Vy_a3B|@&b_==EPpJfUg9wRXWVgmFW$9}B0X4XV; z%-gVhc5KyW|&=JQK zOw5O1u42>|PK3e!!Wm*`jl*Xchy;M(jxt;LhZbmYe{me(6O z!&o4-Al77z6vWDX+5sotfK`Vy!pp-qK}5!_;L3Wy2u7nLMi1aIu%qMCA|RmW1`B6k z0qAa)jof{o4Wc)(Y_hgd2CYcigF$9o2~4R$mG1z@&jkGbz~x+cI_@Od)?^aG>rTFU z%oua<@sa!UGUGu=VtGj(RpMSid|vl*z62$>Yp%R1ev%l!L5u9k&dL2*|2}&m`3G5F z?*1a4^^763*Rc|#&})M!jcdORO(NYftWA5~B()5=_EJEYCrh)!+r~SNMO8IZGM=$? z2KqNn#7?n)Hh{)(9<>H=hZYR6oUl@~9FK=7fP))a0^Gn032#yr&HLj(@*%9mmCaqnh;1m&|b+3RuQpAg#JJXw9o?0mhp9#ieQY9Qg z_>_3z#99$wg+SfJ>e`i>lg3_yg7!~rkisTJ9zjKbz{GlVkZ>_f+L0KCH((L@U-b2G z3kM%c@g({t%%2{l(|n$+HeGimZ#cN=T7yp0NI$m7B5-e^$2{tLBzmnKkl`cO0GNBGa)v zMK831)?3DQ_&ynlt`g0Ych9i?`KTJD@b7q-1tAiRt2S^K^NSb&OTHh0K#XM7Zv&@Q zH-{b5R|o|d{1b;3WK8U<}SE4 z3`UqLZA9n8Qbg92WE==ivDvVy?$vvHdAR^Cyv7-PBk;0x`yMC&Lhzz9PH_>DuQf}TWAWl^IiOlqE$ac_7 z56gDq$Qu%Gl0TAeBiIbj47yhvhmV?47Aa7^_vnJ`g@K!K49ksO0q~utAVUf>5rE*q zC&e}f(t@D)1YhKxNelKYd{Ty3odLedLNwV@M-281uYyL|pMWY^=i!5$wg!m@5@ZfT zFHKqpR(_#PIRSuR)IgjjKgP=*lfL^g?$R5Lym6PV9z7l;_1VT@IA;-`|6mTw`q{?e zxuKu~V!Rg(wSW1|XM_TLQ?~d{UTl2{5@9{}qkAt&pL8d{#=nDuKYsbm1nfBNl#Rm? znLOE4vk^NRZ(xIZv4_XIB@}rGh9{uv`f2Pz_?UDGA9yF26oqj_aFuq-_j>T&`;gJK zLAW)FIHoUzHuk?IFk$1Vafg!vt%I;D0xH8{*3;aFC>&KlOGMRrcUApnz12ZbBf0`4 zT2Qz5clXq_rg{RtrXPZ!Z5RePiZ(o7Z|^tNJYyZ83b=+L&-?M>;cwe2m)%Md84b^> zyjvq2>bJWuG<(CInW3JBBvN^)9c=@cd&7;D9)>Gzs5p9GXlv2-$i>s z6c@&xQ9}R|yG8X~pfH>(Leo>U)@KUCYWq_G&(HlB@Z6lFv;a?Q2sh86z(D5N+*A-P z|1LBSN;N=BHjsv5{-2>G_6U4Ar41IQnWspcY{+T9YA_<6Y>KW6(tcX{kSMz`TNE8K zaUv7_KnUnhC_pNpmK6L55*mk*B5`<5{_=03QruQ>gkxI5Y5w;hI5%Zw5Ndkp_!0Ix zWJJ;_ZAjU?$vTQHHg;hcd3alOv=-LRAP-1CBN*{)Ozi{!fa(nZ06~Re001-TZ*_L> zG_SWnl#zU68>=R?8q5OBV_nV9_sh**t4rxQ5rDvaKiO?}DZ6Kr?^5;M9o#JP%@B4$ zqtLpvw?le7FCYuF^orP^V39;vjvO551h1z5l0%Wnf<0-mq-> zN{~~9Z*<#04}B+6K_kS^3$oCXO;gIPzM2 z$77M7v(A>@`;C`F-^;{Alv;i^n?`j%S4v$N>2JWL)IV z``J4|J01lzYWa&o`dRHLedpO{;lN{GJ_^@$Kop{r;zh*Ubr;yl&{s%R;JpZ^h@`Pv zsZv!xZ8i#XK0)E3;{%1a5r-VscpLtN56h>ZF}6;%;PW18vfk++xuVW)N()JPi2mJy zZGOJlHqJIFi;eFKt2`BxPlUe15mjxrk&35w$@w9*EzoC-qb?M zB0svT;L4w-OX9L?RYFP-yc#K@aJY_ojqD*9pFEH7V$dg_LzYl5myJD@*WwgIoC+qy zv9q$>_+u(2X?zzhJoqQb0^yxjV_an%lM@LBTe6f*Gs!nOC87f3U~;R1QIH`U`j&Gd z;*Uw%qr`=Xjp=00(*f;(K}Xg{>A2QyK(5n z)Jq;e!Nsra94w1>cyjMCbMa9RZ2m*sNSca$7AF77&abr&zu}RwMDCc@t`+|ZaebXk zf!M%^eSv$e+d~@V3U&<<@L>)Ll4#f|n>|WRBZ&sNhV`06cxkVX`7YC3KwGx${W`QQgw7$=2cFdW0b%TC?^vsaG(N2Fr zcF32z~rC>LRb(+!siu`zHQ{5*1+G2B?V!EeA!5r4tpI6 zY&{9EhJLg<*W3G)a@Xo8kUXl1s8md3We;s3e~Jp$jWSgI)~0EMsMc7ZNQ z0$*53cHe1IZ{o2(spy-2hUGsHjeKV+@a9{pfJ9C?VeX&bhC2NJD#W@dgjR{iTBH-A z71q~1R&vRzJDwfB1GPd7QY@>B6H%)4ZB!fw632hA{Oub)kD-Kmd)5t{mnrE~#*yb(N6wVTq6MBj*WSA*9 zNzinor3ieIbzGP+3G|X>V7|<#6)m>putus|38KQ#s~Als(&43o+?}XU3*;TAt1dOs z-h4z)KXEvEM&A-c2~fI$<8S(e4ZH@8oR&1B`_;t2IMJB~$*pQQ9@Fs%Fi2x%;w$VB~(K( z^c9j13T`1mF68(FMhu5HNWf1hdz9tTd@?e%P2)ikb}6NmOdOu`bAZy`6&&KJxJhJR z>clxdCt^~LiTfo>KDeGSKJ;O@5Q#E*(%C zxeZ(lih_l>Hl0vMSVG^k!~6ikAo0lMGl?_A1;I11S+m#t7=i(~{4D;!g3-AJte9c> zI&X}QcW6!p{s21|AlSal62a!9IW)@y@h$SUJtp_}kPmt$$>jMkli=wRGRzYx$yeHK z4`mKN5!c>0O&R})T=R3x$Sxe8liuz>G1eP5n6pBe`{Ch!`0;=r#GVc1+8Z{Fzz8lU zoQ~pH?+6Pgms39omPC`qal8ROgL3G43CU0D7ikwG-4fdCd@Bmd=pLw<*(CPgfR(fZ zDZ@DR<@><2$mAu5@jv4Gn}VFR<`>}c-jEO!1(EST^gz|ntT0z!Ya;&LWVdwkTxen7 zt#>-E!r@6u4^yEmV!kFfH8HoOGxZM^kyi=qY0sSed9MBLlRwQh+7F%l?r~eOKs+*% z;P4Mw2`WO6ks>4$z(7m32uB#4B*oLo^~s45*Z*kVCWB6ORpRu zLk1-p&?&eY3_BsT{{Z6#D*3G>(Y~AqLa~3z8{hl|127JF3WFN1-eKwEU;i|yq6Ad= z|J=Fh%;8n<@DiO2$cnr0jCiBsJO-jZxs1biQqA(7^Z1V-zc-uty3|ROXlHi#4!*#| zpwTHCMj)`se5vZDaejH8$}4;T zVw8^L-hxn>7?MfI_tWJ`HZZ=5ha7CuEri#?HAH`#3c2?P_~?+)?ie?z)vvXii=`Wj zNt`i2mi{hDzM4Tv9Z=U35;k@*5|feJXin|?Se-D@@r&Cb5J*Sw9{ z8^IwhdGZc^w}E>9@Z}H@r=e&g;By~X56tyGWpMITu}a7ZGrk`>Y$kmD;1gs3L!YPR z7^*&Y=H{ln>7$3v(IJ9=*_pMjn!^WHg4ZB(^0jPSazSzCVEf=7C0;oAE&`=(+RO?t zH~lf79k7%*Nl7XFscKmgJ&~$eD(Bs&-F&19_r;|UK7l$n1iI46OPh|?m?z}8h{!i4 z9&sY0+Y01z^b{2>4I;l`Mj?fOpTRu@LexCYO+AfmvZMn`q7sz~cCbc2#a|;@ADkh> zKw+JilpHM>@swzReC8=jM2}&CzDo-fH?zsdI(CM0YI!*%t26uD$+xnN2c{2yg;(?N zd10hD(xZPYY3JYjDQ3d*sg+4OWAu^cfj6|@%{>oyqkEN?&1Scs`_bX=unbAFWAD}v z5B`G!cR2VYs{%r#SBh-4S*j&-MZ|x=kbo&>4JiRlw;rUcfdiO&Bo7!-S;ihw`YO(j z!>=7QfWa{C9m3{xq}Ja7!itko8WjYRs>-fXSCz`*($d=cN(2!>Jbt;?LUsoBfM@#G?&5(oTHV6mORe_p{a&w5 zW%UkqUPbOQ{n@Fvx)J=-5qKKU>pfw-dKYixQQX+?T;Ic{&n`8he}ZA;pF@~*R-CkX z>?ALr>*Is{5;&N6WOM9f8?P4Uty93N3I}@R{8mvy9e5=p#8Aj}EC7q;7*CHMdc-7e z4=2%cdg-KgffT;Uo62Ux=Cp?;eIfvVgG`Ib9qL``iT%kwQJ^y^nAjHJqb9!rF$&3j zJ|&o>XM8ARVFXC%TX#ShNfgIKC@{i+pAL#L$;%w!CMMILz*BQtHA2y-d#YxeJV5A? zTedxvg)k4^B*GO?RS>4~cE!7tso|e%xzg-)zW`g%gC64aR<{G4-=Ke2WMg9u9nhxE F{{Y@||5E?} diff --git a/lispusers/TMAX-NGROUP.~1~ b/lispusers/TMAX-NGROUP.~1~ deleted file mode 100644 index 09d23c4d..00000000 --- a/lispusers/TMAX-NGROUP.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:34:27" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NGROUP.;2| 47949 |previous| |date:| "11-Nov-87 11:57:39" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NGROUP.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-ngroupcoms) (rpaqq tmax-ngroupcoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Other| |unsorted| |functions|) (fns insert.ngroup verify.ngroup.order get.previous.ngroups add.number.group add.ngroup.to.dbase collect.ngroups list.font.props map.ngroup.looks ngroup.getfont change.ngroup change.ngroup.font show.ngroup.font change.ngroup.format show.ngroup.format change.ngroup.format.txtbefore change.ngroup.format.display change.ngroup.format.txtafter get.ngroup.delimiter change.ngroup.format.abbrev change.ngroup.format.start get.ngroup.start change.ngroup.format.toc change.ngroup.format.manindex update.ngroup.manindex ngroup.fixup.records) (* * |Table-of-Contents| |functions|) (fns get.ngroup.textstring convert.tabs.to.spaces create.toc.file ngroup.toc.entries view.toc.file get.toc.file write.toc.file write.toc.entry))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Other| |unsorted| |functions|) (defineq (insert.ngroup (lambda (node graphw) (* |fsg| "26-Aug-87 14:37") (* * |Insert| \a |NGroup| |build| |from| |the| |prototype| |definition.|) (and node (let* ((twindow (windowprop graphw 'twindow)) (tstream (windowprop graphw 'tstream)) (label (|fetch| (graphnode nodeid) |of| node)) (oldlooks (|fetch| caretlooks |of| (textobj tstream))) (newlooks (ngroup.getfont label twindow))) (|with| numberobj (car (gethash label (tsp.get.ngroup.array twindow))) (selectq label (new.ngroup nil) (let ((newobj (numberobj 'ngroup template (concat "[" label "]") label newlooks (get.fromnodes label twindow) abbrev-val))) (tedit.caretlooks tstream newlooks) (get.ngroup.textstring newobj label tstream twindow) (imageobjprop newobj 'twindow twindow) (tedit.insert.object newobj tstream) (tedit.caretlooks tstream oldlooks) (and (update? twindow) (update.numberobjs twindow tstream 'ngroupp)) (verify.ngroup.order twindow newobj)))))))) (verify.ngroup.order (lambda (window ngroup.obj) (* |fsg| "28-Jul-87 15:59") (* * |Verify| |the| |NGroup| |order| |before| |inserting| \a |new| |NGroup.|  |The| |order| |is| |valid| |if| |the| |new| |NGroup| |is| \a |top| |level|  |node| |or| |its| |parent| |Ngroup| |has| |already| |been| |inserted.|) (let* ((mother (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) ngroup.mother)) (selection (tedit.getsel (textstream window))) (ch# (and selection (|fetch| ch# |of| selection)))) (cond ((or (eq mother 'new.ngroup) (and ch# (|for| prev.ngroup |in| (tsp.list.of.objects (textobj window) (function get.previous.ngroups) ch#) |thereis| (eq mother (|with| numberobj (|fetch| objectdatum |of| (car prev.ngroup)) ref.type))))) (tedit.promptprint (textstream window) "" t)) (t (tedit.promptprint (textstream window) (concat "Warning...\"" (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) ref.type) "\" is not preceded by \"" mother "\" NGroup.") t) (flashwindow (|with| textobj (textobj window) promptwindow) 2)))))) (get.previous.ngroups (lambda (ngroup.obj char.pos) (* |fsg| "28-Jul-87 14:01") (* * |Called| |from| tsp.list.of.objects |to| |collect| |all| |the| |NGroup|  |ImageObjs| |that| |exist| |before| |the| |character| |position| char.pos.) (and (ngroupp ngroup.obj) (ilessp ch# char.pos)))) (add.number.group (lambda (twindow stream) (* \; "Edited 30-Sep-87 14:34 by fsg") (or (ngroupmenu.enabled? twindow) (progn (fm.changestate (fm.getitem 'ngroup.menu nil (windowprop twindow 'imageobj.menuw)) t (windowprop twindow 'imageobj.menuw)) (graphmenu stream twindow))) (let* ((prev.items (collect.ngroups twindow)) (new.groupid (mkatom (tsp.legalid (cons 'new.ngroup prev.items) stream))) template dependent.class new.node) (prog1 (cond (new.groupid (setq dependent.class (or (mkatom (and prev.items (menu (|create| menu title _ "Parent Group?" items _ (sort prev.items 'ualphorder) )))) 'new.ngroup)) (or template (setq template (|create| ngtemplate ng.chartype _ '|Number| ng.text-before _ nil ng.text-after _ "." ng.start _ 1 ng.addtotoc _ t ng.currentval _ nil ng.manualindex _ nil))) (setq new.node (nodecreate new.groupid new.groupid nil nil (list dependent.class ))) (add.ngroup.to.dbase new.groupid template dependent.class |GP.DefaultFont| new.node twindow) (add.node.to.graph new.node (windowprop twindow 'ngroup.graph) twindow)) (t nil)) (tedit.promptprint stream "" t))))) (add.ngroup.to.dbase (lambda (new.groupid template dependent.class font ngroup.node twindow) (* |fsg| " 3-Aug-87 16:43") (let ((ngroup.array (tsp.get.ngroup.array twindow))) (or (gethash new.groupid ngroup.array) (progn (windowprop twindow 'rebuild.graphflg t) (puthash new.groupid (list (|create| numberobj ngroup.mother _ dependent.class font _ font ref.type _ new.groupid template _ template) ngroup.node) (list ngroup.array))))))) (collect.ngroups (lambda (twindow) (* |ss:| "31-Mar-86 13:53") (let ((graph (windowprop twindow 'ngroup.graph))) (|for| node |in| (|fetch| (graph graphnodes) |of| graph) |collect| (|fetch| (graphnode nodeid) |of| node) |unless| (eq (|fetch| (graphnode nodeid) |of| node) 'new.ngroup))))) (list.font.props (lambda (fontdes) (* |fsg| " 3-Aug-87 10:03") (and (fontp fontdes) (list (fontprop fontdes 'family) (fontprop fontdes 'size) (fontprop fontdes 'face))))) (map.ngroup.looks (lambda (label new.font twindow new.template) (* |fsg| " 5-Aug-87 13:40") (* * |Here| |to| |change| |the| |font| |or| |format| |of| |an| |NGroup.|  i\f new.template |is| |non-NIL| |then| |we| |are| |changing| |the| |format,|  |else| |we| |are| |changing| |the| |font.|) (tedit.promptprint (textstream twindow) (concat "Updating " (cond (new.template "FORMAT") (t "FONT")) " for \"" label "\" Ngroups...") t) (|for| ngroup.obj |in| (tsp.list.of.objects (textobj twindow) `(lambda (obj) (and (ngroupp obj) (eq (fetch ref.type of (fetch objectdatum of obj)) \, (kwote label))))) |do| (|with| numberobj (|fetch| objectdatum |of| (car ngroup.obj)) (cond (new.template (setq template new.template)) (t (tedit.looks (textstream twindow) new.font (cadr ngroup.obj) 1) (setq font new.font))))) (tedit.promptprint (textstream twindow) "Done."))) (ngroup.getfont (lambda (ngroup.name window ngroup.obj) (* |fsg| " 4-Aug-87 15:00") (* * |Get| |an| |NGroup's| |font.| i\f ngroup.obj |is| |non-NIL| |then| |we|  |get| |the| |font| |from| |this| |ImageObj's| objectdatum.  |Else| |we| |get| |the| |font| |from| |the| |NGroup| |graph| |prototype|  |NGroup.|) (|fetch| (numberobj font) |of| (cond (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) (t (car (gethash ngroup.name (tsp.get.ngroup.array window)))))) )) (change.ngroup (lambda (node graphw) (* |fsg| "30-Jul-87 13:52") (* * |Here| |when| |number| |group| |node| |is| |middle| |buttoned.|  |Allow| |user| |to| |change| |the| |font| |and/or| |format| |of| |the|  |ngroup.|) (and node (let ((label (|fetch| (graphnode nodeid) |of| node))) (selectq label (new.ngroup nil) (menu (|create| menu title _ (mkstring label) centerflg _ t items _ (eval ngroup.graph.menu.items)))))))) (change.ngroup.font (lambda (label graphw font.field ngroup.obj) (* |fsg| " 4-Aug-87 15:09") (* * |Change| \a |NGroup| |font.| i\f |NGROUP.OBJis| |non-NIL| |then| |we|  |are| |working| |on| |an| |inserted| |NGroup.|  |Else| |we| |are| |working| |on| |the| |graph| |prototype| |NGroups.|) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) new.font) (show.ngroup.font label graphw ngroup.obj) (tedit.promptprint stream (selectq font.field (family ", change Family to...") (size ", change Size to...") (face ", change Face to...") ", change to...")) (|with| numberobj (cond (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) (t (car (gethash label (tsp.get.ngroup.array window))))) (setq new.font (fontcreate (get.tsp.font window font font.field))) (tedit.promptprint stream "" t) (and (neq font new.font) (progn (setq font new.font) (cond (ngroup.obj new.font) (t (map.ngroup.looks label new.font window))))))))) (show.ngroup.font (lambda (label graphw ngroup.obj) (* |fsg| " 4-Aug-87 14:57") (* * |Show| |this| |NGroup's| |font| |specification.|) (let* ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) (font.list (abbreviate.font (ngroup.getfont label window ngroup.obj)))) (tedit.promptprint stream (concat label ": Family=" (|pop| font.list) " Size=" (|pop| font.list) " Face=" (|pop| font.list)) t)))) (change.ngroup.format (lambda (label graphw format.field) (* |fsg| " 1-Sep-87 15:39") (* * |Change| |the| |entire| |format| |or| \a |selected| |field| |of| |an|  |NGroup.|) (let ((window (windowprop graphw 'twindow)) (new.format (|for| field |in| (cond (format.field (list format.field)) (t '(txtbefore display txtafter abbrevval start toc manindex))) |collect| (selectq field (txtbefore (change.ngroup.format.txtbefore label graphw)) (display (change.ngroup.format.display label graphw)) (txtafter (change.ngroup.format.txtafter label graphw)) (abbrevval (change.ngroup.format.abbrev label graphw)) (start (change.ngroup.format.start label graphw)) (toc (change.ngroup.format.toc label graphw)) (manindex (change.ngroup.format.manindex label graphw)) (error "Unknown NGroup Format field" field))))) (and (apply 'or new.format) (let ((nbrobj (car (gethash label (tsp.get.ngroup.array window))))) (map.ngroup.looks label (|fetch| (numberobj font) |of| nbrobj) window (|fetch| (numberobj template) |of| nbrobj))))))) (show.ngroup.format (lambda (label graphw) (* |fsg| "26-Aug-87 12:02") (* * |Show| |this| |NGroup's| |format| |specification.|) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow))) (|with| numberobj (car (gethash label (tsp.get.ngroup.array window))) (|with| ngtemplate template (tedit.promptprint stream (concat label ": Display=" (concat (cond (ng.text-before (concat "\"" ng.text-before "\"")) (t "\"\"")) ng.chartype (cond (ng.text-after (concat "\"" ng.text-after "\"")) (t "\"\""))) " Abbrev=" (or abbrev-val "None") " Start=" ng.start " TOC=" (cond (ng.addtotoc "Yes") (t "No")) (cond ((manualindex.enabled? window) (cond (ng.manualindex " ManIndex=Yes") (t " ManIndex=No"))) (t ""))) t)))))) (change.ngroup.format.txtbefore (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:11") (* * |Show| |and| |possibly| |reset| |the| |delimiter| |preceding| |this|  |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new|  |delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on|  |an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph|  |prototype.|) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) new.delimiter) (|with| ngtemplate (|fetch| (numberobj template) |of| (cond (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) (t (car (gethash label ( tsp.get.ngroup.array window))))) ) (and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-before 'before)) (not (strequal new.delimiter ng.text-before)) (setq ng.text-before new.delimiter)))))) (change.ngroup.format.display (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12") (* * |Show| |and| |possibly| |reset| |how| |this| |NGroup| |is| |displayed.|  |Return| nil |if| |nothing| |changed| |else| |returm| |the| |new| |display|  |type.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| |an|  |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| |prototype.|) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) new.display) (|with| ngtemplate (|fetch| (numberobj template) |of| (cond (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) (t (car (gethash label ( tsp.get.ngroup.array window))))) ) (tedit.promptprint stream (concat "\"" label "\" displayed as " ng.chartype ", change to...") t) (|until| (or (null (setq new.display (menu (|create| menu title _ "NGroup Displays" centerflg _ t items _ '(|Number| |Null String| uppercase\ letter |lowercase letter| uppercase\ roman |lowercase roman|))))) (selectq new.display ((|Number| |Null String|) t) (igreaterp ng.start 0))) |do| (tedit.promptprint stream (concat "Starting value (=" ng.start ") must be > 0 for \"" new.display "\". Try again.") t)) (tedit.promptprint stream "" t) (and new.display (neq new.display ng.chartype) (kwote (setq ng.chartype new.display))))))) (change.ngroup.format.txtafter (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12") (* * |Show| |and| |possibly| |reset| |the| |delimiter| |following| |this|  |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new|  |delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on|  |an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph|  |prototype.|) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) new.delimiter) (|with| ngtemplate (|fetch| (numberobj template) |of| (cond (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) (t (car (gethash label ( tsp.get.ngroup.array window))))) ) (and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-after 'after)) (not (strequal new.delimiter ng.text-after)) (setq ng.text-after new.delimiter)))))) (get.ngroup.delimiter (lambda (stream label delimiter before/after) (* |fsg| "17-Aug-87 15:12") (* * |Show| |and| |possibly| |reset| |the| |delimiter| |before/after| |this|  |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new|  |delimiter.|) (tedit.promptprint stream (concat "Delimiter " (selectq before/after (before "preceding ") "following ") label "\" is " (cond (delimiter (concat "\"" delimiter "\"")) (t '|Unspecified|)) ", change to...") t) (prog1 (menu (|create| menu title _ "NGroup Delimiters" centerflg _ t items _ '((|Period| ".") (|Colon| ":") (|Dash| "-") (|Null String| "") (|Other| (tedit.getinput stream (concat "Specify delimiter " (selectq before/after (before "preceding ") "following ") label ":")))))) (tedit.promptprint stream "" t)))) (change.ngroup.format.abbrev (lambda (label graphw ngroup.obj) (* |fsg| "26-Aug-87 11:48") (* * |Change| |the| |display| |level| |of| \a |NGroup.|  |Let| |the| |user| |decide| |how| |far| |up| |the| |parent| |tree| |to| |go|  |wrt| |printing| |values.| |This| |allows| |user| |to| |number| |things| |as|  |2.a,| |b,| |c,| |etc.| |Thanks| |to| |Michael| |Wescoat| |at| |Xerox| |for|  |suggesting| |this.|) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow))) (|with| numberobj (cond (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) (t (car (gethash label (tsp.get.ngroup.array window))))) (let ((parents (list.ancestors label nil window))) (cond (parents (tedit.promptprint stream (concat label (cond (abbrev-val (concat " abbreviation starts at " abbrev-val)) (t " not abbreviated")) ". Select starting level.") t) (let ((new.abrev (menu (|create| menu title _ (concat label " Levels") items _ (append parents (list label)) centerflg _ t)))) (and new.abrev (neq new.abrev abbrev-val) (true (setq abbrev-val (cond ((eq new.abrev (car parents)) nil) (t new.abrev))))))) (t (tedit.promptprint stream (concat "Cannot abbreviate top level NGroup \"" label "\"") t)))))))) (change.ngroup.format.start (lambda (label graphw) (* |fsg| " 9-Jul-87 15:45") (* * |Show| |and| |possibly| |reset| |this| |NGroup's| |starting| |value.|  |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| |starting|  |value.|) (let ((window (windowprop graphw 'twindow)) new.start) (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( tsp.get.ngroup.array window)))) (and (setq new.start (get.ngroup.start label ng.chartype ng.start (windowprop graphw 'tstream))) (neq new.start ng.start) (setq ng.start new.start)))))) (get.ngroup.start (lambda (label display start stream) (* |fsg| "23-Jul-87 14:38") (* * |Get| |the| |starting| |value| |for| |this| |NGroup.|  |Any| |value| |is| |ok| |for| \a |Number| |display| |but| |Letter/Roman|  |numeral| |values| |must| |be| |greater| |than| |zero.|) (let ((prompt.string (concat "Starting value of \"" label "\" is " start)) new.start) (|until| (or (null (setq new.start (mkatom (tedit.getinput stream (concat prompt.string ". New starting value:" ))))) (cond ((not (fixp new.start)) (setq prompt.string (concat new.start " is not an integer")) nil) (t (selectq display ((|Number| |Null String|) t) (cond ((ileq new.start 0) (setq prompt.string (concat "Start (=" new.start ") must be > 0 for \"" display "\"")) nil) (t t))))))) new.start))) (change.ngroup.format.toc (lambda (label graphw) (* |fsg| " 7-Jul-87 09:12") (* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included|  |in| |the| |Table-Of¬Contents.| |Return| nil |if| |no| |change| |else| |return|  t.) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) new.addtotoc) (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( tsp.get.ngroup.array window)))) (tedit.promptprint stream (concat "\"" label "\" is " (cond (ng.addtotoc "") (t "NOT ")) "included in the TOC. Do you want it included?") t) (setq new.addtotoc (menu (|create| menu title _ "In TOC?" centerflg _ t items _ '((yes t) (no nil)) whenselectedfn _ (function (lambda (item) item))))) (tedit.promptprint stream "" t) (and new.addtotoc (neq (cadr new.addtotoc) ng.addtotoc) (progn (setq ng.addtotoc (cadr new.addtotoc)) t)))))) (change.ngroup.format.manindex (lambda (label graphw) (* |fsg| " 1-Sep-87 15:39") (* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included|  |in| |the| |manual| |index.| |Return| nil |if| |no| |change| |else| |return| t.) (let ((stream (windowprop graphw 'tstream)) (window (windowprop graphw 'twindow)) new.manualindex) (and (manualindex.enabled? window) (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( tsp.get.ngroup.array window)))) (tedit.promptprint stream (concat "\"" label "\" is " (cond (ng.manualindex "") (t "NOT")) " included in the Manual Index. Do you want it included?" ) t) (setq new.manualindex (menu (|create| menu title _ "Manual Index?" centerflg _ t items _ '((yes t) (no nil)) whenselectedfn _ (function (lambda (item) item))))) (tedit.promptprint stream "" t) (and new.manualindex (neq (cadr new.manualindex) ng.manualindex) (true (cond ((setq ng.manualindex (cadr new.manualindex)) (windowaddprop window 'manualgroups label)) (t (windowdelprop window 'manualgroups label)))))))))) (update.ngroup.manindex (lambda (template label window) (* |ss:| "27-Jun-87 16:22") (* * |Update| |the| |NGroup| |template| |list| |wrt| |the| |current| |NGroup|  |level.| |Note| |that| |when| \a |new| |NGroup| |is| |seen,| |all| |it's|  |children| |become| |undefined.| |Furthermore| |we| |know| |the| |NGroups|  |are| |in| |order| |since| |the| |order| |is| |verified| |when| |the| |NGroup|  |is| |inserted.|) (and (manualindex.enabled? window) (let* ((man.groups (windowprop window 'manualgroups)) (label.groups (memb label man.groups))) (and label.groups (let* ((label.offset (add1 (idifference (length man.groups) (length label.groups)))) (man.templates (windowprop window 'manualtemplates)) (template.sublist (nth man.templates label.offset))) (cond (template.sublist (rplnode template.sublist template)) (t (windowaddprop window 'manualtemplates template))))))))) (ngroup.fixup.records (lambda (ngroup.record copyflg) (* |fsg| " 3-Sep-87 15:35") (* * |Function| |to| "fix up" |the| |NGroup| |record.|  |This| |allows| |us| |to| |expand| |the| |NGroup| |record| |and| |still|  |maintain| |backwatd| |compatability.| i\f copyflg |is| |non-NIL,| |we| |are|  |doing| \a copy. i\n |this| |case| |un-update| |the| |record;|  |Copied| |NGroups| |are| |always| |unupdated.|) (let ((template (|fetch| (numberobj template) |of| ngroup.record))) (|create| numberobj ref.type _ (|fetch| (numberobj ref.type) |of| ngroup.record) numstring _ (cond (copyflg (selectq (|fetch| (numberobj use) |of| ngroup.record) (ngroup (concat "[" (|fetch| (numberobj ref.type) |of| ngroup.record) "]")) (note "Note#") nil)) (t (|fetch| (numberobj numstring) |of| ngroup.record))) use _ (|fetch| (numberobj use) |of| ngroup.record) ngroup.mother _ (|fetch| (numberobj ngroup.mother) |of| ngroup.record) template _ (|create| ngtemplate ng.chartype _ (|fetch| (ngtemplate ng.chartype) |of| template) ng.text-before _ (|fetch| (ngtemplate ng.text-before) |of| template ) ng.text-after _ (|fetch| (ngtemplate ng.text-after) |of| template) ng.start _ (|fetch| (ngtemplate ng.start) |of| template) ng.addtotoc _ (|fetch| (ngtemplate ng.addtotoc) |of| template) ng.currentval _ (cond (copyflg nil) (t (|fetch| (ngtemplate ng.currentval) |of| template))) ng.manualindex _ (|fetch| (ngtemplate ng.manualindex) |of| template )) updated.obj _ (cond (copyflg nil) (t (|fetch| (numberobj updated.obj) |of| ngroup.record))) text.after# _ (|fetch| (numberobj text.after#) |of| ngroup.record) page.number _ (|fetch| (numberobj page.number) |of| ngroup.record) font _ (|fetch| (numberobj font) |of| ngroup.record) text.before# _ (|fetch| (numberobj text.before#) |of| ngroup.record) abbrev-val _ (|fetch| (numberobj abbrev-val) |of| ngroup.record))))) ) (* * |Table-of-Contents| |functions|) (defineq (get.ngroup.textstring (lambda (nbrobj label stream window) (* |fsg| " 5-Aug-87 10:36") (* * |Get| |the| |Table-Of-Contents| |before/after| |text| |string| |for|  |this| |NGroup.| |Because| |the| write.toc.file |function| |uses| \a |tab| |to|  |align| |the| |page| |numbers,| |any| |tabs| |in| |the| toc |strings| |are|  |converted| |to| |spaces.|) (and (textbefore.enabled? window) (let ((toc.string (tedit.getinput stream (concat "Text before " label ":") (mkstring label)))) (and toc.string (|replace| (numberobj text.before#) |of| (|fetch| objectdatum |of| nbrobj) |with| (concat (convert.tabs.to.spaces toc.string) " "))))) (and (textafter.enabled? window) (let ((toc.string (tedit.getinput stream (concat "Text after " label ":")))) (and toc.string (|replace| (numberobj text.after#) |of| (|fetch| objectdatum |of| nbrobj) |with| (concat " " (convert.tabs.to.spaces toc.string)))))))) (convert.tabs.to.spaces (lambda (string) (* |fsg| "10-Mar-87 11:01") (* * |Returns| \a |string| |with| |all| |tabs| |converted| |to| |spaces.|  w\e |do| |this| |because| |some| |features| |like| |the| |Table-Of-Contents|  |use| \a |tab| |to| |align| |the| |page| |numbers.|) (and (stringp string) (mkstring (pack (|for| char |in| (unpack string) |collect| (cond ((eq char (character (charcode tab))) (character (charcode space))) (t char)))))))) (create.toc.file (lambda (stream window) (* |fsg| "16-Jul-87 11:46") (* * |Here| |to| |print| |the| |Table| o\f |Contents.|  |Each| |Line| |of| |the| toc |consists| |of| |the| |NGroup,| |the|  |corresponding| |text,| |followed| |by| |the| |current| |listing| |page|  |number.|) (let ((toc.list (tsp.list.of.objects (textobj window) (function ngroup.toc.entries))) (toc.file (get.toc.file (windowprop window 'imageobj.menuw))) (toc.tabstop (list 'paralooks (list 'tabs (list nil (cons (fixr (times 72.27 6.125)) 'dottedleft))))) toc.stream) (cond ((and toc.list toc.file) (setq toc.stream (opentextstream nil nil nil nil toc.tabstop)) (tedit.promptprint stream (concat "Putting Table-Of-Contents into file " toc.file "...") t) (write.toc.file toc.stream toc.list window) (tedit.promptprint stream "done") (tedit.put toc.stream toc.file) (closef? toc.file) toc.file) (toc.list (tedit.promptprint stream "Specify a file name for the Table-Of-Contents first." t) nil) (t (tedit.promptprint stream "There are no NGroups included in the Table-Of-Contents." t) nil))))) (ngroup.toc.entries (lambda (nbrobj) (* |fsg| "16-Jul-87 11:20") (* * |Check| |if| nbrobj |is| \a |NGroup| |ImageObject| |and| |its| ng.addtotoc  |flag| |is| |on.|) (and (ngroupp nbrobj) (|fetch| (ngtemplate ng.addtotoc) |of| (|fetch| (numberobj template) |of| (|fetch| objectdatum |of| nbrobj)))))) (view.toc.file (lambda (stream window) (* |fsg| "12-Aug-87 16:36") (* * |Writes| |out| |the| toc |file| |via| create.toc.file |and| |then| |opens|  |another| |TEdit| |window| |where| |this| |new| |file| |is| |displayed.|) (let ((toc.file (create.toc.file stream window))) (and toc.file (progn (or (windowprop window 'toc.window) (windowprop window 'toc.window (createw nil (concat "Viewing TOC file: " toc.file)))) (tedit toc.file (windowprop window 'toc.window))))))) (get.toc.file (lambda (menuw) (* \; "Edited 29-Sep-87 15:17 by fsg") (* * |Return| |the| |user| |specified| |Table-Of-Contents| |file| |name.|) (let ((filename (fm.itemprop (fm.getitem 'toc.file nil menuw) 'label))) (and (not (strequal filename "")) (mkatom filename))))) (write.toc.file (lambda (toc.stream toc.list window) (* |fsg| "26-Aug-87 15:37") (* * |Here| |to| |speficy| |the| |order| |of| |the| |Table-Of-Contents.|  |The| toc |is| |ordered| |by| |the| |top-level| |sister| |nodes.|) (dspfont (fontcreate '(helvetica 14 brr)) toc.stream) (printout toc.stream "Table of Contents" t) (|for| toc.mother |in| (toplevel.sisters window) |do| (dspfont |GP.DefaultFont| toc.stream) (printout toc.stream t) (|for| toc.item |in| toc.list |when| (|with| numberobj (|fetch| objectdatum |of| (car toc.item)) (eq (get.ngroup.mother ref.type window) toc.mother)) |do| (write.toc.entry toc.item toc.stream window))))) (write.toc.entry (lambda (toc.item toc.stream window) (* |fsg| "27-Jul-87 14:55") (* * |Write| |one| |line| |to| |the| |Table-Of-Contents| |file.|) (let* ((datum (|fetch| objectdatum |of| (car toc.item))) (item.level (length (list.ancestors (|fetch| (numberobj ref.type) |of| datum) nil window)))) (dspfont |GP.DefaultFont| toc.stream) (cond ((zerop item.level) (printout toc.stream t)) (t (rptq item.level (printout toc.stream " ")))) (dspfont (|fetch| (numberobj font) |of| datum) toc.stream) (printout toc.stream (concat (or (|fetch| (numberobj text.before#) |of| datum) "") (|fetch| (numberobj numstring) |of| datum) (or (|fetch| (numberobj text.after#) |of| datum) ""))) (dspfont |GP.DefaultFont| toc.stream) (printout toc.stream (character (charcode tab)) (|fetch| (numberobj page.number) |of| datum) t)))) ) (putprops tmax-ngroup copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1604 40075 (insert.ngroup 1614 . 3225) (verify.ngroup.order 3227 . 5020) ( get.previous.ngroups 5022 . 5391) (add.number.group 5393 . 7758) (add.ngroup.to.dbase 7760 . 8566) ( collect.ngroups 8568 . 9165) (list.font.props 9167 . 9435) (map.ngroup.looks 9437 . 10926) ( ngroup.getfont 10928 . 11578) (change.ngroup 11580 . 12281) (change.ngroup.font 12283 . 13741) ( show.ngroup.font 13743 . 14461) (change.ngroup.format 14463 . 16189) (show.ngroup.format 16191 . 18768 ) (change.ngroup.format.txtbefore 18770 . 20309) (change.ngroup.format.display 20311 . 22959) ( change.ngroup.format.txtafter 22961 . 24495) (get.ngroup.delimiter 24497 . 26186) ( change.ngroup.format.abbrev 26188 . 28780) (change.ngroup.format.start 28782 . 29860) ( get.ngroup.start 29862 . 31334) (change.ngroup.format.toc 31336 . 33220) ( change.ngroup.format.manindex 33222 . 35562) (update.ngroup.manindex 35564 . 36860) ( ngroup.fixup.records 36862 . 40073)) (40120 47866 (get.ngroup.textstring 40130 . 41509) ( convert.tabs.to.spaces 41511 . 42375) (create.toc.file 42377 . 43901) (ngroup.toc.entries 43903 . 44375) (view.toc.file 44377 . 45172) (get.toc.file 45174 . 45572) (write.toc.file 45574 . 46576) ( write.toc.entry 46578 . 47864))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-NGROUP.~2~ b/lispusers/TMAX-NGROUP.~2~ deleted file mode 100644 index 7a9c559e..00000000 --- a/lispusers/TMAX-NGROUP.~2~ +++ /dev/null @@ -1,662 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "25-Jan-97 11:49:57" |{DSK}medley2.0>lispusers>TMAX-NGROUP.;2| 47901 |changes| |to:| (FNS CONVERT.TABS.TO.SPACES) |previous| |date:| "30-Dec-87 11:34:27" |{DSK}medley2.0>lispusers>TMAX-NGROUP.;1|) ; Copyright (c) 1987, 1997 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-NGROUPCOMS) (RPAQQ TMAX-NGROUPCOMS ((* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Other| |unsorted| |functions|) (FNS INSERT.NGROUP VERIFY.NGROUP.ORDER GET.PREVIOUS.NGROUPS ADD.NUMBER.GROUP ADD.NGROUP.TO.DBASE COLLECT.NGROUPS LIST.FONT.PROPS MAP.NGROUP.LOOKS NGROUP.GETFONT CHANGE.NGROUP CHANGE.NGROUP.FONT SHOW.NGROUP.FONT CHANGE.NGROUP.FORMAT SHOW.NGROUP.FORMAT CHANGE.NGROUP.FORMAT.TXTBEFORE CHANGE.NGROUP.FORMAT.DISPLAY CHANGE.NGROUP.FORMAT.TXTAFTER GET.NGROUP.DELIMITER CHANGE.NGROUP.FORMAT.ABBREV CHANGE.NGROUP.FORMAT.START GET.NGROUP.START CHANGE.NGROUP.FORMAT.TOC CHANGE.NGROUP.FORMAT.MANINDEX UPDATE.NGROUP.MANINDEX NGROUP.FIXUP.RECORDS) (* * |Table-of-Contents| |functions|) (FNS GET.NGROUP.TEXTSTRING CONVERT.TABS.TO.SPACES CREATE.TOC.FILE NGROUP.TOC.ENTRIES VIEW.TOC.FILE GET.TOC.FILE WRITE.TOC.FILE WRITE.TOC.ENTRY))) (* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * |Other| |unsorted| |functions|) (DEFINEQ (insert.ngroup - (lambda (node graphw) (* |fsg| "26-Aug-87 14:37") - (* * |Insert| \a |NGroup| |build| |from| |the| |prototype| |definition.|) - - (and node (let* ((twindow (windowprop graphw 'twindow)) - (tstream (windowprop graphw 'tstream)) - (label (|fetch| (graphnode nodeid) |of| node)) - (oldlooks (|fetch| caretlooks |of| (textobj tstream))) - (newlooks (ngroup.getfont label twindow))) - (|with| numberobj (car (gethash label (tsp.get.ngroup.array twindow))) - (selectq label - (new.ngroup nil) - (let ((newobj (numberobj 'ngroup template (concat "[" label "]") - label newlooks (get.fromnodes label twindow) - abbrev-val))) - (tedit.caretlooks tstream newlooks) - (get.ngroup.textstring newobj label tstream twindow) - (imageobjprop newobj 'twindow twindow) - (tedit.insert.object newobj tstream) - (tedit.caretlooks tstream oldlooks) - (and (update? twindow) - (update.numberobjs twindow tstream 'ngroupp)) - (verify.ngroup.order twindow newobj)))))))) (verify.ngroup.order - (lambda (window ngroup.obj) (* |fsg| "28-Jul-87 15:59") - (* * |Verify| |the| |NGroup| |order| |before| |inserting| \a |new| |NGroup.| - |The| |order| |is| |valid| |if| |the| |new| |NGroup| |is| \a |top| |level| - |node| |or| |its| |parent| |Ngroup| |has| |already| |been| |inserted.|) - - (let* ((mother (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) - ngroup.mother)) - (selection (tedit.getsel (textstream window))) - (ch# (and selection (|fetch| ch# |of| selection)))) - (cond - ((or (eq mother 'new.ngroup) - (and ch# (|for| prev.ngroup |in| (tsp.list.of.objects (textobj window) - (function get.previous.ngroups) - ch#) - |thereis| (eq mother (|with| numberobj (|fetch| objectdatum - |of| (car prev.ngroup)) - ref.type))))) - (tedit.promptprint (textstream window) - "" t)) - (t (tedit.promptprint (textstream window) - (concat "Warning...\"" (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) - ref.type) - "\" is not preceded by \"" mother "\" NGroup.") - t) - (flashwindow (|with| textobj (textobj window) - promptwindow) - 2)))))) (get.previous.ngroups - (lambda (ngroup.obj char.pos) (* |fsg| "28-Jul-87 14:01") - (* * |Called| |from| tsp.list.of.objects |to| |collect| |all| |the| |NGroup| - |ImageObjs| |that| |exist| |before| |the| |character| |position| char.pos.) - - (and (ngroupp ngroup.obj) - (ilessp ch# char.pos)))) (add.number.group - (lambda (twindow stream) (* \; "Edited 30-Sep-87 14:34 by fsg") - - (or (ngroupmenu.enabled? twindow) - (progn (fm.changestate (fm.getitem 'ngroup.menu nil (windowprop twindow 'imageobj.menuw)) - t - (windowprop twindow 'imageobj.menuw)) - (graphmenu stream twindow))) - (let* ((prev.items (collect.ngroups twindow)) - (new.groupid (mkatom (tsp.legalid (cons 'new.ngroup prev.items) - stream))) - template dependent.class new.node) - (prog1 (cond - (new.groupid (setq dependent.class - (or (mkatom (and prev.items - (menu (|create| menu - title _ "Parent Group?" - items _ (sort prev.items 'ualphorder) - )))) - 'new.ngroup)) - (or template - (setq template - (|create| ngtemplate - ng.chartype _ '|Number| - ng.text-before _ nil - ng.text-after _ "." - ng.start _ 1 - ng.addtotoc _ t - ng.currentval _ nil - ng.manualindex _ nil))) - (setq new.node (nodecreate new.groupid new.groupid nil nil (list - dependent.class - ))) - (add.ngroup.to.dbase new.groupid template dependent.class |GP.DefaultFont| - new.node twindow) - (add.node.to.graph new.node (windowprop twindow 'ngroup.graph) - twindow)) - (t nil)) - (tedit.promptprint stream "" t))))) (add.ngroup.to.dbase - (lambda (new.groupid template dependent.class font ngroup.node twindow) - (* |fsg| " 3-Aug-87 16:43") - (let ((ngroup.array (tsp.get.ngroup.array twindow))) - (or (gethash new.groupid ngroup.array) - (progn (windowprop twindow 'rebuild.graphflg t) - (puthash new.groupid - (list (|create| numberobj - ngroup.mother _ dependent.class - font _ font - ref.type _ new.groupid - template _ template) - ngroup.node) - (list ngroup.array))))))) (collect.ngroups - (lambda (twindow) (* |ss:| "31-Mar-86 13:53") - (let ((graph (windowprop twindow 'ngroup.graph))) - (|for| node |in| (|fetch| (graph graphnodes) |of| graph) |collect| (|fetch| (graphnode - nodeid) - |of| node) - |unless| (eq (|fetch| (graphnode nodeid) |of| node) - 'new.ngroup))))) (list.font.props - (lambda (fontdes) (* |fsg| " 3-Aug-87 10:03") - (and (fontp fontdes) - (list (fontprop fontdes 'family) - (fontprop fontdes 'size) - (fontprop fontdes 'face))))) (map.ngroup.looks - (lambda (label new.font twindow new.template) (* |fsg| " 5-Aug-87 13:40") - (* * |Here| |to| |change| |the| |font| |or| |format| |of| |an| |NGroup.| - i\f new.template |is| |non-NIL| |then| |we| |are| |changing| |the| |format,| - |else| |we| |are| |changing| |the| |font.|) - - (tedit.promptprint (textstream twindow) - (concat "Updating " (cond - (new.template "FORMAT") - (t "FONT")) - " for \"" label "\" Ngroups...") - t) - (|for| ngroup.obj |in| (tsp.list.of.objects (textobj twindow) - `(lambda (obj) - (and (ngroupp obj) - (eq (fetch ref.type of (fetch objectdatum of obj)) - \, - (kwote label))))) - |do| (|with| numberobj (|fetch| objectdatum |of| (car ngroup.obj)) - (cond - (new.template (setq template new.template)) - (t (tedit.looks (textstream twindow) - new.font - (cadr ngroup.obj) - 1) - (setq font new.font))))) - (tedit.promptprint (textstream twindow) - "Done."))) (ngroup.getfont - (lambda (ngroup.name window ngroup.obj) (* |fsg| " 4-Aug-87 15:00") - (* * |Get| |an| |NGroup's| |font.| i\f ngroup.obj |is| |non-NIL| |then| |we| - |get| |the| |font| |from| |this| |ImageObj's| objectdatum. - |Else| |we| |get| |the| |font| |from| |the| |NGroup| |graph| |prototype| - |NGroup.|) - - (|fetch| (numberobj font) |of| (cond - (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) - (t (car (gethash ngroup.name (tsp.get.ngroup.array window)))))) - )) (change.ngroup - (lambda (node graphw) (* |fsg| "30-Jul-87 13:52") - (* * |Here| |when| |number| |group| |node| |is| |middle| |buttoned.| - |Allow| |user| |to| |change| |the| |font| |and/or| |format| |of| |the| - |ngroup.|) - - (and node (let ((label (|fetch| (graphnode nodeid) |of| node))) - (selectq label - (new.ngroup nil) - (menu (|create| menu - title _ (mkstring label) - centerflg _ t - items _ (eval ngroup.graph.menu.items)))))))) (change.ngroup.font - (lambda (label graphw font.field ngroup.obj) (* |fsg| " 4-Aug-87 15:09") - (* * |Change| \a |NGroup| |font.| i\f |NGROUP.OBJis| |non-NIL| |then| |we| - |are| |working| |on| |an| |inserted| |NGroup.| - |Else| |we| |are| |working| |on| |the| |graph| |prototype| |NGroups.|) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - new.font) - (show.ngroup.font label graphw ngroup.obj) - (tedit.promptprint stream (selectq font.field - (family ", change Family to...") - (size ", change Size to...") - (face ", change Face to...") - ", change to...")) - (|with| numberobj (cond - (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) - (t (car (gethash label (tsp.get.ngroup.array window))))) - (setq new.font (fontcreate (get.tsp.font window font font.field))) - (tedit.promptprint stream "" t) - (and (neq font new.font) - (progn (setq font new.font) - (cond - (ngroup.obj new.font) - (t (map.ngroup.looks label new.font window))))))))) (show.ngroup.font - (lambda (label graphw ngroup.obj) (* |fsg| " 4-Aug-87 14:57") - (* * |Show| |this| |NGroup's| |font| |specification.|) - - (let* ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - (font.list (abbreviate.font (ngroup.getfont label window ngroup.obj)))) - (tedit.promptprint stream (concat label ": Family=" (|pop| font.list) - " Size=" - (|pop| font.list) - " Face=" - (|pop| font.list)) - t)))) (change.ngroup.format - (lambda (label graphw format.field) (* |fsg| " 1-Sep-87 15:39") - (* * |Change| |the| |entire| |format| |or| \a |selected| |field| |of| |an| - |NGroup.|) - - (let ((window (windowprop graphw 'twindow)) - (new.format (|for| field |in| (cond - (format.field (list format.field)) - (t '(txtbefore display txtafter abbrevval start toc - manindex))) - |collect| (selectq field - (txtbefore (change.ngroup.format.txtbefore label graphw)) - (display (change.ngroup.format.display label graphw)) - (txtafter (change.ngroup.format.txtafter label graphw)) - (abbrevval (change.ngroup.format.abbrev label graphw)) - (start (change.ngroup.format.start label graphw)) - (toc (change.ngroup.format.toc label graphw)) - (manindex (change.ngroup.format.manindex label graphw)) - (error "Unknown NGroup Format field" field))))) - (and (apply 'or new.format) - (let ((nbrobj (car (gethash label (tsp.get.ngroup.array window))))) - (map.ngroup.looks label (|fetch| (numberobj font) |of| nbrobj) - window - (|fetch| (numberobj template) |of| nbrobj))))))) (show.ngroup.format - (lambda (label graphw) (* |fsg| "26-Aug-87 12:02") - (* * |Show| |this| |NGroup's| |format| |specification.|) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow))) - (|with| numberobj (car (gethash label (tsp.get.ngroup.array window))) - (|with| ngtemplate template (tedit.promptprint stream - (concat label ": Display=" - (concat (cond - (ng.text-before (concat "\"" - ng.text-before - "\"")) - (t "\"\"")) - ng.chartype - (cond - (ng.text-after (concat "\"" - ng.text-after - "\"")) - (t "\"\""))) - " Abbrev=" - (or abbrev-val "None") - " Start=" ng.start " TOC=" (cond - (ng.addtotoc - "Yes") - (t "No")) - (cond - ((manualindex.enabled? window) - (cond - (ng.manualindex " ManIndex=Yes") - (t " ManIndex=No"))) - (t ""))) - t)))))) (change.ngroup.format.txtbefore - (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:11") - (* * |Show| |and| |possibly| |reset| |the| |delimiter| |preceding| |this| - |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| - |delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| - |an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| - |prototype.|) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - new.delimiter) - (|with| ngtemplate (|fetch| (numberobj template) |of| (cond - (ngroup.obj (|fetch| objectdatum - |of| ngroup.obj)) - (t (car (gethash label ( - tsp.get.ngroup.array - window))))) - ) - (and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-before - 'before)) - (not (strequal new.delimiter ng.text-before)) - (setq ng.text-before new.delimiter)))))) (change.ngroup.format.display - (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12") - (* * |Show| |and| |possibly| |reset| |how| |this| |NGroup| |is| |displayed.| - |Return| nil |if| |nothing| |changed| |else| |returm| |the| |new| |display| - |type.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| |an| - |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| |prototype.|) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - new.display) - (|with| ngtemplate (|fetch| (numberobj template) |of| (cond - (ngroup.obj (|fetch| objectdatum - |of| ngroup.obj)) - (t (car (gethash label ( - tsp.get.ngroup.array - window))))) - ) - (tedit.promptprint stream (concat "\"" label "\" displayed as " ng.chartype - ", change to...") - t) - (|until| (or (null (setq new.display - (menu (|create| menu - title _ "NGroup Displays" - centerflg _ t - items _ '(|Number| |Null String| uppercase\ letter - |lowercase letter| uppercase\ roman - |lowercase roman|))))) - (selectq new.display - ((|Number| |Null String|) - t) - (igreaterp ng.start 0))) - |do| (tedit.promptprint stream (concat "Starting value (=" ng.start - ") must be > 0 for \"" new.display - "\". Try again.") - t)) - (tedit.promptprint stream "" t) - (and new.display (neq new.display ng.chartype) - (kwote (setq ng.chartype new.display))))))) (change.ngroup.format.txtafter - (lambda (label graphw ngroup.obj) (* |fsg| " 5-Aug-87 10:12") - (* * |Show| |and| |possibly| |reset| |the| |delimiter| |following| |this| - |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| - |delimiter.| i\f ngroup.obj |is| |non-NIL| |then| |we| |are| |working| |on| - |an| |inserted| |NGroup.| |Else| |we're| |working| |on| |the| |graph| - |prototype.|) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - new.delimiter) - (|with| ngtemplate (|fetch| (numberobj template) |of| (cond - (ngroup.obj (|fetch| objectdatum - |of| ngroup.obj)) - (t (car (gethash label ( - tsp.get.ngroup.array - window))))) - ) - (and (setq new.delimiter (get.ngroup.delimiter stream label ng.text-after - 'after)) - (not (strequal new.delimiter ng.text-after)) - (setq ng.text-after new.delimiter)))))) (get.ngroup.delimiter - (lambda (stream label delimiter before/after) (* |fsg| "17-Aug-87 15:12") - (* * |Show| |and| |possibly| |reset| |the| |delimiter| |before/after| |this| - |NGroup.| |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| - |delimiter.|) - - (tedit.promptprint stream (concat "Delimiter " (selectq before/after - (before "preceding ") - "following ") - label "\" is " (cond - (delimiter (concat "\"" delimiter "\"")) - (t '|Unspecified|)) - ", change to...") - t) - (prog1 (menu (|create| menu - title _ "NGroup Delimiters" - centerflg _ t - items _ '((|Period| ".") - (|Colon| ":") - (|Dash| "-") - (|Null String| "") - (|Other| (tedit.getinput stream (concat "Specify delimiter " - (selectq before/after - (before "preceding ") - "following ") - label ":")))))) - (tedit.promptprint stream "" t)))) (change.ngroup.format.abbrev - (lambda (label graphw ngroup.obj) (* |fsg| "26-Aug-87 11:48") - (* * |Change| |the| |display| |level| |of| \a |NGroup.| - |Let| |the| |user| |decide| |how| |far| |up| |the| |parent| |tree| |to| |go| - |wrt| |printing| |values.| |This| |allows| |user| |to| |number| |things| |as| - |2.a,| |b,| |c,| |etc.| |Thanks| |to| |Michael| |Wescoat| |at| |Xerox| |for| - |suggesting| |this.|) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow))) - (|with| numberobj (cond - (ngroup.obj (|fetch| objectdatum |of| ngroup.obj)) - (t (car (gethash label (tsp.get.ngroup.array window))))) - (let ((parents (list.ancestors label nil window))) - (cond - (parents (tedit.promptprint stream (concat label (cond - (abbrev-val (concat - - " abbreviation starts at " - abbrev-val)) - (t " not abbreviated")) - ". Select starting level.") - t) - (let ((new.abrev (menu (|create| menu - title _ (concat label " Levels") - items _ (append parents (list label)) - centerflg _ t)))) - (and new.abrev (neq new.abrev abbrev-val) - (true (setq abbrev-val (cond - ((eq new.abrev (car parents)) - nil) - (t new.abrev))))))) - (t (tedit.promptprint stream (concat "Cannot abbreviate top level NGroup \"" - label "\"") - t)))))))) (change.ngroup.format.start - (lambda (label graphw) (* |fsg| " 9-Jul-87 15:45") - (* * |Show| |and| |possibly| |reset| |this| |NGroup's| |starting| |value.| - |Return| nil |if| |nothing| |changed| |else| |return| |the| |new| |starting| - |value.|) - - (let ((window (windowprop graphw 'twindow)) - new.start) - (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( - tsp.get.ngroup.array - window)))) - (and (setq new.start (get.ngroup.start label ng.chartype ng.start (windowprop - graphw - 'tstream))) - (neq new.start ng.start) - (setq ng.start new.start)))))) (get.ngroup.start - (lambda (label display start stream) (* |fsg| "23-Jul-87 14:38") - (* * |Get| |the| |starting| |value| |for| |this| |NGroup.| - |Any| |value| |is| |ok| |for| \a |Number| |display| |but| |Letter/Roman| - |numeral| |values| |must| |be| |greater| |than| |zero.|) - - (let ((prompt.string (concat "Starting value of \"" label "\" is " start)) - new.start) - (|until| (or (null (setq new.start (mkatom (tedit.getinput stream (concat prompt.string - ". New starting value:" - ))))) - (cond - ((not (fixp new.start)) - (setq prompt.string (concat new.start " is not an integer")) - nil) - (t (selectq display - ((|Number| |Null String|) - t) - (cond - ((ileq new.start 0) - (setq prompt.string (concat "Start (=" new.start - ") must be > 0 for \"" display "\"")) - nil) - (t t))))))) - new.start))) (change.ngroup.format.toc - (lambda (label graphw) (* |fsg| " 7-Jul-87 09:12") - (* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included| - |in| |the| |Table-Of¬Contents.| |Return| nil |if| |no| |change| |else| |return| - t.) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - new.addtotoc) - (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( - tsp.get.ngroup.array - window)))) - (tedit.promptprint stream (concat "\"" label "\" is " (cond - (ng.addtotoc "") - (t "NOT ")) - "included in the TOC. Do you want it included?") - t) - (setq new.addtotoc (menu (|create| menu - title _ "In TOC?" - centerflg _ t - items _ '((yes t) - (no nil)) - whenselectedfn _ (function (lambda (item) - item))))) - (tedit.promptprint stream "" t) - (and new.addtotoc (neq (cadr new.addtotoc) - ng.addtotoc) - (progn (setq ng.addtotoc (cadr new.addtotoc)) - t)))))) (change.ngroup.format.manindex - (lambda (label graphw) (* |fsg| " 1-Sep-87 15:39") - (* * |Show| |and| |possibly| |reset| |whether| |this| |NGroup| |is| |included| - |in| |the| |manual| |index.| |Return| nil |if| |no| |change| |else| |return| t.) - - (let ((stream (windowprop graphw 'tstream)) - (window (windowprop graphw 'twindow)) - new.manualindex) - (and (manualindex.enabled? window) - (|with| ngtemplate (|fetch| (numberobj template) |of| (car (gethash label ( - tsp.get.ngroup.array - window)))) - (tedit.promptprint stream (concat "\"" label "\" is " (cond - (ng.manualindex "") - (t "NOT")) - - " included in the Manual Index. Do you want it included?" - ) - t) - (setq new.manualindex (menu (|create| menu - title _ "Manual Index?" - centerflg _ t - items _ '((yes t) - (no nil)) - whenselectedfn _ (function (lambda (item) - item))))) - (tedit.promptprint stream "" t) - (and new.manualindex (neq (cadr new.manualindex) - ng.manualindex) - (true (cond - ((setq ng.manualindex (cadr new.manualindex)) - (windowaddprop window 'manualgroups label)) - (t (windowdelprop window 'manualgroups label)))))))))) (update.ngroup.manindex - (lambda (template label window) (* |ss:| "27-Jun-87 16:22") - (* * |Update| |the| |NGroup| |template| |list| |wrt| |the| |current| |NGroup| - |level.| |Note| |that| |when| \a |new| |NGroup| |is| |seen,| |all| |it's| - |children| |become| |undefined.| |Furthermore| |we| |know| |the| |NGroups| - |are| |in| |order| |since| |the| |order| |is| |verified| |when| |the| |NGroup| - |is| |inserted.|) - - (and (manualindex.enabled? window) - (let* ((man.groups (windowprop window 'manualgroups)) - (label.groups (memb label man.groups))) - (and label.groups (let* ((label.offset (add1 (idifference (length man.groups) - (length label.groups)))) - (man.templates (windowprop window 'manualtemplates)) - (template.sublist (nth man.templates label.offset))) - (cond - (template.sublist (rplnode template.sublist template)) - (t (windowaddprop window 'manualtemplates template))))))))) (ngroup.fixup.records - (lambda (ngroup.record copyflg) (* |fsg| " 3-Sep-87 15:35") - (* * |Function| |to| "fix up" |the| |NGroup| |record.| - |This| |allows| |us| |to| |expand| |the| |NGroup| |record| |and| |still| - |maintain| |backwatd| |compatability.| i\f copyflg |is| |non-NIL,| |we| |are| - |doing| \a copy. i\n |this| |case| |un-update| |the| |record;| - |Copied| |NGroups| |are| |always| |unupdated.|) - - (let ((template (|fetch| (numberobj template) |of| ngroup.record))) - (|create| numberobj - ref.type _ (|fetch| (numberobj ref.type) |of| ngroup.record) - numstring _ (cond - (copyflg (selectq (|fetch| (numberobj use) |of| ngroup.record) - (ngroup (concat "[" (|fetch| (numberobj ref.type) - |of| ngroup.record) - "]")) - (note "Note#") - nil)) - (t (|fetch| (numberobj numstring) |of| ngroup.record))) - use _ (|fetch| (numberobj use) |of| ngroup.record) - ngroup.mother _ (|fetch| (numberobj ngroup.mother) |of| ngroup.record) - template _ (|create| ngtemplate - ng.chartype _ (|fetch| (ngtemplate ng.chartype) |of| template) - ng.text-before _ (|fetch| (ngtemplate ng.text-before) |of| template - ) - ng.text-after _ (|fetch| (ngtemplate ng.text-after) |of| template) - ng.start _ (|fetch| (ngtemplate ng.start) |of| template) - ng.addtotoc _ (|fetch| (ngtemplate ng.addtotoc) |of| template) - ng.currentval _ (cond - (copyflg nil) - (t (|fetch| (ngtemplate ng.currentval) - |of| template))) - ng.manualindex _ (|fetch| (ngtemplate ng.manualindex) |of| template - )) - updated.obj _ (cond - (copyflg nil) - (t (|fetch| (numberobj updated.obj) |of| ngroup.record))) - text.after# _ (|fetch| (numberobj text.after#) |of| ngroup.record) - page.number _ (|fetch| (numberobj page.number) |of| ngroup.record) - font _ (|fetch| (numberobj font) |of| ngroup.record) - text.before# _ (|fetch| (numberobj text.before#) |of| ngroup.record) - abbrev-val _ (|fetch| (numberobj abbrev-val) |of| ngroup.record))))) ) (* * |Table-of-Contents| |functions|) (DEFINEQ (get.ngroup.textstring - (lambda (nbrobj label stream window) (* |fsg| " 5-Aug-87 10:36") - (* * |Get| |the| |Table-Of-Contents| |before/after| |text| |string| |for| - |this| |NGroup.| |Because| |the| write.toc.file |function| |uses| \a |tab| |to| - |align| |the| |page| |numbers,| |any| |tabs| |in| |the| toc |strings| |are| - |converted| |to| |spaces.|) - - (and (textbefore.enabled? window) - (let ((toc.string (tedit.getinput stream (concat "Text before " label ":") - (mkstring label)))) - (and toc.string (|replace| (numberobj text.before#) |of| (|fetch| objectdatum - |of| nbrobj) - |with| (concat (convert.tabs.to.spaces toc.string) - " "))))) - (and (textafter.enabled? window) - (let ((toc.string (tedit.getinput stream (concat "Text after " label ":")))) - (and toc.string (|replace| (numberobj text.after#) |of| (|fetch| objectdatum - |of| nbrobj) - |with| (concat " " (convert.tabs.to.spaces toc.string)))))))) (CONVERT.TABS.TO.SPACES (LAMBDA (STRING) (* \; "Edited 25-Jan-97 11:49 by rmk:") (* |fsg| "10-Mar-87 11:01") (* |;;| "Returns a string with all tabs and CR's converted to spaces. We do this because some features like the Table-Of-Contents use a tab to align the page numbers.") (AND (STRINGP STRING) (CONCATLIST (FOR CHAR IN (CHCON STRING) COLLECT (CHARACTER (SELCHARQ CHAR ((CR TAB LF) (CHARCODE SPACE)) CHAR))))))) (create.toc.file - (lambda (stream window) (* |fsg| "16-Jul-87 11:46") - (* * |Here| |to| |print| |the| |Table| o\f |Contents.| - |Each| |Line| |of| |the| toc |consists| |of| |the| |NGroup,| |the| - |corresponding| |text,| |followed| |by| |the| |current| |listing| |page| - |number.|) - - (let ((toc.list (tsp.list.of.objects (textobj window) - (function ngroup.toc.entries))) - (toc.file (get.toc.file (windowprop window 'imageobj.menuw))) - (toc.tabstop (list 'paralooks (list 'tabs (list nil (cons (fixr (times 72.27 6.125)) - 'dottedleft))))) - toc.stream) - (cond - ((and toc.list toc.file) - (setq toc.stream (opentextstream nil nil nil nil toc.tabstop)) - (tedit.promptprint stream (concat "Putting Table-Of-Contents into file " toc.file "...") - t) - (write.toc.file toc.stream toc.list window) - (tedit.promptprint stream "done") - (tedit.put toc.stream toc.file) - (closef? toc.file) - toc.file) - (toc.list (tedit.promptprint stream - "Specify a file name for the Table-Of-Contents first." t) - nil) - (t (tedit.promptprint stream "There are no NGroups included in the Table-Of-Contents." t) - nil))))) (ngroup.toc.entries - (lambda (nbrobj) (* |fsg| "16-Jul-87 11:20") - (* * |Check| |if| nbrobj |is| \a |NGroup| |ImageObject| |and| |its| ng.addtotoc - |flag| |is| |on.|) - - (and (ngroupp nbrobj) - (|fetch| (ngtemplate ng.addtotoc) |of| (|fetch| (numberobj template) - |of| (|fetch| objectdatum |of| nbrobj)))))) (view.toc.file - (lambda (stream window) (* |fsg| "12-Aug-87 16:36") - (* * |Writes| |out| |the| toc |file| |via| create.toc.file |and| |then| |opens| - |another| |TEdit| |window| |where| |this| |new| |file| |is| |displayed.|) - - (let ((toc.file (create.toc.file stream window))) - (and toc.file (progn (or (windowprop window 'toc.window) - (windowprop window 'toc.window (createw nil (concat - "Viewing TOC file: " - toc.file)))) - (tedit toc.file (windowprop window 'toc.window))))))) (get.toc.file - (lambda (menuw) (* \; "Edited 29-Sep-87 15:17 by fsg") - - (* * |Return| |the| |user| |specified| |Table-Of-Contents| |file| |name.|) - - (let ((filename (fm.itemprop (fm.getitem 'toc.file nil menuw) - 'label))) - (and (not (strequal filename "")) - (mkatom filename))))) (write.toc.file - (lambda (toc.stream toc.list window) (* |fsg| "26-Aug-87 15:37") - (* * |Here| |to| |speficy| |the| |order| |of| |the| |Table-Of-Contents.| - |The| toc |is| |ordered| |by| |the| |top-level| |sister| |nodes.|) - - (dspfont (fontcreate '(helvetica 14 brr)) - toc.stream) - (printout toc.stream "Table of Contents" t) - (|for| toc.mother |in| (toplevel.sisters window) - |do| (dspfont |GP.DefaultFont| toc.stream) - (printout toc.stream t) - (|for| toc.item |in| toc.list |when| (|with| numberobj (|fetch| objectdatum - |of| (car toc.item)) - (eq (get.ngroup.mother ref.type window) - toc.mother)) - |do| (write.toc.entry toc.item toc.stream window))))) (write.toc.entry - (lambda (toc.item toc.stream window) (* |fsg| "27-Jul-87 14:55") - (* * |Write| |one| |line| |to| |the| |Table-Of-Contents| |file.|) - - (let* ((datum (|fetch| objectdatum |of| (car toc.item))) - (item.level (length (list.ancestors (|fetch| (numberobj ref.type) |of| datum) - nil window)))) - (dspfont |GP.DefaultFont| toc.stream) - (cond - ((zerop item.level) - (printout toc.stream t)) - (t (rptq item.level (printout toc.stream " ")))) - (dspfont (|fetch| (numberobj font) |of| datum) - toc.stream) - (printout toc.stream (concat (or (|fetch| (numberobj text.before#) |of| datum) - "") - (|fetch| (numberobj numstring) |of| datum) - (or (|fetch| (numberobj text.after#) |of| datum) - ""))) - (dspfont |GP.DefaultFont| toc.stream) - (printout toc.stream (character (charcode tab)) - (|fetch| (numberobj page.number) |of| datum) - t)))) ) (PUTPROPS TMAX-NGROUP COPYRIGHT ("Xerox Corporation" 1987 1997)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1660 40131 (INSERT.NGROUP 1670 . 3281) (VERIFY.NGROUP.ORDER 3283 . 5076) ( GET.PREVIOUS.NGROUPS 5078 . 5447) (ADD.NUMBER.GROUP 5449 . 7814) (ADD.NGROUP.TO.DBASE 7816 . 8622) ( COLLECT.NGROUPS 8624 . 9221) (LIST.FONT.PROPS 9223 . 9491) (MAP.NGROUP.LOOKS 9493 . 10982) ( NGROUP.GETFONT 10984 . 11634) (CHANGE.NGROUP 11636 . 12337) (CHANGE.NGROUP.FONT 12339 . 13797) ( SHOW.NGROUP.FONT 13799 . 14517) (CHANGE.NGROUP.FORMAT 14519 . 16245) (SHOW.NGROUP.FORMAT 16247 . 18824 ) (CHANGE.NGROUP.FORMAT.TXTBEFORE 18826 . 20365) (CHANGE.NGROUP.FORMAT.DISPLAY 20367 . 23015) ( CHANGE.NGROUP.FORMAT.TXTAFTER 23017 . 24551) (GET.NGROUP.DELIMITER 24553 . 26242) ( CHANGE.NGROUP.FORMAT.ABBREV 26244 . 28836) (CHANGE.NGROUP.FORMAT.START 28838 . 29916) ( GET.NGROUP.START 29918 . 31390) (CHANGE.NGROUP.FORMAT.TOC 31392 . 33276) ( CHANGE.NGROUP.FORMAT.MANINDEX 33278 . 35618) (UPDATE.NGROUP.MANINDEX 35620 . 36916) ( NGROUP.FIXUP.RECORDS 36918 . 40129)) (40176 47813 (GET.NGROUP.TEXTSTRING 40186 . 41565) ( CONVERT.TABS.TO.SPACES 41567 . 42322) (CREATE.TOC.FILE 42324 . 43848) (NGROUP.TOC.ENTRIES 43850 . 44322) (VIEW.TOC.FILE 44324 . 45119) (GET.TOC.FILE 45121 . 45519) (WRITE.TOC.FILE 45521 . 46523) ( WRITE.TOC.ENTRY 46525 . 47811))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-NUMBER.LCOM.~3~ b/lispusers/TMAX-NUMBER.LCOM.~3~ deleted file mode 100644 index fd1c76683c278dd6371951ac40ac8a7e198407c8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 15075 zcmb_jU5p#ob>{4@E!z!UucZWr>bkcyU~`Qu!y)%SwYx)dxSU=7i9gaR7FtsxS4){% zZuZBv8U{^@A_3C&A!&oaF46!+AJU=^@>&9HCB?qh??sTlx9{pxAJgxgbMMTM%avA6 z^&rmNnYlmb=R4my_ijAr=Do5zoA-+DtXIxg)GJjdyWy<4D(00NZmsCmt1C-HpH{6_xspZ*H>&|Q{X)h^zaV0&!lAMpJcw{CaZz0RFwnBno9-93z#Oe%Y6C26muQ`G+f4cL3VJy3)0&OpUV+^s^t zDu3APsrsG${^5ZNPdAZB#MGeOI_Ti5p@k%uR?Ex5o z8N!eH6H_a>rD(jWlB(=p!9N?x)c5XYreKGiV={b5dZAA(<>4N|J9lAPk|3W0bm{i<5)>5ris%n02_&z=F z-;3qLFc#(meVowLLK5p4R^Hrl@V=UxQzQm-qn1>x+&}2N3S;xvS``VCB)k$Pg(ZI( zQ@2*zKjVe)+W6`rW^bqb+0pFLsl6B)Ytama0oH1jW_3*OzsJ2lOY*sQe)Vbk{X8-; zVfkZ(7E1%9(n|VLcG@2t?Pd*$9AKpAT!qnUTUn6TGL=mQ`KoNQR&&dZ#MNr0j)pl^ z&eRfYCRLb8rI<4}dToh@vxfILYCL$ANq0`gWmFH#AFIu0i1|pueCbk`INRtJ~qb&mY@YrKn zS$AX7@DU!$KkIMUCh2AU;ne!k`E`$Pe!jlyu@N2@`TL`<6@$UXU-IiRhhryr`CrX| zS6;AQI$o6*LNh$Nd~DvpOthmECM+ISKQYax4DrdI@_San(sRCBmc<_BwNSMDCb;?a z>4~RH@OO7(xZH*~nIM2*B`lx?gko{<2e4fOWT4tJKuOoI-QLE$7M=ESiR` ztGSdvm-GpkNY5?spgFgmt$Ec3I!WWLOr=@Qk)x(l0q&`E5&(vdA-$y1?yXXUGz=<` zh3z-n^H_kB#e5;Zy7vuSq%o9J@`_j0B9LD`nFp$HkB}?e8+{q44aOyiOf95TET#}M z>1R2qV$Gd)XREsdenF99tJ~?def&&RYc5$#BLJUAgNO!yjT~t+34reRCM|%jhC`r4 z{S=TG=iy;zOg*79z95cv?>XZ;gz{;CpD};io--!8JQp<2WAY(up(rzKEa)Q~=qOaA z5XDIeFdwa!)Pkr3KN>@a)nUUDparb23J_-Zop1CWRG@kH>=xUYfFEwl~JYbZVX zN?5h)jPef*zB1VU!@9YZhZ`FCH@Hu38-E#w<#ho|T7#a-jK*MxyVIEaD~>$|fq(TM zw|@P7bEAKsy~QL6_LKtrm?*5>Sz>Mqr~nAAXC1KrR0^@(=>FB4e8G&xcs+ok?R<+^u-=0SOFuYb5ZpcrRxRw3qV z(|}`%B?Wkjxd(5~`r8<_ zJNKVmW!+6YLn(uAMbqae*SWnnDZ2fizuhie{It-vjxHXv{`u(-n?EmDf|)>3>&V7` z>j5mXb$s$N8ohP4wPR0gXTp+OfZS(Jsy@I^|aYWLkhyVC-wbX${0 zFP~lIE>ZS;IdE8#LEy1e{*ZK){Ip(a*0OGp{c&-TZTar+w=HpXzO{Z?x__>?eeqAeTYT-`CMNIySNTQxIvN_qj6q=En^^zd z=U-r`mkDtTt*_*8KCv8(U_l|1at}iHP$BDT%Jc^$*ES6Dy4|V zGW^2~-8xbr})EmC>%$tBg z#k!h{Bu$ESMIzrIJ6zFYhGuFl2pTZ0|DB3No?+-eeuv<)H}&7Q9)2G5u=1lOBxu zfoJ_DkTn$Vgu91w1SrC!i9}mg)vHYjAi3S zV9G-eMg}A_#U!!?r@V#&e=6x`>oyp)z$A>@bfIj}@uE|gDa&#YB=8k^K`7PN5R0(l ze+oLrWa?xGktpo&QB8kGgWp;dQZ(e)DAhWWI7gMb=y zciKCsx5gBpBi3l$R9pQ$b+C;ueQ+j{G+Ms(OWwwt#<;_Z6^Tr+-3TiQ87>u~HCG|3 zBhSx=-tEGoG@(sX)rPDoO(9S&PzN${6P!!R1HzvLB@~WlMxvWTB>FZM2*F(IeDE!- zYfQxT7gTkq5(`JS0~A0_fP-g39#YNyJzCuA-G1AmwH$SVR5;A1bgm0W4H_(Z$0|5Nu=r-XZSLfuBb@3yBFB%mDF`68p3Zwv0U5(@P^B8v3Z(}rD`Z7D z?OxI00rxY}6M2J!y(Zg~v3`W5EO?K@kNqTf{!agd@-bEc)uI zNQDH*OcDS27g}JK3MTS_>!HY3&eCSVXo3QwLMp|C0VI!^e=zl6ZaifnmYC)nP_4Di z3d7Wd(etEvDq_XktdfE?0d>HMM|de}P)G}i^MRm^jkyTLv>41djq>4W?u4SkXu8H? zXN{Z!qS}D9$ggnHOL#(|OO}R91TV8efK*6q8s5U|_cx;`$I;KcGV((BKJ7OoJnTu; zp;f~a6aG`+VCcEY{e$PkRpoPt_nS{mMyA9HSfJTJw$rJpcPN3}o zL4O0fgQA3~Z9{Tnvf&||f&9Uyv1jZwiw)|m;1+Wr9H3&^BIVDBdn$#U%&AFwN}TM~ z0l2l_NrIZMP!8#=p)(ZmfzqYU&LM%Vs6%$7d4tDSDcLmXlGre92GKQd8HP1DgjYtH zkau<>0>T>z*AH7x}W}pf`aWX95V=p6!BOl3j2P7DZa}2uVk)cdy4)I;~ zrgLu5MVWwRsSEayEUZCl_EP@Qb_k_}fgCbH;zb`C5d~XlL8mMiLYol__C5G3uptdJ z;;7rJ?5_--lFbBL2qz|>mE&uqUZ{xp^|*!taD{v%PK4w>gGo$^u*IB1I$-l=#22PU zC^C-NAmADE3`!^>e5T1FMMzCjH8LqwD477*wu-GNg^>OxH~?ZEQ<%Ufwd`as(14=A zr*5NtNXAG46BPSA7(2|43Wv0Rh)h@-o*Z8mbic69&!4s;PlX|1buxGVIhN1Ik&m`7 zejNF6+j=`-sF%ew?|zdF`r(JGrs189lP}30V(6u>o0ooeyqXmZVl9}B%byOl3hCWo zr})&nf3C27@f+VQy!IL5@Z?{7{F__rFHTQ9#q%ifJA^XG_mN5=Ww4RMo5~zwuSkDL z=!sV;(?JOVH1!dWQD+_dSWXyF!Z!ACW3%Dpae_rrS$SOdX448g@nfH(gNzGRW4DU) zH1RGlaV`{+&7nktJu({!qKstYU;tmeif_5TXgUBZl}mntLWoSBSi&Ma-At8sF=eM* zkvsSk2r^IsP_lCyFZ%@sDKx5lfA4ndKyQE%_QZoeOvnCU!4yJM^QS-Kd(1eUX=DZx z0GZ*0bZUdDiv-U4mf~){=v;<`&J5N6G#QCZWn{aC4r_>CJp4OiMc>iX$P!4=kABRa z@|XO7!QvlAI=08@iHY^2xiN1_HFC@Y{`SGRVb@QDy6*dOp5iML_Qd}4Y9%=;@uDS(W_I=hWy^AAJbd3<$NrL&oIKpr%?sHcoiy%O%I^{Mv#J>3+ ze)kV|cl&z>xZ2w5-yW#4S5SkSd#xQb)oQcJY{_|ckn?T zZ@r7(wQleB;oe@0+FCo*dA)VJOF!GKZa;y;dieT{@RZ74Q4K;{7kix6pL|QjInJ=~}FQakM5Q&0}f; zddg#R>yt^OVQwcnKf!_ZEJBo0Z+L#x{w(k8p0SuEFKjUbl6<*CBn2T5BDg z$|U{rk&CXcE2@DTLXQmZ_n(E6snPGij7=UDH(L=sNJwXpAU`x}WHAtZ;obGTR?kWUkZe-tJP^%y6tc%Ro`1RiBg%>9wQU zey2FMd!y6t?%b48q*#`yLB|2rz%{uZsG0zV#w3}C#7O1RwnUjun+J;` zT9|b@L=w)jOf#M#n!{EQUgcK5*XzGOc9jw^yEwC~iWIQUG;maVjn8apt@Yi`jqcVR zEVP5&lh)n=jn|_-Rex(}`R}!QhuYTb=Ecj@_C#Vvoxaux2{|NSK!ZPnV6f<*K?plr z*_zG5ondu2u6@FTPgQH9l4S{dJ2!fV?at7Ou-!<@KG8oZ_u5xiRop4(R9tpP`79)k z3(_h7+#jpBq&u8z>m)cH6;RS!(CoNWiBxg6ALVLQikim?&1+=CUe!{BJXyS*h zP)IvVATfm!Q(+)Bq^AXLaVjSJnDj)UWpps@Cs7G6GeZOa)`8~4U|OdfY|c8=S;Ef9 zKt8;3=sD{^XAVMUw5YE!zxa5X(U6WF5t4k<88*kL87Z^`Q?@o0zVS-(jpHl<3*yrJ z=9GCnb{Zj|mt>T2$PcAqq(6H+JKLP1r^?1m>I+1>lff?f|0p7^teh^PFBA(;(cI%L z$Ve$1DWhL3RB{Djlmz|O6BC1?Y8gd!QymtLNKKlM##!3(>b$+hpJ*>vW#F$ zgPo?jG2!PC8CUSfP$nayjVY-J=?$#Ya7Nty5wR(pQXx3y_^>>c#z8bR_=L7ye6a}H zgj|inlK!~GyA=LrxzA8f50HND7D}|f*c5zo0Acl$F6y4q7L>IE+Nireu_JTJqWGI( zuIBg1j9_T0e)9cjS&g9*(kV-ckI-QOCVh=#g9wSNN+>yeRJ%I#nxET3WeLD!jgLIx znkt90Y@+B4c`*zr^C>bfL8i#gJ=Q6DAlSr1o? vP;RSU<-ZHSpOkKP_WB>FY<~}xs}@xuP-|PppAOl}^p}m;q(?6xRnh+gHJDTd diff --git a/lispusers/TMAX-NUMBER.~1~ b/lispusers/TMAX-NUMBER.~1~ deleted file mode 100644 index ab15f69c..00000000 --- a/lispusers/TMAX-NUMBER.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "30-Dec-87 11:36:36" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NUMBER.;2| 34569 |previous| |date:| "11-Nov-87 11:54:01" |{POGO:AISNORTH:XEROX}TMAX>TMAX-NUMBER.;1|) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint tmax-numbercoms) (rpaqq tmax-numbercoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * tmax-numbernil |ImageObject| |functions|) (fns numberobj numberobjp ngroupp number.displayfn number.imageboxfn number.putfn number.getfn number.copyfn number.buttoneventinfn) (fns copy.ngroup.branch dump.ngroup.graph ngroup.buttoneventinfn ngroup.define.tag number.delete.tag ngroup.show.tag change.inserted.ngroup.format change.ngroup.format.#text show.inserted.ngroup.format) (* * |Variable| |and| |Record| |definitions|) (vars ngroup.graph.menu.items ngroup.inserted.menu.items ngroup.inserted.notag.items ngroup.inserted.tag.items) (records ngcounter ngtemplate numberobj))) (* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * tmax-numbernil |ImageObject| |functions|) (defineq (numberobj (lambda (use template numstring ref.type font mother abbrev.level) (* |fsg| "26-Aug-87 14:29") (let ((newobj (imageobjcreate (|create| numberobj ref.type _ ref.type numstring _ (or numstring "Note#") use _ use ngroup.mother _ mother template _ template updated.obj _ nil text.after# _ nil page.number _ nil font _ font text.before# _ nil abbrev-val _ abbrev.level) \\numberobj.imagefns))) (imageobjprop newobj 'type 'numberobj) newobj))) (numberobjp (lambda (imobj) (* |ss:| "27-Jun-87 16:21") (* * |Tests| |an| |imageobj| |to| |see| |if| |it| |is| \a |number|  |imageobject.| |The| |only| |number| |imageobjects| |so| |far| |are| |NGroups|  |and| |Endnotes.| b\y |convention,| |testing| |functions| |for| |an|  |imageobject| |will| |be| |named| (concat || "P")) (and imobj (eq (imageobjprop imobj 'type) 'numberobj)))) (ngroupp (lambda (imobj) (* |ss:| "27-Jun-87 16:15") (* * |Like| numberobjp |but| |also| |checks| |for| |NGroup| |ImageObject.|) (and (numberobjp imobj) (eq (|fetch| (numberobj use) |of| (|fetch| objectdatum |of| imobj)) 'ngroup)))) (number.displayfn (lambda (image.obj stream) (* |fsg| "24-Sep-87 14:56") (* |Display| |function| |for| |numberobjs.|  |Allows| |different| |formats| |for| |display| |according| |to| |the| |use|  |to| |which| |the| |numberobj| |is| |being| |put.|  i\f |no| |specific| |action| |is| |specified,| |displaying| |defaults| |to|  |printing| |out| |as| \a |plain| |number.*|) (|with| numberobj (|fetch| objectdatum |of| image.obj) (let* ((main.window (|with| textobj textobj (car \\window))) (image.tag (imageobjprop image.obj 'tag)) (old.font (dspfont nil stream)) (nbr.font (selectq use (note (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts main.window))) (ngroup font) (error "Undefined USE field" use)))) (and image.tag (or (tsp.getcodeval image.tag main.window) (tsp.putcode image.tag image.obj main.window))) (and (fontp nbr.font) (dspfont (fontcreate (fontprop nbr.font 'family) (fontprop nbr.font 'size) (fontprop nbr.font 'face)) stream)) (or (imagestreamtypep stream 'display) (setq page.number (car formattingstate))) (tmax.shadeobj image.obj stream) (selectq use (ngroup (prin1 (concat (or text.before# "") (mkstring numstring) (or text.after# "")) stream) (or (imagestreamtypep stream 'display) (update.ngroup.manindex template ref.type main.window))) (note (let ((current.ypos (dspyposition nil stream)) (imagebox (listget (|fetch| imageobjplist |of| image.obj) 'boundbox))) (dspyposition (iplus current.ypos (idifference (|fetch| ysize |of| imagebox) (fontprop stream 'height))) stream) (prin1 (mkstring numstring) stream) (dspyposition current.ypos stream))) nil) (dspfont old.font stream))))) (number.imageboxfn (lambda (obj stream currentx rightmargin) (* |fsg| " 4-Aug-87 14:56") (* * |For| |Endnote| |numbers,| |the| |YSize| |is| |the| |current| |font|  |height| |plus| 0.25 |times| |the| |Endnote| |number| |font| |height.|  w\e |do| |this| |so| |the| |the| |Endnote| |number| |will| |be| |superscripted|  |but| |not| |too| |much.|) (* * |The| |YSize| |is| |computed| |as| |the| |current| |font| |height| |plus|  |half| |of| |the| note |or| |NGroup| |font.|  |The| |reason| |is| |weird.| |Ask| |Sami| |for| |more| |details.|) (|with| numberobj (|fetch| objectdatum |of| obj) (let* ((main.window (|with| textobj textobj (car \\window))) (imobj.string (mkstring numstring)) (nbr.font (selectq use (note (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts main.window))) (ngroup font) (error "Undefined USE field" use)))) (and (eq use 'ngroup) (progn (and (stringp text.before#) (setq imobj.string (concat text.before# imobj.string))) (and (stringp text.after#) (setq imobj.string (concat imobj.string text.after#))))) (and (fontp nbr.font) (dspfont (fontcreate (fontprop nbr.font 'family) (fontprop nbr.font 'size) (fontprop nbr.font 'face)) stream)) (|create| imagebox xsize _ (stringwidth imobj.string stream) ysize _ (selectq use (note (fix (plus (times (dspscale nil stream) (fontprop (current.display.font stream) 'height)) (times 0.25 (fontprop stream 'height))))) (fontprop stream 'height)) ydesc _ (fontprop stream 'descent) xkern _ 0))))) (number.putfn (lambda (obj stream) (* |fsg| " 5-Aug-87 08:24") (let ((window (|with| textobj textobj (car \\window))) (use (|with| numberobj (|fetch| objectdatum |of| obj) use)) (old.font (|with| numberobj (|fetch| objectdatum |of| obj) font))) (selectq use (note (note.putfn obj stream window)) (ngroup (let ((ngroup.rec (copy (|fetch| objectdatum |of| obj)))) (|with| numberobj ngroup.rec (setq font (list.font.props font)) (prin4 (list '|NGroup| (and (windowprop window 'dumpngroupgraph) (dump.ngroup.graph window)) (imageobjprop obj 'tag) ngroup.rec) stream)))) (error "Unknown NUMBER ImageObject type" use))))) (number.getfn (lambda (stream copy.object) (* |fsg| " 3-Sep-87 15:17") (* * i\f copy.object |is| |non-NIL| |then| |we| |are| |COPYing| |it| |to|  |this| |window.|) (let ((nbrobj.datum (or copy.object (cdr (read stream)))) (newobj (numberobj)) (window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window) (and (ilessp (length nbrobj.datum) 3) (setq nbrobj.datum (cons nil nbrobj.datum))) (and (car nbrobj.datum) (not (and (boundp 'tmax.prune.ngraph) tmax.prune.ngraph)) (copy.ngroup.branch (car nbrobj.datum) window)) (and (cadr nbrobj.datum) (not (gethash (cadr nbrobj.datum) (windowprop window 'tsp.code.array))) (progn (tsp.putcode (cadr nbrobj.datum) newobj window) (imageobjprop newobj 'tag (cadr nbrobj.datum)))) (|with| numberobj (setq nbrobj.datum (ngroup.fixup.records (caddr nbrobj.datum) copy.object)) (selectq use (note (note.getfn newobj nbrobj.datum window)) (ngroup (and (listp font) (setq font (fontcreate font))) (create.ngroup.node ref.type ngroup.mother nbrobj.datum window) (create.ngroup.node ngroup.mother nil nil window) (add.ngroup.to.mother.node ref.type ngroup.mother window) (windowprop window 'rebuild.graphflg t) (and (|fetch| (ngtemplate ng.manualindex) |of| template) (windowaddprop window 'manualgroups ref.type)) (|replace| objectdatum |of| newobj |with| nbrobj.datum)) (error "Unknown USE type in NUMBER.GETFN" use))) newobj))) (number.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| " 4-Aug-87 09:46") (* * |Here| |to| copy \a |Number| |Image| |Object.|  i\f |we| |are| |copying| |to| |our| |own| |window,| |we| |delete| |the| tag  |if| |any| |so| |we| |don't| |get| |two| |ImageObjs| |with| |the| |same| tag  |name.|) (selectq (imagestreamtype target.stream) (text (let ((source.window (|with| textobj textobj (car \\window))) (textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (list (|with| numberobj (|fetch| objectdatum |of| image.obj) (and (eq use 'ngroup) (neq source.stream target.stream) (|for| parent |in| (append (list.ancestors ref.type nil source.window) (list ref.type)) |collect| (car (gethash parent (tsp.get.ngroup.array source.window)))))) (and (neq source.stream target.stream) (imageobjprop image.obj 'tag)) (|fetch| objectdatum |of| image.obj))))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (number.buttoneventinfn (lambda (obj stream sel relx rely window hoststream button)(* |fsg| " 2-Sep-87 11:09") (* * |Here| |when| \a |NumberOBJ| |is| |left| |or| |middle| |buttoned.|  |Left| |just| |dislays| |the| |Tag| |if| |any| |in| |the| |prompt| |window.|  |Middle| |pops| |up| \a |menu| |allowing| |this| |user| |to| |do| |various|  |things.|) (and (mousestate left) (cond ((imageobjprop obj 'tag) (|with| numberobj (|fetch| objectdatum |of| obj) (tedit.promptprint stream (concat "Tag for this " (selectq use (note "Endnote") (ngroup ref.type) (error "Undefined USE code" use)) " is \"" (imageobjprop obj 'tag) "\"") t))) (t (tedit.promptprint stream "" t)))) (and (mousestate middle) (let* ((datum (|fetch| objectdatum |of| obj)) (use (|fetch| (numberobj use) |of| datum)) (ref.type (|fetch| (numberobj ref.type) |of| datum))) (and (selectq use (note (note.buttoneventinfn obj stream window)) (ngroup (ngroup.buttoneventinfn ref.type obj stream window)) (error "Undefined USE code" use)) (progn (tedit.promptprint stream "" t) 'changed)))))) ) (defineq (copy.ngroup.branch (lambda (ngroup.parents window) (* |fsg| "11-Aug-87 09:36") (* * |Build| |the| |NGroup| |database| |for| |the| |parents| |of| \a |copied|  |NGroup| |or| |the| |entire| |NGroup| |database| |on| \a get.) (|for| parent |in| ngroup.parents |do| (and parent (|with| numberobj parent (and (listp font) (setq font (fontcreate font))) (or ngroup.mother (setq ngroup.mother 'new.ngroup)) (create.ngroup.node ref.type ngroup.mother parent window) (create.ngroup.node ngroup.mother nil nil window) (add.ngroup.to.mother.node ref.type ngroup.mother window)))))) (dump.ngroup.graph (lambda (window) (* |fsg| " 3-Aug-87 16:03") (* * |Return| \a |list| |of| |the| |NGroup| |graph| |data| |that| |is| put  |along| |with| |the| |NGroup| |Imageobject.|  w\e |can| |then| |rebuild| |the| |entire| |NGroup| |graph| |on| \a get.) (let ((graph.list (tconc nil))) (maphash (tsp.get.ngroup.array window) (function (lambda (val key) (and (neq key 'new.ngroup) (let ((ngroup.rec (copy (car val)))) (|with| numberobj ngroup.rec (setq font (list.font.props font)) (tconc graph.list ngroup.rec))))))) (windowprop window 'dumpngroupgraph nil) (cdar graph.list)))) (ngroup.buttoneventinfn (lambda (ref.type ngroup.obj stream window) (* |fsg| " 5-Aug-87 08:31") (* * |Here| |when| |an| |inserted| |NGroup| |is| |middle| |buttoned.|) (let ((tag (imageobjprop ngroup.obj 'tag)) (graphw (windowprop window 'imageobj.menuw))) (menu (|create| menu title _ (concat ref.type " Menu") items _ (append (cond (tag ngroup.inserted.tag.items) (t ngroup.inserted.notag.items)) ngroup.inserted.menu.items) centerflg _ t))))) (ngroup.define.tag (lambda (ref.type window ngroup.obj) (* |fsg| " 5-Aug-87 09:26") (* * |Define| \a tag |for| |this| |NGroup| |or| |Change| |the| tag |if| |it|  |already| |exists.|) (let ((old.tag (imageobjprop ngroup.obj 'tag)) (new.tag (tsp.get.incode (textstream window)))) (and new.tag (neq new.tag old.tag) (progn (and old.tag (number.delete.tag window ngroup.obj)) (tsp.putcode new.tag ngroup.obj window) (imageobjprop ngroup.obj 'tag new.tag)))))) (number.delete.tag (lambda (window ngroup.obj) (* |fsg| " 5-Aug-87 09:27") (* * |Delete| |this| |Imageobj's| tag.) (tsp.putcode (imageobjprop ngroup.obj 'tag nil) nil window) nil)) (ngroup.show.tag (lambda (ref.type window ngroup.obj) (* |fsg| " 5-Aug-87 08:43") (* * |Show| |this| |NGroup's| tag.) (tedit.promptprint (textstream window) (concat ref.type ": Tag=\"" (imageobjprop ngroup.obj 'tag) "\"") t))) (change.inserted.ngroup.format (lambda (ref.type ngroup.obj stream window format.field) (* |fsg| " 1-Sep-87 15:33") (* * |Change| |an| |inserted| |NGroup's| |entire| |format| |or| \a |selected|  |field.|) (let ((graphw (windowprop window 'imageobj.menuw)) (new.format (|for| field |in| (cond (format.field (list format.field)) (t '(txtbefore display txtafter abbrevval before#txt after#txt))) |collect| (selectq field (txtbefore (change.ngroup.format.txtbefore ref.type graphw ngroup.obj)) (display (change.ngroup.format.display ref.type graphw ngroup.obj)) (txtafter (change.ngroup.format.txtafter ref.type graphw ngroup.obj)) (abbrevval (change.ngroup.format.abbrev ref.type graphw ngroup.obj)) (before#txt (change.ngroup.format.#text ref.type window ngroup.obj 'before)) (after#txt (change.ngroup.format.#text ref.type window ngroup.obj 'after)) (error "Unknown NGroup Format field" field))))) (apply 'or new.format)))) (change.ngroup.format.#text (lambda (ref.type window ngroup.obj flavor) (* |fsg| "25-Aug-87 14:48") (* * |Change| |the| |text| |before| |or| |after| |an| |inserted| |NGroup|  |regardless| |of| |the| |Text| |Before| |or| |Text| |After| |toggle|  |settings.|) (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) (let ((old.string (selectq flavor (before text.before#) text.after#)) (new.string (tedit.getinput (textstream window) (concat (selectq flavor (before "Text before ") "Text after ") ref.type ":")))) (and new.string (setq new.string (concat (selectq flavor (before "") " ") (convert.tabs.to.spaces new.string) (selectq flavor (before " ") "")))) (selectq flavor (before (setq text.before# new.string)) (setq text.after# new.string)) (not (strequal old.string new.string)))))) (show.inserted.ngroup.format (lambda (ref.type ngroup.obj stream window) (* |fsg| "26-Aug-87 12:05") (* * |Show| |the| |format| |of| |an| |inserted| |NGroup.|) (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) (|with| ngtemplate template (tedit.promptprint stream (concat ref.type ": Display=" (concat (cond (ng.text-before (concat "\"" ng.text-before "\"")) (t "\"\"")) ng.chartype (cond (ng.text-after (concat "\"" ng.text-after "\"")) (t "\"\""))) " Abbrev=" (or abbrev-val "None")) t))))) ) (* * |Variable| |and| |Record| |definitions|) (rpaqq ngroup.graph.menu.items `((|Change Font| (change.ngroup.font label graphw) "Change this NGroup's entire FONT." (subitems (|Family| (change.ngroup.font label graphw 'family) "Change this NGroup's font family.") (|Size| (change.ngroup.font label graphw 'size) "Change this NGroup's font size.") (|Face| (change.ngroup.font label graphw 'face) "Change this NGroup's font face."))) (|Show Font| (show.ngroup.font label graphw) "Show this NGroup's FONT.") (|Change Format| (change.ngroup.format label graphw) "Change this NGroup's entire FORMAT." (subitems (|Delimiter Before| (change.ngroup.format label graphw 'txtbefore) "Change the delimiter preceding this NGroup." ) (|Display Type| (change.ngroup.format label graphw 'display) "Change how this NGroup is displayed.") (|Delimiter After| (change.ngroup.format label graphw 'txtafter) "Change the delimiter following this NGroup.") (|Abbreviate Level| (change.ngroup.format label graphw 'abbrevval) "Specify the starting level of this NGroup value." ) (|Starting Value| (change.ngroup.format label graphw 'start) "Change this NGroup's starting value.") (|Table-Of-Contents| (change.ngroup.format label graphw 'toc) "Include this NGroup in the Table-Of-Contents." ) \,@ (and (manualindex.enabled? (windowprop graphw 'twindow)) (list (list '|Manual Index| (function (change.ngroup.format label graphw 'manindex)) "Include this NGroup in the Manual Index page numbers." ))))) (|Show Format| (show.ngroup.format label graphw) "Show this NGroup's FORMAT."))) (rpaqq ngroup.inserted.menu.items ((|Change Font| (change.ngroup.font ref.type graphw nil ngroup.obj) "Change this NGroup's entire FONT." (subitems (|Family| (change.ngroup.font ref.type graphw 'family ngroup.obj) "Change this NGroup's font family.") (|Size| (change.ngroup.font ref.type graphw 'size ngroup.obj) "Change this NGroup's font size.") (|Face| (change.ngroup.font ref.type graphw 'face ngroup.obj) "Change this NGroup's font face."))) (|Show Font| (show.ngroup.font ref.type graphw ngroup.obj) "Show this NGroup's FONT.") (|Change Format| (change.inserted.ngroup.format ref.type ngroup.obj stream window) "Change this NGroup's entire FORMAT." (subitems (|Delimiter Before| ( change.inserted.ngroup.format ref.type ngroup.obj stream window 'txtbefore) "Change the delimiter preceding this NGroup." ) (|Display Type| (change.inserted.ngroup.format ref.type ngroup.obj stream window 'display) "Change how this NGroup is displayed.") (|Delimiter After| (change.inserted.ngroup.format ref.type ngroup.obj stream window 'txtafter) "Change the delimiter following this NGroup." ) (|Abbreviate Level| (change.inserted.ngroup.format ref.type ngroup.obj stream window 'abbrevval) "Specify the starting level of this NGroup value." ) (|Text Before| (change.inserted.ngroup.format ref.type ngroup.obj stream window 'before#txt) "Change the text preceding this NGroup.") (|Text After| (change.inserted.ngroup.format ref.type ngroup.obj stream window 'after#txt) "Change the text following this NGroup."))) (|Show Format| (show.inserted.ngroup.format ref.type ngroup.obj stream window) "Show this NGroup's FORMAT."))) (rpaqq ngroup.inserted.notag.items ((|Define Tag| (ngroup.define.tag ref.type window ngroup.obj) "Define a TAG for this NGroup."))) (rpaqq ngroup.inserted.tag.items ((|Change Tag| (ngroup.define.tag ref.type window ngroup.obj) "Change this NGroup's TAG.") (|Delete Tag| (number.delete.tag window ngroup.obj) "Delete this NGroup's TAG.") (|Show Tag| (ngroup.show.tag ref.type window ngroup.obj) "Show this NGroup's TAG."))) (declare\: eval@compile (record ngcounter (ncount . ancestry)) (record ngtemplate (ng.chartype ng.text-after ng.start ng.addtotoc ng.currentval ng.manualindex ng.text-before)) (record numberobj (ref.type numstring use ngroup.mother template updated.obj text.after# page.number font text.before# abbrev-val)) ) (putprops tmax-number copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (1616 15917 (numberobj 1626 . 2651) (numberobjp 2653 . 3193) (ngroupp 3195 . 3549) ( number.displayfn 3551 . 6590) (number.imageboxfn 6592 . 9085) (number.putfn 9087 . 10171) ( number.getfn 10173 . 12309) (number.copyfn 12311 . 14008) (number.buttoneventinfn 14010 . 15915)) ( 15918 25089 (copy.ngroup.branch 15928 . 17384) (dump.ngroup.graph 17386 . 18262) ( ngroup.buttoneventinfn 18264 . 18964) (ngroup.define.tag 18966 . 19569) (number.delete.tag 19571 . 19830) (ngroup.show.tag 19832 . 20154) (change.inserted.ngroup.format 20156 . 21951) ( change.ngroup.format.#text 21953 . 23539) (show.inserted.ngroup.format 23541 . 25087))))) stop \ No newline at end of file diff --git a/lispusers/TMAX-NUMBER.~2~ b/lispusers/TMAX-NUMBER.~2~ deleted file mode 100644 index 16b856a9..00000000 --- a/lispusers/TMAX-NUMBER.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 6-May-2000 10:37:14" |{DSK}medley3.5>lispusers>TMAX-NUMBER.;4| 32399 |changes| |to:| (FNS NUMBEROBJ.TEDIT-TO-TEX-FN NUMBEROBJ) (VARS TMAX-NUMBERCOMS) |previous| |date:| "18-May-99 22:54:30" |{DSK}medley3.5>lispusers>TMAX-NUMBER.;2|) ; Copyright (c) 1987, 1999, 2000 by Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TMAX-NUMBERCOMS) (RPAQQ TMAX-NUMBERCOMS ((* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * TMAX-NUMBERNIL |ImageObject| |functions|) (FNS NUMBEROBJ NUMBEROBJP NGROUPP NUMBER.DISPLAYFN NUMBER.PREPRINTFN NUMBER.IMAGEBOXFN NUMBER.PUTFN NUMBER.GETFN NUMBER.COPYFN NUMBER.BUTTONEVENTINFN NUMBEROBJ.TEDIT-TO-TEX-FN ) (FNS COPY.NGROUP.BRANCH DUMP.NGROUP.GRAPH NGROUP.BUTTONEVENTINFN NGROUP.DEFINE.TAG NUMBER.DELETE.TAG NGROUP.SHOW.TAG CHANGE.INSERTED.NGROUP.FORMAT CHANGE.NGROUP.FORMAT.#TEXT SHOW.INSERTED.NGROUP.FORMAT) (* * |Variable| |and| |Record| |definitions|) (VARS NGROUP.GRAPH.MENU.ITEMS NGROUP.INSERTED.MENU.ITEMS NGROUP.INSERTED.NOTAG.ITEMS NGROUP.INSERTED.TAG.ITEMS) (RECORDS NGCOUNTER NGTEMPLATE NUMBEROBJ))) (* |Developed| |under| |support| |from| NIH |grant| RR-00785.) (* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* * TMAX-NUMBERNIL |ImageObject| |functions|) (DEFINEQ (NUMBEROBJ (LAMBDA (USE TEMPLATE NUMSTRING REF.TYPE FONT MOTHER ABBREV.LEVEL) (* |fsg| "26-Aug-87 14:29") (LET ((NEWOBJ (IMAGEOBJCREATE (|create| NUMBEROBJ REF.TYPE _ REF.TYPE NUMSTRING _ (OR NUMSTRING "Note#") USE _ USE NGROUP.MOTHER _ MOTHER TEMPLATE _ TEMPLATE UPDATED.OBJ _ NIL TEXT.AFTER# _ NIL PAGE.NUMBER _ NIL FONT _ FONT TEXT.BEFORE# _ NIL ABBREV-VAL _ ABBREV.LEVEL) \\NUMBEROBJ.IMAGEFNS))) (IMAGEOBJPROP NEWOBJ 'TYPE 'NUMBEROBJ) (IMAGEOBJPROP NEWOBJ 'TEDIT-TO-TEX-FN (FUNCTION NUMBEROBJ.TEDIT-TO-TEX-FN)) NEWOBJ))) (numberobjp (lambda (imobj) (* |ss:| "27-Jun-87 16:21") (* * |Tests| |an| |imageobj| |to| |see| |if| |it| |is| \a |number|  |imageobject.| |The| |only| |number| |imageobjects| |so| |far| |are| |NGroups|  |and| |Endnotes.| b\y |convention,| |testing| |functions| |for| |an|  |imageobject| |will| |be| |named| (concat || "P")) (and imobj (eq (imageobjprop imobj 'type) 'numberobj)))) (ngroupp (lambda (imobj) (* |ss:| "27-Jun-87 16:15") (* * |Like| numberobjp |but| |also| |checks| |for| |NGroup| |ImageObject.|) (and (numberobjp imobj) (eq (|fetch| (numberobj use) |of| (|fetch| objectdatum |of| imobj)) 'ngroup)))) (number.displayfn (lambda (image.obj stream) (* |fsg| "24-Sep-87 14:56") (* |Display| |function| |for| |numberobjs.|  |Allows| |different| |formats| |for| |display| |according| |to| |the| |use|  |to| |which| |the| |numberobj| |is| |being| |put.|  i\f |no| |specific| |action| |is| |specified,| |displaying| |defaults| |to|  |printing| |out| |as| \a |plain| |number.*|) (|with| numberobj (|fetch| objectdatum |of| image.obj) (let* ((main.window (|with| textobj textobj (car \\window))) (image.tag (imageobjprop image.obj 'tag)) (old.font (dspfont nil stream)) (nbr.font (selectq use (note (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts main.window))) (ngroup font) (error "Undefined USE field" use)))) (and image.tag (or (tsp.getcodeval image.tag main.window) (tsp.putcode image.tag image.obj main.window))) (and (fontp nbr.font) (dspfont (fontcreate (fontprop nbr.font 'family) (fontprop nbr.font 'size) (fontprop nbr.font 'face)) stream)) (or (imagestreamtypep stream 'display) (setq page.number (car formattingstate))) (tmax.shadeobj image.obj stream) (selectq use (ngroup (prin1 (concat (or text.before# "") (mkstring numstring) (or text.after# "")) stream) (or (imagestreamtypep stream 'display) (update.ngroup.manindex template ref.type main.window))) (note (let ((current.ypos (dspyposition nil stream)) (imagebox (listget (|fetch| imageobjplist |of| image.obj) 'boundbox))) (dspyposition (iplus current.ypos (idifference (|fetch| ysize |of| imagebox) (fontprop stream 'height))) stream) (prin1 (mkstring numstring) stream) (dspyposition current.ypos stream))) nil) (dspfont old.font stream))))) (NUMBER.PREPRINTFN (LAMBDA (IMAGE.OBJ) (* \; "Edited 18-May-99 22:51 by rmk:") (* |fsg| "24-Sep-87 14:56") (* |;;| "Returns string that represents the number object, for plaintext put. If no specific action is specified, displaying defaults to printing out as a plain number.*") (WITH NUMBEROBJ (FETCH OBJECTDATUM OF IMAGE.OBJ) (LET* ((MAIN.WINDOW (WITH TEXTOBJ TEXTOBJ (CAR \\WINDOW))) (IMAGE.TAG (IMAGEOBJPROP IMAGE.OBJ 'TAG))) (AND IMAGE.TAG (OR (TSP.GETCODEVAL IMAGE.TAG MAIN.WINDOW) (TSP.PUTCODE IMAGE.TAG IMAGE.OBJ MAIN.WINDOW))) (SELECTQ USE (NGROUP (CONCAT (OR TEXT.BEFORE# "") (MKSTRING NUMSTRING) (OR TEXT.AFTER# ""))) (NOTE (MKSTRING NUMSTRING)) NIL))))) (number.imageboxfn (lambda (obj stream currentx rightmargin) (* |fsg| " 4-Aug-87 14:56") (* * |For| |Endnote| |numbers,| |the| |YSize| |is| |the| |current| |font|  |height| |plus| 0.25 |times| |the| |Endnote| |number| |font| |height.|  w\e |do| |this| |so| |the| |the| |Endnote| |number| |will| |be| |superscripted|  |but| |not| |too| |much.|) (* * |The| |YSize| |is| |computed| |as| |the| |current| |font| |height| |plus|  |half| |of| |the| note |or| |NGroup| |font.|  |The| |reason| |is| |weird.| |Ask| |Sami| |for| |more| |details.|) (|with| numberobj (|fetch| objectdatum |of| obj) (let* ((main.window (|with| textobj textobj (car \\window))) (imobj.string (mkstring numstring)) (nbr.font (selectq use (note (|fetch| (endnotefonts number.font) |of| (get.endnote.fonts main.window))) (ngroup font) (error "Undefined USE field" use)))) (and (eq use 'ngroup) (progn (and (stringp text.before#) (setq imobj.string (concat text.before# imobj.string))) (and (stringp text.after#) (setq imobj.string (concat imobj.string text.after#))))) (and (fontp nbr.font) (dspfont (fontcreate (fontprop nbr.font 'family) (fontprop nbr.font 'size) (fontprop nbr.font 'face)) stream)) (|create| imagebox xsize _ (stringwidth imobj.string stream) ysize _ (selectq use (note (fix (plus (times (dspscale nil stream) (fontprop (current.display.font stream) 'height)) (times 0.25 (fontprop stream 'height))))) (fontprop stream 'height)) ydesc _ (fontprop stream 'descent) xkern _ 0))))) (number.putfn (lambda (obj stream) (* |fsg| " 5-Aug-87 08:24") (let ((window (|with| textobj textobj (car \\window))) (use (|with| numberobj (|fetch| objectdatum |of| obj) use)) (old.font (|with| numberobj (|fetch| objectdatum |of| obj) font))) (selectq use (note (note.putfn obj stream window)) (ngroup (let ((ngroup.rec (copy (|fetch| objectdatum |of| obj)))) (|with| numberobj ngroup.rec (setq font (list.font.props font)) (prin4 (list '|NGroup| (and (windowprop window 'dumpngroupgraph) (dump.ngroup.graph window)) (imageobjprop obj 'tag) ngroup.rec) stream)))) (error "Unknown NUMBER ImageObject type" use))))) (number.getfn (lambda (stream copy.object) (* |fsg| " 3-Sep-87 15:17") (* * i\f copy.object |is| |non-NIL| |then| |we| |are| |COPYing| |it| |to|  |this| |window.|) (let ((nbrobj.datum (or copy.object (cdr (read stream)))) (newobj (numberobj)) (window (|with| textobj textobj (car \\window)))) (tsp.setup.fmmenu window) (and (ilessp (length nbrobj.datum) 3) (setq nbrobj.datum (cons nil nbrobj.datum))) (and (car nbrobj.datum) (not (and (boundp 'tmax.prune.ngraph) tmax.prune.ngraph)) (copy.ngroup.branch (car nbrobj.datum) window)) (and (cadr nbrobj.datum) (not (gethash (cadr nbrobj.datum) (windowprop window 'tsp.code.array))) (progn (tsp.putcode (cadr nbrobj.datum) newobj window) (imageobjprop newobj 'tag (cadr nbrobj.datum)))) (|with| numberobj (setq nbrobj.datum (ngroup.fixup.records (caddr nbrobj.datum) copy.object)) (selectq use (note (note.getfn newobj nbrobj.datum window)) (ngroup (and (listp font) (setq font (fontcreate font))) (create.ngroup.node ref.type ngroup.mother nbrobj.datum window) (create.ngroup.node ngroup.mother nil nil window) (add.ngroup.to.mother.node ref.type ngroup.mother window) (windowprop window 'rebuild.graphflg t) (and (|fetch| (ngtemplate ng.manualindex) |of| template) (windowaddprop window 'manualgroups ref.type)) (|replace| objectdatum |of| newobj |with| nbrobj.datum)) (error "Unknown USE type in NUMBER.GETFN" use))) newobj))) (number.copyfn (lambda (image.obj source.stream target.stream) (* |fsg| " 4-Aug-87 09:46") (* * |Here| |to| copy \a |Number| |Image| |Object.|  i\f |we| |are| |copying| |to| |our| |own| |window,| |we| |delete| |the| tag  |if| |any| |so| |we| |don't| |get| |two| |ImageObjs| |with| |the| |same| tag  |name.|) (selectq (imagestreamtype target.stream) (text (let ((source.window (|with| textobj textobj (car \\window))) (textobj (textobj target.stream))) (apply* (imageobjprop image.obj 'getfn) target.stream (list (|with| numberobj (|fetch| objectdatum |of| image.obj) (and (eq use 'ngroup) (neq source.stream target.stream) (|for| parent |in| (append (list.ancestors ref.type nil source.window) (list ref.type)) |collect| (car (gethash parent (tsp.get.ngroup.array source.window)))))) (and (neq source.stream target.stream) (imageobjprop image.obj 'tag)) (|fetch| objectdatum |of| image.obj))))) (error "Unknown TARGET stream type" (imagestreamtype target.stream))))) (number.buttoneventinfn (lambda (obj stream sel relx rely window hoststream button)(* |fsg| " 2-Sep-87 11:09") (* * |Here| |when| \a |NumberOBJ| |is| |left| |or| |middle| |buttoned.|  |Left| |just| |dislays| |the| |Tag| |if| |any| |in| |the| |prompt| |window.|  |Middle| |pops| |up| \a |menu| |allowing| |this| |user| |to| |do| |various|  |things.|) (and (mousestate left) (cond ((imageobjprop obj 'tag) (|with| numberobj (|fetch| objectdatum |of| obj) (tedit.promptprint stream (concat "Tag for this " (selectq use (note "Endnote") (ngroup ref.type) (error "Undefined USE code" use)) " is \"" (imageobjprop obj 'tag) "\"") t))) (t (tedit.promptprint stream "" t)))) (and (mousestate middle) (let* ((datum (|fetch| objectdatum |of| obj)) (use (|fetch| (numberobj use) |of| datum)) (ref.type (|fetch| (numberobj ref.type) |of| datum))) (and (selectq use (note (note.buttoneventinfn obj stream window)) (ngroup (ngroup.buttoneventinfn ref.type obj stream window)) (error "Undefined USE code" use)) (progn (tedit.promptprint stream "" t) 'changed)))))) (NUMBEROBJ.TEDIT-TO-TEX-FN (LAMBDA (OBJ STREAM) (PRIN3 "\\ex{" STREAM) (LET ((DATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM))) (PRIN3 (CAR DATUM) STREAM) (PRIN3 (CADR DATUM) STREAM)) (PRIN3 "}" STREAM) T)) ) (DEFINEQ (copy.ngroup.branch (lambda (ngroup.parents window) (* |fsg| "11-Aug-87 09:36") (* * |Build| |the| |NGroup| |database| |for| |the| |parents| |of| \a |copied|  |NGroup| |or| |the| |entire| |NGroup| |database| |on| \a get.) (|for| parent |in| ngroup.parents |do| (and parent (|with| numberobj parent (and (listp font) (setq font (fontcreate font))) (or ngroup.mother (setq ngroup.mother 'new.ngroup)) (create.ngroup.node ref.type ngroup.mother parent window) (create.ngroup.node ngroup.mother nil nil window) (add.ngroup.to.mother.node ref.type ngroup.mother window)))))) (dump.ngroup.graph (lambda (window) (* |fsg| " 3-Aug-87 16:03") (* * |Return| \a |list| |of| |the| |NGroup| |graph| |data| |that| |is| put  |along| |with| |the| |NGroup| |Imageobject.|  w\e |can| |then| |rebuild| |the| |entire| |NGroup| |graph| |on| \a get.) (let ((graph.list (tconc nil))) (maphash (tsp.get.ngroup.array window) (function (lambda (val key) (and (neq key 'new.ngroup) (let ((ngroup.rec (copy (car val)))) (|with| numberobj ngroup.rec (setq font (list.font.props font)) (tconc graph.list ngroup.rec))))))) (windowprop window 'dumpngroupgraph nil) (cdar graph.list)))) (ngroup.buttoneventinfn (lambda (ref.type ngroup.obj stream window) (* |fsg| " 5-Aug-87 08:31") (* * |Here| |when| |an| |inserted| |NGroup| |is| |middle| |buttoned.|) (let ((tag (imageobjprop ngroup.obj 'tag)) (graphw (windowprop window 'imageobj.menuw))) (menu (|create| menu title _ (concat ref.type " Menu") items _ (append (cond (tag ngroup.inserted.tag.items) (t ngroup.inserted.notag.items)) ngroup.inserted.menu.items) centerflg _ t))))) (ngroup.define.tag (lambda (ref.type window ngroup.obj) (* |fsg| " 5-Aug-87 09:26") (* * |Define| \a tag |for| |this| |NGroup| |or| |Change| |the| tag |if| |it|  |already| |exists.|) (let ((old.tag (imageobjprop ngroup.obj 'tag)) (new.tag (tsp.get.incode (textstream window)))) (and new.tag (neq new.tag old.tag) (progn (and old.tag (number.delete.tag window ngroup.obj)) (tsp.putcode new.tag ngroup.obj window) (imageobjprop ngroup.obj 'tag new.tag)))))) (number.delete.tag (lambda (window ngroup.obj) (* |fsg| " 5-Aug-87 09:27") (* * |Delete| |this| |Imageobj's| tag.) (tsp.putcode (imageobjprop ngroup.obj 'tag nil) nil window) nil)) (ngroup.show.tag (lambda (ref.type window ngroup.obj) (* |fsg| " 5-Aug-87 08:43") (* * |Show| |this| |NGroup's| tag.) (tedit.promptprint (textstream window) (concat ref.type ": Tag=\"" (imageobjprop ngroup.obj 'tag) "\"") t))) (change.inserted.ngroup.format (lambda (ref.type ngroup.obj stream window format.field) (* |fsg| " 1-Sep-87 15:33") (* * |Change| |an| |inserted| |NGroup's| |entire| |format| |or| \a |selected|  |field.|) (let ((graphw (windowprop window 'imageobj.menuw)) (new.format (|for| field |in| (cond (format.field (list format.field)) (t '(txtbefore display txtafter abbrevval before#txt after#txt))) |collect| (selectq field (txtbefore (change.ngroup.format.txtbefore ref.type graphw ngroup.obj)) (display (change.ngroup.format.display ref.type graphw ngroup.obj)) (txtafter (change.ngroup.format.txtafter ref.type graphw ngroup.obj)) (abbrevval (change.ngroup.format.abbrev ref.type graphw ngroup.obj)) (before#txt (change.ngroup.format.#text ref.type window ngroup.obj 'before)) (after#txt (change.ngroup.format.#text ref.type window ngroup.obj 'after)) (error "Unknown NGroup Format field" field))))) (apply 'or new.format)))) (change.ngroup.format.#text (lambda (ref.type window ngroup.obj flavor) (* |fsg| "25-Aug-87 14:48") (* * |Change| |the| |text| |before| |or| |after| |an| |inserted| |NGroup|  |regardless| |of| |the| |Text| |Before| |or| |Text| |After| |toggle|  |settings.|) (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) (let ((old.string (selectq flavor (before text.before#) text.after#)) (new.string (tedit.getinput (textstream window) (concat (selectq flavor (before "Text before ") "Text after ") ref.type ":")))) (and new.string (setq new.string (concat (selectq flavor (before "") " ") (convert.tabs.to.spaces new.string) (selectq flavor (before " ") "")))) (selectq flavor (before (setq text.before# new.string)) (setq text.after# new.string)) (not (strequal old.string new.string)))))) (show.inserted.ngroup.format (lambda (ref.type ngroup.obj stream window) (* |fsg| "26-Aug-87 12:05") (* * |Show| |the| |format| |of| |an| |inserted| |NGroup.|) (|with| numberobj (|fetch| objectdatum |of| ngroup.obj) (|with| ngtemplate template (tedit.promptprint stream (concat ref.type ": Display=" (concat (cond (ng.text-before (concat "\"" ng.text-before "\"")) (t "\"\"")) ng.chartype (cond (ng.text-after (concat "\"" ng.text-after "\"")) (t "\"\""))) " Abbrev=" (or abbrev-val "None")) t))))) ) (* * |Variable| |and| |Record| |definitions|) (RPAQQ NGROUP.GRAPH.MENU.ITEMS `((|Change Font| (CHANGE.NGROUP.FONT LABEL GRAPHW) "Change this NGroup's entire FONT." (SUBITEMS (|Family| (CHANGE.NGROUP.FONT LABEL GRAPHW 'FAMILY) "Change this NGroup's font family.") (|Size| (CHANGE.NGROUP.FONT LABEL GRAPHW 'SIZE) "Change this NGroup's font size.") (|Face| (CHANGE.NGROUP.FONT LABEL GRAPHW 'FACE) "Change this NGroup's font face."))) (|Show Font| (SHOW.NGROUP.FONT LABEL GRAPHW) "Show this NGroup's FONT.") (|Change Format| (CHANGE.NGROUP.FORMAT LABEL GRAPHW) "Change this NGroup's entire FORMAT." (SUBITEMS (|Delimiter Before| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'TXTBEFORE) "Change the delimiter preceding this NGroup.") (|Display Type| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'DISPLAY) "Change how this NGroup is displayed.") (|Delimiter After| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'TXTAFTER) "Change the delimiter following this NGroup.") (|Abbreviate Level| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'ABBREVVAL) "Specify the starting level of this NGroup value.") (|Starting Value| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'START) "Change this NGroup's starting value.") (|Table-Of-Contents| (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'TOC) "Include this NGroup in the Table-Of-Contents.") \,@ (AND (MANUALINDEX.ENABLED? (WINDOWPROP GRAPHW 'TWINDOW)) (LIST (LIST '|Manual Index| (FUNCTION (CHANGE.NGROUP.FORMAT LABEL GRAPHW 'MANINDEX)) "Include this NGroup in the Manual Index page numbers."))))) (|Show Format| (SHOW.NGROUP.FORMAT LABEL GRAPHW) "Show this NGroup's FORMAT."))) (RPAQQ NGROUP.INSERTED.MENU.ITEMS ((|Change Font| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW NIL NGROUP.OBJ) "Change this NGroup's entire FONT." (SUBITEMS (|Family| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW 'FAMILY NGROUP.OBJ) "Change this NGroup's font family.") (|Size| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW 'SIZE NGROUP.OBJ) "Change this NGroup's font size.") (|Face| (CHANGE.NGROUP.FONT REF.TYPE GRAPHW 'FACE NGROUP.OBJ) "Change this NGroup's font face."))) (|Show Font| (SHOW.NGROUP.FONT REF.TYPE GRAPHW NGROUP.OBJ) "Show this NGroup's FONT.") (|Change Format| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW) "Change this NGroup's entire FORMAT." (SUBITEMS (|Delimiter Before| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'TXTBEFORE) "Change the delimiter preceding this NGroup.") (|Display Type| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'DISPLAY) "Change how this NGroup is displayed.") (|Delimiter After| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'TXTAFTER) "Change the delimiter following this NGroup.") (|Abbreviate Level| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'ABBREVVAL) "Specify the starting level of this NGroup value.") (|Text Before| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'BEFORE#TXT) "Change the text preceding this NGroup.") (|Text After| (CHANGE.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW 'AFTER#TXT) "Change the text following this NGroup."))) (|Show Format| (SHOW.INSERTED.NGROUP.FORMAT REF.TYPE NGROUP.OBJ STREAM WINDOW) "Show this NGroup's FORMAT."))) (RPAQQ NGROUP.INSERTED.NOTAG.ITEMS ((|Define Tag| (NGROUP.DEFINE.TAG REF.TYPE WINDOW NGROUP.OBJ) "Define a TAG for this NGroup."))) (RPAQQ NGROUP.INSERTED.TAG.ITEMS ((|Change Tag| (NGROUP.DEFINE.TAG REF.TYPE WINDOW NGROUP.OBJ) "Change this NGroup's TAG.") (|Delete Tag| (NUMBER.DELETE.TAG WINDOW NGROUP.OBJ) "Delete this NGroup's TAG.") (|Show Tag| (NGROUP.SHOW.TAG REF.TYPE WINDOW NGROUP.OBJ) "Show this NGroup's TAG."))) (DECLARE\: EVAL@COMPILE (RECORD NGCOUNTER (NCOUNT . ANCESTRY)) (RECORD NGTEMPLATE (NG.CHARTYPE NG.TEXT-AFTER NG.START NG.ADDTOTOC NG.CURRENTVAL NG.MANUALINDEX NG.TEXT-BEFORE)) (RECORD NUMBEROBJ (REF.TYPE NUMSTRING USE NGROUP.MOTHER TEMPLATE UPDATED.OBJ TEXT.AFTER# PAGE.NUMBER FONT TEXT.BEFORE# ABBREV-VAL)) ) (PUTPROPS TMAX-NUMBER COPYRIGHT ("Xerox Corporation" 1987 1999 2000)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1599 17297 (NUMBEROBJ 1609 . 2715) (NUMBEROBJP 2717 . 3257) (NGROUPP 3259 . 3613) ( NUMBER.DISPLAYFN 3615 . 6654) (NUMBER.PREPRINTFN 6656 . 7700) (NUMBER.IMAGEBOXFN 7702 . 10195) ( NUMBER.PUTFN 10197 . 11281) (NUMBER.GETFN 11283 . 13419) (NUMBER.COPYFN 13421 . 15118) ( NUMBER.BUTTONEVENTINFN 15120 . 17025) (NUMBEROBJ.TEDIT-TO-TEX-FN 17027 . 17295)) (17298 26469 ( COPY.NGROUP.BRANCH 17308 . 18764) (DUMP.NGROUP.GRAPH 18766 . 19642) (NGROUP.BUTTONEVENTINFN 19644 . 20344) (NGROUP.DEFINE.TAG 20346 . 20949) (NUMBER.DELETE.TAG 20951 . 21210) (NGROUP.SHOW.TAG 21212 . 21534) (CHANGE.INSERTED.NGROUP.FORMAT 21536 . 23331) (CHANGE.NGROUP.FORMAT.#TEXT 23333 . 24919) ( SHOW.INSERTED.NGROUP.FORMAT 24921 . 26467))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX-XREF.LCOM.~3~ b/lispusers/TMAX-XREF.LCOM.~3~ deleted file mode 100644 index 6d3d7a4b582bf54f18ec8638f77f8fbfb8e3faad..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 10260 zcmb7K-)|e)btWlq_eZ0yw05%SCdi(h6pa)_EN4iHl-BiXL=HvT#v@Ex zoqt~L-238ocj`{2cb@bvhP~09`uL_UAMojOL^@WKqJZRJj}usq=I?zMN51 z*mOFr(Y)WAxp*pej7)JiTii8@+O@N8duQd{bGyd&ZZ3~C)X^>`{ zVd&dMnxCBYMyKv{&f<@E=d@9=J0xd?Vr$Np)7)~b!>x+FN%M<|`^jK@iOC`{W@{7` zCbOH%>}Cp~qW_=L81v0l-ja69#np`#WyrQ3HuvvR4VR92Ko!#I_?V|)G+k@JPax(d zCAN~uL~`%`TM7JIPbR9Td?6oy%2(IEuO&8eI>`c9snu?_$jHaPZwFtMcR~Hx?WG!_ ztWFC`A|oSHNzapW)UxofI$BGejSqy4A^CS9UUKhEmh$<{JrP+>Ay+RUCpbBdK9iD@S*{lWPtFqN8wQDV>*(PIW zVI;6$y47{Q_E3MphZ5uM$q9a&h!~a65U4ntC04OPI8oHX*b6p?k6RG7WTp3y0Cd3& z%E?JXfnXS4AULs71MER9#EQhP**@stTZSIi>~ixV?5|U)**Z#NmQ`}ZA3WEn5G(i4 zQSPz7l1!vJ>J;xJIjqE1H_aDsDsM@xCzG|L46Y|rcjeTzRPx2^awU;>7Z%$#0_i2v zvPBV$i~>$+mf3htrt06E(1y@C595}MsMG#iX~>Sc`}B-^P(Vr5^BrK0dzPJLTnPezRStNrB`9;Rw< z|JmA@-B&#(@dZ5;cF1bC;a-KDQi$50@qzN*5F}7Kiu(lVJHe4W00 zj3Ox?ffun_Fr9$-T6gqhH2!qtsfVVsiQ7A;+0zRbsYX0!zw0qnT9<%>gcoQ?%*;nbQozQy3v%Rrly zJVJQ9vBVG7wG~rbpemoWZ?QWJBqZM8%d4O8=ac_?{POJO^Oe8IJ{w+DLO+fe zMFd$--l)G=Q(`L7&el>tkAA?6WR1^Ab(b0XTh)JTCFX@e)-@2mhWF#3gXt2 zuQi_kwbD)FRzjXwlh2pW|5C|f4dh{w<|?|enw;3k0-F`uBPtp#hXK=}tg#p^2oDbN zz&98)jY7d6L~>_Dbt+f{*M0`UBQP-;h!!uUcmq0;8?&BtbXU;4C8K%~00Z;_QFYSI ziU+D4fLbB$^ZGXLBG?MLmM4ZeDk3R0?UIS?lwn~T&2Go)I3TlxDc5Dl?)dW;XaRyJ zn=`0XHSGfs;Vja2Oc~ismgXhlcvJ?n9rm7r`t1~gCyZhkqhxGv2eaGmBX{DCPJqJ( zfY?_QM+OdU14T=wZCgm1Ss;`Bz-nU(SS1u*JE%HPguzq?)61sQZIF(&UyUw$UZ;6w zFzQp;eKZ&iW`i*pv<^CjNH@E6ht*cK>Schvj^tjdx0Q{kfCJuG;oA(TKbTW~o9bpq zsZ;>~tisV9%Orm0WmL?9$Y~lG07}hnI@T^xaC$oHP3in{I2&AW9nlY@n||C;%t-6iJAuMwJ#d#Qlv3hMbuaw~D|$e?$F6nu8L% zE!f&hvza?gZ`AjX{7erHRce;Gev5?&OaPycCIWG`u=MZ~0XUtw5|bLI3F#K`SqW?- zkEbF6E26TVRMmhW&(ZU(>hm87#46CLCB45X?;>(bG0^1-31wvlqdHUg%sV(cc^q{+oMH00LV@YYDnWq!iwPb%<=cFdc8y25jBR@ zO+G-x1sWZzTtw~ABlPE+1{Hf;6JcS+3fD8hg4;ev3ZnCl#+V&&C$=l~6`s<$J3AZq zH9~&TFb`m<{T1RB$Z$J&o}yM$&LHLrE8Kv)N^!_#ZOfftOsEpSS9jKv zD^>Gn;%h&ZPx%o2Db7>-D)H-na((@^deZaw-`c|b1TR|M&sQ99;;9;H*v2_k`zDZ+F!wekWd{X;oI8rdfbOW8}_ z=MyR`0G5l2gK+z&f=pTU>O&os7dmeMHSiRLX=nqW_u(-WU1||^KjUwuz$@+Z59GQ9 z$SW)(Pun?vQQ>)t92o)w*9lcfpZFw)9*ak;8abr?vO9EV%u$fyuTuphgPj7Zpcg?h zx+BTq$mIx5Pz)e@oImIS@yt2{#TY>N=m3agd;pb9Y@ir+kwAPzCmfVW+(4K9c;qs5 z$bc94;?GOt(QGh6)w>CuW74tqW6%gb8x3YOp3vjV>5NWf*3A6~&!ce#Jc=Af(KS+Z zV3mN7TF7Ij(rHA}(z+LDHx5RpKq{#Q`(u0|8Fgv=2tZY{fg{4I{md(@QesvT_(E5~ z&qA%X^*{nv6{bzqJPOfr<`1svDAL+y?nUZ@# zDTia)>;pOj9m!NGrVgL?`8`c>i|JUG%Y9L20C;kD%0oqt|TkG&rHp`ITd<3QR}hkpc#O+_~RI zHxOjovJcRT!)l!-Mo<8#rDD$k1^i-(6$v%(>@0~_#6%db5UOj|Th(T}j4}f$d>*D# zr+11rG&pfAb~(iKT#S;Vsf}3Sh;q&lAk@SE(Kr$pG#JtBY%rz%_~i239nH{?Hw@GR zfggnZxWFNzE+Zt=?A(jzs>FXX3pM{qJp0SPl|N?@IwfxYUkUts_TKWFUuu$SmfsXh zs=Sp#d#dVJ;Z2o_B1uQu2eJ}36J)hl^by$ayrko`^4Lp?S!MB^tVh?1NE;2NYBk4d z5N_i#PCpoWB2(ZQ*QaDN(J8>PYg1rM#z?;zsH2p>4)E-`p~vV3>etXo_EGC{){6NE zMzE+keKMyVoTP18?9g(SLfCRo^WZ~*n|pi0;)K0?(DCl0^p4y|Askx|)$79iFiG)x z5SHaoUd!3Q>wC^yy;DvE2rkW>oTB^$^ndJ9W#YPA4Ay4uIovZAQQV}{6eN0TNL>P|~Zxkg{T;IwgDq_%Ep^2tg3bbgdjuH#SSQC(a&1 z9Veb&R22-%=)d2rzIa>BQdF?IwilsN;gg47{uY%V4x>;Kd}#qB!4y1l6aZ)x^|Go( z1nF6H7=sJ1Fncp|Q#nH28wtUeFzGU&&VC=79sp=^} zcKEu*Z({MF{7$8kE#C-=z_0>D-#(^@rtO1v6R%IA@`in%g_@s@?#)+a-cQ-|el^c= zlHz~KXNSriUOwAXBN+Q-aHaTz1euH_t0`42$&jKrUOOOuU%eZtCa=$fjnO>u>kM%A zC8tt74szx!Y1MW#Z`PIupX z8kk_CplX99dFaed$!}m{o~;bre}#byrbifleihjDndVu2(bTYS%;rlC$Sq~n(MHbn zl}~sD=wHJSs46`}aGsVVw_p;qg1Cjktrn=BEx@YZ0RKi~sDu(s-U9@`$G`|v$#%=U ze_vip%da$elr}bgM8_YJR(3yehvN&BdzYw{CN#agxEN1n^k_0ZC%aaq(@AeMqjq~M zlPMJQX>F6#ldIap$zV2fN8EC)VA2yh7!1!ZCzIY&>Y-8H>75U#bJiP-y@%!>eu$q@ zXy!)kdiGSWZ-N zCxCpEf4vbX>U7paD<0(;f0e2RMI=oJ_`S(f!Vg%6Q;=Af9$k)3xOJ|kd^(t&K?ZKY z%+7iQ;ATvdnPY3vw4%Qt7y*()o+(>P(D*gde!`52hh=^0FvGS-XmJGz0vOoDh zsS&HRc8Me^ zg|GgGUc(w`6+q(mWxYpZ&Av#lfEQz0>(|d=-Ne~hUXM{+gK^%x!B#8;oG@K=vI zL{z=1RXo?8(j#<3;CO60jzd^!O(j(tiL2%z=p3*B1;e+n|BZDM-Pw)VlIQyL(!2}|0C diff --git a/lispusers/TMAX.INDEX.~1~ b/lispusers/TMAX.INDEX.~1~ deleted file mode 100644 index 662653223119e8149c2af95c24ba489b02a3226c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 244 zcmeawOG&NZ<@E$nnR)37MX80Qsl_G53P9lJ>BH-kUzAy_pr+uLSdv(rkq8rJ009;t z6ldV{aPrsO-*OeseEVNUBuwcy#)(Kj?MUXoyLPKQDU+ zfAL4{NpC!P_oL3kL1*}GZFJljynEW~4tkIB>8*DM{mH}Q(YVJSXFSudTldoM){y3WHKsS*vn-1^0}m%(kX-QbX9+-63IGmrLdQ(oDBxbdo&rHO;r@abUK|>-Odzn z#URfV_VR_jTp>Aoy{uescUNJ`W_E9LE2-oz567bqd&kq63q;}GQn|wRc0nDVbcPRl z6Ez)udrzh6R>^I8301ca?DRd?t~86c(@q^^s5HEF^>Ez#xIa3ZFqD{|%oZ5IfFPIK z+uYpCZC)LMd}2M}d#!XCl&x7u=}NtBH`;2iTu7u^Dy#TdI-j}^RZC^mq0=Zg50!&Y z&j*p~>uRaEvb3~(>+4JSpZvSFvg~m4)(#eXCT}r{*(?!1Zju-AWUiHLSYrsa!@iTXy3RAZK}kzQ>k&A3W&z z>AK}K4nevt9AJ5#-=vOGv+k+QoVwlie5Z1x@;l0JwlGU=6+njOUHedZRjb8+T&Hnx zsETd(=x|+dHVcGC+NP@1(~fV~fvvo<@A-DabD9mba*7~Mvz!oexkVRXy!x2RS7Oux z=YsNz+EO%x4j}s9URYjQZhwu?^{cnmmY1rGzUcI)q$^`lJz3%dR{Kbofl((2nYs=Sa|4KXlP3^CFMvbS);Va>q&t9+H=GFl( zlf~z+t*k!z`xB5lTi7N@7q2jI180hKd?Ye&^>R~?q)#a(t+U)RRBdar&JufR#uR>c*mAdhDaeZvfG-s zi5s$Dnu=@NL=QPOj~$~OJG+X>xRaN^VB@mm+9ki~9;vOJNCW&_ZF;`i%*x+fK_3*M zGWajMv#F9$MA_|(O5zWgG--_=sME8_RDIA>m2t0E?+wqKY3~%nnF40hm7ub~xqh>x zAf)!aIHR&?ThNc$P`*89Z|^1$UaD@mkSVvZQE{8~o6L|rR&LkpM;n!4jgGXOqSy@@?-+~Hog>P;ge~r11s1ErBGi${G-0rHqM$@fZ zH6S`BRxw4CS2w{J5M&6_1~{f%v)zp%?&vi3J%TpJfZP;FDm81LIPE?<)>E^^hO||?H5*|3i-Y)7f-5duPl9^5h#@gzt z=)_lf-qXjc)mN9F+&Fw$geXlS76^0gRmLKaSI9+mTYfjH3M0e?jv*j&qqb+eq)36? zovdLsFqMW^ZEhL-lMaobCW<)lX50>tiUjATO0_+a%XDO^CXeR5FJe%b$4JdX)XTP4 z0#E(J3iO^fEo;kSNd`hFVeU}Sy%JJK`ga+4L%`IRQQp#nSVGId08i6-R^-c8z7 z{+5j$=_e+iGh^AU?2KW{f_y?Et6XMNm(9%@zbq(e^b84h+%)dyRn>xda$W04?G(aB zOF<9Kae&&M1z~GDT*C^<>;}8Fyin*A7B&lg7v~nJFPJbbVOgy^#j4w7)1BK@ zrCQU2ivv{-c@hnwU?hkUO3kvJmYYI(&-84HAT;*fCY%D9l@~W4)|cI!0gTug^#w@V7@)~Zs#!(5 z2Gx>-%i#Mk{|+YTx#T*rAt41C!xj4t@bQ*ztu8OE-V!r=OU&%8h?%`+g$gF}xwg7e z^k0X|lF`B=`R;?%6 ztukzV+N#wAi8FW!T*?h-%oR%%DNB~cw-Ox?-v05|Z&{2O$Q`Vt(}2SB({`iWX!>vr z^SA`~2Z4*9ZdTH8qF|NbFQQvCHcYM3Ad#!>kprpQjds0gyIA7kT2ObcykHV-_*|Ikm-ekg880Xy6XC9QVNPm^jRhW_v6<)tN9!aGd5@7(*WAzJh4=l1u3 zkR>MW`G>51tNbq${lk+!4~utt9+}FYgB3>I`JL4#WCwo2oAW;>H*OrSod2(#CWbpa z>6P$ghI_XC%U^%Il*&O<5hp^Ag9G!ycXoG2!DsPIkduYSifFs#LN=hvE48*)b)Eex z+~O^$N$nxSh18P@@#XLx^#JTpWHC0du!bs2s(7idBCH)1CC&B|*>KEfg zUs>@&bbn@t%o1sBa=YO>wv0y1!YhtP)m;r$-3kO!d5HG~m zZ_k_vQxqG|&7LP$)SJnstirb7eyed0S%_mK0zP=8*g^;}C!^6vv+g1UB7JG17c?S4co`D5T4Y9i`uH8~EFnbX z9+ndpvS+oSND+LMYA$&f3ceyh62oPjNkyEb$8p{HaqzYo2Sw+{VTotsa(D<}wwS%v z4lYMB+N_h_j=KX}s)z)MYqJs#`SlAS@GU}MfH#fFzY~1*MXaT9A`MuaS)U5m1vdz~ zzp@Qm89?ldQq< zyEwEp?!tG?g^fhuatT~68fcN@y%@Ua;mjwR%_xG7A(Y}sL2z0!60=^N(QVJfd}TF` z`3Mm%!9V=B+rMzCEUT|bYKNq8M_gkg9l|sun8ZDtuLB3Q@~vX92LbPY*Ng{KUCW} zWf+iht&p9W2~eNW39wqR9pRzQEZB_BC!vDjdp3#Ee(#g%MzMDvDfO5bJd?YBlk|#U zihN#Cn9rqM!etA1RqLqd(=@Z-MD-2h+qysPjsHKO+p55ad~R&>s;?f|ye;Fp-Wi^C z25D#5?S1lp7tM96fy_6%KF@{X$hxlz$&oD?!BBc>a z4y#0k4P+giKamPY#i~2VosfE=S;$yZHl7?>6D{&$a%uzF`_VOWYM-1)^j~~(+kCtw zA8W6zR-M}?-M&PK?>&C4>Kw3fU|WDN@P@=0eUf!Fb1?! zETqww&A`G4CJ{HvDpU~&$vdzVv^6{i{!4WYwCBjC_YIw@DE{GEeUHj{9AJN|%hvY# ztLNSR^>3c**0pm<)kQ>n`E@1~UKEu5<~yiKBG9!kzMi0rQnE4{PF1CI+8;bZpf^uT5!eT`k85{pP6w7v@rGAm5PMRw(~xP{Bjw zj7lFR67$>ZA#%L_pY>)@!%Tb;YJO9g6!P}PS=5_$hTYD%8?cq@;w?j}jvQLMPFcBj z&2r6OWT92cnRW&tPuHF3e8-2)D8;51M}uJVqHJDlLhCNtn&!s0FUt13Vs7&|YabK! ztYXo%?>dy=C2lh2L3m5l9)-lB_$f_Jvp74;sSIj?>Hq6RitJcze3pu+jm4j&a(;Yk z4OO9KU9oxki*r`wpZ>Av^PfxWZAY|LF#LuL|BV0q)QtX27FSo6*KWN~U0GTF^mn_< z-(zV0`QXWmw@+@o|ChJ_@Ly2J{!d++TU-8GgU4s~e|x6=E#3aPoFLiCr*iy{8?Umh zg0VrcVv5>3rXWsfLkJE`Mx#U#Lm;aNpM!6*5k`iAWcq|I%pu(rp==Jq2(lvSfYb>w zM-GMvoPqiuA{AjSywy?QEadc1;58hYg-WhtUKVj;MCWBuG6)qOu)btv}-#u2p{dIp4ASlLE) z-f&$;6`Sowx!AnNE(Z^@x1mcJ+Y%5u5*bC&FrYWl?8Ao zRF}ai;(So74y4w6If_)J*E(u7J+52ROB1y31#LJLCXUmNg|r1cvSma*Sh{_@&*|Oo zoDHVlNvGQ*?HSw**(7U9&hef1I}@#(tT({_!7}W^1r==eJ*ee7$5kZh@yIo3WHa zxzVTmGZmVHdjo2O+5!aS&KMfdRzCE|MOO<64KlKXkZT#jPoAZ;_=37Fg1h`aCHkz# zH%=IS5Ln2qtGUZ7AS7iP^~<3a1LMJdG5mmr3zTzJCB`(vnrh)Og@1(iMabbp4HA3O zV4F8LP?J!-u2sRNWtsPF2IHst4l^90=Fl z$Ygd3TWK-`v@nr89QUWFQc{k(f;k_l{r=$eY&`BfQm`z_gUg}7HT@BbmX zGl}T*SRRFD&tw)BO$R8^328P?u^u*C zbDmMmVg)cHOQXR6Z$_1K+Ii4xen9U>W2`cx+_7-K)+|~zVaU)>aJ&&V*=}I6JS~-% zrIdIkd~N13 zx$O)F-d_L{Zi2_L^8>We`*Sx-$rWb%dGexr$?gkAc*X3KT!6k95i}dGdzdyUWAa$u zpo0k*ddNt|H6<4bn)>9RouDIii#CN06XS&4S>bTeC0=+ZK{L8BMcnpn(Pk-Au@{XH z*FEbnHZ_&<+C|zCP)gMas!A&k=vS*=EL#LX@Qe@B!bcrpKkyQ*eZj^AD@YS3W$%gV z;3YP_xtVN?d-r?e-tbtIY-4{sI(s+=b^t*lvLWOkD29aH;00sE@%(oVfHK~b4?2$~ zYIt_~L2tbAfX-8=&{;`sEEXtD8j%<7Y&x%COru6WG=RV$h_XR!z@~9SzgdxnWd3-D z@P>3l0aC$G`uV++d=q~p2(G9hrdi>6q3;o~S}Axcc%Ok-0Z%aDr|_eG@;u?VgMoa@ zJ>ob5xe=2Jp&*_DNw6U(L64l0_5S3zH^7ViM|*h4&&xGi>BYoU^nZj8v`#M*`X`lB z*6&o5XXAGRpqMsDu&r#!_g0hDp)_^4GtQ3x`bV#>lZH%7OLVSLujd!lCsen!6IUZj$8W*oQ(G%*)4Ui!QQsw8jC9_Q6|jyb0b zHjWUY1c$RXoK92)KZbfXF%np+8ND>_LHFRnLWwaYt`)ugkKA`L-`wp3$!6VM$3C1{ zbpgB5EP`^_ISnAC7#ZU2`gqO8f=wN?H(Q>0ndV_|OTtWfmN=u3*M~#!Y|Mm+;o2YL zBq4V6nFz5z0S&qczr&^XeEM|(enjz1bSAW3)sXVRtW>YIJSmZiIr<{2v?!jroU=4M zS7a=p&nQF9SRpQiwXS#_X0C88v6rlbe!ASeCwbKsS&a9bXEJd=43~wI7PA?-Op=i? z?s+7Bhe^?{Ma;j|*+cV^1$aY}(KsP+z#{K}&GVT=WOC>sXdhlb>_sRB-$&vC&PuX} zjW6>EhkWK#Xzf#a9a(OD4m?1W3e5R}3CgD##=cQ(f-sn0N}DZ$msyw>F=Z(TQv6}H zxmxsQq2)rJh^&~|oiYvbQ$cJSSSk84Gw|Mu3>OrSJTs4M8(M%Ae)z)?l@9#U+5?ti zad1W~7MR@+03|3WknQCc8uncf0Ka;s zcsy7KxGBZ>CEJJ>P5iuYLk=n9_?%B|AU|_;jOv7fcA)uAi4X?g2e_R(<}1Xm{>$StfOnxXP?u;61Flh)Y07m87n2(ksT5uz>;D){0#*f7@$MZ7o#dwCN0Svgo>nevsfx)o3#7)wfW;%7~* sBl&?;DoO7Z@S?e^+Qa_G_>YP7r^r=hckvsk>@J=m;GbR44w9GnAM3B-yZ`_I diff --git a/lispusers/TMAX.TOC.~1~ b/lispusers/TMAX.TOC.~1~ deleted file mode 100644 index b605c055ea2bb768ca1f45e37c00abaa739abc9b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2115 zcmah}YflqF6rJ+Wtcov;k3`LUQu?K`^leN`Sqd~lF;Muvbf@hm?QF9Nn3Cd~@Co{E70MqeazlM1>T&?#dkl@b{LjK!}oN|VK9qHiGq6Tx?902_-c zShQszBLxN|Rz-shaw;faMfr|QM6C2hqHjQYPmF~Uxf>`Bt3Fe+u>iJltbt=Uom|2g z4&o@CW>Ph@?Gi%mpBvQBx+|`-8x4YMPh2a$D+W<4oGNBnD}f`StpUtfgH`D9$d|)V z4!If$9*BXTjuqdBwcx%C;1ExIrRg=31e6s{LQqPa+FZY`yMS7D2^ph-15H#k32%@S zQqM$ii(H?}HF0LC)QM%a4`Y8ia_WnI)uCT{hxvX8&1_(N9sA|Q0``XYPCN}lyDmcL z*Aj%yI`Jq}`V;XLsAd=q5bww!#PuTC2Fd~=uJto0wy)t03ZM?_0(5`K=t>%aCg#<^ zF&z6c^~V{#xv*<4?B=CVNOP%_xkCo)Vk{7B>3ON3B?osKEY7B)9}Z^NS)T^&xZ8^) zTzvaaVf4`iHX=%gBbCr5j6(REKq|w}IxDaeowA?R0%L{3pS5KycV1%;*&F5@wvR5_ zy^hynj|}B5c$MABUbzK7nTr6t$<_~A-r>EvPYv@sbGP=|`>pe%-u_9q$6dZfk=)%b z>SF^=z4qyGr`tN>jbd>rThv*B7BKb_j}PDr$zod=dy5C`1N8!t7dhm$Mlh119^(Nu z4DvjOY$5_>E;yuvQN}B;OhsGDl%a)ChL+AN^g>mW54G8fBF=vh<8Cs1ms6%nt-78e z$5OtBV?`A)3Ws8Hrfyis`yA(U4*8&wf8?CckX{TcXW9)!j1EoE>MFefRupk8#ORp1 oXkJ*mQ8rs=b1a>F&Sru}=OfmRPq?`B^9c`#XwKRTMAX>TMAX.;8| 24599 changes to%: (VARS TMAXCOMS) previous date%: "30-Dec-87 11:33:00" |{POGO:AISNORTH:XEROX}TMAX>TMAX.;7|) (* " Copyright (c) 1987 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT TMAXCOMS) (RPAQQ TMAXCOMS ((* ; "Developed under support from NIH grant RR-00785.") (* ; "Written by Frank Gilmurray and Sami Shaio.") (FILES (COMPILED SYSLOAD) TEDIT FREEMENU) (VARS TMAX.FILE.LIST) (DECLARE%: DONTCOPY (P (DOFILESLOAD (LIST* (QUOTE (SOURCE)) TMAX.FILE.LIST))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (OR (GETPROP (QUOTE EXPORTS.ALL) (QUOTE FILE)) (LOAD (QUOTE EXPORTS.ALL)))))) (P (DOFILESLOAD TMAX.FILE.LIST)) (* ;;; "Free Menu data structures") (VARS TSP.FM.DESC IMAGEOBJ.MENU.ITEMS) (* ;;; "Free Menu functions") (FNS TSP.DISPLAY.FMMENU TSP.SETUP.FILENAMES TSP.SETUP.FMMENU TSP.FMMENU TSP.FM.APPLY UPDATE.ALL DOWNDATE.ALL TSP.FUNCTION.HOOKS TSP.GETFN TSP.PUTFN TSP.HARDCOPYFN) (* ;;; "Free Menu toggle functions") (FNS AutoUpdate.TOGGLE UPDATE? NGROUP.Menu.TOGGLE NGROUPMENU.ENABLED? NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE TEXTAFTER.ENABLED? Manual.Index.TOGGLE MANUALINDEX.ENABLED?) (* ;;; "TSP font stuff") (FNS GET.TSP.FONT GET.TSP.FONT.FAMILY GET.TSP.FONT.SIZE GET.TSP.FONT.FACE ABBREVIATE.FONT TMAX.SHADEOBJ) (* ;;; "Collect ImageObjects") (FNS TSP.LIST.OF.OBJECTS) (GLOBALVARS GP.DefaultFont GP.DefaultShade) (MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.INDEXOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS MAKE.XREFOBJ.IMAGEFNS) (P (SETQ GP.DefaultFont (FONTCREATE (QUOTE GACHA) 10)) (SETQ GP.DefaultShade 10260) (SETQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (SETQ \DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (SETQ \REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (SETQ \INDEXOBJ.IMAGEFNS (MAKE.INDEXOBJ.IMAGEFNS)) (SETQ \XREFOBJ.IMAGEFNS (MAKE.XREFOBJ.IMAGEFNS)) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU (QUOTE (TMAX% Menu (FUNCTION TSP.DISPLAY.FMMENU)))) (TSP.FUNCTION.HOOKS) (SETQ IMAGEOBJGETFNS (APPEND (QUOTE ((DATE.GETFN) (INDEX.GETFN) (NUMBER.GETFN) (REGMARK.GETFN) (XREF.GETFN))) IMAGEOBJGETFNS)))) ) (* ; "Developed under support from NIH grant RR-00785.") (* ; "Written by Frank Gilmurray and Sami Shaio.") (FILESLOAD (COMPILED SYSLOAD) TEDIT FREEMENU) (RPAQQ TMAX.FILE.LIST (TMAX-DATE TMAX-ENDNOTE TMAX-INDEX TMAX-NUMBER TMAX-NGRAPH TMAX-NGROUP TMAX-XREF) ) (DECLARE%: DONTCOPY (DOFILESLOAD (LIST* (QUOTE (SOURCE)) TMAX.FILE.LIST)) (DECLARE%: EVAL@COMPILE DONTCOPY (OR (GETPROP (QUOTE EXPORTS.ALL) (QUOTE FILE)) (LOAD (QUOTE EXPORTS.ALL))) ) ) (DOFILESLOAD TMAX.FILE.LIST) (* ;;; "Free Menu data structures") (RPAQQ TSP.FM.DESC ((PROPS FORMAT TABLE TYPE MOMENTARY FONT (HELVETICA 10 BRR)) ((LABEL "Miscellany:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Update" ID UPDATE SELECTEDFN TSP.FM.APPLY) (LABEL "Undo Update" ID UNDOUPDATE SELECTEDFN TSP.FM.APPLY) (LABEL "Set AutoUpdate" TYPE TOGGLE SELECTEDFN AutoUpdate.TOGGLE FONT (NIL NIL BIR)) (LABEL "Date/Time" ID DATE/TIME SELECTEDFN TSP.FM.APPLY)) ((LABEL "References:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Reference" ID REFERENCE SELECTEDFN TSP.FM.APPLY) (LABEL "Known References" ID KNOWNREF SELECTEDFN TSP.FM.APPLY) (LABEL "Reference By" TYPE STATE MENUITEMS (Ask Value Page) INITSTATE Value LINKS (DISPLAY DEFAULTREF)) (LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (GACHA 10 MRR))) ((LABEL "Endnotes:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Endnote" ID ENDNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Insert Endnotes" ID INSERTNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Delete Endnotes" ID DELETENOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Set Style" ID SETSTYLE SELECTEDFN TSP.FM.APPLY)) ((LABEL "Numbering:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "NGroup Menu" TYPE TOGGLE ID NGROUP.MENU SELECTEDFN NGROUP.Menu.TOGGLE FONT (NIL NIL BIR)) (LABEL "New Ngroup" ID NEWNGROUP SELECTEDFN TSP.FM.APPLY) (LABEL "Text Before" TYPE TOGGLE SELECTEDFN NGROUP.Text-Before.TOGGLE FONT (NIL NIL BIR)) (LABEL "Text After" TYPE TOGGLE SELECTEDFN NGROUP.Text-After.TOGGLE FONT (NIL NIL BIR))) ((LABEL "Contents File:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Create TOC" ID CREATETOC SELECTEDFN TSP.FM.APPLY) (LABEL "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY) (LABEL "TOC Filename:" TYPE EDITSTART LINKS (EDIT TOC.FILE)) (LABEL "" TYPE EDIT ID TOC.FILE FONT (GACHA 10 MRR))) ((LABEL "Indices:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Index" ID INDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Extended Index" ID XTNDINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Known Indices" ID KNOWNINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Manual Index" TYPE TOGGLE SELECTEDFN Manual.Index.TOGGLE FONT (NIL NIL BIR))) ((LABEL "Indices File:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Create Index" ID CREATEINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Index Filename:" TYPE EDITSTART LINKS (EDIT INDEX.FILE)) (LABEL "" TYPE EDIT ID INDEX.FILE FONT (GACHA 10 MRR)))) ) (RPAQQ IMAGEOBJ.MENU.ITEMS ((UPDATE (UPDATE.ALL TSTREAM TWINDOW)) (UNDOUPDATE (DOWNDATE.ALL TSTREAM TWINDOW)) (DATE/TIME (TEDIT.INSERT.OBJECT (DATEOBJ) (TEXTOBJ TSTREAM))) (REFERENCE (INSERT.REF TSTREAM)) (KNOWNREF (INSERT.REF TSTREAM T)) (ENDNOTE (ADD.ENDNOTE TSTREAM TWINDOW)) (INSERTNOTE (INSERT.ENDNOTES TSTREAM TWINDOW)) (DELETENOTE (DELETE.ENDNOTES TSTREAM)) (SETSTYLE (SET.ENDNOTE.STYLE TSTREAM TWINDOW)) (NEWNGROUP (AND (ADD.NUMBER.GROUP TWINDOW TSTREAM) (GRAPHMENU TSTREAM TWINDOW))) (CREATETOC (CREATE.TOC.FILE TSTREAM TWINDOW)) (VIEWTOC (VIEW.TOC.FILE TSTREAM TWINDOW)) (INDEX (INSERT.INDEX TSTREAM TWINDOW)) (XTNDINDEX (INSERT.INDEXENTRY TSTREAM TWINDOW)) (KNOWNINDEX (INSERT.KNOWN.INDEX TSTREAM TWINDOW)) (CREATEINDEX (CREATE.INDEX.FILE TSTREAM TWINDOW)) (VIEWINDEX (VIEW.INDEX.FILE TSTREAM TWINDOW))) ) (* ;;; "Free Menu functions") (DEFINEQ (TSP.DISPLAY.FMMENU [LAMBDA (STREAM) (* fsg "24-Aug-87 14:37") (* * Here when user buttons TMAX Menu in the TEDIT.DEFAULT.MENU.) (LET ((WINDOW (\TEDIT.MAINW STREAM)) (IMAGEOBJ.MENUW (TSP.FMMENU STREAM))) (AND (NOT (OPENWP IMAGEOBJ.MENUW)) (PROGN (TSP.SETUP.FILENAMES IMAGEOBJ.MENUW) (ATTACHWINDOW IMAGEOBJ.MENUW WINDOW 'TOP 'JUSTIFY) (WINDOWPROP IMAGEOBJ.MENUW 'PASSTOMAINCOMS '(MOVEW SHAPEW SHRINKW BURYW]) (TSP.SETUP.FILENAMES [LAMBDA (OBJMENUW) (* ; "Edited 11-Nov-87 11:19 by drc:") (* * Here when displaying the TMAX menu.  Setup the TOC/INDEX filenames if they're not already specified.) (LET ((TEXT.FILE (with TEXTOBJ TEXTOBJ TXTFILE))) (AND (STREAMP TEXT.FILE) (LET* [(FILE.NAME (fetch (STREAM FULLNAME) of TEXT.FILE)) (FILE.BASE (PACKFILENAME 'HOST (FILENAMEFIELD FILE.NAME 'HOST) 'DIRECTORY (FILENAMEFIELD FILE.NAME 'DIRECTORY) 'NAME (FILENAMEFIELD FILE.NAME 'NAME] (for EXTENSION in '(TOC INDEX) do (LET ((FM.ITEM (FM.GETITEM (MKATOM (CONCAT EXTENSION ".FILE")) NIL OBJMENUW))) (AND (STREQUAL (FM.ITEMPROP FM.ITEM 'LABEL) "") (FM.CHANGESTATE FM.ITEM (CONCAT FILE.BASE "." EXTENSION) OBJMENUW]) (TSP.SETUP.FMMENU [LAMBDA (WINDOW) (* fsg "24-Aug-87 16:04") (* * Here to set up things like the FreeMenu, hasharrays, etc.  the first time through.) (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) (TSP.FMMENU (OR (CAR (NLSETQ (TEXTSTREAM WINDOW))) (with STREAM (with TEXTOBJ TEXTOBJ STREAMHINT) FULLNAME]) (TSP.FMMENU [LAMBDA (STREAM) (* ; "Edited 29-Sep-87 11:17 by fsg") (* * Creates the TMAX ImageObj menu but doesn't attach itself to the main TEdit  window.) (LET ((WINDOW (\TEDIT.MAINW STREAM)) IMAGEOBJ.MENUW) (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) (PROGN (WINDOWPROP WINDOW 'TSP.CODE.ARRAY (HASHARRAY 100)) (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY (HASHARRAY 100)) (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY (HASHARRAY 100)) (SETQ IMAGEOBJ.MENUW (FREEMENU TSP.FM.DESC "TMAX (Tedit Macros And eXtensions) -- LYRIC version" )) (WINDOWPROP IMAGEOBJ.MENUW 'TSTREAM STREAM) (WINDOWADDPROP IMAGEOBJ.MENUW 'CLOSEFN (FUNCTION FREEATTACHEDWINDOW)) (WINDOWPROP IMAGEOBJ.MENUW 'TWINDOW WINDOW) (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW IMAGEOBJ.MENUW) (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION TSP.HARDCOPYFN)) IMAGEOBJ.MENUW]) (TSP.FM.APPLY [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:17 by fsg") (LET [(LABEL (FM.ITEMPROP ITEM 'ID)) (TSTREAM (WINDOWPROP WINDOW 'TSTREAM)) (TWINDOW (WINDOWPROP WINDOW 'TWINDOW] (EVAL (CADR (ASSOC LABEL IMAGEOBJ.MENU.ITEMS]) (UPDATE.ALL [LAMBDA (STREAM WINDOW) (* fsg "24-Aug-87 11:40") (* * Update the NGroup/Endnote numbers and any References to them.) (UPDATE.NUMBEROBJS WINDOW STREAM 'NUMBEROBJP) (UPDATE.XREFS WINDOW) (* * This should check if there is an Endnote section.  If there is one then we want to re-insert the Endnotes.  The test for REGMARKOBJs works because we are only using them for the purpose  of marking the Endnote section.) (AND (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) 'REGMARKOBJP) (INSERT.ENDNOTES STREAM WINDOW]) (DOWNDATE.ALL [LAMBDA (STREAM WINDOW) (* fsg "24-Sep-87 16:16") (* * Undo everything that UPDATE does.) (DOWNDATE.NUMBEROBJS WINDOW STREAM 'NUMBEROBJP) (UPDATE.XREFS WINDOW T) (AND (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) 'REGMARKOBJP) (INSERT.ENDNOTES STREAM WINDOW]) (TSP.FUNCTION.HOOKS [LAMBDA NIL (* fsg " 3-Aug-87 15:33") (* * Called during LOAD to set up any function hooks.) (LET (FUNCTION.HOOK) (AND (SETQ FUNCTION.HOOK (LISTGET TEDIT.DEFAULT.PROPS 'GETFN)) (NEQ FUNCTION.HOOK (FUNCTION TSP.GETFN)) (PROGN (PRINTOUT PROMPTWINDOW T .CENTER 0 (CONCAT "TEdit GETFN hook " FUNCTION.HOOK " replaced by TMAX GETFN hook.") T) (FLASHWINDOW PROMPTWINDOW 2))) [COND ((LISTP TEDIT.DEFAULT.PROPS) (LISTPUT TEDIT.DEFAULT.PROPS 'GETFN (FUNCTION TSP.GETFN))) (T (SETQ TEDIT.DEFAULT.PROPS (LIST 'GETFN (FUNCTION TSP.GETFN] (AND (SETQ FUNCTION.HOOK (LISTGET TEDIT.DEFAULT.PROPS 'PUTFN)) (NEQ FUNCTION.HOOK (FUNCTION TSP.PUTFN)) (PROGN (PRINTOUT PROMPTWINDOW T .CENTER 0 (CONCAT "TEdit PUTFN hook " FUNCTION.HOOK " replaced by TMAX PUTFN hook.") T) (FLASHWINDOW PROMPTWINDOW 2))) (COND ((LISTP TEDIT.DEFAULT.PROPS) (LISTPUT TEDIT.DEFAULT.PROPS 'PUTFN (FUNCTION TSP.PUTFN))) (T (SETQ TEDIT.DEFAULT.PROPS (LIST 'PUTFN (FUNCTION TSP.PUTFN]) (TSP.GETFN [LAMBDA (STREAM FILENAME FLAVOR) (* fsg "24-Aug-87 14:27") (* * Called both BEFORE and AFTER a TEdit GET.  Only interested in BEFORE call at which time we clear all the hash arrays in  case of multiple GETs.) (AND (EQ FLAVOR 'BEFORE) (LET ((WINDOW (\TEDIT.MAINW STREAM))) (CLRHASH (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)) (CLRHASH (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) (CLRHASH (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY]) (TSP.PUTFN [LAMBDA (STREAM FILENAME FLAVOR) (* fsg " 3-Aug-87 11:05") (* * Called both before and after a TEdit PUT.) (LET ((WINDOW (\TEDIT.MAINW STREAM))) (COND ((EQ FLAVOR 'BEFORE) (WINDOWPROP WINDOW 'DUMPNGROUPGRAPH T)) (T (WINDOWPROP WINDOW 'DUMPNGROUPGRAPH NIL]) (TSP.HARDCOPYFN [LAMBDA (WINDOW IMAGESTREAM) (* fsg "13-Aug-87 10:35") (* * Here when the TMAX/TEdit window is hardcopied.  Clear out the old Index page numbers and then do the regular hardcopy.) (RESET.INDEX.PAGENUMBERS WINDOW) (TEDIT.HARDCOPYFN WINDOW IMAGESTREAM]) ) (* ;;; "Free Menu toggle functions") (DEFINEQ (AutoUpdate.TOGGLE [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:35 by fsg") (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) 'AUTOUPDATE (FM.ITEMPROP ITEM 'STATE]) (UPDATE? [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:33") (WINDOWPROP WINDOW 'AUTOUPDATE]) (NGROUP.Menu.TOGGLE [LAMBDA (ITEM WINDOW BUTTON) (* ss%: "27-Jun-87 16:28") (LET [(TWINDOW (WINDOWPROP WINDOW 'TWINDOW)) (TSTREAM (WINDOWPROP WINDOW 'TSTREAM)) (TOGGLE.STATE (FM.ITEMPROP ITEM 'STATE] (COND (TOGGLE.STATE (GRAPHMENU TSTREAM TWINDOW)) (T (CLOSE.NGROUP.GRAPH TWINDOW]) (NGROUPMENU.ENABLED? [LAMBDA (TWINDOW) (* ; "Edited 29-Sep-87 11:42 by fsg") (FM.ITEMPROP (FM.GETITEM 'NGROUP.MENU NIL (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) 'STATE]) (NGROUP.Text-Before.TOGGLE [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:45 by fsg") (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) 'NGROUPTEXTBEFORE (FM.ITEMPROP ITEM 'STATE]) (TEXTBEFORE.ENABLED? [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:29") (WINDOWPROP WINDOW 'NGROUPTEXTBEFORE]) (NGROUP.Text-After.TOGGLE [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:46 by fsg") (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) 'NGROUPTEXTAFTER (FM.ITEMPROP ITEM 'STATE]) (TEXTAFTER.ENABLED? [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:29") (WINDOWPROP WINDOW 'NGROUPTEXTAFTER]) (Manual.Index.TOGGLE [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:48 by fsg") (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) 'MANUALINDEX (FM.ITEMPROP ITEM 'STATE]) (MANUALINDEX.ENABLED? [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:27") (WINDOWPROP WINDOW 'MANUALINDEX]) ) (* ;;; "TSP font stuff") (DEFINEQ (GET.TSP.FONT [LAMBDA (WINDOW DEFAULT.FONT FONT.FIELD) (* fsg " 8-Jul-87 10:08") (* * Return the font descriptor list. If the FAMILY, SIZE, and/or FACE is not  specified, it defaults to the corresponding value in the DEFAULT.FONT  descriptor. If FONT.FIELD is non-NIL, it specifies which one of the three  fields to get.) (LET ([FAMILY (COND ((AND FONT.FIELD (NEQ FONT.FIELD 'FAMILY)) (FONTPROP DEFAULT.FONT 'FAMILY)) (T (GET.TSP.FONT.FAMILY DEFAULT.FONT] [SIZE (COND ((AND FONT.FIELD (NEQ FONT.FIELD 'SIZE)) (FONTPROP DEFAULT.FONT 'SIZE)) (T (GET.TSP.FONT.SIZE DEFAULT.FONT] [FACE (COND ((AND FONT.FIELD (NEQ FONT.FIELD 'FACE)) (FONTPROP DEFAULT.FONT 'FACE)) (T (GET.TSP.FONT.FACE DEFAULT.FONT] NEWENTRY.FONT) (AND (SETQ NEWENTRY.FONT (FONTCREATE FAMILY SIZE FACE NIL NIL T)) (LIST FAMILY SIZE (FONTPROP NEWENTRY.FONT 'FACE]) (GET.TSP.FONT.FAMILY [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") (* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.) (OR [MKATOM (MENU (create MENU TITLE _ "Font Family" CENTERFLG _ T ITEMS _ '((Classic 'CLASSIC) (Gacha 'GACHA) (Helvetica 'HELVETICA) (Modern 'MODERN) (TimesRoman 'TIMESROMAN] (FONTPROP DEFAULT.FONT 'FAMILY]) (GET.TSP.FONT.SIZE [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 09:56") (* * Get the font size from the menu or DEFAULT.FONT if the menu returns NIL.) (OR [MKATOM (MENU (create MENU TITLE _ "Font Size" CENTERFLG _ T MENUCOLUMNS _ 2 ITEMS _ '(6 8 10 12 14 18 24 36] (FONTPROP DEFAULT.FONT 'SIZE]) (GET.TSP.FONT.FACE [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") (* * Get the font face from the menu or DEFAULT.FONT if the menu returns NIL.) (OR [MKATOM (MENU (create MENU TITLE _ "Font Face" CENTERFLG _ T ITEMS _ '((Standard 'MRR "(MEDIUM REGULAR REGULAR)") (Italic 'MIR "(MEDIUM ITALIC REGULAR)") (Bold 'BRR "(BOLD REGULAR REGULAR)") (BoldItalic 'BIR "(BOLD ITALIC REGULAR)"] (FONTPROP DEFAULT.FONT 'FACE]) (ABBREVIATE.FONT [LAMBDA (FONT) (* fsg " 8-Jul-87 15:57") (* * Returns an abbreviated font description.  For example, if the font is (TIMESROMAN 12  (BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.) (LET [(FONT.LIST (COND [(FONTP FONT) (LIST (FONTPROP FONT 'FAMILY) (FONTPROP FONT 'SIZE) (FONTPROP FONT 'FACE] (T FONT] (LIST (LET ((FONT.FAMILY (CAR FONT.LIST))) (SELECTQ FONT.FAMILY (CLASSIC 'Classic) (GACHA 'Gacha) (HELVETICA 'Helvetica) (MODERN 'Modern) (TIMESROMAN 'TimesRoman) FONT.FAMILY)) (CADR FONT.LIST) (LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST) collect (GNC FIELD] (SELECTQ (MKATOM FONT.FACE) (MRR 'Standard) (MIR 'Italic) (BRR 'Bold) (BIR 'BoldItalic) FONT.FACE]) (TMAX.SHADEOBJ [LAMBDA (OBJ STREAM) (* fsg "17-Sep-87 11:25") (* * Shade the ImageObject to distinguish it from normal text.) (AND (IMAGESTREAMTYPEP STREAM 'DISPLAY) (LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] (BLTSHADE GP.DefaultShade STREAM (DSPXPOSITION NIL STREAM) (IDIFFERENCE (DSPYPOSITION NIL STREAM) (with IMAGEBOX BOUNDBOX YDESC)) (with IMAGEBOX BOUNDBOX XSIZE) (with IMAGEBOX BOUNDBOX YSIZE]) ) (* ;;; "Collect ImageObjects") (DEFINEQ (TSP.LIST.OF.OBJECTS [LAMBDA (TEXTOBJ TESTFN TESTFNARG) (* ss%: "27-Jun-87 16:32") (* * Loop through each PIECE of the TEdit document and call the user supplied  function on those PIECEs that are ImageObjects.) (AND TESTFN (LET ((OBJLIST (TCONC NIL))) (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PIECE PC# OBL) (AND (TYPENAMEP PIECE 'PIECE) (IMAGEOBJP (fetch POBJ of PIECE)) (APPLY* TESTFN (fetch POBJ of PIECE) TESTFNARG) (TCONC OBL (LIST (fetch POBJ of PIECE) CH#] OBJLIST) (CDAR OBJLIST]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GP.DefaultFont GP.DefaultShade) ) (DECLARE%: EVAL@COMPILE (PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN) (FUNCTION DATE.IMAGEBOXFN) (FUNCTION DATE.PUTFN) (FUNCTION DATE.GETFN) (FUNCTION DATE.COPYFN) (FUNCTION DATE.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) (PUTPROPS MAKE.INDEXOBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION INDEX.DISPLAYFN) (FUNCTION INDEX.IMAGEBOXFN) (FUNCTION INDEX.PUTFN) (FUNCTION INDEX.GETFN) (FUNCTION INDEX.COPYFN) (FUNCTION INDEX.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION INDEX.WHENDELETEDFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) (PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN) (FUNCTION NUMBER.IMAGEBOXFN) (FUNCTION NUMBER.PUTFN) (FUNCTION NUMBER.GETFN) (FUNCTION NUMBER.COPYFN) (FUNCTION NUMBER.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION XREF.WHENDELETEDFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) (PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN) (FUNCTION REGMARK.IMAGEBOXFN) (FUNCTION REGMARK.PUTFN) (FUNCTION REGMARK.GETFN) (FUNCTION REGMARK.COPYFN) (FUNCTION REGMARK.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) (PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO (LAMBDA NIL (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN) (FUNCTION XREF.IMAGEBOXFN) (FUNCTION XREF.PUTFN) (FUNCTION XREF.GETFN) (FUNCTION XREF.COPYFN) (FUNCTION XREF.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL)))) ) (SETQ GP.DefaultFont (FONTCREATE (QUOTE GACHA) 10)) (SETQ GP.DefaultShade 10260) (SETQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (SETQ \DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (SETQ \REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (SETQ \INDEXOBJ.IMAGEFNS (MAKE.INDEXOBJ.IMAGEFNS)) (SETQ \XREFOBJ.IMAGEFNS (MAKE.XREFOBJ.IMAGEFNS)) (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU (QUOTE (TMAX% Menu (FUNCTION TSP.DISPLAY.FMMENU)))) (TSP.FUNCTION.HOOKS) (SETQ IMAGEOBJGETFNS (APPEND (QUOTE ((DATE.GETFN) (INDEX.GETFN) (NUMBER.GETFN) (REGMARK.GETFN) (XREF.GETFN))) IMAGEOBJGETFNS)) (PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5973 13549 (TSP.DISPLAY.FMMENU 5983 . 6548) (TSP.SETUP.FILENAMES 6550 . 7801) ( TSP.SETUP.FMMENU 7803 . 8263) (TSP.FMMENU 8265 . 9463) (TSP.FM.APPLY 9465 . 9784) (UPDATE.ALL 9786 . 10458) (DOWNDATE.ALL 10460 . 10830) (TSP.FUNCTION.HOOKS 10832 . 12262) (TSP.GETFN 12264 . 12824) ( TSP.PUTFN 12826 . 13198) (TSP.HARDCOPYFN 13200 . 13547)) (13595 15844 (AutoUpdate.TOGGLE 13605 . 13841 ) (UPDATE? 13843 . 13988) (NGROUP.Menu.TOGGLE 13990 . 14372) (NGROUPMENU.ENABLED? 14374 . 14610) ( NGROUP.Text-Before.TOGGLE 14612 . 14862) (TEXTBEFORE.ENABLED? 14864 . 15027) (NGROUP.Text-After.TOGGLE 15029 . 15277) (TEXTAFTER.ENABLED? 15279 . 15440) (Manual.Index.TOGGLE 15442 . 15681) ( MANUALINDEX.ENABLED? 15683 . 15842)) (15878 20843 (GET.TSP.FONT 15888 . 17052) (GET.TSP.FONT.FAMILY 17054 . 17737) (GET.TSP.FONT.SIZE 17739 . 18227) (GET.TSP.FONT.FACE 18229 . 18928) (ABBREVIATE.FONT 18930 . 20239) (TMAX.SHADEOBJ 20241 . 20841)) (20883 22099 (TSP.LIST.OF.OBJECTS 20893 . 22097))))) STOP \ No newline at end of file diff --git a/lispusers/TMAX.~2~ b/lispusers/TMAX.~2~ deleted file mode 100644 index 656c1e26..00000000 --- a/lispusers/TMAX.~2~ +++ /dev/null @@ -1,242 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-May-99 08:41:45" {DSK}medley3.5>lispusers>TMAX.;5 28668 changes to%: (MACROS MAKE.XREFOBJ.IMAGEFNS) previous date%: "18-May-99 22:44:24" {DSK}medley3.5>lispusers>TMAX.;3) (* ; " Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved. ") (PRETTYCOMPRINT TMAXCOMS) (RPAQQ TMAXCOMS ( (* ;  "Developed under support from NIH grant RR-00785.") (* ;  "Written by Frank Gilmurray and Sami Shaio.") (FILES (COMPILED SYSLOAD) TEDIT FREEMENU) (VARS TMAX.FILE.LIST) [DECLARE%: DONTCOPY (P (DOFILESLOAD (LIST* '(SOURCE) TMAX.FILE.LIST))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (OR (GETPROP 'EXPORTS.ALL 'FILE) (LOAD 'EXPORTS.ALL] (P (DOFILESLOAD TMAX.FILE.LIST)) (* ;;; "Free Menu data structures") (VARS TSP.FM.DESC IMAGEOBJ.MENU.ITEMS) (* ;;; "Free Menu functions") (FNS TSP.DISPLAY.FMMENU TSP.SETUP.FILENAMES TSP.SETUP.FMMENU TSP.FMMENU TSP.FM.APPLY UPDATE.ALL DOWNDATE.ALL TSP.FUNCTION.HOOKS TSP.GETFN TSP.PUTFN) (* ;;; "Free Menu toggle functions") (FNS AutoUpdate.TOGGLE UPDATE? NGROUP.Menu.TOGGLE NGROUPMENU.ENABLED? NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE TEXTAFTER.ENABLED? Manual.Index.TOGGLE MANUALINDEX.ENABLED?) (* ;;; "TSP font stuff") (FNS GET.TSP.FONT GET.TSP.FONT.FAMILY GET.TSP.FONT.SIZE GET.TSP.FONT.FACE ABBREVIATE.FONT TMAX.SHADEOBJ) (* ;;; "Collect ImageObjects") (FNS TSP.LIST.OF.OBJECTS) (GLOBALVARS GP.DefaultFont GP.DefaultShade) (MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS MAKE.XREFOBJ.IMAGEFNS) (VARS (GP.DefaultFont (FONTCREATE 'GACHA 10)) (GP.DefaultShade 10260) (\NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (\DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (\REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (\XREFOBJ.IMAGEFNS (MAKE.XREFOBJ.IMAGEFNS))) (ADDVARS (IMAGEOBJGETFNS (DATE.GETFN) (NUMBER.GETFN) (REGMARK.GETFN) (XREF.GETFN))) (P [TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(TMAX% Menu (FUNCTION TSP.DISPLAY.FMMENU) NIL (SUBITEMS (Update [FUNCTION (LAMBDA (TEXTSTREAM) (UPDATE.ALL TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Updates all cross-references" ) (NGroup% Menu [FUNCTION (LAMBDA (TEXTSTREAM) (GRAPHMENU TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Displays number-group menu"] (TSP.FUNCTION.HOOKS)))) (* ; "Developed under support from NIH grant RR-00785.") (* ; "Written by Frank Gilmurray and Sami Shaio.") (FILESLOAD (COMPILED SYSLOAD) TEDIT FREEMENU) (RPAQQ TMAX.FILE.LIST (TMAX-DATE TMAX-ENDNOTE TMAX-INDEX TMAX-NUMBER TMAX-NGRAPH TMAX-NGROUP TMAX-XREF)) (DECLARE%: DONTCOPY (DOFILESLOAD (LIST* '(SOURCE) TMAX.FILE.LIST)) (DECLARE%: EVAL@COMPILE DONTCOPY (OR (GETPROP 'EXPORTS.ALL 'FILE) (LOAD 'EXPORTS.ALL)) ) ) (DOFILESLOAD TMAX.FILE.LIST) (* ;;; "Free Menu data structures") (RPAQQ TSP.FM.DESC [(PROPS FORMAT TABLE TYPE MOMENTARY FONT (HELVETICA 10 BRR)) ((LABEL "Miscellany:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Update" ID UPDATE SELECTEDFN TSP.FM.APPLY) (LABEL "Undo Update" ID UNDOUPDATE SELECTEDFN TSP.FM.APPLY) (LABEL "Set AutoUpdate" TYPE TOGGLE SELECTEDFN AutoUpdate.TOGGLE FONT (NIL NIL BIR)) (LABEL "Date/Time" ID DATE/TIME SELECTEDFN TSP.FM.APPLY)) ((LABEL "References:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Reference" ID REFERENCE SELECTEDFN TSP.FM.APPLY) (LABEL "Known References" ID KNOWNREF SELECTEDFN TSP.FM.APPLY) (LABEL "Reference By" TYPE STATE MENUITEMS (Ask Value Page) INITSTATE Value LINKS (DISPLAY DEFAULTREF)) (LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (GACHA 10 MRR))) ((LABEL "Endnotes:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Endnote" ID ENDNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Insert Endnotes" ID INSERTNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Delete Endnotes" ID DELETENOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Set Style" ID SETSTYLE SELECTEDFN TSP.FM.APPLY)) ((LABEL "Numbering:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "NGroup Menu" TYPE TOGGLE ID NGROUP.MENU SELECTEDFN NGROUP.Menu.TOGGLE FONT (NIL NIL BIR)) (LABEL "New Ngroup" ID NEWNGROUP SELECTEDFN TSP.FM.APPLY) (LABEL "Text Before" TYPE TOGGLE SELECTEDFN NGROUP.Text-Before.TOGGLE FONT (NIL NIL BIR)) (LABEL "Text After" TYPE TOGGLE SELECTEDFN NGROUP.Text-After.TOGGLE FONT (NIL NIL BIR))) ((LABEL "Contents File:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Create TOC" ID CREATETOC SELECTEDFN TSP.FM.APPLY) (LABEL "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY) (LABEL "TOC Filename:" TYPE EDITSTART LINKS (EDIT TOC.FILE)) (LABEL "" TYPE EDIT ID TOC.FILE FONT (GACHA 10 MRR))) ((LABEL "Indices:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Index" ID INDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Extended Index" ID XTNDINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Known Indices" ID KNOWNINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Manual Index" TYPE TOGGLE SELECTEDFN Manual.Index.TOGGLE FONT (NIL NIL BIR))) ((LABEL "Indices File:" TYPE DISPLAY FONT (NIL NIL MRR)) (LABEL "Create Index" ID CREATEINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Index Filename:" TYPE EDITSTART LINKS (EDIT INDEX.FILE)) (LABEL "" TYPE EDIT ID INDEX.FILE FONT (GACHA 10 MRR]) (RPAQQ IMAGEOBJ.MENU.ITEMS ((UPDATE (UPDATE.ALL TSTREAM TWINDOW)) (UNDOUPDATE (DOWNDATE.ALL TSTREAM TWINDOW)) (DATE/TIME (TEDIT.INSERT.OBJECT (DATEOBJ) (TEXTOBJ TSTREAM))) (REFERENCE (INSERT.REF TSTREAM)) (KNOWNREF (INSERT.REF TSTREAM T)) (ENDNOTE (ADD.ENDNOTE TSTREAM TWINDOW)) (INSERTNOTE (INSERT.ENDNOTES TSTREAM TWINDOW)) (DELETENOTE (DELETE.ENDNOTES TSTREAM)) (SETSTYLE (SET.ENDNOTE.STYLE TSTREAM TWINDOW)) (NEWNGROUP (AND (ADD.NUMBER.GROUP TWINDOW TSTREAM) (GRAPHMENU TSTREAM TWINDOW))) (CREATETOC (CREATE.TOC.FILE TSTREAM TWINDOW)) (VIEWTOC (VIEW.TOC.FILE TSTREAM TWINDOW)) (INDEX (INSERT.INDEX TSTREAM TWINDOW)) (XTNDINDEX (INSERT.INDEXENTRY TSTREAM TWINDOW)) (KNOWNINDEX (INSERT.KNOWN.INDEX TSTREAM TWINDOW)) (CREATEINDEX (VIEW.INDEX.FILE TSTREAM TWINDOW T)) (VIEWINDEX (VIEW.INDEX.FILE TSTREAM TWINDOW)))) (* ;;; "Free Menu functions") (DEFINEQ (TSP.DISPLAY.FMMENU - [LAMBDA (STREAM) (* fsg "24-Aug-87 14:37") - (* * Here when user buttons TMAX Menu in the TEDIT.DEFAULT.MENU.) - - (LET ((WINDOW (\TEDIT.MAINW STREAM)) - (IMAGEOBJ.MENUW (TSP.FMMENU STREAM))) - (AND (NOT (OPENWP IMAGEOBJ.MENUW)) - (PROGN (TSP.SETUP.FILENAMES IMAGEOBJ.MENUW) - (ATTACHWINDOW IMAGEOBJ.MENUW WINDOW 'TOP 'JUSTIFY) - (WINDOWPROP IMAGEOBJ.MENUW 'PASSTOMAINCOMS '(MOVEW SHAPEW SHRINKW BURYW]) (TSP.SETUP.FILENAMES - [LAMBDA (OBJMENUW) (* ; "Edited 11-Nov-87 11:19 by drc:") - - (* * Here when displaying the TMAX menu. - Setup the TOC/INDEX filenames if they're not already specified.) - - (LET ((TEXT.FILE (with TEXTOBJ TEXTOBJ TXTFILE))) - (AND (STREAMP TEXT.FILE) - (LET* [(FILE.NAME (fetch (STREAM FULLNAME) of TEXT.FILE)) - (FILE.BASE (PACKFILENAME 'HOST (FILENAMEFIELD FILE.NAME 'HOST) - 'DIRECTORY - (FILENAMEFIELD FILE.NAME 'DIRECTORY) - 'NAME - (FILENAMEFIELD FILE.NAME 'NAME] - (for EXTENSION in '(TOC INDEX) - do (LET ((FM.ITEM (FM.GETITEM (MKATOM (CONCAT EXTENSION ".FILE")) - NIL OBJMENUW))) - (AND (STREQUAL (FM.ITEMPROP FM.ITEM 'LABEL) - "") - (FM.CHANGESTATE FM.ITEM (CONCAT FILE.BASE "." EXTENSION) - OBJMENUW]) (TSP.SETUP.FMMENU - [LAMBDA (WINDOW) (* fsg "24-Aug-87 16:04") - (* * Here to set up things like the FreeMenu, hasharrays, etc. - the first time through.) - - (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) - (TSP.FMMENU (OR (CAR (NLSETQ (TEXTSTREAM WINDOW))) - (with STREAM (with TEXTOBJ TEXTOBJ STREAMHINT) - FULLNAME]) (TSP.FMMENU [LAMBDA (STREAM) (* ; "Edited 2-May-97 17:02 by rmk:") (* ; "Edited 29-Sep-87 11:17 by fsg") (* ;; "Creates the TMAX ImageObj menu but doesn't attach itself to the main TEdit window.") (LET ((WINDOW (\TEDIT.MAINW STREAM)) IMAGEOBJ.MENUW) (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) (PROGN (CL:UNLESS (HASHARRAYP (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY)) (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY (HASHARRAY 100))) (CL:UNLESS (HASHARRAYP (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)) (WINDOWPROP WINDOW 'TSP.CODE.ARRAY (HASHARRAY 100))) (SETQ IMAGEOBJ.MENUW (FREEMENU TSP.FM.DESC "TMAX (Tedit Macros And eXtensions)")) (WINDOWPROP IMAGEOBJ.MENUW 'TSTREAM STREAM) (WINDOWADDPROP IMAGEOBJ.MENUW 'CLOSEFN (FUNCTION FREEATTACHEDWINDOW)) (WINDOWPROP IMAGEOBJ.MENUW 'TWINDOW WINDOW) (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW IMAGEOBJ.MENUW) IMAGEOBJ.MENUW]) (TSP.FM.APPLY - [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:17 by fsg") - - (LET [(LABEL (FM.ITEMPROP ITEM 'ID)) - (TSTREAM (WINDOWPROP WINDOW 'TSTREAM)) - (TWINDOW (WINDOWPROP WINDOW 'TWINDOW] - (EVAL (CADR (ASSOC LABEL IMAGEOBJ.MENU.ITEMS]) (UPDATE.ALL - [LAMBDA (STREAM WINDOW) (* fsg "24-Aug-87 11:40") - (* * Update the NGroup/Endnote numbers and any References to them.) - - (UPDATE.NUMBEROBJS WINDOW STREAM 'NUMBEROBJP) - (UPDATE.XREFS WINDOW) - (* * This should check if there is an Endnote section. - If there is one then we want to re-insert the Endnotes. - The test for REGMARKOBJs works because we are only using them for the purpose - of marking the Endnote section.) - - (AND (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) - 'REGMARKOBJP) - (INSERT.ENDNOTES STREAM WINDOW]) (DOWNDATE.ALL - [LAMBDA (STREAM WINDOW) (* fsg "24-Sep-87 16:16") - (* * Undo everything that UPDATE does.) - - (DOWNDATE.NUMBEROBJS WINDOW STREAM 'NUMBEROBJP) - (UPDATE.XREFS WINDOW T) - (AND (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM) - 'REGMARKOBJP) - (INSERT.ENDNOTES STREAM WINDOW]) (TSP.FUNCTION.HOOKS - [LAMBDA NIL (* fsg " 3-Aug-87 15:33") - (* * Called during LOAD to set up any function hooks.) - - (LET (FUNCTION.HOOK) - (AND (SETQ FUNCTION.HOOK (LISTGET TEDIT.DEFAULT.PROPS 'GETFN)) - (NEQ FUNCTION.HOOK (FUNCTION TSP.GETFN)) - (PROGN (PRINTOUT PROMPTWINDOW T .CENTER 0 (CONCAT "TEdit GETFN hook " FUNCTION.HOOK - " replaced by TMAX GETFN hook.") - T) - (FLASHWINDOW PROMPTWINDOW 2))) - [COND - ((LISTP TEDIT.DEFAULT.PROPS) - (LISTPUT TEDIT.DEFAULT.PROPS 'GETFN (FUNCTION TSP.GETFN))) - (T (SETQ TEDIT.DEFAULT.PROPS (LIST 'GETFN (FUNCTION TSP.GETFN] - (AND (SETQ FUNCTION.HOOK (LISTGET TEDIT.DEFAULT.PROPS 'PUTFN)) - (NEQ FUNCTION.HOOK (FUNCTION TSP.PUTFN)) - (PROGN (PRINTOUT PROMPTWINDOW T .CENTER 0 (CONCAT "TEdit PUTFN hook " FUNCTION.HOOK - " replaced by TMAX PUTFN hook.") - T) - (FLASHWINDOW PROMPTWINDOW 2))) - (COND - ((LISTP TEDIT.DEFAULT.PROPS) - (LISTPUT TEDIT.DEFAULT.PROPS 'PUTFN (FUNCTION TSP.PUTFN))) - (T (SETQ TEDIT.DEFAULT.PROPS (LIST 'PUTFN (FUNCTION TSP.PUTFN]) (TSP.GETFN - [LAMBDA (STREAM FILENAME FLAVOR) (* fsg "24-Aug-87 14:27") - (* * Called both BEFORE and AFTER a TEdit GET. - Only interested in BEFORE call at which time we clear all the hash arrays in - case of multiple GETs.) - - (AND (EQ FLAVOR 'BEFORE) - (LET ((WINDOW (\TEDIT.MAINW STREAM))) - (CLRHASH (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)) - (CLRHASH (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY)) - (CLRHASH (WINDOWPROP WINDOW 'TSP.NGROUP.ARRAY]) (TSP.PUTFN - [LAMBDA (STREAM FILENAME FLAVOR) (* fsg " 3-Aug-87 11:05") - (* * Called both before and after a TEdit PUT.) - - (LET ((WINDOW (\TEDIT.MAINW STREAM))) - (COND - ((EQ FLAVOR 'BEFORE) - (WINDOWPROP WINDOW 'DUMPNGROUPGRAPH T)) - (T (WINDOWPROP WINDOW 'DUMPNGROUPGRAPH NIL]) ) (* ;;; "Free Menu toggle functions") (DEFINEQ (AutoUpdate.TOGGLE - [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:35 by fsg") - - (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) - 'AUTOUPDATE - (FM.ITEMPROP ITEM 'STATE]) (UPDATE? - [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:33") - (WINDOWPROP WINDOW 'AUTOUPDATE]) (NGROUP.Menu.TOGGLE - [LAMBDA (ITEM WINDOW BUTTON) (* ss%: "27-Jun-87 16:28") - (LET [(TWINDOW (WINDOWPROP WINDOW 'TWINDOW)) - (TSTREAM (WINDOWPROP WINDOW 'TSTREAM)) - (TOGGLE.STATE (FM.ITEMPROP ITEM 'STATE] - (COND - (TOGGLE.STATE (GRAPHMENU TSTREAM TWINDOW)) - (T (CLOSE.NGROUP.GRAPH TWINDOW]) (NGROUPMENU.ENABLED? - [LAMBDA (TWINDOW) (* ; "Edited 29-Sep-87 11:42 by fsg") - - (FM.ITEMPROP (FM.GETITEM 'NGROUP.MENU NIL (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) - 'STATE]) (NGROUP.Text-Before.TOGGLE - [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:45 by fsg") - - (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) - 'NGROUPTEXTBEFORE - (FM.ITEMPROP ITEM 'STATE]) (TEXTBEFORE.ENABLED? - [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:29") - (WINDOWPROP WINDOW 'NGROUPTEXTBEFORE]) (NGROUP.Text-After.TOGGLE - [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:46 by fsg") - - (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) - 'NGROUPTEXTAFTER - (FM.ITEMPROP ITEM 'STATE]) (TEXTAFTER.ENABLED? - [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:29") - (WINDOWPROP WINDOW 'NGROUPTEXTAFTER]) (Manual.Index.TOGGLE - [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 29-Sep-87 11:48 by fsg") - - (WINDOWPROP (WINDOWPROP WINDOW 'TWINDOW) - 'MANUALINDEX - (FM.ITEMPROP ITEM 'STATE]) (MANUALINDEX.ENABLED? - [LAMBDA (WINDOW) (* ss%: "27-Jun-87 16:27") - (WINDOWPROP WINDOW 'MANUALINDEX]) ) (* ;;; "TSP font stuff") (DEFINEQ (GET.TSP.FONT - [LAMBDA (WINDOW DEFAULT.FONT FONT.FIELD) (* fsg " 8-Jul-87 10:08") - (* * Return the font descriptor list. If the FAMILY, SIZE, and/or FACE is not - specified, it defaults to the corresponding value in the DEFAULT.FONT - descriptor. If FONT.FIELD is non-NIL, it specifies which one of the three - fields to get.) - - (LET ([FAMILY (COND - ((AND FONT.FIELD (NEQ FONT.FIELD 'FAMILY)) - (FONTPROP DEFAULT.FONT 'FAMILY)) - (T (GET.TSP.FONT.FAMILY DEFAULT.FONT] - [SIZE (COND - ((AND FONT.FIELD (NEQ FONT.FIELD 'SIZE)) - (FONTPROP DEFAULT.FONT 'SIZE)) - (T (GET.TSP.FONT.SIZE DEFAULT.FONT] - [FACE (COND - ((AND FONT.FIELD (NEQ FONT.FIELD 'FACE)) - (FONTPROP DEFAULT.FONT 'FACE)) - (T (GET.TSP.FONT.FACE DEFAULT.FONT] - NEWENTRY.FONT) - (AND (SETQ NEWENTRY.FONT (FONTCREATE FAMILY SIZE FACE NIL NIL T)) - (LIST FAMILY SIZE (FONTPROP NEWENTRY.FONT 'FACE]) (GET.TSP.FONT.FAMILY - [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") - (* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.) - - (OR [MKATOM (MENU (create MENU - TITLE _ "Font Family" - CENTERFLG _ T - ITEMS _ '((Classic 'CLASSIC) - (Gacha 'GACHA) - (Helvetica 'HELVETICA) - (Modern 'MODERN) - (TimesRoman 'TIMESROMAN] - (FONTPROP DEFAULT.FONT 'FAMILY]) (GET.TSP.FONT.SIZE - [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 09:56") - (* * Get the font size from the menu or DEFAULT.FONT if the menu returns NIL.) - - (OR [MKATOM (MENU (create MENU - TITLE _ "Font Size" - CENTERFLG _ T - MENUCOLUMNS _ 2 - ITEMS _ '(6 8 10 12 14 18 24 36] - (FONTPROP DEFAULT.FONT 'SIZE]) (GET.TSP.FONT.FACE - [LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") - (* * Get the font face from the menu or DEFAULT.FONT if the menu returns NIL.) - - (OR [MKATOM (MENU (create MENU - TITLE _ "Font Face" - CENTERFLG _ T - ITEMS _ '((Standard 'MRR "(MEDIUM REGULAR REGULAR)") - (Italic 'MIR "(MEDIUM ITALIC REGULAR)") - (Bold 'BRR "(BOLD REGULAR REGULAR)") - (BoldItalic 'BIR "(BOLD ITALIC REGULAR)"] - (FONTPROP DEFAULT.FONT 'FACE]) (ABBREVIATE.FONT - [LAMBDA (FONT) (* fsg " 8-Jul-87 15:57") - (* * Returns an abbreviated font description. - For example, if the font is (TIMESROMAN 12 - (BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.) - - (LET [(FONT.LIST (COND - [(FONTP FONT) - (LIST (FONTPROP FONT 'FAMILY) - (FONTPROP FONT 'SIZE) - (FONTPROP FONT 'FACE] - (T FONT] - (LIST (LET ((FONT.FAMILY (CAR FONT.LIST))) - (SELECTQ FONT.FAMILY - (CLASSIC 'Classic) - (GACHA 'Gacha) - (HELVETICA 'Helvetica) - (MODERN 'Modern) - (TIMESROMAN 'TimesRoman) - FONT.FAMILY)) - (CADR FONT.LIST) - (LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST) collect (GNC FIELD] - (SELECTQ (MKATOM FONT.FACE) - (MRR 'Standard) - (MIR 'Italic) - (BRR 'Bold) - (BIR 'BoldItalic) - FONT.FACE]) (TMAX.SHADEOBJ [LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:") (* fsg "17-Sep-87 11:25") (* ;; "Shade the ImageObject to distinguish it from normal text.") (AND (IMAGESTREAMTYPEP STREAM 'DISPLAY) (LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] (BLTSHADE (OR SHADE GP.DefaultShade) STREAM (DSPXPOSITION NIL STREAM) (IDIFFERENCE (DSPYPOSITION NIL STREAM) (FETCH YDESC OF BOUNDBOX)) (FETCH XSIZE OF BOUNDBOX) (FETCH YSIZE OF BOUNDBOX]) ) (* ;;; "Collect ImageObjects") (DEFINEQ (TSP.LIST.OF.OBJECTS - [LAMBDA (TEXTOBJ TESTFN TESTFNARG) (* ss%: "27-Jun-87 16:32") - (* * Loop through each PIECE of the TEdit document and call the user supplied - function on those PIECEs that are ImageObjects.) - - (AND TESTFN (LET ((OBJLIST (TCONC NIL))) - (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PIECE PC# OBL) - (AND (TYPENAMEP PIECE 'PIECE) - (IMAGEOBJP (fetch POBJ of PIECE)) - (APPLY* TESTFN (fetch POBJ - of PIECE) - TESTFNARG) - (TCONC OBL - (LIST (fetch POBJ of PIECE) - CH#] - OBJLIST) - (CDAR OBJLIST]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GP.DefaultFont GP.DefaultShade) ) (DECLARE%: EVAL@COMPILE (PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN) (FUNCTION DATE.IMAGEBOXFN) (FUNCTION DATE.PUTFN) (FUNCTION DATE.GETFN) (FUNCTION DATE.COPYFN) (FUNCTION DATE.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) (PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN) (FUNCTION NUMBER.IMAGEBOXFN) (FUNCTION NUMBER.PUTFN) (FUNCTION NUMBER.GETFN) (FUNCTION NUMBER.COPYFN) (FUNCTION NUMBER.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION XREF.WHENDELETEDFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NUMBER.PREPRINTFN]) (PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN) (FUNCTION REGMARK.IMAGEBOXFN) (FUNCTION REGMARK.PUTFN) (FUNCTION REGMARK.GETFN) (FUNCTION REGMARK.COPYFN) (FUNCTION REGMARK.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) (PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO [LAMBDA NIL (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN) (FUNCTION XREF.IMAGEBOXFN) (FUNCTION XREF.PUTFN) (FUNCTION XREF.GETFN) (FUNCTION XREF.COPYFN) (FUNCTION XREF.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION XREF.GET.DISPLAY.TEXT]) ) (RPAQ GP.DefaultFont (FONTCREATE 'GACHA 10)) (RPAQQ GP.DefaultShade 10260) (RPAQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (RPAQ \DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (RPAQ \REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (RPAQ \XREFOBJ.IMAGEFNS (MAKE.XREFOBJ.IMAGEFNS)) (ADDTOVAR IMAGEOBJGETFNS (DATE.GETFN) (NUMBER.GETFN) (REGMARK.GETFN) (XREF.GETFN)) [TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(TMAX% Menu (FUNCTION TSP.DISPLAY.FMMENU) NIL (SUBITEMS (Update [FUNCTION (LAMBDA (TEXTSTREAM) (UPDATE.ALL TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Updates all cross-references") (NGroup% Menu [FUNCTION (LAMBDA (TEXTSTREAM) (GRAPHMENU TEXTSTREAM (\TEDIT.MAINW TEXTSTREAM] "Displays number-group menu"] (TSP.FUNCTION.HOOKS) (PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987 1997 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8744 15959 (TSP.DISPLAY.FMMENU 8754 . 9319) (TSP.SETUP.FILENAMES 9321 . 10572) ( TSP.SETUP.FMMENU 10574 . 11034) (TSP.FMMENU 11036 . 12222) (TSP.FM.APPLY 12224 . 12543) (UPDATE.ALL 12545 . 13217) (DOWNDATE.ALL 13219 . 13589) (TSP.FUNCTION.HOOKS 13591 . 15021) (TSP.GETFN 15023 . 15583) (TSP.PUTFN 15585 . 15957)) (16005 18254 (AutoUpdate.TOGGLE 16015 . 16251) (UPDATE? 16253 . 16398) (NGROUP.Menu.TOGGLE 16400 . 16782) (NGROUPMENU.ENABLED? 16784 . 17020) ( NGROUP.Text-Before.TOGGLE 17022 . 17272) (TEXTBEFORE.ENABLED? 17274 . 17437) (NGROUP.Text-After.TOGGLE 17439 . 17687) (TEXTAFTER.ENABLED? 17689 . 17850) (Manual.Index.TOGGLE 17852 . 18091) ( MANUALINDEX.ENABLED? 18093 . 18252)) (18288 23401 (GET.TSP.FONT 18298 . 19462) (GET.TSP.FONT.FAMILY 19464 . 20147) (GET.TSP.FONT.SIZE 20149 . 20637) (GET.TSP.FONT.FACE 20639 . 21338) (ABBREVIATE.FONT 21340 . 22649) (TMAX.SHADEOBJ 22651 . 23399)) (23441 24657 (TSP.LIST.OF.OBJECTS 23451 . 24655))))) STOP \ No newline at end of file diff --git a/lispusers/TWODGRAPHICS.LCOM.~2~ b/lispusers/TWODGRAPHICS.LCOM.~2~ deleted file mode 100644 index b3f9d0c616fd7d2303d87d70a453e3685accaff9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 16320 zcmd5@U2Gi3eZM=>GA--aBTYL_o7fY!jgLXi-rfg!qyy*n?v{5;?(LrLmLlmSa3mdV zlBPs~r0oPv0vBz8qCg)~z(~;)1?-TlMB>#1t`!% z(FY;@&DZYC-jS4Ipa>z|?#%q>>;L`#&uqGC&DpN?dMl?AhAk#XDg zt(IfAo8#oMmSt9bv+P8w%VygmMrIDPK?mm5PwX?bUt=wec>CN?>3oq`hZtpzp zFL~8k%WT%|N_+CD>_ig1W}Y-JY>T0bvl(MHmmMd&bmYw^I%FLKJ99Ncis1?-Cnv{A z=kzY-9arnIETb@+FN{Z*Po`Ms;xsYxvzeLM>@*g8^3->}+_b7zt8KYYQ>;W*mm~S< zOtwhQuAM&r{OS(b-TM7ml0Id&+9av&qvAE%6C^$7wn@dYn;3GkZ2M)$CmemJY-_3M zwS3aH{I(B_Hrk8jmQ}MomsTx#EvG7q+PJ|ea!|)_*UhR$Fky4ixBQmrw&%Q7LsqCG z@rn4bzNfY%d6TFl>P{vrj@P#4T)nc|GM9X>x6T2Z_15}c)7SAcS#3ALOil#0-E3Ld zzFyn#PFc~pcwNt^O~>=iNcWZnRQ9emsKy}Le$gOi)G?2h)y*cwgn~KWQ<2JBWF4b? z#iPU#)T&w(nh`k})M0I9P~5WI5Ds+=lPVBUAd6y~L9u1KM$i~+j0AJEy~S3=5;M1~ zrejvDNnV^F7q(YlTHktchY1h3d0Y_;$j;2H0jW+NDH)L42y4$)i^;S@(pkdiCkElj z3RyiPY9=N~>^}x#v4OSH@fiL_zK}34KU$C16ZpseC*mh)!e{Z_r1X4G{t|n7?2%@urm$tGe_se|AgH({46fgq@0|vqq6D z*>2TaGON{Q%WINsrl7N*?b<#uW~K#P6Ym*fwOU?_7}LdmVr@+2h|6)Gg)YlVm{1qY zOcCp(W4SfIPKpI^$}Asn8l;hGr%9&Jlj(NBC^_(yTAm^hTE=s>TNB)q#Fnx|YO^*m z3e)7^%^LxjFD&s?P{) z7K|{ek8tA7UNRU#z+i;2QYz-!4(JR7OR|z|KCcvVMWq1hhG0gBU+}TgLRmQgGr)&o zp-@l?>O6)qqqJm{0g6ihf>NJX-m}Vzja)cTI2(8{;1os0lfJwX+X0(IcqJgeMwOc} zSrqh@MTYU4v5|-GtHnWF5PT$Ex=3$iM%-v5CC z@pl1K8cUc=cVdTNhaQ0~OoeI-OrfYPa9<7flWEn(w$);46|5q)9Pk4L8Eie5qncG$ zV<%4$=E|+T83tYYKz&%zy8QncRV&y-Mg8@qMk$8*~yt9|Ovo``wCX2&&_I?Y+ zI%9{A|LbP_W^A;SP&*?U;&FnVY2q23N!4}DBABxFWeg+2-cVe&+UXgZ@AH!4Jh z88YX1rVo>=sU2tzS)WlfP%!|XR#XcHkz7FX8QC!#3K>GB00Og0v`g1pqB=`FrwZ3p zlewl(9i@K-x(CW{ckUhI3U2NK;lG`_*BKrymlF3j$7jpJyin^Pu{<4$ATg#C3>f(k zNM&%tP=LaL)N#~d@;N!x0XmVIji(Qn&0{-6vB}K~?x-1wtbN+hwq2&-c9s$*XmaHRqF@S`#pr^r}TS_}0wHXFcFn zv%&*R^Tj|j=BE_pnGZE)UR9ZS z_%~9za)=UyqR34tE=?|!>YOUpxl90`h02zEPqM1k&K5$IpnJ25=RiZXpu2&XDl8P$ zLT*YfkcK)TP(}el2eFB11q4n`01j0byyrrbLFHN2Q~$)6CgauBo!#~Gr*~=4#G|8# zW!Dve$md91mLW^js?5Rti1T=Ljm4{nzcb!c;KDMj>y(UMtCqvuv4SDOSy=%G2I(s9 zwDCAN7pcHLH3)1LY^Uuc%*cTE!a{yZ2a^dbU{t*R3MVHq8O0PMf z2_>1dk$6OSY_{tNjnTK_If&O4&dw<|AuF^$Hs~Wh#jimL@GuB)e<@x{m~k^vt{`Qb zlnybn2HM8y^fW&-kz}FSgr2C9twG>Y3|2NRR;KV-L0MT|tSm=XvLs8E5lfR514~?H zEBrSost34QyB5=*ffeA@kw}QESJ@=Asw@gMr7B|CBviI63caW5U)j`uOs)y}>?6nS zv*#C_M%Aj?_bBS1#9b;LOrSs?m84(ZV1X zgljQ4=WCr#1^+utVV65^)R`cd@}(4b14y1|N=JGG22BIXnQ~cL3U&`F!P3jdLpfEZ z`sJoV@u66&DVaEtKe?7bCT@){m;b`2WG>J9=YI8mo$1Pb_PfS6SCW1W+yreW^6UYb zCcLgRy|&Gq^*kav&-KlA1r9Pn`V+0oK`R^*l&OE+Fk3a-#a^KpL^ho!0RkOy*uGhM zH{3HbynTL*!fioHw>N*II7o0$ zIk~y*KEjZTlO9PBRne0`6`los2DsG;RG%#NQGK#Ws6JWjqxyK$wHTu$$ONB~FNk7H z@l``xq?#ht5`~6HwL^z7VsL^c_a6F{f$pLVgv1V9l3<0pB+1qG(^}$?N)E4kK!L0n zq~@$NLv{HC1b?DSWow!S6IMdZhO7V!LS*;>MBc4rhUaE- z$-jn22mjVLDdVsgW=NO%7*b(Sqizz775iIC+9C}l^$ewV5ZFoZh;Sz~4hbTT zU&pZskn`zGA~IU{U=xE$`1B z!I}g!gS`-XNNg+G1I9zt!jlP@{V;h9##At@iKM{Ykun(!bP(3$F}7rLX$mN1egOYO zHAV6~c6@-QAn4J=C(kgO%g!f0`6@Rz%xaB%;g~b<_Q*rLil2FwQt_{Iv?s1M*vq^d z|Ckx+1sBI$>}}q~ut8<;&a4+sV;c;p>m_*9;zD7eD?^)ac?U`WtYNeSztFc9vg{6?kZ zH4_qq0QZ`bzblL@xVa02M^f^4F+(IJe;0H72B+ky2(b$_lKTrJ$eQDh5i;d1mS4{j zmIg=iLPoQ{2an;HS-t&Nn?tW`SSFr>uWXbmcqU%iD3@-3?}b-3KK$@Qei$LV8EII1 zbN@2HfgT7#AEfE`q*TV1d?i_wkAh~|| zakInp?%#GzHULxcf6A)P40mg(Ljh7U{6?%6Yf0^ zx|#&$fdg~yKoF#ZB0VHQvoLtV$;JIacH577wMbiuiI72-JSG^E*^X$ZK#xr;Ogkk9 zp%#epsm6hV@w5Xd#(jwTLvBWrPzppJHjMoEEM`}=O)+26lff7fo@{u^)D=4@nNaa_hSuYz5iea1nQS-y`S z&OMABz!Z!f9LfQ;;V@5w$W@}9aMDBGIGhQaG27P#BJh00p&hIw^)^ znQ0J0BO!I|qv>Y&B_bh(R2fT16~tva&@j|WbU~D^P##vrbE`o*gZf3SwjY%Hk?u3l znnNX)kB*lU6w|gD)6c&~y;zkVIU(SE?hYj+^B=5{*gbhF+~y!va$w!~eN)3nz*H z1oD5laqHRCtI#lS#olx~8@DcfscYgqv4YEo-WXJ68HFkoCkjJd7X@$lsy9YQ*&Mtd9Z6^ zfQ!FFYwJpF9kqYL^yTR5Z~f{CFLmi*Ron5SgRax44YSalM$6e^PNWxb_yw63hX{mS ztr3P5hiH_j)W`QRIpNn|z-T-nK~HD;F1Chv{=PD^g#348e87ya@q_C6X5xbz`_GsO zQMOt6tEKWrr!v1#x0$-DCIgxvG?1GTMkUAcZrr9Imx}F4`=Xl{X>FKzQx!rFYLT4N z6i1WY43^#!bO5_*4mw!N%~s#ty^f6ym^{}4-?YRtt$!_Q)>3tzd+c2LAL`k&DDW2> zw|?>wznb)dDuZi$6!94O;?TT(`*PQuXH@2Gu+t4M^*%&rq4CShk9xx$=a-is(qaDG z8+OYKVUV*c^DkU~=Hfeu7H~03ME?d}=#MuL#iKvKHD3{4<$ zHl&LXy}4Sq>*jU4d|g%EEOiz#UMNiwtmsGyq$!O{`o6zHqi}3jzdeu2HaM`=G*6z? zQiZgEq|;v_Pd!D(m$tSyJNR~jyu5zCv-L9B-9CMO=ee!zbGU{kKAK<`kAuWXPsA^8 z^eO@JU3^M$@C`TKA}?X-=cz(4wIc+Xjn*nDBBhz`X<+yH^??OD^nkL@CG^_6|5}0` zFeEk9PYOBFM&xx+aayfVkXl{HxBBXX`sg4*0!kk{sP2WA8L30^9a=~ZCTWv zP0(#QQWQ7dHQKHa{acq60i=z;tS6C|`@yW}Fk&36tOY--Rc$AOv>)m?+c&q@&#mvS zzqCruZmwUruzvn|f)9iOmY2b8#2^Gk`KeFvS%=DR5-Jd8wc?&X9l?^562nVo6X#v@ zYbL&nIo!*C@%)*sZ{ka<=Qg)+?F9R{u(f`Empp&^+$s~{s#S5!mW8iLsyI-qc+C~O zSf@;AhkRJ-2)rQ zj(#G{K-hjr8m_VHn2mDPB@I~=6t&W1oVS#FxaHjepn2fo}SC|zXLZZ7`4w< zVKtQT?q;vaV6zA8^{5Rf^YQgpNH-`fVnXA@RDGq0~dL> zk|5T4#Qd5v*O>XB1su)FM`Ed$!46qve_{$+9=OOuu%xl#(O9DM_rnrjK{8!6@nI&t z1T85^(l9HyXThzrP?mu=tzIQ1=_o^RZ4AArHJHmuap)FpX{;R3fTP-AEX_>-*Y$4z z?T=e`9FIYRTNH;wed64LnPcPQj{~?yBH&O#DhE4}m zKNOP0+twxjQ!$g`4t7L{fY>+i9YZigxsWoIl8_kKNHk0Z}BjMFt q;Rh7y@#WR+t#6Xb);2!CVK;a29nlO<^YK%lKU4H)8e`EY^8Wz+j$oSr diff --git a/lispusers/WDWHACKS.TEDIT.~1~ b/lispusers/WDWHACKS.TEDIT.~1~ deleted file mode 100644 index 099b715190dd2afa5e6e432b7a88e83498df0271..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3720 zcmeHHTW{k;6n3-S8zm2{K;rSJAYnrl+HSV(F478bGHtAN>|i_FE^m`$npkyg%bpN| z!~?JUhmd#&?N8w6aL)LWmUdae0|;rOHkmn>?|kPwGb7@kzxy@G@1J&0duHdk-`sCD z+s)=)vsqhkjh1JtCjh3DE9ftxD2#K^%S9{YU!RFA`Mxzy=0>aOCvyS$EXgFy`1m3R zIpY%M{6fGoj3>zw*D;@pxrim?Q8=B+Xa$1jp~zZIJK>Wso?=p%!+979I8U;%AQS)VlQZSX7o$*$IarQAV4cAA{2kyJHgE@i z&m1t&F-c^w-HDQ1Y(oiHvBjcBk&uZr;uRS_mSGYTJt$EwClu8~nM1OSVa%hb1<*X5 ziMZm8{pBJOV<{#(uu2xdGXXrm5EF&TArn(7kenAyj58tPf(N2i=AvdPau`dI()Pz%G^cbuN~mp->5m9WSy>okzvyQvIB;P|HbjrSyCe$uPy!DZ@D)&VorIxfC!G za*2~tuyUCc_48IUAW8)PWtyY~=i+{lT8mtqFCqxf)k#=#yc*brz!Qw;aw<@6yj6H7 zu>E8qYq|Ie@L;D&#8n4Tq);p`^PKW+GY{UjdGX5aWnvQzTNuUC9@%X=_Iv zzoK6bK4aB=kgHVWe4K@;ES09i(=4wcYBo=DS#?6!Vtp`ZipWchc{a&`r)d<9IbEN8 z2bS0(>Zra+3XYZpmCYluq(-YlrN)5w zeG~P$CL9X0ci4u92e5y1gg-_RulJbQML7$(%1!W+NDLhZ9c04Xqc$A2+wf@ra&ExR z0+py{h#`*;p#A6o4t947cmp$U8ZyPVz-9ps14G`;@22^wdA=JOUc&#;rTg!OW*F*m zy{+BWc4)QnTDyxsjmD<3zv-)r{Qv_t8@JvRrtCY~EA7?Bk#^^A#8TqsTR8M62>Ghd zE#$kg@p_}!XHAhkdr zd+!F@`#0FiIP|P@Nu=VlwyopH)4)-oIJ6|)RmVuQSkO*cY8OrOKK?8DtLz2_ZS}mN z%~~fcICeHJF}Pe!K^2r5s^q_$NKGj2)G=`y zxJO?KRMWnoB^i`fRIIirImx126r&Q!V&cErDVAjUw6avd%5w$yrz)f_wN+W_Qg&sz m22)q+RUtK-_BG4lHA@{+0smfwREC<>kELhxH|^;Uzx)AuFFla} diff --git a/lispusers/WDWHACKS.TEDIT.~2~ b/lispusers/WDWHACKS.TEDIT.~2~ deleted file mode 100644 index 645ff3c36c8153f3373be8d054544ef2c5c697ba..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3768 zcmeHHO>f&q5TzZbNt)`=q6K;!xIK`l!P<^uJ1J0vmR1&Pid0D|ihHA_wM3XA1#%Td zz4e+u6rlG4`3e0wo!KR68MYhr(xN~Fn_SMvn>TNEm#6Pu|B)4shV5b3YMlm+{YInN zXzVo_wFTE`IbJ;nu!LAaZ;>Q%T7X_I%z5DeMn(!G<1r$j>}woG9ZC5Z{p7*2UwHH3{9JmDk3 z$2+jf77*neqT&)~K$sEad_o1X3)S5y=R8$B5Unz+nx*=2DtKNXBxc|+N&vzgQDRFJsg! z=L&)F%5)Thz7&KifQraD)wx)L21q3+cC^TIxv3?awfY5Nq3+}CTIty$5%CEWyYPq5n;OUrWd6dU^67_TR(V%E&KrHCM#W_z_#t(q=Cd4#}@(B{D z;jZO#b7Jnut*ZKsAYiOIJ2cuN8s+g^luFY^YiRVlr#p5Kg0Af z;rf>2d8c@N{5-JQ&|+@LeAYIg)wTT66AY+$%eVU>0@?0MJFt%(241IwEjf6V^pQ#^ zzx%!yqJg!Qml*HuLdWXa&KdN)HuGKZUNYaY-4Y=5?NjCrRQkZhh}y?q^({BBJr{g- zGH@&(uLcjVqv~tO?2~Q?J-ovPJtD^Zs`3DDF)0tp7lda>7gq-A=Jzbr=Z0`7%-&%W zo*cmb(Gk836|Z-h)kZm$T;)f2MkEHViw-hj?oksCn@xDSzn&YiSD{RlGsKW*2heCO9m_VPMF|`Q0`@InR$n!$bH#I&}Zt&I|Q!jQN8-9z3R8}B#Nm-d+M zk@9}h9V{1Wb0I5hZIE9zM~}>WE2&v zEmBUh)LPatazPJSonoYga3nZcEc};WvJX@pBKdX?+P`LISP>USERS>WDWHACKS.;1| 3524 changes to%: (FNS Inspecticide) previous date%: "19-Mar-86 23:25:10" |{IE:PARC:XEROX}LYRIC>LISPUSERS>WDWHACKS.;1|) (PRETTYCOMPRINT WDWHACKSCOMS) (RPAQQ WDWHACKSCOMS ((FNS CLOSE.WINDOWS.IN.REGION SHAPEW.AND.SAVE SHAPEW.POP SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW Inspecticide) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (RPLACA (CDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (QUOTE (QUOTE SHAPEW.AND.SAVE))) (RPLACD (CDDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (COPY (QUOTE ((SUBITEMS ("PopShape" (QUOTE SHAPEW.POP) "Return a reshaped window to its original form.")))))) (SETQ WindowMenu NIL) (SETQ BackgroundMenuCommands (CONS (COPY (QUOTE ("SlamWs" (QUOTE (CLOSE.WINDOWS.IN.REGION)) "Close all the windows in a region of the screen." (SUBITEMS ("Inspectors" (QUOTE (Inspecticide)) "Close only inspector windows."))))) BackgroundMenuCommands)) (SETQ BackgroundMenu NIL) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW)))) ) (DEFINEQ (CLOSE.WINDOWS.IN.REGION (LAMBDA (R) (* edited%: "12-May-85 22:27") (OR R (SETQ R (GETREGION))) (for W in (OPENWINDOWS) do (COND ((INTERSECTREGIONS R (WINDOWPROP W (QUOTE REGION))) (CLOSEW W))))) ) (SHAPEW.AND.SAVE (LAMBDA (WINDOW NEWREGION) (* Jeff.Shrager "18-Mar-86 18:01") (WINDOWPROP WINDOW (QUOTE OLD.SHAPE) (WINDOWREGION WINDOW)) (SHAPEW WINDOW NEWREGION)) ) (SHAPEW.POP (LAMBDA (WINDOW) (* Jeff.Shrager "18-Mar-86 18:01") (COND ((WINDOWPROP WINDOW (QUOTE OLD.SHAPE)) (SHAPEW WINDOW (WINDOWPROP WINDOW (QUOTE OLD.SHAPE) (WINDOWREGION WINDOW)))))) ) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW (LAMBDA NIL (* Jeff.Shrager "18-Mar-86 18:48") (* * This is the universe's worst known hack. Whoever wrote ATTACHEDWINDOW put hard constants into the ATTACHWINDOW fn which get inserted into the PASSTOMAINCOMS prop of attached windows. This should be a var so that we can tell it what messages to pass or not in a general case. This function creates an attached window and (you'll love this) smashes the prop's value so that the const in the ATTACHWINDOW function is smashed so that everything works pretty generally. Yuko!!!) (LET ((TEMPWINDOW (CREATEW (QUOTE (0 0 10 10)))) MAINWINDOW) (ATTACHWINDOW TEMPWINDOW (SETQ MAINWINDOW (CREATEW (QUOTE (0 0 10 10)))) (QUOTE TOP)) (RPLACD (WINDOWPROP TEMPWINDOW (QUOTE PASSTOMAINCOMS)) (APPEND (COPY (QUOTE (SHAPEW.POP SHAPEW.AND.SAVE))) (CDR (WINDOWPROP TEMPWINDOW (QUOTE PASSTOMAINCOMS))))) (CLOSEW TEMPWINDOW) (CLOSEW MAINWINDOW))) ) (Inspecticide (LAMBDA NIL (* ; "Edited 18-Feb-88 09:48 by Rao") (for w in (OPENWINDOWS) when (AND (EQ (QUOTE INSPECTW.REPAINTFN) (WINDOWPROP w (QUOTE REPAINTFN))) (STRPOS "Inspect" (WINDOWPROP w (QUOTE TITLE)))) do (CLOSEW w))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPLACA (CDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (QUOTE (QUOTE SHAPEW.AND.SAVE))) (RPLACD (CDDR (ASSOC (QUOTE Shape) WindowMenuCommands)) (COPY (QUOTE ((SUBITEMS ("PopShape" (QUOTE SHAPEW.POP) "Return a reshaped window to its original form.")))))) (SETQ WindowMenu NIL) (SETQ BackgroundMenuCommands (CONS (COPY (QUOTE ("SlamWs" (QUOTE (CLOSE.WINDOWS.IN.REGION)) "Close all the windows in a region of the screen." (SUBITEMS ("Inspectors" (QUOTE (Inspecticide)) "Close only inspector windows."))))) BackgroundMenuCommands)) (SETQ BackgroundMenu NIL) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW) ) (PUTPROPS WDWHACKS COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1094 2834 (CLOSE.WINDOWS.IN.REGION 1104 . 1305) (SHAPEW.AND.SAVE 1307 . 1478) ( SHAPEW.POP 1480 . 1673) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW 1675 . 2597) (Inspecticide 2599 . 2832 ))))) STOP \ No newline at end of file diff --git a/lispusers/WDWHACKS.~2~ b/lispusers/WDWHACKS.~2~ deleted file mode 100644 index 820369bf..00000000 --- a/lispusers/WDWHACKS.~2~ +++ /dev/null @@ -1,9 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Jul-99 10:05:38" {DSK}medley3.5>lispusers>WDWHACKS.;3 6218 changes to%: (VARS WDWHACKSCOMS) (FNS Filebrowsericide) previous date%: " 1-Dec-96 21:15:33" {DSK}medley3.5>lispusers>WDWHACKS.;2) (PRETTYCOMPRINT WDWHACKSCOMS) (RPAQQ WDWHACKSCOMS [(FNS CLOSE.WINDOWS.IN.REGION SHAPEW.AND.SAVE SHAPEW.POP SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW Filebrowsericide Inspecticide SEditicide) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (RPLACA (CDR (ASSOC 'Shape WindowMenuCommands)) ''SHAPEW.AND.SAVE) [RPLACD (CDDR (ASSOC 'Shape WindowMenuCommands)) (COPY '((SUBITEMS ("PopShape" 'SHAPEW.POP "Return a reshaped window to its original form."] (SETQ WindowMenu NIL) (SETQ BackgroundMenuCommands (CONS [COPY '("SlamWs" '(CLOSE.WINDOWS.IN.REGION) "Close all the windows in a region of the screen." (SUBITEMS ("Inspectors" '(Inspecticide) "Close only inspector windows.") ("SEdit" '(SEditicide) "Close only SEdit windows.") ("Filebrowsers" '(Filebrowsericide) "Close only file browser windows."] BackgroundMenuCommands)) (SETQ BackgroundMenu NIL) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW]) (DEFINEQ (CLOSE.WINDOWS.IN.REGION -(LAMBDA (R) (* edited%: "12-May-85 22:27") (OR R (SETQ R (GETREGION))) (for W in (OPENWINDOWS) do (COND ((INTERSECTREGIONS R (WINDOWPROP W (QUOTE REGION))) (CLOSEW W))))) -) (SHAPEW.AND.SAVE -(LAMBDA (WINDOW NEWREGION) (* Jeff.Shrager "18-Mar-86 18:01") (WINDOWPROP WINDOW (QUOTE OLD.SHAPE) (WINDOWREGION WINDOW)) (SHAPEW WINDOW NEWREGION)) -) (SHAPEW.POP -(LAMBDA (WINDOW) (* Jeff.Shrager "18-Mar-86 18:01") (COND ((WINDOWPROP WINDOW (QUOTE OLD.SHAPE)) (SHAPEW WINDOW (WINDOWPROP WINDOW (QUOTE OLD.SHAPE) (WINDOWREGION WINDOW)))))) -) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW -(LAMBDA NIL (* Jeff.Shrager "18-Mar-86 18:48") (* * This is the universe's worst known hack. Whoever wrote ATTACHEDWINDOW put hard constants into the ATTACHWINDOW fn which get inserted into the PASSTOMAINCOMS prop of attached windows. This should be a var so that we can tell it what messages to pass or not in a general case. This function creates an attached window and (you'll love this) smashes the prop's value so that the const in the ATTACHWINDOW function is smashed so that everything works pretty generally. Yuko!!!) (LET ((TEMPWINDOW (CREATEW (QUOTE (0 0 10 10)))) MAINWINDOW) (ATTACHWINDOW TEMPWINDOW (SETQ MAINWINDOW (CREATEW (QUOTE (0 0 10 10)))) (QUOTE TOP)) (RPLACD (WINDOWPROP TEMPWINDOW (QUOTE PASSTOMAINCOMS)) (APPEND (COPY (QUOTE (SHAPEW.POP SHAPEW.AND.SAVE))) (CDR (WINDOWPROP TEMPWINDOW (QUOTE PASSTOMAINCOMS))))) (CLOSEW TEMPWINDOW) (CLOSEW MAINWINDOW))) -) (Filebrowsericide [LAMBDA NIL (* ; "Edited 13-Jul-99 10:05 by rmk:") (FOR W IN (OPENWINDOWS) WHEN (AND (EQ 'TB.REPAINTFN (WINDOWPROP W 'REPAINTFN)) (WINDOWPROP W 'FILEBROWSER)) DO (CLOSEW W]) (Inspecticide [LAMBDA NIL (* ; "Edited 1-Dec-96 20:51 by rmk:") (* ; "Edited 18-Feb-88 09:48 by Rao") (for w in (OPENWINDOWS) when (OR [AND (EQ 'INSPECTW.REPAINTFN (WINDOWPROP w 'REPAINTFN)) (STRPOS "Inspect" (WINDOWPROP w 'TITLE] (WINDOWPROP w 'INSPECTWINDOW)) do (CLOSEW w]) (SEditicide [LAMBDA NIL (* ; "Edited 1-Dec-96 21:15 by rmk:") (* ; "Edited 18-Feb-88 09:48 by Rao") (FOR W IN (OPENWINDOWS) WHEN (OR [AND (EQ 'SEDIT::REPAINTFN (WINDOWPROP W 'REPAINTFN)) (STRPOS "SEdit" (WINDOWPROP W 'TITLE] (WINDOWPROP W 'INSPECTWINDOW)) DO (CLOSEW W]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPLACA (CDR (ASSOC 'Shape WindowMenuCommands)) ''SHAPEW.AND.SAVE) [RPLACD (CDDR (ASSOC 'Shape WindowMenuCommands)) (COPY '((SUBITEMS ("PopShape" 'SHAPEW.POP "Return a reshaped window to its original form."] (SETQ WindowMenu NIL) (SETQ BackgroundMenuCommands (CONS [COPY '("SlamWs" '(CLOSE.WINDOWS.IN.REGION) "Close all the windows in a region of the screen." (SUBITEMS ("Inspectors" '(Inspecticide) "Close only inspector windows.") ("SEdit" '(SEditicide) "Close only SEdit windows.") ("Filebrowsers" '(Filebrowsericide) "Close only file browser windows."] BackgroundMenuCommands)) (SETQ BackgroundMenu NIL) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW) ) (PUTPROPS WDWHACKS COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1868 4997 (CLOSE.WINDOWS.IN.REGION 1878 . 2079) (SHAPEW.AND.SAVE 2081 . 2252) ( SHAPEW.POP 2254 . 2447) (SMASH.THE.DAMNED.CONST.IN.ATTACHWINDOW 2449 . 3371) (Filebrowsericide 3373 . 3698) (Inspecticide 3700 . 4387) (SEditicide 4389 . 4995))))) STOP \ No newline at end of file diff --git a/lispusers/WHO-LINE.~1~ b/lispusers/WHO-LINE.~1~ deleted file mode 100644 index 60862b8a..00000000 --- a/lispusers/WHO-LINE.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Feb-89 15:13:40" |{EG:PARC:XEROX}LISP>USERS>WHO-LINE.;10| 65795 changes to%: (FNS WHO-LINE-CURRENT-DIRECTORY) previous date%: "30-Jun-88 15:41:39" |{EG:PARC:XEROX}LISP>USERS>WHO-LINE.;9|) (* " Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WHO-LINECOMS) (RPAQQ WHO-LINECOMS ((* ;;; "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (* ;; "") (* ;; "Public fn for manipulating the who-line") (FNS INSTALL-WHO-LINE-OPTIONS) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some fns that compute useful values for the who-line, and act as nice button event fns") (* ;; "") (* ;; "Showing / changing the current logged in user") (FNS WHO-LINE-USERNAME WHO-LINE-CHANGE-USER WHO-LINE-USER-AFTER-LOGIN) (VARIABLES *WHO-LINE-CURRENT-USER* *WHO-LINE-USER-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDVARS (\SYSTEMCACHEVARS *WHO-LINE-CURRENT-USER*) (\AFTERLOGINFNS WHO-LINE-USER-AFTER-LOGIN))) (* ;; "") (* ;; "Showing the current machine name") (FNS WHO-LINE-HOST-NAME) (VARIABLES *WHO-LINE-HOST-NAME* *WHO-LINE-HOST-NAME-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDVARS (\SYSTEMCACHEVARS *WHO-LINE-HOST-NAME*))) (* ;; "") (* ;; "Showing / changing the current tty process package") (FNS CURRENT-TTY-PACKAGE SET-PACKAGE-INTERACTIVELY SET-TTY-PACKAGE-INTERACTIVELY) (VARIABLES *WHO-LINE-PACKAGE-NAME-CACHE* *WHO-LINE-PACKAGE-ENTRY*) (* ;; "") (* ;; "Showing / changing the current tty process readtable") (FNS CURRENT-TTY-READTABLE-NAME SET-READTABLE-INTERACTIVELY SET-TTY-READTABLE-INTERACTIVELY) (VARIABLES *WHO-LINE-READTABLE-ENTRY*) (* ;; "") (* ;; "Showing / changing the current tty process") (FNS WHO-LINE-TTY-PROCESS CHANGE-TTY-PROCESS-INTERACTIVELY) (VARIABLES *WHO-LINE-TTY-PROC-ENTRY*) (* ;; "") (* ;; "Showing / changing the currently connected directory") (FNS WHO-LINE-CURRENT-DIRECTORY SET-CONNECTED-DIRECTORY-INTERACTIVELY) (VARIABLES *WHO-LINE-DIRECTORIES* *WHO-LINE-LAST-DIRECTORY* *WHO-LINE-DIRECTORY-ENTRY*) (* ;; "") (* ;; "Showing / changing the current VMem utilization") (FNS WHO-LINE-VMEM WHO-LINE-SAVE-VMEM) (VARIABLES *WHO-LINE-LAST-VMEM* *WHO-LINE-VMEM-ENTRY*) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILES (LOADCOMP) LLFAULT MODARITH) (P (CHECKIMPORTS (QUOTE (LLPARAMS)) T))) (* ;; "") (* ;; "Showing the percent of symbol-space currently used") (FUNCTIONS WHO-LINE-SYMBOL-SPACE) (VARIABLES *WHO-LINE-SYMBOL-SPACE* *WHO-LINE-SYMBOL-SPACE-ENTRY*) (* ;; "") (* ;; "Showing the current time") (FNS WHO-LINE-TIME WHO-LINE-SET-TIME) (VARIABLES *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME* *WHO-LINE-TIME-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-TIMER* SECONDS)))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some as yet un-debugged entries. Try at your own risk.") (* ;; "") (* ;; "Showing the machine-active entry") (FNS WHO-LINE-SHOW-ACTIVE \UPDATE-WHO-LINE-ACTIVE-FLAG \PERIODICALLY-WHO-LINE-SHOW-ACTIVE) (VARIABLES *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-SHOW-ACTIVE-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-ACTIVE-TIMER* MILLISECONDS)))) (* ;; "") (* ;; "Showing / changing the current reader profile") (FNS CURRENT-PROFILE SET-PROFILE-INTERACTIVELY SET-TTY-PROFILE-INTERACTIVELY) (VARIABLES *WHO-LINE-PROFILE-ENTRY*) (* ;; "") (* ;; "Showing the state of the current TTY process") (FNS WHO-LINE-TTY-STATE WHO-LINE-WHAT-IS-RUNNING) (VARIABLES *WHO-LINE-STATE* *WHO-LINE-STATE-UNINTERESTING-FNS* *WHO-LINE-TTY-STATE-ENTRY*) (PROP WHO-LINE-STATE AWAIT.EVENT BLOCK EXCHANGEPUPS GETPUP SENDPUP WAIT.FOR.TTY \TTYBACKGROUND \WAITFORSYSBUFP \\getkey \SENDLEAF PUTSEQUIN \LEAF.READPAGES) (* ;;; "----------------------------------------------------------------------") (* ;;; "Default options for the who-line") (VARIABLES *WHO-LINE-ENTRIES* *WHO-LINE-ENTRY-REGISTRY* *WHO-LINE-ANCHOR* *WHO-LINE-NAME-FONT* *WHO-LINE-VALUE-FONT* *WHO-LINE-DISPLAY-NAMES?* *WHO-LINE-COLOR* *WHO-LINE-TITLE* *WHO-LINE-BORDER* *WHO-LINE-UPDATE-INTERVAL*) (* ;;; "----------------------------------------------------------------------") (* ;;; "Internal fns") (FNS REDISPLAY-WHO-LINE PERIODICALLY-UPDATE-WHO-LINE SETUP-WHOLINE-TIMER UPDATE-WHO-LINE WHEN-WHO-LINE-SELECTED-FN WHO-LINE-CONTROL-SELECT WHO-LINE-COPY-INSERT) (FNS WHO-LINE-REDISPLAY-INTERRUPT) (VARIABLES *WHO-LINE* *WHO-LINE-UPDATE-TIMER*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-UPDATE-TIMER* TICKS)))) (FUNCTIONS INVERT-WHO-LINE-ENTRY) (DECLARE%: DONTCOPY (RECORDS WHO-LINE-ENTRY)) (* ; "Macros that lets us lock down the Who-Line while we evaluate some forms") (FUNCTIONS WITH-WHO-LINE WITH-AVAILABLE-WHO-LINE) (* ;;; "----------------------------------------------------------------------") (* ;;; "Initialize the who-line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (P (INSTALL-WHO-LINE-OPTIONS)) (ADDVARS (BACKGROUNDFNS PERIODICALLY-UPDATE-WHO-LINE))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT WHO-LINE) (PROP FILETYPE WHO-LINE)))) (* ;;; "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (* ;; "") (* ;; "Public fn for manipulating the who-line") (DEFINEQ (INSTALL-WHO-LINE-OPTIONS (LAMBDA NIL (* ; "Edited 16-May-88 14:19 by smL") (* ;;; "") (* ;;; "Install new descriptions of the values to be displayed in the who-line.") (* ;;; "Each description is a list of four items: then name of the value, a form that will compute the value, the maximum number of characters in the resulting value, and an optional function that will be FUNCALLed if/when that item is moused in the who-line.") (* ;;; "") (* ;; "") (* ;; "Create the who-line window if it isn't there already") (* ;; "") (if (NOT (AND (BOUNDP '*WHO-LINE*) (WINDOWP *WHO-LINE*))) then (SETQ *WHO-LINE* (CREATEW (CREATEREGION 0 0 100 20) NIL NIL T)) (WINDOWPROP *WHO-LINE* 'LOCK (CREATE.MONITORLOCK "WHO-LINE"))) (WITH-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'VALID NIL) (OPENW *WHO-LINE*) (LET ((CURRENT-LEFT 0) ENTRIES) (* ;; "") (* ;; "Make sure the who-line has all the correct window properties") (* ;; "") (WINDOWPROP *WHO-LINE* 'REPAINTFN 'REDISPLAY-WHO-LINE) (WINDOWPROP *WHO-LINE* 'BUTTONEVENTFN 'WHEN-WHO-LINE-SELECTED-FN) (WINDOWPROP *WHO-LINE* 'DISPLAY-NAMES? *WHO-LINE-DISPLAY-NAMES?*) (WINDOWPROP *WHO-LINE* 'ANCHOR *WHO-LINE-ANCHOR*) (WINDOWPROP *WHO-LINE* 'NAME-FONT *WHO-LINE-NAME-FONT*) (WINDOWPROP *WHO-LINE* 'VALUE-FONT *WHO-LINE-VALUE-FONT*) (WINDOWPROP *WHO-LINE* 'COLOR *WHO-LINE-COLOR*) (WINDOWPROP *WHO-LINE* 'TITLE *WHO-LINE-TITLE*) (WINDOWPROP *WHO-LINE* 'BORDER *WHO-LINE-BORDER*) (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL (FIX (TIMES *WHO-LINE-UPDATE-INTERVAL* \RCLKMILLISECOND))) (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*)) (* ;; "") (* ;; "Create and fill in the who-line entries that go on the window.") (* ;; "This entails computing the positions of the entries in the who-line") (* ;; "") (SETQ ENTRIES (for ITEM in *WHO-LINE-ENTRIES* bind (DISPLAY-NAMES? _ (WINDOWPROP *WHO-LINE* 'DISPLAY-NAMES?)) (VALUE-FONT _ (WINDOWPROP *WHO-LINE* 'VALUE-FONT)) (NAME-FONT _ (WINDOWPROP *WHO-LINE* 'NAME-FONT)) collect (LET ((ENTRY (create WHO-LINE-ENTRY NAME _ (CL:FIRST ITEM) FORM _ (CL:SECOND ITEM)))) (with WHO-LINE-ENTRY ENTRY (* ;; "") (* ;; "Leave a little space (the size of an %"A%") between the previous value and this name") (* ;; "") (SETQ NAME-START (PLUS (STRINGWIDTH "A" VALUE-FONT) CURRENT-LEFT)) (if DISPLAY-NAMES? then (SETQ CURRENT-LEFT (PLUS NAME-START (STRINGWIDTH NAME NAME-FONT)))) (* ;; "") (* ;; "The value is displayed after the name, with a little space between them") (* ;; "") (SETQ VALUE-START (PLUS CURRENT-LEFT (STRINGWIDTH "A" VALUE-FONT))) (SETQ VALUE-END (PLUS VALUE-START (TIMES (CL:THIRD ITEM) (STRINGWIDTH "A" VALUE-FONT))) ) (* ; "Leave a little extra space after each value") (SETQ CURRENT-LEFT (PLUS VALUE-END (STRINGWIDTH "A" VALUE-FONT))) (* ;; "") (* ;; "Set the when-selected-fn") (* ;; "") (SETQ WHEN-SELECTED-FN (CL:FOURTH ITEM)) (* ;; "") (* ;; "And the reset-form") (* ;; "") (SETQ RESET-FORM (CL:FIFTH ITEM)) (* ;; "") (* ;; "And return the filled in entry") (* ;; "") ENTRY)))) (* ;; "") (* ;; "Reshape the window to hold the new in info") (* ;; "") (LET ((HORIZ-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) then (fetch XCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) thereis (MEMB anchor '(:LEFT :CENTER :JUSTIFY :RIGHT))) (ERROR "No horizontal anchor specified" (WINDOWPROP *WHO-LINE* 'ANCHOR))))) (VERT-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) then (fetch YCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) thereis (MEMB anchor '(:TOP :BOTTOM))) (ERROR "No vertical anchor specified" (WINDOWPROP *WHO-LINE* 'ANCHOR))))) (WIDTH (WIDTHIFWINDOW CURRENT-LEFT (WINDOWPROP *WHO-LINE* 'BORDER))) (HEIGHT (HEIGHTIFWINDOW (MAX (FONTPROP (WINDOWPROP *WHO-LINE* 'NAME-FONT) 'HEIGHT) (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'HEIGHT)) (WINDOWPROP *WHO-LINE* 'TITLE) (WINDOWPROP *WHO-LINE* 'BORDER)))) (* ;; "") (* ;; "Make sure the window fits on the screen (i.e. doesn't run off the edge, and is justified against left and right sides if the user wants).") (* ;; "If the items don't fit, change the length of each item so they do.") (* ;; "Do this by distributing the %"pain%" among all the entries in the who-line.") (* ;; "") (if (OR (GREATERP WIDTH SCREENWIDTH) (EQ HORIZ-ANCHOR :JUSTIFY)) then (for ENTRY in ENTRIES bind (REMAINING-ADJUSTMENT _ (DIFFERENCE SCREENWIDTH WIDTH)) (REMAINING-VALUE-SIZE _ (for ENTRY in ENTRIES sum (with WHO-LINE-ENTRY ENTRY (DIFFERENCE VALUE-END VALUE-START)))) (RUNNING-ADJUSTMENT _ 0) ENTRY-ADJUSTMENT do (with WHO-LINE-ENTRY ENTRY (* ;; "") (* ;; "Figure out how much this entry value gets adjusted.") (* ;; "") (* ;; "Note that, by keeping track of the remaing adjustment needed, we avoid problems with round-off.") (* ;; "") (SETQ ENTRY-ADJUSTMENT (QUOTIENT (TIMES REMAINING-ADJUSTMENT (DIFFERENCE VALUE-END VALUE-START) ) REMAINING-VALUE-SIZE)) (* ;; "") (* ;; "Update this entry size & position") (* ;; "") (add NAME-START RUNNING-ADJUSTMENT) (add VALUE-START RUNNING-ADJUSTMENT) (add RUNNING-ADJUSTMENT ENTRY-ADJUSTMENT) (add VALUE-END RUNNING-ADJUSTMENT)) finally (SETQ WIDTH SCREENWIDTH))) (* ;; "") (* ;; "Set the who-line window size so it can't be reshaped") (* ;; "") (WINDOWPROP *WHO-LINE* 'MAXSIZE (CONS WIDTH HEIGHT)) (WINDOWPROP *WHO-LINE* 'MINSIZE (CONS WIDTH HEIGHT)) (* ;; "") (* ;; "The anchor-point decribes where on the screen the who-line should be placed.") (* ;; "The CAR should be one of :JUSTIFY, :LEFT, :RIGHT, or :CENTER.") (* ;; "The CADR should be one of :TOP, :BOTTOM, or :CENTER.") (* ;; "") (SHAPEW *WHO-LINE* (CREATEREGION (SELECTQ HORIZ-ANCHOR ((:JUSTIFY :LEFT) 0) (:RIGHT (DIFFERENCE SCREENWIDTH WIDTH)) (:CENTER (QUOTIENT (DIFFERENCE SCREENWIDTH WIDTH) 2)) HORIZ-ANCHOR) (SELECTQ VERT-ANCHOR (:TOP (DIFFERENCE SCREENHEIGHT HEIGHT)) (:BOTTOM 0) (:CENTER (QUOTIENT (DIFFERENCE SCREENHEIGHT HEIGHT ) 2)) VERT-ANCHOR) WIDTH HEIGHT))) (* ;; "") (* ;; "The values should be centered vertically between the top and the bottom of the window") (* ;; "") (WINDOWPROP *WHO-LINE* 'VALUE-BOTTOM (PLUS (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'DESCENT) (QUOTIENT (DIFFERENCE (WINDOWPROP *WHO-LINE* 'HEIGHT) (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'HEIGHT)) 2))) (* ;; "Cache a bitmap that is the same size as the inside of the who-line, and a display stream onto the bitmap.") (WINDOWPROP *WHO-LINE* 'TEMP-STREAM (DSPCREATE (BITMAPCREATE (WINDOWPROP *WHO-LINE* 'WIDTH) (WINDOWPROP *WHO-LINE* 'HEIGHT)))) (* ;; "") (* ;; "Install the entries") (* ;; "") (WINDOWPROP *WHO-LINE* 'ENTRIES ENTRIES) (* ;; "") (* ;; "Finally, update the window") (* ;; "") (REDISPLAY-WHO-LINE *WHO-LINE*) (WINDOWPROP *WHO-LINE* 'VALID T))))) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some fns that compute useful values for the who-line, and act as nice button event fns") (* ;; "") (* ;; "Showing / changing the current logged in user") (DEFINEQ (WHO-LINE-USERNAME (LAMBDA NIL (* ; "Edited 30-Jun-88 15:41 by smL") (* ;;; "") (* ;;; "Return the name of the currently logged in user. Avoid consing up a new string if possible.") (* ;;; "") (* ;; "The cached value in *WHO-LINE-CURRENT-USER* gets invalidated by an entry on the list of \SYSTEMCACHEVARS, and by a function on the list of \AFTERLOGINFNS") (* ;; "") (DECLARE (GLOBALVARS *WHO-LINE-CURRENT-USER*)) (if *WHO-LINE-CURRENT-USER* then *WHO-LINE-CURRENT-USER* else (SETQ *WHO-LINE-CURRENT-USER* (USERNAME NIL NIL T))))) (WHO-LINE-CHANGE-USER (LAMBDA NIL (* smL "17-Nov-86 11:19") (* ;;; "") (* ;;; "Change the currently logged in user") (* ;;; "") (if (MENU (create MENU TITLE _ "Change user?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T "Log in as a different user") ("No" NIL "Don't change the current user"))))) then (LOGIN))) ) (WHO-LINE-USER-AFTER-LOGIN (LAMBDA (HOST USER) (* ; "Edited 30-Jun-88 15:34 by smL") (CL:WHEN (NULL HOST) (SETQ *WHO-LINE-CURRENT-USER* NIL)))) ) (DEFGLOBALVAR *WHO-LINE-CURRENT-USER* NIL "Cached name of the current logged in user") (CL:DEFPARAMETER *WHO-LINE-USER-ENTRY* (QUOTE ("User" (WHO-LINE-USERNAME) 10 WHO-LINE-CHANGE-USER (SETQ *WHO-LINE-CURRENT-USER* NIL) "Name of the currently logged in user")) "Who-Line entry for displaying the name of the currently logged in user") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDTOVAR \SYSTEMCACHEVARS *WHO-LINE-CURRENT-USER*) (ADDTOVAR \AFTERLOGINFNS WHO-LINE-USER-AFTER-LOGIN) ) (* ;; "") (* ;; "Showing the current machine name") (DEFINEQ (WHO-LINE-HOST-NAME (LAMBDA NIL (* ; "Edited 14-Jan-87 12:46 by smL") (* ;;; "") (* ;;; "Return the name of the curren workstation. Avoid consing up a new string if possible.") (* ;;; "") (* ;; "") (* ;; "The cached value in *WHO-LINE-HOST-NAME* gets invalidated by an entry on the list of \SYSTEMCACHEVARS") (* ;; "") (DECLARE (GLOBALVARS *WHO-LINE-HOST-NAME*)) (if *WHO-LINE-HOST-NAME* then *WHO-LINE-HOST-NAME* else (SETQ *WHO-LINE-HOST-NAME* (ETHERHOSTNAME)))) ) ) (DEFGLOBALVAR *WHO-LINE-HOST-NAME* NIL "Cached name of the current machine, for the Who-Line") (CL:DEFPARAMETER *WHO-LINE-HOST-NAME-ENTRY* (QUOTE ("on" (WHO-LINE-HOST-NAME) 10 NIL (SETQ *WHO-LINE-HOST-NAME* NIL) "Name of the currently running machine")) "Who-Line entry for displaying the name of the current machine") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDTOVAR \SYSTEMCACHEVARS *WHO-LINE-HOST-NAME*) ) (* ;; "") (* ;; "Showing / changing the current tty process package") (DEFINEQ (CURRENT-TTY-PACKAGE (LAMBDA NIL (* ; "Edited 17-Mar-87 17:52 by smL") (* ;;; "") (* ;;; "Return the name of the current package of the current TTY process") (* ;;; "") (LET ((PACKAGE (PROCESS.EVALV (TTY.PROCESS) '*PACKAGE*))) (* ;; "") (* ;; "The *WHO-LINE-PACKAGE-NAME-CACHE* AList is used to cache computed package names with terminating %":%"'s.") (* ;; "This lets us display the name with a colon w/o having to allocate new strings all the time.") (* ;; "") (OR (CDR (ASSOC PACKAGE *WHO-LINE-PACKAGE-NAME-CACHE*)) (PUTASSOC PACKAGE (CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) (CL:PACKAGE-NAME PACKAGE)) ":") *WHO-LINE-PACKAGE-NAME-CACHE*))))) (SET-PACKAGE-INTERACTIVELY (LAMBDA NIL (* ; "Edited 18-Mar-87 13:13 by smL") (* ;; "") (* ;; "Let the user interactivly change the current package") (* ;; "") (LET ((PACKAGE (MENU (create MENU TITLE _ "Select package" ITEMS _ (SORT (for PACKAGE in (CL:LIST-ALL-PACKAGES) bind PACKAGE-NAME collect (SETQ PACKAGE-NAME (CL:PACKAGE-NAME PACKAGE)) `(,(CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) PACKAGE-NAME) ":") ',PACKAGE-NAME ,(CONCAT "Set the current package to " PACKAGE-NAME ":"))) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y))))) CENTERFLG _ T)))) (if PACKAGE then (if (SHIFTDOWNP 'SHIFT) then (WHO-LINE-COPY-INSERT (CONCAT PACKAGE ":")) else (CL:IN-PACKAGE PACKAGE)))))) (SET-TTY-PACKAGE-INTERACTIVELY (LAMBDA NIL (* smL "28-Oct-86 09:49") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PACKAGE-INTERACTIVELY)) T)) ) ) (DEFGLOBALVAR *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL) "An AList used to cache package names, together with their terminating ':'s") (CL:DEFPARAMETER *WHO-LINE-PACKAGE-ENTRY* (QUOTE ("Pkg" (CURRENT-TTY-PACKAGE) 10 SET-TTY-PACKAGE-INTERACTIVELY (SETQ *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL)) "Package of the current TTY process")) "Who-Line entry for displaying the package of the current TTY process") (* ;; "") (* ;; "Showing / changing the current tty process readtable") (DEFINEQ (CURRENT-TTY-READTABLE-NAME (LAMBDA NIL (* smL "28-Oct-86 19:13") (* ;;; "") (* ;;; "Return the name of the readtable of the current TTY process") (* ;;; "") (OR (READTABLEPROP (PROCESS.EVALV (TTY.PROCESS) (QUOTE *READTABLE*)) (QUOTE NAME)) "Unknown")) ) (SET-READTABLE-INTERACTIVELY (LAMBDA NIL (* smL "10-Nov-86 18:36") (* ;; "") (* ;; "Let the user interactivly change the current readtable") (* ;; "") (DECLARE (GLOBALVARS \READTABLEHASH)) (LET ((READTABLE (MENU (create MENU TITLE _ "Select readtable" ITEMS _ (LET ((READTABLES NIL)) (MAPHASH \READTABLEHASH (FUNCTION (LAMBDA (VALUE NAME) (push READTABLES (LIST NAME VALUE))))) (SORT READTABLES (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y)))))) CENTERFLG _ T)))) (if (READTABLEP READTABLE) then (SETQ *READTABLE* READTABLE)))) ) (SET-TTY-READTABLE-INTERACTIVELY (LAMBDA NIL (* smL "28-Oct-86 09:51") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY readtable") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-READTABLE-INTERACTIVELY)) T)) ) ) (CL:DEFPARAMETER *WHO-LINE-READTABLE-ENTRY* (QUOTE ("Rdtbl" (CURRENT-TTY-READTABLE-NAME) 10 SET-TTY-READTABLE-INTERACTIVELY NIL "Readtable of the current TTY process")) "Who-Line entry for displaying the name of the ReadTable of the current TTY process") (* ;; "") (* ;; "Showing / changing the current tty process") (DEFINEQ (WHO-LINE-TTY-PROCESS (LAMBDA NIL (* smL "28-Oct-86 09:54") (* ;;; "") (* ;;; "Return the name of the current TTY process") (* ;;; "") (PROCESSPROP (TTY.PROCESS) (QUOTE NAME))) ) (CHANGE-TTY-PROCESS-INTERACTIVELY (LAMBDA NIL (* smL "10-Nov-86 18:36") (DECLARE (GLOBALVARS \PROCESSES)) (LET ((NEW-PROC (MENU (create MENU TITLE _ "Give TTY to process" CENTERFLG _ T ITEMS _ (SORT (for PROC in \PROCESSES collect (LIST (PROCESSPROP PROC (QUOTE NAME)) PROC)) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y))))))))) (if NEW-PROC then (TTY.PROCESS NEW-PROC)))) ) ) (CL:DEFPARAMETER *WHO-LINE-TTY-PROC-ENTRY* (QUOTE ("Tty" (WHO-LINE-TTY-PROCESS) 15 CHANGE-TTY-PROCESS-INTERACTIVELY NIL "The current TTY process")) "Who-Line entry for displaying the name of the current TTY process") (* ;; "") (* ;; "Showing / changing the currently connected directory") (DEFINEQ (WHO-LINE-CURRENT-DIRECTORY (LAMBDA NIL (* ; "Edited 3-Feb-89 14:52 by smL") (* ;;; "Get the currently connected directory") (* ;; "First, update the cached directory / namestring pair to reflect the current TTY proc") (DECLARE (GLOBALVARS *WHO-LINE-LAST-DIRECTORY*)) (* ;; "The connected directory is looked up in the TTY process, in case one day it becomes a per-process var") (LET ((CONNECTED-DIRECTORY (PROCESS.EVALV (TTY.PROCESS) (QUOTE *DEFAULT-PATHNAME-DEFAULTS*)))) (* ; "The CAR contains the path, the CDR contains a string version of the path") (if (NEQ CONNECTED-DIRECTORY (CAR *WHO-LINE-LAST-DIRECTORY*)) then (* ; "The connected directory has changed") (change (CAR *WHO-LINE-LAST-DIRECTORY*) CONNECTED-DIRECTORY) (* ; "Put the host name last, since that is least important") (change (CDR *WHO-LINE-LAST-DIRECTORY*) (if (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) then (CONCAT (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) " on {" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}") else (CONCAT "{" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}"))) (* ; "Update the list of known directories") (LET ((DIR-NAME (CL:NAMESTRING CONNECTED-DIRECTORY))) (if (NOT (CL:MEMBER DIR-NAME *WHO-LINE-DIRECTORIES* :TEST (CL:FUNCTION STRING-EQUAL))) then (MERGEINSERT DIR-NAME (SORT *WHO-LINE-DIRECTORIES* (CL:FUNCTION UALPHORDER))))))) (* ;; "Return the namestring of the current dir") (CDR *WHO-LINE-LAST-DIRECTORY*)) ) (SET-CONNECTED-DIRECTORY-INTERACTIVELY (LAMBDA NIL (* ; "Edited 9-Jun-87 08:57 by smL") (* ;;; "Let the user interactivly change the current connected directory") (DECLARE (GLOBALVARS *WHO-LINE-DIRECTORIES*)) (* ;; "If the user selects an item while holding down a shift key, copy-insert the name of the directory instead of connecting to it") (if (SHIFTDOWNP 'SHIFT) then (LET ((NEW-DIRECTORY (MENU (create MENU TITLE _ "Type in directory name:" ITEMS _ *WHO-LINE-DIRECTORIES*)))) (if NEW-DIRECTORY then (WHO-LINE-COPY-INSERT NEW-DIRECTORY))) else (LET ((NEW-DIRECTORY (MENU (create MENU TITLE _ "Connect to:" ITEMS _ (CONS "* Other *" *WHO-LINE-DIRECTORIES*))))) (if NEW-DIRECTORY then (if (STRING-EQUAL NEW-DIRECTORY "* Other *") then (CLEARW PROMPTWINDOW) (SETQ NEW-DIRECTORY (PROMPTFORWORD "Connect to directory " (CL:NAMESTRING (PROCESS.EVALV (TTY.PROCESS) ' *DEFAULT-PATHNAME-DEFAULTS* )) NIL PROMPTWINDOW NIL 'TTY NIL))) (if NEW-DIRECTORY then (ALLOW.BUTTON.EVENTS) (* ; "Should do this in the current TTY process, in case the conntected directory is a per-process var") (CNDIR NEW-DIRECTORY))))))) ) (DEFGLOBALVAR *WHO-LINE-DIRECTORIES* (BQUOTE ((\, LOGINHOST/DIR))) "Cached list of known directories for the Who-Line Directory entry") (DEFGLOBALVAR *WHO-LINE-LAST-DIRECTORY* (LET ((NAMESTRING (CL:NAMESTRING *DEFAULT-PATHNAME-DEFAULTS*))) (CONS (PATHNAME NAMESTRING) (MKSTRING NAMESTRING))) "Cached name of the current connected directory for the Who-Line Directory entry") (CL:DEFPARAMETER *WHO-LINE-DIRECTORY-ENTRY* (QUOTE ("Dir" (WHO-LINE-CURRENT-DIRECTORY) 30 SET-CONNECTED-DIRECTORY-INTERACTIVELY (SETQ *WHO-LINE-LAST-DIRECTORY* (CONS NIL NIL)) "The currently connected directory")) "Who-Line entry for displaying the name of the currently connected directory") (* ;; "") (* ;; "Showing / changing the current VMem utilization") (DEFINEQ (WHO-LINE-VMEM (LAMBDA NIL (* ; "Edited 14-Jan-87 12:57 by smL") (* ;;; "") (* ;;; "Compute the percentage of vmem in use.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-LAST-VMEM* \LASTVMEMFILEPAGE \InterfacePage \IFPValidKey)) (* ;; "") (* ;; "Compute the percentage of vmem in use. The ratio is the amount in use (computed by (VMEMSIZE)) divided by the amount available (stored in \LASTVMEMFILEPAGE). We multiply by 100 to get a percentage, round to an integer, and do it all in such a way as to ensure we don't cons any FIXPs.") (* ;; "The basic code here is due to Mike Dixon.") (* ;; "") (LET* ((ONE-PERCENT-VMEM (IQUOTIENT (IPLUS \LASTVMEMFILEPAGE 50) 100)) (VMEM-PERCENT (IQUOTIENT (IPLUS (VMEMSIZE) (RSH ONE-PERCENT-VMEM 1)) ONE-PERCENT-VMEM)) (VMEM-CONSISTENT? (.VMEM.CONSISTENTP.))) (* ;; "") (* ;; "We cache the last VMem info and the string-translation of it in the var *WHO-LINE-LAST-VMEM*. That way, we don't have to alloc a new string all the time. We do, however, have to make sure the cached info in correct.") (* ;; "") (if (NOT (AND (EQ VMEM-CONSISTENT? (CADR *WHO-LINE-LAST-VMEM*)) (EQP VMEM-PERCENT (CAR *WHO-LINE-LAST-VMEM*)))) then (change (CAR *WHO-LINE-LAST-VMEM*) VMEM-PERCENT) (change (CADR *WHO-LINE-LAST-VMEM*) VMEM-CONSISTENT?) (change (CADDR *WHO-LINE-LAST-VMEM*) (CONCAT (if VMEM-CONSISTENT? then " " else "*") VMEM-PERCENT "%%"))) (* ;; "") (* ;; "Return the info string") (* ;; "") (CADDR *WHO-LINE-LAST-VMEM*)))) (WHO-LINE-SAVE-VMEM (LAMBDA NIL (* smL "29-Oct-86 11:22") (* ;;; "") (* ;;; "Save the VMem, if the user really wants to") (* ;;; "") (if (MENU (create MENU TITLE _ "Save VMem?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T) ("No" NIL))))) then (SAVEVM))) ) ) (DEFGLOBALVAR *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL) "Cached value for storing the last VMem information for the Who-Line VMem entry") (CL:DEFPARAMETER *WHO-LINE-VMEM-ENTRY* (QUOTE ("VMem" (WHO-LINE-VMEM) 5 WHO-LINE-SAVE-VMEM (SETQ *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL)) "Percentage of VMem currently in use")) "Who-Line entry for displaying the current VMem utilization") (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILESLOAD (LOADCOMP) LLFAULT MODARITH) (CHECKIMPORTS (QUOTE (LLPARAMS)) T) ) (* ;; "") (* ;; "Showing the percent of symbol-space currently used") (CL:DEFUN WHO-LINE-SYMBOL-SPACE NIL "Return a string describing the percentage of symbol space in use" (LET ((TOTAL-SYMBOL-SPACE (UNFOLD (CL:1+ \LastAtomPage) WORDSPERCELL)) (SYMBOL-SPACE-IN-USE (FOLDHI \AtomFrLst CELLSPERPAGE))) (* ;; "Only recompute the display string when the fraction of space has changed. This saves us the effort of CONSing up the string each time.") (CL:UNLESS (AND (EQL (CL:FIRST *WHO-LINE-SYMBOL-SPACE*) TOTAL-SYMBOL-SPACE) (EQL (CL:SECOND *WHO-LINE-SYMBOL-SPACE*) SYMBOL-SPACE-IN-USE)) (CL:SETF (CL:FIRST *WHO-LINE-SYMBOL-SPACE*) TOTAL-SYMBOL-SPACE (CL:SECOND *WHO-LINE-SYMBOL-SPACE*) SYMBOL-SPACE-IN-USE (CL:THIRD *WHO-LINE-SYMBOL-SPACE*) (CL:FORMAT NIL "~3D%%" (- 100 (ROUND (- 100 (/ (CL:* SYMBOL-SPACE-IN-USE 100) TOTAL-SYMBOL-SPACE))))))) (CL:THIRD *WHO-LINE-SYMBOL-SPACE*))) (DEFGLOBALVAR *WHO-LINE-SYMBOL-SPACE* (LIST NIL NIL NIL "Remembers the previous who-line symbol space")) (CL:DEFPARAMETER *WHO-LINE-SYMBOL-SPACE-ENTRY* (QUOTE ("Syms" (WHO-LINE-SYMBOL-SPACE) 4 NIL (SETQ *WHO-LINE-SYMBOL-SPACE* (LIST NIL NIL NIL)) "Percentage of symbol space currently in use")) "Who-line entry for displaying percent of symbol space in use") (* ;; "") (* ;; "Showing the current time") (DEFINEQ (WHO-LINE-TIME (LAMBDA NIL (* ; "Edited 14-Jan-87 12:48 by smL") (* ;;; "") (* ;;; "Return the current time as a string. Avoid CONSing as much as possible.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME*)) (if (TIMEREXPIRED? *WHO-LINE-TIMER* (QUOTE SECONDS)) then (* ;; "") (* ;; "Reset the timer, and return the new time") (* ;; "") (LET ((NOW (IDATE))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER NOW 60)) (CONSTANT (SETUPTIMER 0 NIL (QUOTE SECONDS))) (QUOTE SECONDS))) (SETQ *WHO-LINE-OLD-TIME* (GDATE NOW (CONSTANT (DATEFORMAT NO.SECONDS)) *WHO-LINE-OLD-TIME*)) *WHO-LINE-OLD-TIME*) else (* ;; "") (* ;; "The timer hasn't expired, so the old time is good enough") (* ;; "") *WHO-LINE-OLD-TIME*)) ) (WHO-LINE-SET-TIME (LAMBDA NIL (* ; "Edited 17-Mar-87 18:20 by smL") (* ;;; "") (* ;;; "Set the time from the network, if the user really wants to") (* ;;; "") (COND ((SHIFTDOWNP 'SHIFT) (* ;; "Selection with a shift key down causes the current time to be bksysbuf'ed") (WHO-LINE-COPY-INSERT *WHO-LINE-OLD-TIME*)) ((MENU (create MENU TITLE _ "Set time?" CENTERFLG _ T ITEMS _ '(("Yes" T) ("No" NIL)))) (* ;; "The user wants to reset the time") (SETTIME))))) ) (DEFGLOBALVAR *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) 60)) NIL (QUOTE SECONDS)) "Timer for controlling updates of the Who-Line Time entry") (DEFGLOBALVAR *WHO-LINE-OLD-TIME* (DATE (DATEFORMAT NO.SECONDS)) "Cached value for the Who-Line Time entry") (CL:DEFPARAMETER *WHO-LINE-TIME-ENTRY* (QUOTE ("Time" (WHO-LINE-TIME) 15 WHO-LINE-SET-TIME (PROGN (SETQ *WHO-LINE-OLD-TIME* (DATE (DATEFORMAT NO.SECONDS))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) 60)) NIL (QUOTE SECONDS)))) "Time of day")) "Who-Line entry for displaying the current time of day") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-TIMER* SECONDS)) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some as yet un-debugged entries. Try at your own risk.") (* ;; "") (* ;; "Showing the machine-active entry") (DEFINEQ (WHO-LINE-SHOW-ACTIVE (LAMBDA NIL (* ; "Edited 20-Apr-87 09:58 by smL") (* ;;; "Update the who-line active indicator, if it is time") (DECLARE (GLOBALVARS *WHO-LINE* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-ACTIVE-PERIOD*)) (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS) then (* ;; "A second has passed, so update the indicator if we can") (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*) (* ;; "Reset the timer") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS))) (* ;; "Always return the same thing") " ")) (\UPDATE-WHO-LINE-ACTIVE-FLAG (LAMBDA (WINDOW) (* ; "Edited 20-Apr-87 09:58 by smL") (* ;;; "Flip the active-indicator in the who-line") (for ENTRY in (WINDOWPROP WINDOW 'ENTRIES) thereis (with WHO-LINE-ENTRY ENTRY (AND (LISTP FORM) (EQ (CAR FORM) 'WHO-LINE-SHOW-ACTIVE))) finally (if $$VAL then (with WHO-LINE-ENTRY $$VAL (BLTSHADE BLACKSHADE WINDOW VALUE-START 2 (DIFFERENCE VALUE-END VALUE-START) (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) 4) 'INVERT)))))) (\PERIODICALLY-WHO-LINE-SHOW-ACTIVE (LAMBDA NIL (* ; "Edited 14-Jan-87 12:50 by smL") (* ;;; "") (* ;;; "Update the who-line active indicator, if it is time") (* ;;; "This is designed to be run on the \PERIODIC.INTERRUPT hook.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-ACTIVE-TIMER* *WHO-LINE* *WHO-LINE-ACTIVE-PERIOD*)) (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS)) then (* ;; "") (* ;; "A second has passed, so update the indicator if we can") (* ;; "") (* ;; "But only if the who-line is on the top") (* ;; "") (if (AND (OPENWP *WHO-LINE*) (TOPWP *WHO-LINE*)) then (* ;; "") (* ;; "The who-line is on the top, so we can update it") (* ;; "") (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*)) (* ;; "") (* ;; "Reset the timer") (* ;; "") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS))))) ) ) (DEFGLOBALVAR *WHO-LINE-ACTIVE-PERIOD* 500 "Interval between updating the Who-Line activity entry") (DEFGLOBALVAR *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* NIL (QUOTE MILLISECONDS)) "Timer for controlling updating of the Who-Line activity entry") (CL:DEFPARAMETER *WHO-LINE-SHOW-ACTIVE-ENTRY* (QUOTE ("" (WHO-LINE-SHOW-ACTIVE) 2 NIL (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* NIL (QUOTE MILLISECONDS))) "Indication of machine activity")) "Who-Line entry for displaying the activity of the machine") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-ACTIVE-TIMER* MILLISECONDS)) ) (* ;; "") (* ;; "Showing / changing the current reader profile") (DEFINEQ (CURRENT-PROFILE (LAMBDA NIL (* ; "Edited 12-Jan-87 14:36 by smL") (* ;;; "") (* ;;; "Return the name of the current reader profile of the current TTY process") (* ;;; "") (XCL:PROFILE-NAME (PROCESS.EVALV (TTY.PROCESS) (QUOTE XCL:*PROFILE*)))) ) (SET-PROFILE-INTERACTIVELY (LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;; "") (* ;; "Let the user interactivly change the current reader profile") (* ;; "") (LET ((PROFILE (MENU (create MENU TITLE _ "Select profile" ITEMS _ (SORT (for PROFILE in (XCL:LIST-ALL-PROFILES) bind PROFILE-NAME collect (XCL:PROFILE-NAME PROFILE))) CENTERFLG _ T)))) (if PROFILE then (XCL:RESTORE-PROFILE PROFILE)))) ) (SET-TTY-PROFILE-INTERACTIVELY (LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;;; "") (* ;;; "Interactivly let the user change the reader profile of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PROFILE-INTERACTIVELY)) T)) ) ) (CL:DEFPARAMETER *WHO-LINE-PROFILE-ENTRY* (QUOTE ("Profile" (CURRENT-PROFILE) 10 SET-TTY-PROFILE-INTERACTIVELY NIL "The read/write profile of the current TTY process")) "Who-Line entry for displaying the current read/write profile") (* ;; "") (* ;; "Showing the state of the current TTY process") (DEFINEQ (WHO-LINE-TTY-STATE (LAMBDA NIL (* ; "Edited 17-Apr-87 18:26 by smL") (* ;;; "Find out what state the current TTY process is in") (LET ((PROC (TTY.PROCESS))) (COND ((NULL PROC) (* ;; " No tty process? Never happens now, but maybe allowed in future.") "") ((EQ PROC (THIS.PROCESS)) (* ;; " Check explicitly for us being tty, since in that case PROC is not a valid stack pointer (we're running).") "Who-Line") ((PROCESS.EVALV PROC '*WHO-LINE-STATE*)) ((NOT (PROCESS.FINISHEDP PROC)) (for I from 0 by -1 bind FRAMENAME while (SETQ FRAMENAME (STKNTHNAME I PROC)) unless (MEMB FRAMENAME *WHO-LINE-STATE-UNINTERESTING-FNS*) do (* ;; " Walk back process looking for interesting frame name. This search is non-linear in that each iteration takes a little longer, but we expect it to terminate early.") (RETURN (OR (GETPROP FRAMENAME 'WHO-LINE-STATE) FRAMENAME)))))))) (WHO-LINE-WHAT-IS-RUNNING (LAMBDA NIL (* ; "Edited 14-Jan-87 12:51 by smL") (* ;;; "") (* ;;; "When run under a (PROCESS.EVAL '(WHO-LINE-WHAT-IS-RUNNING) T), returns the name of the current running frame in the process") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-STATE-UNINTERESTING-FNS*)) (PROG ((POS-HOLDER (CONSTANT (LIST NIL))) POS) (* ;; "") (* ;; "We use the POS-HOLDER to hold an old stack pointer, so that we don't have to alloc one") (* ;; "") (SETQ POS (STKPOS (QUOTE \PROCESS.EVAL1) NIL NIL (CAR POS-HOLDER))) (COND (POS (change (CAR POS-HOLDER) POS)) (T (RETURN NIL))) LP (SETQ POS (STKNTH 1 POS POS)) (COND ((NULL POS) (RETURN NIL)) ((MEMB (STKNAME POS) *WHO-LINE-STATE-UNINTERESTING-FNS*) (* ; "Ignore any uninteresting fns") (GO LP)) (T (RETURN (PROG1 (STKNAME POS) (RELSTK POS))))))) ) ) (CL:DEFVAR *WHO-LINE-STATE* NIL "Cached state shown in the Who-Line State entry") (DEFGLOBALVAR *WHO-LINE-STATE-UNINTERESTING-FNS* (QUOTE (BLOCK ERRORSET OBTAIN.MONITORLOCK MONITOR.AWAIT.EVENT AWAIT.EVENT SI::*UNWIND-PROTECT*)) "Uninteresting fns to skip over in the Who-Line State entry") (CL:DEFPARAMETER *WHO-LINE-TTY-STATE-ENTRY* (QUOTE ("State" (WHO-LINE-TTY-STATE) 15 NIL (SETQ *WHO-LINE-STATE* NIL) "Running state of the current TTY process")) "Who-Line entry for showing the running state of the current TTY process") (PUTPROPS AWAIT.EVENT WHO-LINE-STATE "Block") (PUTPROPS BLOCK WHO-LINE-STATE "Block") (PUTPROPS EXCHANGEPUPS WHO-LINE-STATE "Net I/O") (PUTPROPS GETPUP WHO-LINE-STATE "Net I/O") (PUTPROPS SENDPUP WHO-LINE-STATE "Net I/O") (PUTPROPS WAIT.FOR.TTY WHO-LINE-STATE "TTY wait") (PUTPROPS \TTYBACKGROUND WHO-LINE-STATE "TTY wait") (PUTPROPS \WAITFORSYSBUFP WHO-LINE-STATE "TTY wait") (PUTPROPS \\getkey WHO-LINE-STATE "TTY wait") (PUTPROPS \SENDLEAF WHO-LINE-STATE "Net I/O") (PUTPROPS PUTSEQUIN WHO-LINE-STATE "Net I/O") (PUTPROPS \LEAF.READPAGES WHO-LINE-STATE "Net I/O") (* ;;; "----------------------------------------------------------------------") (* ;;; "Default options for the who-line") (DEFGLOBALVAR *WHO-LINE-ENTRIES* (BQUOTE ((\, *WHO-LINE-USER-ENTRY*) (\, *WHO-LINE-PACKAGE-ENTRY*) (\, *WHO-LINE-READTABLE-ENTRY*) (\, *WHO-LINE-TTY-PROC-ENTRY*) (\, *WHO-LINE-DIRECTORY-ENTRY*) (\, *WHO-LINE-VMEM-ENTRY*) (\, *WHO-LINE-TIME-ENTRY*))) "List of all the entries to show in the Who-Line") (DEFGLOBALVAR *WHO-LINE-ENTRY-REGISTRY* (LIST *WHO-LINE-USER-ENTRY* *WHO-LINE-HOST-NAME-ENTRY* *WHO-LINE-PACKAGE-ENTRY* *WHO-LINE-READTABLE-ENTRY* *WHO-LINE-TTY-PROC-ENTRY* *WHO-LINE-DIRECTORY-ENTRY* *WHO-LINE-VMEM-ENTRY* *WHO-LINE-SYMBOL-SPACE-ENTRY* *WHO-LINE-TIME-ENTRY* *WHO-LINE-SHOW-ACTIVE-ENTRY* *WHO-LINE-PROFILE-ENTRY* *WHO-LINE-TTY-STATE-ENTRY*) "List of all known Who-Line entries.") (DEFGLOBALVAR *WHO-LINE-ANCHOR* (QUOTE (:CENTER :BOTTOM)) "Location to place the Who-Line") (DEFGLOBALVAR *WHO-LINE-NAME-FONT* (FONTCREATE (QUOTE (HELVETICA 8 BOLD))) "Font to use to show entry labels in the Who-Line") (DEFGLOBALVAR *WHO-LINE-VALUE-FONT* (FONTCREATE (QUOTE (GACHA 8))) "Font to use to show the entry values in the Who-Line") (DEFGLOBALVAR *WHO-LINE-DISPLAY-NAMES?* T "Flag for enabling or disabling the display of entry names in the Who-Line") (DEFGLOBALVAR *WHO-LINE-COLOR* :WHITE "Color of the Who-Line -- one of :WHITE or :BLACK") (DEFGLOBALVAR *WHO-LINE-TITLE* NIL "The window title of the Who-Line") (DEFGLOBALVAR *WHO-LINE-BORDER* 2 "The border width of the Who-Line window") (DEFGLOBALVAR *WHO-LINE-UPDATE-INTERVAL* 100 "Update interval for the Who-Line, in milliseconds") (* ;;; "----------------------------------------------------------------------") (* ;;; "Internal fns") (DEFINEQ (REDISPLAY-WHO-LINE (LAMBDA (WINDOW) (* ; "Edited 17-Apr-87 19:06 by smL") (* ;;; "Redisplay the entire who-line, including the names of the fields") (WITH-WHO-LINE WINDOW (* ;; "") (* ;; "Set the display characteristics of the window, according to its color") (DSPSOURCETYPE (SELECTQ (WINDOWPROP WINDOW 'COLOR) (:WHITE 'INPUT) (:BLACK 'INVERT) (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) WINDOW) (DSPTEXTURE (SELECTQ (WINDOWPROP WINDOW 'COLOR) (:WHITE WHITESHADE) (:BLACK BLACKSHADE) (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) WINDOW) (* ;; "") (* ;; "Clear the window") (CLEARW WINDOW) (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) do (replace (WHO-LINE-ENTRY INVERTED?) of ITEM with NIL)) (* ;; "") (* ;; "Display the labels if we should") (if (WINDOWPROP WINDOW 'DISPLAY-NAMES?) then (DSPFONT (WINDOWPROP WINDOW 'NAME-FONT) WINDOW) (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) bind (FONT _ (WINDOWPROP WINDOW 'NAME-FONT)) do (MOVETO (fetch (WHO-LINE-ENTRY NAME-START) of ITEM) (PLUS (FONTPROP FONT 'DESCENT) (QUOTIENT (DIFFERENCE (WINDOWPROP *WHO-LINE* 'HEIGHT) (FONTPROP FONT 'HEIGHT)) 2)) WINDOW) (PRIN1 (fetch (WHO-LINE-ENTRY NAME) of ITEM) WINDOW))) (* ;; "") (* ;; "Display the values") (DSPFONT (WINDOWPROP WINDOW 'VALUE-FONT) WINDOW) (UPDATE-WHO-LINE WINDOW (WINDOWPROP WINDOW 'ENTRIES) T) (* ;; "") (* ;; "Reset the timer for the next update") (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) (PERIODICALLY-UPDATE-WHO-LINE (LAMBDA NIL (* ; "Edited 27-Jan-88 10:11 by smL") (* ;;; "") (* ;;; "Update the current who-line window every so often. This is designed to be placed on the list of BACKBROUNDFNS.") (* ;;; "") (DECLARE (GLOBALVARS \IDLING)) (CL:WHEN (TIMEREXPIRED? *WHO-LINE-UPDATE-TIMER* 'TICKS) (CL:WHEN (AND (BOUNDP '*WHO-LINE*) (NOT \IDLING)) (* ; "Don't bother to wait and update if the window is owned by someone.") (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) (GETWINDOWPROP *WHO-LINE* 'VALID)) then (UPDATE-WHO-LINE *WHO-LINE* (GETWINDOWPROP *WHO-LINE* 'ENTRIES))))) (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) (SETUP-WHOLINE-TIMER (LAMBDA (OLD-TIMER) (* ; "Edited 18-Mar-87 11:14 by smL") (SETUPTIMER (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL) OLD-TIMER 'TICKS))) (UPDATE-WHO-LINE (LAMBDA (WINDOW WHO-LINE-ENTRIES ALWAYS?) (* ; "Edited 17-Apr-87 19:05 by smL") (* ;;; "Update the window to show the current who-line stats") (WITH-WHO-LINE WINDOW (* ;; "") (* ;; "Update all the entries that have changed") (for ENTRY in WHO-LINE-ENTRIES bind (VALUE-BOTTOM _ (GETWINDOWPROP WINDOW 'VALUE-BOTTOM)) (STREAM _ (GETWINDOWPROP WINDOW 'TEMP-STREAM)) (HEIGHT _ (GETWINDOWPROP WINDOW 'HEIGHT)) (BLACK-WINDOW-P _ (EQ (WINDOWPROP WINDOW 'COLOR) :BLACK)) do (with WHO-LINE-ENTRY ENTRY (* ; "If the node is inverted, the user is mousing it, so don't update it") (if (NOT INVERTED?) then (if ALWAYS? then (EVAL RESET-FORM)) (LET ((VALUE (EVAL FORM))) (* ;; "") (* ;; "Only update if the value has changed, or we are ordered to.") (if (OR ALWAYS? (NOT (EQUAL VALUE PREV-VALUE))) then (* ;; "") (* ;; "Print the new value") (MOVETO VALUE-START VALUE-BOTTOM STREAM) (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'ERASE) (DSPFONT (DSPFONT NIL WINDOW) STREAM) (PRIN1 VALUE STREAM) (if BLACK-WINDOW-P then (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'INVERT)) (BITBLT STREAM VALUE-START 0 WINDOW VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'PAINT) (* ;; "") (* ;; "Save the value.") (* ;; "We are worried that a form may be re-using a value (to minimize CONS-ing), so we store a copy of the value rather than the real value.") (SETQ PREV-VALUE (COPYALL VALUE)))))))))) (WHEN-WHO-LINE-SELECTED-FN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 09:54 by smL") (* ;;; "") (* ;;; "The button has gone down in the who-line window.") (* ;;; "If the control or edit key is down, allow the user to change the entries in the who-line.") (* ;;; "If the user selects an item, and it has a when-selected-fn, funcall that fn.") (* ;;; "") (WITH-WHO-LINE WINDOW (TOTOPW WINDOW) (GETMOUSESTATE) (if (OR (KEYDOWNP 'EDIT) (KEYDOWNP 'CTRL)) then (WHO-LINE-CONTROL-SELECT) else (bind (REGION _ (WINDOWPROP WINDOW 'REGION)) (ENTRIES _ (WINDOWPROP WINDOW 'ENTRIES)) INVERTED-ITEM CURRENT-ITEM while (MOUSESTATE (NOT UP)) do (* ;; "") (* ;; "If cursor has left the window, quit tracking") (* ;; "") (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) then (SETQ CURRENT-ITEM NIL) (GO $$OUT)) (* ;; "") (* ;; "Find out what item we are currently on") (* ;; "") (SETQ CURRENT-ITEM (for ENTRY in ENTRIES thereis (with WHO-LINE-ENTRY ENTRY (AND (GEQ (LASTMOUSEX WINDOW) NAME-START) (LEQ (LASTMOUSEX WINDOW) VALUE-END) (NOT (NULL WHEN-SELECTED-FN)))))) (* ;; "") (* ;; "Invert the current choice") (* ;; "") (if (NEQ INVERTED-ITEM CURRENT-ITEM) then (if INVERTED-ITEM then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) (if CURRENT-ITEM then (INVERT-WHO-LINE-ENTRY CURRENT-ITEM WINDOW)) (SETQ INVERTED-ITEM CURRENT-ITEM)) finally (* ;; "") (* ;; "The button went up. If we were on an item, let it know") (* ;; "") (if INVERTED-ITEM then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) (if CURRENT-ITEM then (with WHO-LINE-ENTRY CURRENT-ITEM (if WHEN-SELECTED-FN then (APPLY* WHEN-SELECTED-FN ) (EVAL RESET-FORM)))))) ))) (WHO-LINE-CONTROL-SELECT (LAMBDA NIL "Interactivly let the user add or delete an entry to the WHO-LINE." (CL:FLET ((ENTRY-DESCRIPTION (X) (OR (CL:SIXTH X) (CONCAT "Entry named: " (CL:FIRST X))))) (CASE (MENU (create MENU ITEMS _ '(("Add item" :ADD "Add a new entry to the who-line") ("Remove item" :REMOVE "Remove an existing entry from the who-line")) TITLE _ "Change WHO-LINE entries")) (:ADD (LET* ((ITEMS (for entry in *WHO-LINE-ENTRY-REGISTRY* unless (MEMBER entry *WHO-LINE-ENTRIES*) collect `(,(ENTRY-DESCRIPTION entry) ',entry))) (NEW-ENTRY (if ITEMS then (MENU (create MENU ITEMS _ ITEMS TITLE _ "Entry to add to WHO-LINE")) else nil))) (if NEW-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CONS NEW-ENTRY *WHO-LINE-ENTRIES*)) (INSTALL-WHO-LINE-OPTIONS)))) (:REMOVE (LET* ((ITEMS (for entry in *WHO-LINE-ENTRIES* collect `(,(ENTRY-DESCRIPTION entry) ',entry))) (BAD-ENTRY (if ITEMS then (MENU (create MENU ITEMS _ ITEMS TITLE _ "Entry to remove from WHO-LINE")) else nil))) (if BAD-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CL:REMOVE BAD-ENTRY *WHO-LINE-ENTRIES*)) (INSTALL-WHO-LINE-OPTIONS)))))))) (WHO-LINE-COPY-INSERT (LAMBDA (X) (* ; "Edited 18-Mar-87 13:11 by smL") (LET ((TTY-WINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS NIL))))) (if (OR (IMAGEOBJP X) (AND (WINDOWP TTY-WINDOW) (WINDOWPROP TTY-WINDOW 'COPYINSERTFN))) then (COPYINSERT X) else (BKSYSBUF X NIL))))) ) (DEFINEQ (WHO-LINE-REDISPLAY-INTERRUPT (LAMBDA NIL (* ; "Edited 20-Apr-87 11:32 by smL") (* ;;; "Update the current who-line window because the user has requested it via an interrupt.") (if (BOUNDP '*WHO-LINE*) then (* ;; "Update the Who-Line, if it is available") (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) (WINDOWPROP *WHO-LINE* 'VALID)) then (* ; "Flash the Who-line to let people know that it is being updated") (CLOSEW *WHO-LINE*) (OPENW *WHO-LINE*) (* ; "The update the entries") (UPDATE-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'ENTRIES))))) )) ) (DEFGLOBALVAR *WHO-LINE* NIL "The who-line window") (DEFGLOBALVAR *WHO-LINE-UPDATE-TIMER* NIL "Timer for controlling updating of the Who-Line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-UPDATE-TIMER* TICKS)) ) (DEFMACRO INVERT-WHO-LINE-ENTRY (ENTRY WINDOW) (BQUOTE (WITH WHO-LINE-ENTRY (\, ENTRY) (BLTSHADE BLACKSHADE (\, WINDOW) NAME-START 0 (DIFFERENCE VALUE-END NAME-START) NIL (QUOTE INVERT)) (CHANGE INVERTED? (NOT INVERTED?))))) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD WHO-LINE-ENTRY (NAME FORM NAME-START VALUE-START VALUE-END PREV-VALUE WHEN-SELECTED-FN INVERTED? RESET-FORM DESCRIPTION) ) ) ) (* ; "Macros that lets us lock down the Who-Line while we evaluate some forms") (DEFMACRO WITH-WHO-LINE (WHO-LINE &BODY FORMS) "Evaluate the forms with the who-line locked down" (BQUOTE (WITH.MONITOR (WINDOWPROP (\, WHO-LINE) (QUOTE LOCK)) (\,@ FORMS)))) (DEFMACRO WITH-AVAILABLE-WHO-LINE (WHO-LINE &BODY FORMS) "Evaluate the forms with the who-line locked down, if the who-line is available" (LET ((LOCK (CL:GENSYM))) (BQUOTE (LET (((\, LOCK) (OBTAIN.MONITORLOCK (WINDOWPROP (\, WHO-LINE) (QUOTE LOCK)) T))) (CL:UNWIND-PROTECT (* ; "Only eval the forms if we got the lock") (COND ((\, LOCK) (\,@ FORMS))) (* ;; "Now for the cleanup forms") (COND ((EQ (\, LOCK) T) (* ; "Had the lock before, so no need to release it") NIL) ((NULL (\, LOCK)) (* ; "Couldn't get the lock, so no need to release it") NIL) (T (* ; "We got the lock, and need to release it") (RELEASE.MONITORLOCK (\, LOCK))))))))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Initialize the who-line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (INSTALL-WHO-LINE-OPTIONS) (ADDTOVAR BACKGROUNDFNS PERIODICALLY-UPDATE-WHO-LINE) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PUTPROPS WHO-LINE MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) (PUTPROPS WHO-LINE FILETYPE :COMPILE-FILE) ) (PUTPROPS WHO-LINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5579 20958 (INSTALL-WHO-LINE-OPTIONS 5589 . 20956)) (21218 22387 (WHO-LINE-USERNAME 21228 . 21875) (WHO-LINE-CHANGE-USER 21877 . 22183) (WHO-LINE-USER-AFTER-LOGIN 22185 . 22385)) (22936 23415 (WHO-LINE-HOST-NAME 22946 . 23413)) (23910 26539 (CURRENT-TTY-PACKAGE 23920 . 24872) ( SET-PACKAGE-INTERACTIVELY 24874 . 26293) (SET-TTY-PACKAGE-INTERACTIVELY 26295 . 26537)) (27025 28077 ( CURRENT-TTY-READTABLE-NAME 27035 . 27289) (SET-READTABLE-INTERACTIVELY 27291 . 27825) ( SET-TTY-READTABLE-INTERACTIVELY 27827 . 28075)) (28404 28976 (WHO-LINE-TTY-PROCESS 28414 . 28592) ( CHANGE-TTY-PROCESS-INTERACTIVELY 28594 . 28974)) (29275 32746 (WHO-LINE-CURRENT-DIRECTORY 29285 . 30692) (SET-CONNECTED-DIRECTORY-INTERACTIVELY 30694 . 32744)) (33493 35893 (WHO-LINE-VMEM 33503 . 35640) (WHO-LINE-SAVE-VMEM 35642 . 35891)) (37698 39136 (WHO-LINE-TIME 37708 . 38450) ( WHO-LINE-SET-TIME 38452 . 39134)) (40057 42690 (WHO-LINE-SHOW-ACTIVE 40067 . 40845) ( \UPDATE-WHO-LINE-ACTIVE-FLAG 40847 . 41815) (\PERIODICALLY-WHO-LINE-SHOW-ACTIVE 41817 . 42688)) (43425 44350 (CURRENT-PROFILE 43435 . 43680) (SET-PROFILE-INTERACTIVELY 43682 . 44085) ( SET-TTY-PROFILE-INTERACTIVELY 44087 . 44348)) (44657 46640 (WHO-LINE-TTY-STATE 44667 . 45828) ( WHO-LINE-WHAT-IS-RUNNING 45830 . 46638)) (49496 62477 (REDISPLAY-WHO-LINE 49506 . 52066) ( PERIODICALLY-UPDATE-WHO-LINE 52068 . 53206) (SETUP-WHOLINE-TIMER 53208 . 53426) (UPDATE-WHO-LINE 53428 . 56496) (WHEN-WHO-LINE-SELECTED-FN 56498 . 59765) (WHO-LINE-CONTROL-SELECT 59767 . 62081) ( WHO-LINE-COPY-INSERT 62083 . 62475)) (62478 63612 (WHO-LINE-REDISPLAY-INTERRUPT 62488 . 63610))))) STOP \ No newline at end of file diff --git a/lispusers/WHO-LINE.~2~ b/lispusers/WHO-LINE.~2~ deleted file mode 100644 index 9108a092..00000000 --- a/lispusers/WHO-LINE.~2~ +++ /dev/null @@ -1,747 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Feb-2001 11:53:32" {DSK}medley3.5>lispusers>WHO-LINE.;4 73898 changes to%: (VARIABLES *WHO-LINE-TIME-ENTRY*) previous date%: "28-Dec-98 12:56:28" {DSK}medley3.5>lispusers>WHO-LINE.;3) (* ; " Copyright (c) 1986, 1987, 1988, 1989, 1994, 1998, 2001 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WHO-LINECOMS) (RPAQQ WHO-LINECOMS ( (* ;;; "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (* ;; "") (* ;; "Public fn for manipulating the who-line") (FNS INSTALL-WHO-LINE-OPTIONS) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some fns that compute useful values for the who-line, and act as nice button event fns") (* ;; "") (* ;; "Showing / changing the current logged in user") (FNS WHO-LINE-USERNAME WHO-LINE-CHANGE-USER WHO-LINE-USER-AFTER-LOGIN) (VARIABLES *WHO-LINE-CURRENT-USER* *WHO-LINE-USER-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDVARS (\SYSTEMCACHEVARS *WHO-LINE-CURRENT-USER*) (\AFTERLOGINFNS WHO-LINE-USER-AFTER-LOGIN))) (* ;; "") (* ;; "Showing the current machine name") (FNS WHO-LINE-HOST-NAME) (VARIABLES *WHO-LINE-HOST-NAME* *WHO-LINE-HOST-NAME-ENTRY*) (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDVARS (\SYSTEMCACHEVARS *WHO-LINE-HOST-NAME*))) (* ;; "") (* ;; "Showing / changing the current tty process package") (FNS CURRENT-TTY-PACKAGE SET-PACKAGE-INTERACTIVELY SET-TTY-PACKAGE-INTERACTIVELY) (VARIABLES *WHO-LINE-PACKAGE-NAME-CACHE* *WHO-LINE-PACKAGE-ENTRY*) (* ;; "") (* ;; "Showing / changing the current tty process readtable") (FNS CURRENT-TTY-READTABLE-NAME SET-READTABLE-INTERACTIVELY SET-TTY-READTABLE-INTERACTIVELY) (VARIABLES *WHO-LINE-READTABLE-ENTRY*) (* ;; "") (* ;; "Showing / changing the current tty process") (FNS WHO-LINE-TTY-PROCESS CHANGE-TTY-PROCESS-INTERACTIVELY) (VARIABLES *WHO-LINE-TTY-PROC-ENTRY*) (* ;; "") (* ;; "Showing / changing the currently connected directory") (FNS WHO-LINE-CURRENT-DIRECTORY SET-CONNECTED-DIRECTORY-INTERACTIVELY) (VARIABLES *WHO-LINE-DIRECTORIES* *WHO-LINE-LAST-DIRECTORY* *WHO-LINE-DIRECTORY-ENTRY*) (* ;; "") (* ;; "Showing / changing the current VMem utilization") (FNS WHO-LINE-VMEM WHO-LINE-SAVE-VMEM) (VARIABLES *WHO-LINE-LAST-VMEM* *WHO-LINE-VMEM-ENTRY*) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILES (LOADCOMP) LLFAULT MODARITH) (P (CHECKIMPORTS '(LLPARAMS) T))) (* ;; "") (* ;; "Showing the percent of symbol-space currently used") (FUNCTIONS WHO-LINE-SYMBOL-SPACE) (VARIABLES *WHO-LINE-SYMBOL-SPACE* *WHO-LINE-SYMBOL-SPACE-ENTRY*) (* ;; "") (* ;; "Showing the current time") (FNS WHO-LINE-TIME WHO-LINE-SET-TIME) (VARIABLES *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME* *WHO-LINE-TIME-ENTRY*) [DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS (*WHO-LINE-TIMER* SECONDS] (* ;;; "----------------------------------------------------------------------") (* ;;; "Some as yet un-debugged entries. Try at your own risk.") (* ;; "") (* ;; "Showing the machine-active entry") (FNS WHO-LINE-SHOW-ACTIVE \UPDATE-WHO-LINE-ACTIVE-FLAG \PERIODICALLY-WHO-LINE-SHOW-ACTIVE) (VARIABLES *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-SHOW-ACTIVE-ENTRY*) [DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS ( *WHO-LINE-ACTIVE-TIMER* MILLISECONDS] (* ;; "") (* ;; "Showing / changing the current reader profile") (FNS CURRENT-PROFILE SET-PROFILE-INTERACTIVELY SET-TTY-PROFILE-INTERACTIVELY) (VARIABLES *WHO-LINE-PROFILE-ENTRY*) (* ;; "") (* ;; "Showing the state of the current TTY process") (FNS WHO-LINE-TTY-STATE WHO-LINE-WHAT-IS-RUNNING) (VARIABLES *WHO-LINE-STATE* *WHO-LINE-STATE-UNINTERESTING-FNS* *WHO-LINE-TTY-STATE-ENTRY*) (PROP WHO-LINE-STATE AWAIT.EVENT BLOCK EXCHANGEPUPS GETPUP SENDPUP WAIT.FOR.TTY \TTYBACKGROUND \WAITFORSYSBUFP \\getkey \SENDLEAF PUTSEQUIN \LEAF.READPAGES) (* ;;; "----------------------------------------------------------------------") (* ;;; "Default options for the who-line") (VARIABLES *WHO-LINE-ENTRIES* *WHO-LINE-ENTRY-REGISTRY* *WHO-LINE-ANCHOR* *WHO-LINE-NAME-FONT* *WHO-LINE-VALUE-FONT* *WHO-LINE-DISPLAY-NAMES?* *WHO-LINE-COLOR* *WHO-LINE-TITLE* *WHO-LINE-BORDER* *WHO-LINE-UPDATE-INTERVAL*) (* ;;; "----------------------------------------------------------------------") (* ;;; "Internal fns") (FNS REDISPLAY-WHO-LINE PERIODICALLY-UPDATE-WHO-LINE SETUP-WHOLINE-TIMER UPDATE-WHO-LINE WHEN-WHO-LINE-SELECTED-FN WHO-LINE-CONTROL-SELECT WHO-LINE-COPY-INSERT) (FNS WHO-LINE-REDISPLAY-INTERRUPT) (VARIABLES *WHO-LINE* *WHO-LINE-UPDATE-TIMER*) [DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDVARS (\SYSTEMTIMERVARS ( *WHO-LINE-UPDATE-TIMER* TICKS] (FUNCTIONS INVERT-WHO-LINE-ENTRY) (DECLARE%: DONTCOPY (RECORDS WHO-LINE-ENTRY)) (* ;  "Macros that lets us lock down the Who-Line while we evaluate some forms") (FUNCTIONS WITH-WHO-LINE WITH-AVAILABLE-WHO-LINE) (* ;;; "----------------------------------------------------------------------") (* ;;; "Initialize the who-line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (P (INSTALL-WHO-LINE-OPTIONS)) (ADDVARS (BACKGROUNDFNS PERIODICALLY-UPDATE-WHO-LINE))) (* ;;; "----------------------------------------------------------------------") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT WHO-LINE) (PROP FILETYPE WHO-LINE)))) (* ;;; "Define a WHO-LINE window that displays the current state of a number of user specified attributes.") (* ;; "") (* ;; "Public fn for manipulating the who-line") (DEFINEQ (INSTALL-WHO-LINE-OPTIONS - (LAMBDA NIL (* ; "Edited 16-May-88 14:19 by smL") - -(* ;;; "") - -(* ;;; "Install new descriptions of the values to be displayed in the who-line.") - -(* ;;; "Each description is a list of four items: then name of the value, a form that will compute the value, the maximum number of characters in the resulting value, and an optional function that will be FUNCALLed if/when that item is moused in the who-line.") - -(* ;;; "") - - (* ;; "") - - (* ;; "Create the who-line window if it isn't there already") - - (* ;; "") - - (if (NOT (AND (BOUNDP '*WHO-LINE*) - (WINDOWP *WHO-LINE*))) - then (SETQ *WHO-LINE* (CREATEW (CREATEREGION 0 0 100 20) - NIL NIL T)) - (WINDOWPROP *WHO-LINE* 'LOCK (CREATE.MONITORLOCK "WHO-LINE"))) - (WITH-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'VALID NIL) - (OPENW *WHO-LINE*) - (LET ((CURRENT-LEFT 0) - ENTRIES) - - (* ;; "") - - (* ;; "Make sure the who-line has all the correct window properties") - - (* ;; "") - - (WINDOWPROP *WHO-LINE* 'REPAINTFN 'REDISPLAY-WHO-LINE) - (WINDOWPROP *WHO-LINE* 'BUTTONEVENTFN 'WHEN-WHO-LINE-SELECTED-FN) - (WINDOWPROP *WHO-LINE* 'DISPLAY-NAMES? *WHO-LINE-DISPLAY-NAMES?*) - (WINDOWPROP *WHO-LINE* 'ANCHOR *WHO-LINE-ANCHOR*) - (WINDOWPROP *WHO-LINE* 'NAME-FONT *WHO-LINE-NAME-FONT*) - (WINDOWPROP *WHO-LINE* 'VALUE-FONT *WHO-LINE-VALUE-FONT*) - (WINDOWPROP *WHO-LINE* 'COLOR *WHO-LINE-COLOR*) - (WINDOWPROP *WHO-LINE* 'TITLE *WHO-LINE-TITLE*) - (WINDOWPROP *WHO-LINE* 'BORDER *WHO-LINE-BORDER*) - (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL (FIX (TIMES *WHO-LINE-UPDATE-INTERVAL* - \RCLKMILLISECOND))) - (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*)) - - (* ;; "") - - (* ;; "Create and fill in the who-line entries that go on the window.") - - (* ;; "This entails computing the positions of the entries in the who-line") - - (* ;; "") - - (SETQ ENTRIES (for ITEM in *WHO-LINE-ENTRIES* bind (DISPLAY-NAMES? - _ - (WINDOWPROP *WHO-LINE* - 'DISPLAY-NAMES?)) - (VALUE-FONT _ (WINDOWPROP - *WHO-LINE* - 'VALUE-FONT)) - (NAME-FONT _ (WINDOWPROP - *WHO-LINE* - 'NAME-FONT)) - collect (LET ((ENTRY (create WHO-LINE-ENTRY - NAME _ (CL:FIRST ITEM) - FORM _ (CL:SECOND ITEM)))) - (with WHO-LINE-ENTRY ENTRY - - (* ;; "") - - (* ;; - "Leave a little space (the size of an %"A%") between the previous value and this name") - - (* ;; "") - - (SETQ NAME-START (PLUS (STRINGWIDTH "A" - VALUE-FONT) - CURRENT-LEFT)) - (if DISPLAY-NAMES? - then (SETQ CURRENT-LEFT - (PLUS NAME-START (STRINGWIDTH NAME - NAME-FONT)))) - - (* ;; "") - - (* ;; - "The value is displayed after the name, with a little space between them") - - (* ;; "") - - (SETQ VALUE-START (PLUS CURRENT-LEFT - (STRINGWIDTH "A" - VALUE-FONT))) - (SETQ VALUE-END (PLUS VALUE-START - (TIMES (CL:THIRD ITEM) - (STRINGWIDTH "A" - VALUE-FONT))) - ) (* ; - "Leave a little extra space after each value") - (SETQ CURRENT-LEFT (PLUS VALUE-END - (STRINGWIDTH "A" - VALUE-FONT))) - - (* ;; "") - - (* ;; "Set the when-selected-fn") - - (* ;; "") - - (SETQ WHEN-SELECTED-FN (CL:FOURTH ITEM)) - - (* ;; "") - - (* ;; "And the reset-form") - - (* ;; "") - - (SETQ RESET-FORM (CL:FIFTH ITEM)) - - (* ;; "") - - (* ;; "And return the filled in entry") - - (* ;; "") - - ENTRY)))) - - (* ;; "") - - (* ;; "Reshape the window to hold the new in info") - - (* ;; "") - - (LET ((HORIZ-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) - then (fetch XCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) - else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) - thereis (MEMB anchor '(:LEFT :CENTER :JUSTIFY - :RIGHT))) - (ERROR "No horizontal anchor specified" - (WINDOWPROP *WHO-LINE* 'ANCHOR))))) - (VERT-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) - then (fetch YCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) - else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) - thereis (MEMB anchor '(:TOP :BOTTOM))) - (ERROR "No vertical anchor specified" - (WINDOWPROP *WHO-LINE* 'ANCHOR))))) - (WIDTH (WIDTHIFWINDOW CURRENT-LEFT (WINDOWPROP *WHO-LINE* 'BORDER))) - (HEIGHT (HEIGHTIFWINDOW (MAX (FONTPROP (WINDOWPROP *WHO-LINE* 'NAME-FONT) - 'HEIGHT) - (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) - 'HEIGHT)) - (WINDOWPROP *WHO-LINE* 'TITLE) - (WINDOWPROP *WHO-LINE* 'BORDER)))) - - (* ;; "") - - (* ;; "Make sure the window fits on the screen (i.e. doesn't run off the edge, and is justified against left and right sides if the user wants).") - - (* ;; "If the items don't fit, change the length of each item so they do.") - - (* ;; - "Do this by distributing the %"pain%" among all the entries in the who-line.") - - (* ;; "") - - (if (OR (GREATERP WIDTH SCREENWIDTH) - (EQ HORIZ-ANCHOR :JUSTIFY)) - then (for ENTRY in ENTRIES - bind (REMAINING-ADJUSTMENT _ (DIFFERENCE SCREENWIDTH WIDTH)) - (REMAINING-VALUE-SIZE _ (for ENTRY in ENTRIES - sum (with WHO-LINE-ENTRY ENTRY - (DIFFERENCE VALUE-END - VALUE-START)))) - (RUNNING-ADJUSTMENT _ 0) - ENTRY-ADJUSTMENT - do (with WHO-LINE-ENTRY ENTRY - - (* ;; "") - - (* ;; "Figure out how much this entry value gets adjusted.") - - (* ;; "") - - (* ;; - "Note that, by keeping track of the remaing adjustment needed, we avoid problems with round-off.") - - (* ;; "") - - (SETQ ENTRY-ADJUSTMENT (QUOTIENT (TIMES - REMAINING-ADJUSTMENT - (DIFFERENCE - VALUE-END - VALUE-START) - ) - REMAINING-VALUE-SIZE)) - - (* ;; "") - - (* ;; "Update this entry size & position") - - (* ;; "") - - (add NAME-START RUNNING-ADJUSTMENT) - (add VALUE-START RUNNING-ADJUSTMENT) - (add RUNNING-ADJUSTMENT ENTRY-ADJUSTMENT) - (add VALUE-END RUNNING-ADJUSTMENT)) - finally (SETQ WIDTH SCREENWIDTH))) - - (* ;; "") - - (* ;; "Set the who-line window size so it can't be reshaped") - - (* ;; "") - - (WINDOWPROP *WHO-LINE* 'MAXSIZE (CONS WIDTH HEIGHT)) - (WINDOWPROP *WHO-LINE* 'MINSIZE (CONS WIDTH HEIGHT)) - - (* ;; "") - - (* ;; - "The anchor-point decribes where on the screen the who-line should be placed.") - - (* ;; "The CAR should be one of :JUSTIFY, :LEFT, :RIGHT, or :CENTER.") - - (* ;; "The CADR should be one of :TOP, :BOTTOM, or :CENTER.") - - (* ;; "") - - (SHAPEW *WHO-LINE* (CREATEREGION (SELECTQ HORIZ-ANCHOR - ((:JUSTIFY :LEFT) - 0) - (:RIGHT (DIFFERENCE SCREENWIDTH WIDTH)) - (:CENTER (QUOTIENT (DIFFERENCE SCREENWIDTH - WIDTH) - 2)) - HORIZ-ANCHOR) - (SELECTQ VERT-ANCHOR - (:TOP (DIFFERENCE SCREENHEIGHT HEIGHT)) - (:BOTTOM 0) - (:CENTER (QUOTIENT (DIFFERENCE SCREENHEIGHT HEIGHT - ) - 2)) - VERT-ANCHOR) - WIDTH HEIGHT))) - - (* ;; "") - - (* ;; - "The values should be centered vertically between the top and the bottom of the window") - - (* ;; "") - - (WINDOWPROP *WHO-LINE* 'VALUE-BOTTOM (PLUS (FONTPROP (WINDOWPROP *WHO-LINE* - 'VALUE-FONT) - 'DESCENT) - (QUOTIENT - (DIFFERENCE (WINDOWPROP *WHO-LINE* - 'HEIGHT) - (FONTPROP (WINDOWPROP *WHO-LINE* - 'VALUE-FONT) - 'HEIGHT)) - 2))) - - (* ;; "Cache a bitmap that is the same size as the inside of the who-line, and a display stream onto the bitmap.") - - (WINDOWPROP *WHO-LINE* 'TEMP-STREAM (DSPCREATE (BITMAPCREATE (WINDOWPROP *WHO-LINE* - 'WIDTH) - (WINDOWPROP *WHO-LINE* - 'HEIGHT)))) - - (* ;; "") - - (* ;; "Install the entries") - - (* ;; "") - - (WINDOWPROP *WHO-LINE* 'ENTRIES ENTRIES) - - (* ;; "") - - (* ;; "Finally, update the window") - - (* ;; "") - - (REDISPLAY-WHO-LINE *WHO-LINE*) - (WINDOWPROP *WHO-LINE* 'VALID T))))) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some fns that compute useful values for the who-line, and act as nice button event fns") (* ;; "") (* ;; "Showing / changing the current logged in user") (DEFINEQ (WHO-LINE-USERNAME - (LAMBDA NIL (* ; "Edited 30-Jun-88 15:41 by smL") - -(* ;;; "") - -(* ;;; "Return the name of the currently logged in user. Avoid consing up a new string if possible.") - -(* ;;; "") - - (* ;; "The cached value in *WHO-LINE-CURRENT-USER* gets invalidated by an entry on the list of \SYSTEMCACHEVARS, and by a function on the list of \AFTERLOGINFNS") - - (* ;; "") - - (DECLARE (GLOBALVARS *WHO-LINE-CURRENT-USER*)) - (if *WHO-LINE-CURRENT-USER* - then *WHO-LINE-CURRENT-USER* - else (SETQ *WHO-LINE-CURRENT-USER* (USERNAME NIL NIL T))))) (WHO-LINE-CHANGE-USER -(LAMBDA NIL (* smL "17-Nov-86 11:19") (* ;;; "") (* ;;; "Change the currently logged in user") (* ;;; "") (if (MENU (create MENU TITLE _ "Change user?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T "Log in as a different user") ("No" NIL "Don't change the current user"))))) then (LOGIN))) -) (WHO-LINE-USER-AFTER-LOGIN - (LAMBDA (HOST USER) (* ; "Edited 30-Jun-88 15:34 by smL") - - (CL:WHEN (NULL HOST) - (SETQ *WHO-LINE-CURRENT-USER* NIL)))) ) (DEFGLOBALVAR *WHO-LINE-CURRENT-USER* NIL "Cached name of the current logged in user") (CL:DEFPARAMETER *WHO-LINE-USER-ENTRY* '("User" (WHO-LINE-USERNAME) 10 WHO-LINE-CHANGE-USER (SETQ *WHO-LINE-CURRENT-USER* NIL) "Name of the currently logged in user") "Who-Line entry for displaying the name of the currently logged in user") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDTOVAR \SYSTEMCACHEVARS *WHO-LINE-CURRENT-USER*) (ADDTOVAR \AFTERLOGINFNS WHO-LINE-USER-AFTER-LOGIN) ) (* ;; "") (* ;; "Showing the current machine name") (DEFINEQ (WHO-LINE-HOST-NAME -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:46 by smL") (* ;;; "") (* ;;; "Return the name of the curren workstation. Avoid consing up a new string if possible.") (* ;;; "") (* ;; "") (* ;; "The cached value in *WHO-LINE-HOST-NAME* gets invalidated by an entry on the list of \SYSTEMCACHEVARS") (* ;; "") (DECLARE (GLOBALVARS *WHO-LINE-HOST-NAME*)) (if *WHO-LINE-HOST-NAME* then *WHO-LINE-HOST-NAME* else (SETQ *WHO-LINE-HOST-NAME* (ETHERHOSTNAME)))) -) ) (DEFGLOBALVAR *WHO-LINE-HOST-NAME* NIL "Cached name of the current machine, for the Who-Line") (CL:DEFPARAMETER *WHO-LINE-HOST-NAME-ENTRY* '("on" (WHO-LINE-HOST-NAME) 10 NIL (SETQ *WHO-LINE-HOST-NAME* NIL) "Name of the currently running machine") "Who-Line entry for displaying the name of the current machine") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (ADDTOVAR \SYSTEMCACHEVARS *WHO-LINE-HOST-NAME*) ) (* ;; "") (* ;; "Showing / changing the current tty process package") (DEFINEQ (CURRENT-TTY-PACKAGE - (LAMBDA NIL (* ; "Edited 17-Mar-87 17:52 by smL") - -(* ;;; "") - -(* ;;; "Return the name of the current package of the current TTY process") - -(* ;;; "") - - (LET ((PACKAGE (PROCESS.EVALV (TTY.PROCESS) - '*PACKAGE*))) - - (* ;; "") - - (* ;; "The *WHO-LINE-PACKAGE-NAME-CACHE* AList is used to cache computed package names with terminating %":%"'s.") - - (* ;; - "This lets us display the name with a colon w/o having to allocate new strings all the time.") - - (* ;; "") - - (OR (CDR (ASSOC PACKAGE *WHO-LINE-PACKAGE-NAME-CACHE*)) - (PUTASSOC PACKAGE (CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) - (CL:PACKAGE-NAME PACKAGE)) - ":") - *WHO-LINE-PACKAGE-NAME-CACHE*))))) (SET-PACKAGE-INTERACTIVELY - (LAMBDA NIL (* ; "Edited 18-Mar-87 13:13 by smL") - - (* ;; "") - - (* ;; "Let the user interactivly change the current package") - - (* ;; "") - - (LET ((PACKAGE - (MENU (create MENU - TITLE _ "Select package" - ITEMS _ (SORT (for PACKAGE in (CL:LIST-ALL-PACKAGES) bind PACKAGE-NAME - collect (SETQ PACKAGE-NAME (CL:PACKAGE-NAME PACKAGE)) - `(,(CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) - PACKAGE-NAME) - ":") ',PACKAGE-NAME - ,(CONCAT "Set the current package to " - PACKAGE-NAME ":"))) - (FUNCTION (LAMBDA (X Y) - (ALPHORDER (CAR X) - (CAR Y))))) - CENTERFLG _ T)))) - (if PACKAGE - then (if (SHIFTDOWNP 'SHIFT) - then (WHO-LINE-COPY-INSERT (CONCAT PACKAGE ":")) - else (CL:IN-PACKAGE PACKAGE)))))) (SET-TTY-PACKAGE-INTERACTIVELY -(LAMBDA NIL (* smL "28-Oct-86 09:49") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PACKAGE-INTERACTIVELY)) T)) -) ) (DEFGLOBALVAR *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL) "An AList used to cache package names, together with their terminating ':'s") (CL:DEFPARAMETER *WHO-LINE-PACKAGE-ENTRY* '("Pkg" (CURRENT-TTY-PACKAGE) 10 SET-TTY-PACKAGE-INTERACTIVELY (SETQ *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL)) "Package of the current TTY process") "Who-Line entry for displaying the package of the current TTY process") (* ;; "") (* ;; "Showing / changing the current tty process readtable") (DEFINEQ (CURRENT-TTY-READTABLE-NAME -(LAMBDA NIL (* smL "28-Oct-86 19:13") (* ;;; "") (* ;;; "Return the name of the readtable of the current TTY process") (* ;;; "") (OR (READTABLEPROP (PROCESS.EVALV (TTY.PROCESS) (QUOTE *READTABLE*)) (QUOTE NAME)) "Unknown")) -) (SET-READTABLE-INTERACTIVELY -(LAMBDA NIL (* smL "10-Nov-86 18:36") (* ;; "") (* ;; "Let the user interactivly change the current readtable") (* ;; "") (DECLARE (GLOBALVARS \READTABLEHASH)) (LET ((READTABLE (MENU (create MENU TITLE _ "Select readtable" ITEMS _ (LET ((READTABLES NIL)) (MAPHASH \READTABLEHASH (FUNCTION (LAMBDA (VALUE NAME) (push READTABLES (LIST NAME VALUE))))) (SORT READTABLES (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y)))))) CENTERFLG _ T)))) (if (READTABLEP READTABLE) then (SETQ *READTABLE* READTABLE)))) -) (SET-TTY-READTABLE-INTERACTIVELY -(LAMBDA NIL (* smL "28-Oct-86 09:51") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY readtable") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-READTABLE-INTERACTIVELY)) T)) -) ) (CL:DEFPARAMETER *WHO-LINE-READTABLE-ENTRY* '("Rdtbl" (CURRENT-TTY-READTABLE-NAME) 10 SET-TTY-READTABLE-INTERACTIVELY NIL "Readtable of the current TTY process") "Who-Line entry for displaying the name of the ReadTable of the current TTY process") (* ;; "") (* ;; "Showing / changing the current tty process") (DEFINEQ (WHO-LINE-TTY-PROCESS -(LAMBDA NIL (* smL "28-Oct-86 09:54") (* ;;; "") (* ;;; "Return the name of the current TTY process") (* ;;; "") (PROCESSPROP (TTY.PROCESS) (QUOTE NAME))) -) (CHANGE-TTY-PROCESS-INTERACTIVELY -(LAMBDA NIL (* smL "10-Nov-86 18:36") (DECLARE (GLOBALVARS \PROCESSES)) (LET ((NEW-PROC (MENU (create MENU TITLE _ "Give TTY to process" CENTERFLG _ T ITEMS _ (SORT (for PROC in \PROCESSES collect (LIST (PROCESSPROP PROC (QUOTE NAME)) PROC)) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y))))))))) (if NEW-PROC then (TTY.PROCESS NEW-PROC)))) -) ) (CL:DEFPARAMETER *WHO-LINE-TTY-PROC-ENTRY* '("Tty" (WHO-LINE-TTY-PROCESS) 15 CHANGE-TTY-PROCESS-INTERACTIVELY NIL "The current TTY process") "Who-Line entry for displaying the name of the current TTY process") (* ;; "") (* ;; "Showing / changing the currently connected directory") (DEFINEQ (WHO-LINE-CURRENT-DIRECTORY -(LAMBDA NIL (* ; "Edited 3-Feb-89 14:52 by smL") (* ;;; "Get the currently connected directory") (* ;; "First, update the cached directory / namestring pair to reflect the current TTY proc") (DECLARE (GLOBALVARS *WHO-LINE-LAST-DIRECTORY*)) (* ;; "The connected directory is looked up in the TTY process, in case one day it becomes a per-process var") (LET ((CONNECTED-DIRECTORY (PROCESS.EVALV (TTY.PROCESS) (QUOTE *DEFAULT-PATHNAME-DEFAULTS*)))) (* ; "The CAR contains the path, the CDR contains a string version of the path") (if (NEQ CONNECTED-DIRECTORY (CAR *WHO-LINE-LAST-DIRECTORY*)) then (* ; "The connected directory has changed") (change (CAR *WHO-LINE-LAST-DIRECTORY*) CONNECTED-DIRECTORY) (* ; "Put the host name last, since that is least important") (change (CDR *WHO-LINE-LAST-DIRECTORY*) (if (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) then (CONCAT (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) " on {" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}") else (CONCAT "{" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}"))) (* ; "Update the list of known directories") (LET ((DIR-NAME (CL:NAMESTRING CONNECTED-DIRECTORY))) (if (NOT (CL:MEMBER DIR-NAME *WHO-LINE-DIRECTORIES* :TEST (CL:FUNCTION STRING-EQUAL))) then (MERGEINSERT DIR-NAME (SORT *WHO-LINE-DIRECTORIES* (CL:FUNCTION UALPHORDER))))))) (* ;; "Return the namestring of the current dir") (CDR *WHO-LINE-LAST-DIRECTORY*)) -) (SET-CONNECTED-DIRECTORY-INTERACTIVELY - (LAMBDA NIL (* ; "Edited 9-Jun-87 08:57 by smL") - -(* ;;; "Let the user interactivly change the current connected directory") - - (DECLARE (GLOBALVARS *WHO-LINE-DIRECTORIES*)) - - (* ;; "If the user selects an item while holding down a shift key, copy-insert the name of the directory instead of connecting to it") - - (if (SHIFTDOWNP 'SHIFT) - then (LET ((NEW-DIRECTORY (MENU (create MENU - TITLE _ "Type in directory name:" - ITEMS _ *WHO-LINE-DIRECTORIES*)))) - (if NEW-DIRECTORY - then (WHO-LINE-COPY-INSERT NEW-DIRECTORY))) - else (LET ((NEW-DIRECTORY (MENU (create MENU - TITLE _ "Connect to:" - ITEMS _ (CONS "* Other *" *WHO-LINE-DIRECTORIES*))))) - (if NEW-DIRECTORY - then (if (STRING-EQUAL NEW-DIRECTORY "* Other *") - then (CLEARW PROMPTWINDOW) - (SETQ NEW-DIRECTORY (PROMPTFORWORD "Connect to directory " - (CL:NAMESTRING (PROCESS.EVALV - (TTY.PROCESS) - ' - *DEFAULT-PATHNAME-DEFAULTS* - )) - NIL PROMPTWINDOW NIL 'TTY NIL))) - (if NEW-DIRECTORY - then (ALLOW.BUTTON.EVENTS) (* ; - "Should do this in the current TTY process, in case the conntected directory is a per-process var") - - (CNDIR NEW-DIRECTORY))))))) ) (DEFGLOBALVAR *WHO-LINE-DIRECTORIES* `(,LOGINHOST/DIR) "Cached list of known directories for the Who-Line Directory entry") (DEFGLOBALVAR *WHO-LINE-LAST-DIRECTORY* (LET ((NAMESTRING (CL:NAMESTRING *DEFAULT-PATHNAME-DEFAULTS*))) (CONS (PATHNAME NAMESTRING) (MKSTRING NAMESTRING))) "Cached name of the current connected directory for the Who-Line Directory entry") (CL:DEFPARAMETER *WHO-LINE-DIRECTORY-ENTRY* '("Dir" (WHO-LINE-CURRENT-DIRECTORY) 30 SET-CONNECTED-DIRECTORY-INTERACTIVELY (SETQ *WHO-LINE-LAST-DIRECTORY* (CONS NIL NIL)) "The currently connected directory") "Who-Line entry for displaying the name of the currently connected directory") (* ;; "") (* ;; "Showing / changing the current VMem utilization") (DEFINEQ (WHO-LINE-VMEM [LAMBDA NIL (* ; "Edited 16-Jun-94 21:12 by kaplan") (* ;;; "") (* ;;; "Compute the percentage of vmem in use.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-LAST-VMEM* \LASTVMEMFILEPAGE \InterfacePage \IFPValidKey)) (* ;; "") (* ;; "Compute the percentage of vmem in use. The ratio is the amount in use (computed by (VMEMSIZE)) divided by the amount available (stored in \LASTVMEMFILEPAGE). We multiply by 100 to get a percentage, round to an integer, and do it all in such a way as to ensure we don't cons any FIXPs.") (* ;; "The basic code here is due to Mike Dixon.") (* ;; "") (LET* ((ONE-PERCENT-VMEM (IQUOTIENT (IPLUS (MAX \LASTVMEMFILEPAGE (TIMES 2 65535)) 50) 100)) (VMEM-PERCENT (IQUOTIENT (IPLUS (VMEMSIZE) (RSH ONE-PERCENT-VMEM 1)) ONE-PERCENT-VMEM)) (VMEM-CONSISTENT? (.VMEM.CONSISTENTP.))) (* ;; "") (* ;; "We cache the last VMem info and the string-translation of it in the var *WHO-LINE-LAST-VMEM*. That way, we don't have to alloc a new string all the time. We do, however, have to make sure the cached info in correct.") (* ;; "") (if [NOT (AND (EQ VMEM-CONSISTENT? (CADR *WHO-LINE-LAST-VMEM*)) (EQP VMEM-PERCENT (CAR *WHO-LINE-LAST-VMEM*] then (change (CAR *WHO-LINE-LAST-VMEM*) VMEM-PERCENT) (change (CADR *WHO-LINE-LAST-VMEM*) VMEM-CONSISTENT?) (change (CADDR *WHO-LINE-LAST-VMEM*) (CONCAT (if VMEM-CONSISTENT? then " " else "*") VMEM-PERCENT "%%"))) (* ;; "") (* ;; "Return the info string") (* ;; "") (CADDR *WHO-LINE-LAST-VMEM*]) (WHO-LINE-SAVE-VMEM -(LAMBDA NIL (* smL "29-Oct-86 11:22") (* ;;; "") (* ;;; "Save the VMem, if the user really wants to") (* ;;; "") (if (MENU (create MENU TITLE _ "Save VMem?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T) ("No" NIL))))) then (SAVEVM))) -) ) (DEFGLOBALVAR *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL) "Cached value for storing the last VMem information for the Who-Line VMem entry") (CL:DEFPARAMETER *WHO-LINE-VMEM-ENTRY* '("VMem" (WHO-LINE-VMEM) 5 WHO-LINE-SAVE-VMEM (SETQ *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL)) "Percentage of VMem currently in use") "Who-Line entry for displaying the current VMem utilization") (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (FILESLOAD (LOADCOMP) LLFAULT MODARITH) (CHECKIMPORTS '(LLPARAMS) T) ) (* ;; "") (* ;; "Showing the percent of symbol-space currently used") (CL:DEFUN WHO-LINE-SYMBOL-SPACE () "Return a string describing the percentage of symbol space in use" (LET ((TOTAL-SYMBOL-SPACE (UNFOLD (CL:1+ \LastAtomPage) WORDSPERCELL)) (SYMBOL-SPACE-IN-USE (FOLDHI \AtomFrLst CELLSPERPAGE))) (* ;; "Only recompute the display string when the fraction of space has changed. This saves us the effort of CONSing up the string each time.") (CL:UNLESS (AND (EQL (CL:FIRST *WHO-LINE-SYMBOL-SPACE*) TOTAL-SYMBOL-SPACE) (EQL (CL:SECOND *WHO-LINE-SYMBOL-SPACE*) SYMBOL-SPACE-IN-USE)) [CL:SETF (CL:FIRST *WHO-LINE-SYMBOL-SPACE*) TOTAL-SYMBOL-SPACE (CL:SECOND *WHO-LINE-SYMBOL-SPACE*) SYMBOL-SPACE-IN-USE (CL:THIRD *WHO-LINE-SYMBOL-SPACE*) (CL:FORMAT NIL "~3D%%" (- 100 (ROUND (- 100 (/ (CL:* SYMBOL-SPACE-IN-USE 100) TOTAL-SYMBOL-SPACE]) (CL:THIRD *WHO-LINE-SYMBOL-SPACE*))) (DEFGLOBALVAR *WHO-LINE-SYMBOL-SPACE* (LIST NIL NIL NIL "Remembers the previous who-line symbol space")) (CL:DEFPARAMETER *WHO-LINE-SYMBOL-SPACE-ENTRY* '("Syms" (WHO-LINE-SYMBOL-SPACE) 4 NIL (SETQ *WHO-LINE-SYMBOL-SPACE* (LIST NIL NIL NIL)) "Percentage of symbol space currently in use" ) "Who-line entry for displaying percent of symbol space in use") (* ;; "") (* ;; "Showing the current time") (DEFINEQ (WHO-LINE-TIME -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:48 by smL") (* ;;; "") (* ;;; "Return the current time as a string. Avoid CONSing as much as possible.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME*)) (if (TIMEREXPIRED? *WHO-LINE-TIMER* (QUOTE SECONDS)) then (* ;; "") (* ;; "Reset the timer, and return the new time") (* ;; "") (LET ((NOW (IDATE))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER NOW 60)) (CONSTANT (SETUPTIMER 0 NIL (QUOTE SECONDS))) (QUOTE SECONDS))) (SETQ *WHO-LINE-OLD-TIME* (GDATE NOW (CONSTANT (DATEFORMAT NO.SECONDS)) *WHO-LINE-OLD-TIME*)) *WHO-LINE-OLD-TIME*) else (* ;; "") (* ;; "The timer hasn't expired, so the old time is good enough") (* ;; "") *WHO-LINE-OLD-TIME*)) -) (WHO-LINE-SET-TIME - (LAMBDA NIL (* ; "Edited 17-Mar-87 18:20 by smL") - -(* ;;; "") - -(* ;;; "Set the time from the network, if the user really wants to") - -(* ;;; "") - - (COND - ((SHIFTDOWNP 'SHIFT) - - (* ;; "Selection with a shift key down causes the current time to be bksysbuf'ed") - - (WHO-LINE-COPY-INSERT *WHO-LINE-OLD-TIME*)) - ((MENU (create MENU - TITLE _ "Set time?" - CENTERFLG _ T - ITEMS _ '(("Yes" T) - ("No" NIL)))) - - (* ;; "The user wants to reset the time") - - (SETTIME))))) ) (DEFGLOBALVAR *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) 60)) NIL 'SECONDS) "Timer for controlling updates of the Who-Line Time entry") (DEFGLOBALVAR *WHO-LINE-OLD-TIME* (DATE (DATEFORMAT NO.SECONDS)) "Cached value for the Who-Line Time entry") (CL:DEFPARAMETER *WHO-LINE-TIME-ENTRY* '("Time" (WHO-LINE-TIME) 17 WHO-LINE-SET-TIME [PROGN (SETQ *WHO-LINE-OLD-TIME* (DATE (DATEFORMAT NO.SECONDS))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) 60)) NIL 'SECONDS] "Time of day") "Who-Line entry for displaying the current time of day") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-TIMER* SECONDS)) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Some as yet un-debugged entries. Try at your own risk.") (* ;; "") (* ;; "Showing the machine-active entry") (DEFINEQ (WHO-LINE-SHOW-ACTIVE - (LAMBDA NIL (* ; "Edited 20-Apr-87 09:58 by smL") - -(* ;;; "Update the who-line active indicator, if it is time") - - (DECLARE (GLOBALVARS *WHO-LINE* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-ACTIVE-PERIOD*)) - (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS) - then - - (* ;; "A second has passed, so update the indicator if we can") - - (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*) - - (* ;; "Reset the timer") - - (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* - *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS))) - - (* ;; "Always return the same thing") - - " ")) (\UPDATE-WHO-LINE-ACTIVE-FLAG - (LAMBDA (WINDOW) (* ; "Edited 20-Apr-87 09:58 by smL") - -(* ;;; "Flip the active-indicator in the who-line") - - (for ENTRY in (WINDOWPROP WINDOW 'ENTRIES) thereis (with WHO-LINE-ENTRY ENTRY - (AND (LISTP FORM) - (EQ (CAR FORM) - 'WHO-LINE-SHOW-ACTIVE))) - finally (if $$VAL - then (with WHO-LINE-ENTRY $$VAL (BLTSHADE BLACKSHADE WINDOW VALUE-START 2 - (DIFFERENCE VALUE-END VALUE-START) - (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) - 4) - 'INVERT)))))) (\PERIODICALLY-WHO-LINE-SHOW-ACTIVE -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:50 by smL") (* ;;; "") (* ;;; "Update the who-line active indicator, if it is time") (* ;;; "This is designed to be run on the \PERIODIC.INTERRUPT hook.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-ACTIVE-TIMER* *WHO-LINE* *WHO-LINE-ACTIVE-PERIOD*)) (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS)) then (* ;; "") (* ;; "A second has passed, so update the indicator if we can") (* ;; "") (* ;; "But only if the who-line is on the top") (* ;; "") (if (AND (OPENWP *WHO-LINE*) (TOPWP *WHO-LINE*)) then (* ;; "") (* ;; "The who-line is on the top, so we can update it") (* ;; "") (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*)) (* ;; "") (* ;; "Reset the timer") (* ;; "") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS))))) -) ) (DEFGLOBALVAR *WHO-LINE-ACTIVE-PERIOD* 500 "Interval between updating the Who-Line activity entry") (DEFGLOBALVAR *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* NIL 'MILLISECONDS) "Timer for controlling updating of the Who-Line activity entry") (CL:DEFPARAMETER *WHO-LINE-SHOW-ACTIVE-ENTRY* '("" (WHO-LINE-SHOW-ACTIVE) 2 NIL (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* NIL 'MILLISECONDS)) "Indication of machine activity") "Who-Line entry for displaying the activity of the machine") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-ACTIVE-TIMER* MILLISECONDS)) ) (* ;; "") (* ;; "Showing / changing the current reader profile") (DEFINEQ (CURRENT-PROFILE -(LAMBDA NIL (* ; "Edited 12-Jan-87 14:36 by smL") (* ;;; "") (* ;;; "Return the name of the current reader profile of the current TTY process") (* ;;; "") (XCL:PROFILE-NAME (PROCESS.EVALV (TTY.PROCESS) (QUOTE XCL:*PROFILE*)))) -) (SET-PROFILE-INTERACTIVELY -(LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;; "") (* ;; "Let the user interactivly change the current reader profile") (* ;; "") (LET ((PROFILE (MENU (create MENU TITLE _ "Select profile" ITEMS _ (SORT (for PROFILE in (XCL:LIST-ALL-PROFILES) bind PROFILE-NAME collect (XCL:PROFILE-NAME PROFILE))) CENTERFLG _ T)))) (if PROFILE then (XCL:RESTORE-PROFILE PROFILE)))) -) (SET-TTY-PROFILE-INTERACTIVELY -(LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;;; "") (* ;;; "Interactivly let the user change the reader profile of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PROFILE-INTERACTIVELY)) T)) -) ) (CL:DEFPARAMETER *WHO-LINE-PROFILE-ENTRY* '("Profile" (CURRENT-PROFILE) 10 SET-TTY-PROFILE-INTERACTIVELY NIL "The read/write profile of the current TTY process" ) "Who-Line entry for displaying the current read/write profile") (* ;; "") (* ;; "Showing the state of the current TTY process") (DEFINEQ (WHO-LINE-TTY-STATE - (LAMBDA NIL (* ; "Edited 17-Apr-87 18:26 by smL") - -(* ;;; "Find out what state the current TTY process is in") - - (LET ((PROC (TTY.PROCESS))) - (COND - ((NULL PROC) - - (* ;; " No tty process? Never happens now, but maybe allowed in future.") - - "") - ((EQ PROC (THIS.PROCESS)) - - (* ;; " Check explicitly for us being tty, since in that case PROC is not a valid stack pointer (we're running).") - - "Who-Line") - ((PROCESS.EVALV PROC '*WHO-LINE-STATE*)) - ((NOT (PROCESS.FINISHEDP PROC)) - (for I from 0 by -1 bind FRAMENAME while (SETQ FRAMENAME (STKNTHNAME I PROC)) - unless (MEMB FRAMENAME *WHO-LINE-STATE-UNINTERESTING-FNS*) - do - - (* ;; " Walk back process looking for interesting frame name. This search is non-linear in that each iteration takes a little longer, but we expect it to terminate early.") - - (RETURN (OR (GETPROP FRAMENAME 'WHO-LINE-STATE) - FRAMENAME)))))))) (WHO-LINE-WHAT-IS-RUNNING -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:51 by smL") (* ;;; "") (* ;;; "When run under a (PROCESS.EVAL '(WHO-LINE-WHAT-IS-RUNNING) T), returns the name of the current running frame in the process") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-STATE-UNINTERESTING-FNS*)) (PROG ((POS-HOLDER (CONSTANT (LIST NIL))) POS) (* ;; "") (* ;; "We use the POS-HOLDER to hold an old stack pointer, so that we don't have to alloc one") (* ;; "") (SETQ POS (STKPOS (QUOTE \PROCESS.EVAL1) NIL NIL (CAR POS-HOLDER))) (COND (POS (change (CAR POS-HOLDER) POS)) (T (RETURN NIL))) LP (SETQ POS (STKNTH 1 POS POS)) (COND ((NULL POS) (RETURN NIL)) ((MEMB (STKNAME POS) *WHO-LINE-STATE-UNINTERESTING-FNS*) (* ; "Ignore any uninteresting fns") (GO LP)) (T (RETURN (PROG1 (STKNAME POS) (RELSTK POS))))))) -) ) (CL:DEFVAR *WHO-LINE-STATE* NIL "Cached state shown in the Who-Line State entry") (DEFGLOBALVAR *WHO-LINE-STATE-UNINTERESTING-FNS* '(BLOCK ERRORSET OBTAIN.MONITORLOCK MONITOR.AWAIT.EVENT AWAIT.EVENT SI::*UNWIND-PROTECT*) "Uninteresting fns to skip over in the Who-Line State entry") (CL:DEFPARAMETER *WHO-LINE-TTY-STATE-ENTRY* '("State" (WHO-LINE-TTY-STATE) 15 NIL (SETQ *WHO-LINE-STATE* NIL) "Running state of the current TTY process") "Who-Line entry for showing the running state of the current TTY process") (PUTPROPS AWAIT.EVENT WHO-LINE-STATE "Block") (PUTPROPS BLOCK WHO-LINE-STATE "Block") (PUTPROPS EXCHANGEPUPS WHO-LINE-STATE "Net I/O") (PUTPROPS GETPUP WHO-LINE-STATE "Net I/O") (PUTPROPS SENDPUP WHO-LINE-STATE "Net I/O") (PUTPROPS WAIT.FOR.TTY WHO-LINE-STATE "TTY wait") (PUTPROPS \TTYBACKGROUND WHO-LINE-STATE "TTY wait") (PUTPROPS \WAITFORSYSBUFP WHO-LINE-STATE "TTY wait") (PUTPROPS \\getkey WHO-LINE-STATE "TTY wait") (PUTPROPS \SENDLEAF WHO-LINE-STATE "Net I/O") (PUTPROPS PUTSEQUIN WHO-LINE-STATE "Net I/O") (PUTPROPS \LEAF.READPAGES WHO-LINE-STATE "Net I/O") (* ;;; "----------------------------------------------------------------------") (* ;;; "Default options for the who-line") (DEFGLOBALVAR *WHO-LINE-ENTRIES* `(,*WHO-LINE-USER-ENTRY* ,*WHO-LINE-PACKAGE-ENTRY* ,*WHO-LINE-READTABLE-ENTRY* ,*WHO-LINE-TTY-PROC-ENTRY* ,*WHO-LINE-DIRECTORY-ENTRY* ,*WHO-LINE-VMEM-ENTRY* ,*WHO-LINE-TIME-ENTRY*) "List of all the entries to show in the Who-Line") (DEFGLOBALVAR *WHO-LINE-ENTRY-REGISTRY* (LIST *WHO-LINE-USER-ENTRY* *WHO-LINE-HOST-NAME-ENTRY* *WHO-LINE-PACKAGE-ENTRY* *WHO-LINE-READTABLE-ENTRY* *WHO-LINE-TTY-PROC-ENTRY* *WHO-LINE-DIRECTORY-ENTRY* *WHO-LINE-VMEM-ENTRY* *WHO-LINE-SYMBOL-SPACE-ENTRY* *WHO-LINE-TIME-ENTRY* *WHO-LINE-SHOW-ACTIVE-ENTRY* *WHO-LINE-PROFILE-ENTRY* *WHO-LINE-TTY-STATE-ENTRY*) "List of all known Who-Line entries.") (DEFGLOBALVAR *WHO-LINE-ANCHOR* '(:CENTER :BOTTOM) "Location to place the Who-Line") (DEFGLOBALVAR *WHO-LINE-NAME-FONT* (FONTCREATE '(HELVETICA 8 BOLD)) "Font to use to show entry labels in the Who-Line") (DEFGLOBALVAR *WHO-LINE-VALUE-FONT* (FONTCREATE '(GACHA 8)) "Font to use to show the entry values in the Who-Line") (DEFGLOBALVAR *WHO-LINE-DISPLAY-NAMES?* T "Flag for enabling or disabling the display of entry names in the Who-Line") (DEFGLOBALVAR *WHO-LINE-COLOR* :WHITE "Color of the Who-Line -- one of :WHITE or :BLACK") (DEFGLOBALVAR *WHO-LINE-TITLE* NIL "The window title of the Who-Line") (DEFGLOBALVAR *WHO-LINE-BORDER* 2 "The border width of the Who-Line window") (DEFGLOBALVAR *WHO-LINE-UPDATE-INTERVAL* 100 "Update interval for the Who-Line, in milliseconds") (* ;;; "----------------------------------------------------------------------") (* ;;; "Internal fns") (DEFINEQ (REDISPLAY-WHO-LINE - (LAMBDA (WINDOW) (* ; "Edited 17-Apr-87 19:06 by smL") - -(* ;;; "Redisplay the entire who-line, including the names of the fields") - - (WITH-WHO-LINE WINDOW - - (* ;; "") - - (* ;; "Set the display characteristics of the window, according to its color") - - (DSPSOURCETYPE (SELECTQ (WINDOWPROP WINDOW 'COLOR) - (:WHITE 'INPUT) - (:BLACK 'INVERT) - (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) - WINDOW) - (DSPTEXTURE (SELECTQ (WINDOWPROP WINDOW 'COLOR) - (:WHITE WHITESHADE) - (:BLACK BLACKSHADE) - (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) - WINDOW) - - (* ;; "") - - (* ;; "Clear the window") - - (CLEARW WINDOW) - (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) do (replace (WHO-LINE-ENTRY INVERTED?) - of ITEM with NIL)) - - (* ;; "") - - (* ;; "Display the labels if we should") - - (if (WINDOWPROP WINDOW 'DISPLAY-NAMES?) - then (DSPFONT (WINDOWPROP WINDOW 'NAME-FONT) - WINDOW) - (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) bind (FONT _ (WINDOWPROP WINDOW - 'NAME-FONT)) - do (MOVETO (fetch (WHO-LINE-ENTRY NAME-START) of ITEM) - (PLUS (FONTPROP FONT 'DESCENT) - (QUOTIENT (DIFFERENCE (WINDOWPROP *WHO-LINE* 'HEIGHT) - (FONTPROP FONT 'HEIGHT)) - 2)) - WINDOW) - (PRIN1 (fetch (WHO-LINE-ENTRY NAME) of ITEM) - WINDOW))) - - (* ;; "") - - (* ;; "Display the values") - - (DSPFONT (WINDOWPROP WINDOW 'VALUE-FONT) - WINDOW) - (UPDATE-WHO-LINE WINDOW (WINDOWPROP WINDOW 'ENTRIES) - T) - - (* ;; "") - - (* ;; "Reset the timer for the next update") - - (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) (PERIODICALLY-UPDATE-WHO-LINE - (LAMBDA NIL (* ; "Edited 27-Jan-88 10:11 by smL") - -(* ;;; "") - -(* ;;; "Update the current who-line window every so often. This is designed to be placed on the list of BACKBROUNDFNS.") - -(* ;;; "") - - (DECLARE (GLOBALVARS \IDLING)) - (CL:WHEN (TIMEREXPIRED? *WHO-LINE-UPDATE-TIMER* 'TICKS) - (CL:WHEN (AND (BOUNDP '*WHO-LINE*) - (NOT \IDLING)) (* ; - "Don't bother to wait and update if the window is owned by someone.") - - (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) - (GETWINDOWPROP *WHO-LINE* 'VALID)) - then (UPDATE-WHO-LINE *WHO-LINE* - (GETWINDOWPROP *WHO-LINE* - 'ENTRIES))))) - (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) (SETUP-WHOLINE-TIMER - (LAMBDA (OLD-TIMER) (* ; "Edited 18-Mar-87 11:14 by smL") - (SETUPTIMER (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL) - OLD-TIMER - 'TICKS))) (UPDATE-WHO-LINE - (LAMBDA (WINDOW WHO-LINE-ENTRIES ALWAYS?) (* ; "Edited 17-Apr-87 19:05 by smL") - -(* ;;; "Update the window to show the current who-line stats") - - (WITH-WHO-LINE - WINDOW - - (* ;; "") - - (* ;; "Update all the entries that have changed") - - (for ENTRY in WHO-LINE-ENTRIES bind (VALUE-BOTTOM _ (GETWINDOWPROP WINDOW 'VALUE-BOTTOM)) - (STREAM _ (GETWINDOWPROP WINDOW 'TEMP-STREAM)) - (HEIGHT _ (GETWINDOWPROP WINDOW 'HEIGHT)) - (BLACK-WINDOW-P _ (EQ (WINDOWPROP WINDOW 'COLOR) - :BLACK)) - do (with WHO-LINE-ENTRY ENTRY (* ; - "If the node is inverted, the user is mousing it, so don't update it") - (if (NOT INVERTED?) - then (if ALWAYS? - then (EVAL RESET-FORM)) - (LET ((VALUE (EVAL FORM))) - - (* ;; "") - - (* ;; "Only update if the value has changed, or we are ordered to.") - - (if (OR ALWAYS? (NOT (EQUAL VALUE PREV-VALUE))) - then - - (* ;; "") - - (* ;; "Print the new value") - - (MOVETO VALUE-START VALUE-BOTTOM STREAM) - (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE - VALUE-END - VALUE-START) - HEIGHT - 'ERASE) - (DSPFONT (DSPFONT NIL WINDOW) - STREAM) - (PRIN1 VALUE STREAM) - (if BLACK-WINDOW-P - then (BLTSHADE BLACKSHADE STREAM VALUE-START 0 - (DIFFERENCE VALUE-END VALUE-START) - HEIGHT - 'INVERT)) - (BITBLT STREAM VALUE-START 0 WINDOW VALUE-START 0 - (DIFFERENCE VALUE-END VALUE-START) - HEIGHT - 'PAINT) - - (* ;; "") - - (* ;; "Save the value.") - - (* ;; "We are worried that a form may be re-using a value (to minimize CONS-ing), so we store a copy of the value rather than the real value.") - - (SETQ PREV-VALUE (COPYALL VALUE)))))))))) (WHEN-WHO-LINE-SELECTED-FN - (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 09:54 by smL") - -(* ;;; "") - -(* ;;; "The button has gone down in the who-line window.") - -(* ;;; "If the control or edit key is down, allow the user to change the entries in the who-line.") - -(* ;;; "If the user selects an item, and it has a when-selected-fn, funcall that fn.") - -(* ;;; "") - - (WITH-WHO-LINE WINDOW (TOTOPW WINDOW) - (GETMOUSESTATE) - (if (OR (KEYDOWNP 'EDIT) - (KEYDOWNP 'CTRL)) - then (WHO-LINE-CONTROL-SELECT) - else (bind (REGION _ (WINDOWPROP WINDOW 'REGION)) - (ENTRIES _ (WINDOWPROP WINDOW 'ENTRIES)) - INVERTED-ITEM CURRENT-ITEM while (MOUSESTATE (NOT UP)) - do - (* ;; "") - - (* ;; "If cursor has left the window, quit tracking") - - (* ;; "") - - (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) - then (SETQ CURRENT-ITEM NIL) - (GO $$OUT)) - (* ;; "") - - (* ;; "Find out what item we are currently on") - - (* ;; "") - - (SETQ CURRENT-ITEM (for ENTRY in ENTRIES - thereis (with WHO-LINE-ENTRY ENTRY - (AND (GEQ (LASTMOUSEX WINDOW) - NAME-START) - (LEQ (LASTMOUSEX WINDOW) - VALUE-END) - (NOT (NULL WHEN-SELECTED-FN)))))) - (* ;; "") - - (* ;; "Invert the current choice") - - (* ;; "") - - (if (NEQ INVERTED-ITEM CURRENT-ITEM) - then (if INVERTED-ITEM - then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) - (if CURRENT-ITEM - then (INVERT-WHO-LINE-ENTRY CURRENT-ITEM WINDOW)) - (SETQ INVERTED-ITEM CURRENT-ITEM)) - finally - (* ;; "") - - (* ;; "The button went up. If we were on an item, let it know") - - (* ;; "") - - (if INVERTED-ITEM - then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) - (if CURRENT-ITEM - then (with WHO-LINE-ENTRY CURRENT-ITEM (if WHEN-SELECTED-FN - then (APPLY* - WHEN-SELECTED-FN - ) - (EVAL RESET-FORM)))))) - ))) (WHO-LINE-CONTROL-SELECT [LAMBDA NIL (* ; "Edited 28-Dec-98 12:56 by rmk:") "Interactivly let the user add or delete an entry to the WHO-LINE." (CL:FLET [(ENTRY-DESCRIPTION (X) (OR (CL:SIXTH X) (CONCAT "Entry named: " (CL:FIRST X] (CASE (MENU (create MENU ITEMS _ '(("Add item" :ADD "Add a new entry to the who-line") ("Remove item" :REMOVE "Remove an existing entry from the who-line")) TITLE _ "Change WHO-LINE entries")) (:ADD (LET* [[ITEMS (for entry in *WHO-LINE-ENTRY-REGISTRY* unless (MEMBER entry *WHO-LINE-ENTRIES*) collect `(,(ENTRY-DESCRIPTION entry) ',entry] (NEW-ENTRY (if ITEMS then (MENU (create MENU ITEMS _ ITEMS TITLE _ "Entry to add to WHO-LINE"] (if NEW-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CONS NEW-ENTRY *WHO-LINE-ENTRIES*)) (INSTALL-WHO-LINE-OPTIONS)))) (:REMOVE (LET* [[ITEMS (for entry in *WHO-LINE-ENTRIES* collect `(,(ENTRY-DESCRIPTION entry) ',entry] (BAD-ENTRY (if ITEMS then (MENU (create MENU ITEMS _ ITEMS TITLE _ "Entry to remove from WHO-LINE"] (if BAD-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CL:REMOVE BAD-ENTRY *WHO-LINE-ENTRIES*)) (INSTALL-WHO-LINE-OPTIONS)))))]) (WHO-LINE-COPY-INSERT - (LAMBDA (X) (* ; "Edited 18-Mar-87 13:11 by smL") - (LET ((TTY-WINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS NIL))))) - (if (OR (IMAGEOBJP X) - (AND (WINDOWP TTY-WINDOW) - (WINDOWPROP TTY-WINDOW 'COPYINSERTFN))) - then (COPYINSERT X) - else (BKSYSBUF X NIL))))) ) (DEFINEQ (WHO-LINE-REDISPLAY-INTERRUPT - (LAMBDA NIL (* ; "Edited 20-Apr-87 11:32 by smL") - -(* ;;; "Update the current who-line window because the user has requested it via an interrupt.") - - (if (BOUNDP '*WHO-LINE*) - then - - (* ;; "Update the Who-Line, if it is available") - - (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) - (WINDOWPROP *WHO-LINE* 'VALID)) - then (* ; - "Flash the Who-line to let people know that it is being updated") - (CLOSEW *WHO-LINE*) - (OPENW *WHO-LINE*) - (* ; "The update the entries") - (UPDATE-WHO-LINE *WHO-LINE* - (WINDOWPROP *WHO-LINE* 'ENTRIES))))) - )) ) (DEFGLOBALVAR *WHO-LINE* NIL "The who-line window") (DEFGLOBALVAR *WHO-LINE-UPDATE-TIMER* NIL "Timer for controlling updating of the Who-Line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (APPENDTOVAR \SYSTEMTIMERVARS (*WHO-LINE-UPDATE-TIMER* TICKS)) ) (DEFMACRO INVERT-WHO-LINE-ENTRY (ENTRY WINDOW) `(WITH WHO-LINE-ENTRY ,ENTRY (BLTSHADE BLACKSHADE ,WINDOW NAME-START 0 (DIFFERENCE VALUE-END NAME-START) NIL 'INVERT) (CHANGE INVERTED? (NOT INVERTED?)))) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD WHO-LINE-ENTRY (NAME FORM NAME-START VALUE-START VALUE-END PREV-VALUE WHEN-SELECTED-FN INVERTED? RESET-FORM DESCRIPTION)) ) ) (* ; "Macros that lets us lock down the Who-Line while we evaluate some forms") (DEFMACRO WITH-WHO-LINE (WHO-LINE &BODY FORMS) "Evaluate the forms with the who-line locked down" `(WITH.MONITOR (WINDOWPROP ,WHO-LINE 'LOCK) ,@FORMS)) (DEFMACRO WITH-AVAILABLE-WHO-LINE (WHO-LINE &BODY FORMS) "Evaluate the forms with the who-line locked down, if the who-line is available" [LET ((LOCK (CL:GENSYM))) `(LET ((,LOCK (OBTAIN.MONITORLOCK (WINDOWPROP ,WHO-LINE 'LOCK) T))) (CL:UNWIND-PROTECT (* ;  "Only eval the forms if we got the lock") (COND (,LOCK ,@FORMS)) (* ;; "Now for the cleanup forms") [COND ((EQ ,LOCK T) (* ;  "Had the lock before, so no need to release it") NIL) ((NULL ,LOCK) (* ;  "Couldn't get the lock, so no need to release it") NIL) (T (* ;  "We got the lock, and need to release it") (RELEASE.MONITORLOCK ,LOCK])]) (* ;;; "----------------------------------------------------------------------") (* ;;; "Initialize the who-line") (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE (INSTALL-WHO-LINE-OPTIONS) (ADDTOVAR BACKGROUNDFNS PERIODICALLY-UPDATE-WHO-LINE) ) (* ;;; "----------------------------------------------------------------------") (* ;;; "Filemanager stuff") (DECLARE%: DONTCOPY (PUTPROPS WHO-LINE MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) (PUTPROPS WHO-LINE FILETYPE :COMPILE-FILE) ) (PUTPROPS WHO-LINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989 1994 1998 2001)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7446 22825 (INSTALL-WHO-LINE-OPTIONS 7456 . 22823)) (23101 24270 (WHO-LINE-USERNAME 23111 . 23758) (WHO-LINE-CHANGE-USER 23760 . 24066) (WHO-LINE-USER-AFTER-LOGIN 24068 . 24268)) (25172 25651 (WHO-LINE-HOST-NAME 25182 . 25649)) (26363 28992 (CURRENT-TTY-PACKAGE 26373 . 27325) ( SET-PACKAGE-INTERACTIVELY 27327 . 28746) (SET-TTY-PACKAGE-INTERACTIVELY 28748 . 28990)) (29912 30964 ( CURRENT-TTY-READTABLE-NAME 29922 . 30176) (SET-READTABLE-INTERACTIVELY 30178 . 30712) ( SET-TTY-READTABLE-INTERACTIVELY 30714 . 30962)) (31479 32051 (WHO-LINE-TTY-PROCESS 31489 . 31667) ( CHANGE-TTY-PROCESS-INTERACTIVELY 31669 . 32049)) (32552 36023 (WHO-LINE-CURRENT-DIRECTORY 32562 . 33969) (SET-CONNECTED-DIRECTORY-INTERACTIVELY 33971 . 36021)) (37388 39841 (WHO-LINE-VMEM 37398 . 39588) (WHO-LINE-SAVE-VMEM 39590 . 39839)) (42775 44213 (WHO-LINE-TIME 42785 . 43527) ( WHO-LINE-SET-TIME 43529 . 44211)) (45747 48380 (WHO-LINE-SHOW-ACTIVE 45757 . 46535) ( \UPDATE-WHO-LINE-ACTIVE-FLAG 46537 . 47505) (\PERIODICALLY-WHO-LINE-SHOW-ACTIVE 47507 . 48378)) (49541 50466 (CURRENT-PROFILE 49551 . 49796) (SET-PROFILE-INTERACTIVELY 49798 . 50201) ( SET-TTY-PROFILE-INTERACTIVELY 50203 . 50464)) (51028 53011 (WHO-LINE-TTY-STATE 51038 . 52199) ( WHO-LINE-WHAT-IS-RUNNING 52201 . 53009)) (56568 69694 (REDISPLAY-WHO-LINE 56578 . 59138) ( PERIODICALLY-UPDATE-WHO-LINE 59140 . 60278) (SETUP-WHOLINE-TIMER 60280 . 60498) (UPDATE-WHO-LINE 60500 . 63568) (WHEN-WHO-LINE-SELECTED-FN 63570 . 66837) (WHO-LINE-CONTROL-SELECT 66839 . 69298) ( WHO-LINE-COPY-INSERT 69300 . 69692)) (69695 70829 (WHO-LINE-REDISPLAY-INTERRUPT 69705 . 70827))))) STOP \ No newline at end of file diff --git a/lispusers/comparetext.~1~ b/lispusers/comparetext.~1~ deleted file mode 100644 index 954a5466..00000000 --- a/lispusers/comparetext.~1~ +++ /dev/null @@ -1,654 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "18-Nov-93 14:43:00" {DSK}export>lispcore>lispusers>comparetext.;2 39517 - - changes to%: (VARS COMPARETEXTCOMS) - - previous date%: "11-Jul-85 09:12:06" {DSK}export>lispcore>lispusers>comparetext.;1) - - -(* ; " -Copyright (c) 1984, 1985, 1993 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT COMPARETEXTCOMS) - -(RPAQQ COMPARETEXTCOMS - ((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP) - GRAPHER)) - (FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS - IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH - IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS - IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST - IMCOMPARE.UPDATE.SYMBOL.TABLE) - (P (MOVD 'COMPARETEXT 'IMCOMPARE)) - (VARS (IMCOMPARE.LAST.NODE NIL) - (IMCOMPARE.LAST.GRAPH.WINDOW NIL) - (IMCOMPARE.HASH.TYPE.MENU NIL)) - (RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB) - (FILES GRAPHER))) -(DECLARE%: EVAL@COMPILE - -(FILESLOAD (LOADCOMP) - GRAPHER) -) -(DEFINEQ - -(COMPARETEXT - [LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION) - (* mjs " 8-Jan-84 21:06") - - (* Compares the two files, and produces a graph showing their corresponding - chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may - be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. - The file difference graph is displayed at GRAPHREGION. - If GRAPH.REGION = NIL, the user is asked to specify a region. - If GRAPH.REGION = T, a standard region is used.) - - (PROG ((NEWFILE (FINDFILE NEWFILENAME T)) - (OLDFILE (FINDFILE OLDFILENAME T))) - (if (AND OLDFILE NEWFILE) - then (* compare the two "chunks" - consisting of the entire text of the - two files) - (IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK - FILENAME _ NEWFILE - FILEPTR _ 0 - CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH)) - (create IMCOMPARE.CHUNK - FILENAME _ OLDFILE - FILEPTR _ 0 - CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH)) - HASH.TYPE - (if (EQ GRAPH.REGION T) - then (create REGION - LEFT _ 25 - BOTTOM _ 25 - WIDTH _ 500 - HEIGHT _ 150) - elseif GRAPH.REGION - else (CLRPROMPT) - (printout PROMPTWINDOW - "Please specify a window for the file difference graph" T) - (GETREGION))) - else (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME - " --- IMCOMPARE aborted" T]) - -(IMCOMPARE.BOXNODE - [LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40") - (if IMCOMPARE.LAST.NODE - then (RESET/NODE/BORDER IMCOMPARE.LAST.NODE 'INVERT IMCOMPARE.LAST.GRAPH.WINDOW) - (SETQ IMCOMPARE.LAST.NODE NIL) - (SETQ IMCOMPARE.LAST.GRAPH.WINDOW NIL)) - (if NODE - then (RESET/NODE/BORDER NODE 'INVERT WINDOW) - (SETQ IMCOMPARE.LAST.NODE NODE) - (SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW]) - -(IMCOMPARE.CHUNKS - [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION) - (* rmk%: " 8-Sep-84 00:06") - - (* this is the main text-comparison function. - It compares the text in the two chunks and produces a graph showing how the sub-chunks of the two main - chunks are related. The two main chunks may be in the same file, and the file - may actually be an open Tedit textstream. - The main chunks are broken down according to HASH.TYPE, which may be PARA - , LINE, or WORD. HASH.TYPE = NIL defaults to PARA. - The file difference graph is displayed at GRAPH.REGION.) - - (* this text comparison algorithm is originally from the article - "A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM, - V21, %#4, April 1978 --- major difference is that I use lists instead of arrays) - - (PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500)) - NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST) - - (* * collect lists of chunks from each of the main chunks, dividing them - according to HASH.TYPE) - - (SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE)) - (SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE)) - - (* * update the chunk symbol table. For each hash value, this table records the - number of "new" chunks with that hash value, the number of "old" chunks with - that value, and a pointer to the place in OLD.CHUNK.LIST .) - - (IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL) - (IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T) - - (* * For every new chunk whose hash value matches EXACTLY ONE old chunk's - value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK - field to point to the appropriate place in the old chunk list . Also, make sure that OTHERCHUNK of the matching old chunk is - non-NIL, so that unconnected old chunks will be merged correctly.) - - (for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB - do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK) - CHUNK.SYMBOL.TABLE)) - (if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB)) - (EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB))) - then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK - with (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB)) - (replace (IMCOMPARE.CHUNK OTHERCHUNK) - of (CAR (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB)) - with T))) - - (* * merge connected chunks forward) - - (IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL) - - (* * merge connected chunks backwards) - - (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST)) - (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST)) - (IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T) - (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST)) - (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST)) - - (* * merge unconnected chunks) - - (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST) - (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST) - - (* * now, the file comparison is complete. - Format and display the file difference graph) - - (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK - HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST]) - -(IMCOMPARE.COLLECT.HASH.CHUNKS - [LAMBDA (CHUNK HASH.TYPE) (* mjs " 8-Jan-84 20:57") - - (* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE) - - (PROG ((FILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK)) - STREAM END.OF.CHUNK.PTR CHUNK.LIST) - [SETQ STREAM (GETSTREAM (OPENFILE FILENAME 'INPUT 'OLD] - (SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)) - (SETQ END.OF.CHUNK.PTR (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK) - (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK))) - (SETQ CHUNK.LIST (until (IGEQ (GETFILEPTR STREAM) - END.OF.CHUNK.PTR) collect (IMCOMPARE.HASH STREAM - END.OF.CHUNK.PTR - HASH.TYPE))) - (CLOSEF STREAM) - (RETURN CHUNK.LIST]) - -(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH - [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST - OLDFILE.CHUNK.LIST) (* mjs "11-Jul-85 09:10") - - (* * format and display the graph) - - (PROG ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK)) - (OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK)) - (OLD.CHUNK.NODE.FROM.NODES NIL) - (BORDERSIZE 1) - GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD - YCOORD.INCREMENT DIFF.GRAPH) - - (* * set up GRAPH.WINDOW. This is done first so you can get the width and - height of strings to be printed in the window.) - - [SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by " - (SELECTQ HASH.TYPE - ((PARA NIL) - "Paragraph") - (LINE "Line") - (WORD "Word") - (SHOULDNT] - (WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE) - [WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) - (if (EQ WINDOW - IMCOMPARE.LAST.GRAPH.WINDOW) - then (SETQ - IMCOMPARE.LAST.GRAPH.WINDOW - NIL) - (SETQ IMCOMPARE.LAST.NODE NIL] - (SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW) - 2)) - [SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD - (IQUOTIENT (STRINGWIDTH - OLDFILENAME - GRAPH.WINDOW) - 2) - 20] - [SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE) - (fetch (REGION HEIGHT) of (STRINGREGION - NEWFILENAME - GRAPH.WINDOW] - - (* * collect new-chunk graph nodes, while accumulating - OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks) - - (SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from - YCOORD.INCREMENT - by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK - collect (SETQ CORRESPONDING.OLD.CHUNK - (CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) - of NEW.CHUNK))) - (if CORRESPONDING.OLD.CHUNK - then (SETQ OLD.CHUNK.NODE.FROM.NODES - (CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK) - OLD.CHUNK.NODE.FROM.NODES))) - (* Start out with 2 point white - border, so we can invert it) - (NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM - (PACK* (fetch (IMCOMPARE.CHUNK - FILEPTR) - of NEW.CHUNK) - ":" - (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of NEW.CHUNK)) - 12) - (create POSITION - XCOORD _ NEW.CHUNK.XCOORD - YCOORD _ Y) - (if CORRESPONDING.OLD.CHUNK - then (LIST CORRESPONDING.OLD.CHUNK) - else NIL) - NIL DEFAULTFONT -2))) - (SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from - YCOORD.INCREMENT - by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK - collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK - OLD.CHUNK.NODE.FROM.NODES - ))) - (NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM - (PACK* (fetch (IMCOMPARE.CHUNK - FILEPTR) - of OLD.CHUNK) - ":" - (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of OLD.CHUNK)) - 12 "-") - (create POSITION - XCOORD _ OLD.CHUNK.XCOORD - YCOORD _ Y) - NIL - (if CORRESPONDING.NEW.CHUNK - then (LIST CORRESPONDING.NEW.CHUNK) - else NIL) - DEFAULTFONT -2))) - (SETQ DIFF.GRAPH (create GRAPH - DIRECTEDFLG _ T - SIDESFLG _ T - GRAPHNODES _ - (NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME - (create POSITION - XCOORD _ NEW.CHUNK.XCOORD - YCOORD _ 0) - NIL NIL DEFAULTFONT -2)) - NEW.CHUNK.NODES - (LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME - (create POSITION - XCOORD _ OLD.CHUNK.XCOORD - YCOORD _ 0) - NIL NIL DEFAULTFONT -2)) - OLD.CHUNK.NODES))) - (SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN) - (FUNCTION IMCOMPARE.MIDDLEBUTTONFN) - T NIL]) - -(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT - [LAMBDA (FILE) (* mjs " 2-Jan-84 16:19") - - (* returns the Tedit text object of the first Tedit window which is currently - looking at FILE, if there is one. Returns NIL if none is found.) - - (PROG ((TEDIT.TEXT.OBJECT NIL)) - (for X in (OPENWINDOWS) bind POSS.TOBJ POSS.FILENAME - when (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil TEDIT.TEXT.OBJECT - do (SETQ POSS.FILENAME (FULLNAME (fetch (TEXTOBJ TXTFILE) of POSS.TOBJ))) - (if (EQ FILE POSS.FILENAME) - then (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ))) - (RETURN TEDIT.TEXT.OBJECT]) - -(IMCOMPARE.HASH - [LAMBDA (STREAM EOF.PTR HASH.TYPE) (* rmk%: " 8-Sep-84 00:37") - - (* reads caracters from STREAM and creates a hash value for the "next" "chunk" - A chunk is a paragraph ending in two consecutive CRs , - a line ending in a CR , or a word ending in any white space - character space . In computing the hash value, white space is - ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR - Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the - beginning of the chunk, the length of the chunk, and the fullname of the stream) - - (* Note%: Most of the time in COMPARETEXT is spent reading in and hashing - chunks, so this function was optimizes for speed, at the expense of length) - - (PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM)) - (EOLC (GETFILEINFO STREAM 'EOL)) - (HASHNUM 0) - FILE.PTR C) - (SETQ FILE.PTR BEGIN.FILE.PTR) - (SELECTQ HASH.TYPE - ((NIL PARA) - - (* Paragraph chunks end with two consecutive EOL's. - In order to detect this without slowing down the gobbling of normal chars, - LAST.EOL.POS is set to the filepos of the last EOL detected. - This is only checked when another EOL comes along.) - - (PROG ((LAST.EOL.POS -5)) - loop - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (SETQ C (BIN STREAM)) - (CR - - (* If this is the second consecutive CR, this is the end of the chunk. - Otherwise, reset LAST.EOL.POS) - - (SELECTQ EOLC - (CR (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM))) - then (GO endchunk) - else (SETQ LAST.EOL.POS (GETFILEPTR STREAM)))) - (CRLF (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SELCHARQ (\PEEKBIN STREAM T) - (LF (SETQ FILE.PTR (ADD1 FILE.PTR)) - (BIN STREAM) - (if (IEQP LAST.EOL.POS (IDIFFERENCE - (GETFILEPTR STREAM) - 2)) - then (GO endchunk) - else (SETQ LAST.EOL.POS (GETFILEPTR STREAM - )))) - NIL)) - NIL)) - (LF [COND - ((EQ EOLC 'LF) - (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM))) - then (GO endchunk) - else (SETQ LAST.EOL.POS (GETFILEPTR STREAM]) - ((SPACE TAB)) - (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) - 1 16) - 1 16) - 1 16))) - (GO loop))) - (LINE (* Line chunks end on a single CR.) - (PROG NIL - loop - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (SETQ C (BIN STREAM)) - (CR (SELECTQ EOLC - (CR (GO endchunk)) - (LF) - (CRLF (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SELCHARQ (\PEEKBIN STREAM T) - (LF (SETQ FILE.PTR (ADD1 FILE.PTR)) - (BIN STREAM) - (GO endchunk)) - NIL)) - (SHOULDNT))) - (LF (AND (EQ EOLC 'LF) - (GO endchunk))) - ((SPACE TAB)) - (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) - 1 16) - 1 16) - 1 16))) - (GO loop))) - (WORD (* word chunks end on any white - space) - (PROG NIL - loop - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (SETQ C (BIN STREAM)) - ((CR SPACE TAB LF) - (GO endchunk)) - (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) - 1 16) - 1 16) - 1 16))) - (GO loop))) - (SHOULDNT)) - endchunk - (* flush all white space before next - chunk) - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (BIN STREAM) - ((CR SPACE TAB LF) - (GO endchunk)) - (PROGN (SETQ FILE.PTR (SUB1 FILE.PTR)) - (SETFILEPTR STREAM FILE.PTR))) - return - (RETURN (create IMCOMPARE.CHUNK - HASHVALUE _ HASHNUM - FILEPTR _ BEGIN.FILE.PTR - CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR) - FILENAME _ (FULLNAME STREAM]) - -(IMCOMPARE.LEFTBUTTONFN - [LAMBDA (GNODE WINDOW) (* mjs " 2-Apr-85 14:21") - (if GNODE - then (IMCOMPARE.BOXNODE GNODE WINDOW) - (PROG ((NODEID (fetch (GRAPHNODE NODEID) of GNODE)) - (FILEPTR 1) - (CHUNKLENGTH 0) - (TEDIT.TEXT.OBJECT NIL) - FILE) - (SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID)) - (SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID)) - (SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID)) - (SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE)) - (if TEDIT.TEXT.OBJECT - then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25)) - 0 - 'LEFT) - (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT) - (TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT) - (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT) - (TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of - - TEDIT.TEXT.OBJECT - )) - 'PROCESS)) - else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH]) - -(IMCOMPARE.LENGTHEN.ATOM - [LAMBDA (X MIN.LENGTH EXTENDER) (* mjs "30-Dec-83 15:11") - - (* makes sure that the atom X is at least MIN.LENGTH characters long, by - concatinating the first character of EXTENDER - (or space, if not given) to the front) - - (PROG ((C (CHCON X))) - (SETQ EXTENDER (if EXTENDER - then (CHCON1 EXTENDER) - else (CHARCODE SPACE))) - (while (ILESSP (LENGTH C) - MIN.LENGTH) do (SETQ C (CONS EXTENDER C))) - (RETURN (PACKC C]) - -(IMCOMPARE.MERGE.CONNECTED.CHUNKS - [LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35") - (while NEW.CHUNK.LIST bind NEW.CHUNK OLD.CHUNK.PTR - do (SETQ NEW.CHUNK (CAR NEW.CHUNK.LIST)) - (SETQ OLD.CHUNK.PTR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK)) - (if [OR (NULL (CDR NEW.CHUNK.LIST)) - (NULL OLD.CHUNK.PTR) - (NULL (CDR OLD.CHUNK.PTR)) - (NOT (EQP (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR NEW.CHUNK.LIST - )) - (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR OLD.CHUNK.PTR] - then (SETQ NEW.CHUNK.LIST (CDR NEW.CHUNK.LIST)) - else - - (* next chunks have same hash, so "murge" them into current chunks by adding - their chunk lengths to the current chunks, and splicing out the next chunks) - - [replace (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK - with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK) - (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR - NEW.CHUNK.LIST - ] - [replace (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR OLD.CHUNK.PTR) - with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR - OLD.CHUNK.PTR - )) - (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR - OLD.CHUNK.PTR - ] - [if BACKWARDS.FLG - then (* if the list is backwards, copy - next fileptr) - (replace (IMCOMPARE.CHUNK FILEPTR) of NEW.CHUNK - with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR - NEW.CHUNK.LIST - ))) - (replace (IMCOMPARE.CHUNK FILEPTR) of (CAR OLD.CHUNK.PTR) - with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR - OLD.CHUNK.PTR - ] - (* splice chunks out of new and old - list) - (RPLACD NEW.CHUNK.LIST (CDDR NEW.CHUNK.LIST)) - (RPLACD OLD.CHUNK.PTR (CDDR OLD.CHUNK.PTR]) - -(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS - [LAMBDA (CHUNK.LST) (* mjs " 5-JAN-84 13:58") - (while CHUNK.LST bind CHUNK do (SETQ CHUNK (CAR CHUNK.LST)) - (if (OR (NULL (CDR CHUNK.LST)) - (fetch (IMCOMPARE.CHUNK OTHERCHUNK) - of CHUNK) - (fetch (IMCOMPARE.CHUNK OTHERCHUNK) - of (CADR CHUNK.LST))) - then (SETQ CHUNK.LST (CDR CHUNK.LST)) - else (* both current chunk and next chunk - have no OTHERCHUNK, so merge them) - [replace (IMCOMPARE.CHUNK CHUNKLENGTH) - of CHUNK - with (IPLUS (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of CHUNK) - (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of (CADR CHUNK.LST] - (* splice chunks out of new and old - list) - (RPLACD CHUNK.LST (CDDR CHUNK.LST]) - -(IMCOMPARE.MIDDLEBUTTONFN - [LAMBDA (GNODE WINDOW) (* mjs " 6-Jan-84 11:37") - - (* This function is called if the MIDDLE mouse button is pressed over a graph - node. The selected node is IMCOMPARE-ed with the last node selected . The type of hashing used is selected from a - pop-up menu. If none of the hashing types is selected, the current node is - boxed. The pop-up menu is always located a little above the current cursor - position, so a quick double-MIDDLE-click is an easy way to change the current - boxed node.) - - (if GNODE - then (PROG (INNER.HASH.TYPE) - (CLRPROMPT) - (printout PROMPTWINDOW "Please select the type of hashing you wish." T) - [SETQ INNER.HASH.TYPE - (MENU (if (type? MENU IMCOMPARE.HASH.TYPE.MENU) - then IMCOMPARE.HASH.TYPE.MENU - else (SETQ IMCOMPARE.HASH.TYPE.MENU - (create MENU - ITEMS _ '(PARA LINE WORD) - MENUOFFSET _ - (create POSITION - XCOORD _ 20 - YCOORD _ -20] - (if (NULL INNER.HASH.TYPE) - then (* if no hash type is selected, just - box the current node and return) - (IMCOMPARE.BOXNODE GNODE WINDOW) - (RETURN)) - (if (NULL IMCOMPARE.LAST.NODE) - then (CLRPROMPT) - (PRIN1 "You must select another graph node first." PROMPTWINDOW) - (RETURN)) - (printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T) - (IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE - ) - (fetch (GRAPHNODE NODEID) of GNODE) - INNER.HASH.TYPE - (WINDOWPROP WINDOW 'REGION]) - -(IMCOMPARE.SHOW.DIST - [LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13") - (PROG ((WINDOW (CREATEW)) - MAX.Y X MAX.X) - (SETQ MAX.X (WINDOWPROP WINDOW 'WIDTH)) - (SETQ MAX.Y (WINDOWPROP WINDOW 'HEIGHT)) - (for SAMPLE in LST do (SETQ X (FTIMES MAX.X (FQUOTIENT SAMPLE MAX))) - (DRAWLINE X 0 X MAX.Y 1 'PAINT WINDOW]) - -(IMCOMPARE.UPDATE.SYMBOL.TABLE - [LAMBDA (CHUNK.LIST CHUNK.SYMBOL.TABLE OLD.CHUNK.FLG) (* mjs " 8-Jan-84 21:01") - - (* * update the chunk symbol table. For each hash value, this table records the - number of "new" chunks with that hash value, the number of "old" chunks with - that value, and a pointer to the place in OLD.CHUNK.LIST .) - - (for CHUNK.PTR on CHUNK.LIST bind CHUNK SYMB - do (SETQ CHUNK (CAR CHUNK.PTR)) - (SETQ SYMB (if (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK) - CHUNK.SYMBOL.TABLE) - else (PUTHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK) - (create IMCOMPARE.SYMB - NEWCOUNT _ 0 - OLDCOUNT _ 0 - OLDPTR _ NIL) - CHUNK.SYMBOL.TABLE))) - (if OLD.CHUNK.FLG - then (* increment old-chunk count) - (replace (IMCOMPARE.SYMB OLDCOUNT) of SYMB - with (ADD1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB))) - - (* smash old-chunk pointer. Note that it must point to the LIST of old-chunks, - rather than to the individual one) - - (replace (IMCOMPARE.SYMB OLDPTR) of SYMB with CHUNK.PTR) - else (* increment new-chunk count) - (replace (IMCOMPARE.SYMB NEWCOUNT) of SYMB - with (ADD1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB]) -) - -(MOVD 'COMPARETEXT 'IMCOMPARE) - -(RPAQQ IMCOMPARE.LAST.NODE NIL) - -(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW NIL) - -(RPAQQ IMCOMPARE.HASH.TYPE.MENU NIL) -(DECLARE%: EVAL@COMPILE - -(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK) - FILEPTR _ 1 CHUNKLENGTH _ 0) - -(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR)) -) - -(FILESLOAD GRAPHER) -(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1295 39023 (COMPARETEXT 1305 . 3700) (IMCOMPARE.BOXNODE 3702 . 4218) (IMCOMPARE.CHUNKS -4220 . 8406) (IMCOMPARE.COLLECT.HASH.CHUNKS 8408 . 9491) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9493 - . 18359) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18361 . 19124) (IMCOMPARE.HASH 19126 . 26281) ( -IMCOMPARE.LEFTBUTTONFN 26283 . 28019) (IMCOMPARE.LENGTHEN.ATOM 28021 . 28659) ( -IMCOMPARE.MERGE.CONNECTED.CHUNKS 28661 . 32157) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32159 . 34114) ( -IMCOMPARE.MIDDLEBUTTONFN 34116 . 36688) (IMCOMPARE.SHOW.DIST 36690 . 37136) ( -IMCOMPARE.UPDATE.SYMBOL.TABLE 37138 . 39021))))) -STOP diff --git a/lispusers/comparetext.~2~ b/lispusers/comparetext.~2~ deleted file mode 100644 index 87d67381..00000000 --- a/lispusers/comparetext.~2~ +++ /dev/null @@ -1,660 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "23-Dec-98 17:05:12" {DSK}medley3.5>lispusers>comparetext.;3 39844 - - changes to%: (FNS IMCOMPARE.HASH IMCOMPARE.COLLECT.HASH.CHUNKS) - (VARS COMPARETEXTCOMS) - - previous date%: "18-Nov-93 14:43:00" {DSK}medley3.5>lispusers>comparetext.;1) - - -(* ; " -Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT COMPARETEXTCOMS) - -(RPAQQ COMPARETEXTCOMS - ((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP) - GRAPHER)) - (FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS - IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH - IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS - IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST - IMCOMPARE.UPDATE.SYMBOL.TABLE) - (P (MOVD 'COMPARETEXT 'IMCOMPARE)) - (VARS (IMCOMPARE.LAST.NODE NIL) - (IMCOMPARE.LAST.GRAPH.WINDOW NIL) - (IMCOMPARE.HASH.TYPE.MENU NIL)) - (RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB) - (FILES GRAPHER))) -(DECLARE%: EVAL@COMPILE - -(FILESLOAD (LOADCOMP) - GRAPHER) -) -(DEFINEQ - -(COMPARETEXT - [LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION) - (* mjs " 8-Jan-84 21:06") - - (* Compares the two files, and produces a graph showing their corresponding - chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may - be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. - The file difference graph is displayed at GRAPHREGION. - If GRAPH.REGION = NIL, the user is asked to specify a region. - If GRAPH.REGION = T, a standard region is used.) - - (PROG ((NEWFILE (FINDFILE NEWFILENAME T)) - (OLDFILE (FINDFILE OLDFILENAME T))) - (if (AND OLDFILE NEWFILE) - then (* compare the two "chunks" - consisting of the entire text of the - two files) - (IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK - FILENAME _ NEWFILE - FILEPTR _ 0 - CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH)) - (create IMCOMPARE.CHUNK - FILENAME _ OLDFILE - FILEPTR _ 0 - CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH)) - HASH.TYPE - (if (EQ GRAPH.REGION T) - then (create REGION - LEFT _ 25 - BOTTOM _ 25 - WIDTH _ 500 - HEIGHT _ 150) - elseif GRAPH.REGION - else (CLRPROMPT) - (printout PROMPTWINDOW - "Please specify a window for the file difference graph" T) - (GETREGION))) - else (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME - " --- IMCOMPARE aborted" T]) - -(IMCOMPARE.BOXNODE - [LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40") - (if IMCOMPARE.LAST.NODE - then (RESET/NODE/BORDER IMCOMPARE.LAST.NODE 'INVERT IMCOMPARE.LAST.GRAPH.WINDOW) - (SETQ IMCOMPARE.LAST.NODE NIL) - (SETQ IMCOMPARE.LAST.GRAPH.WINDOW NIL)) - (if NODE - then (RESET/NODE/BORDER NODE 'INVERT WINDOW) - (SETQ IMCOMPARE.LAST.NODE NODE) - (SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW]) - -(IMCOMPARE.CHUNKS - [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION) - (* rmk%: " 8-Sep-84 00:06") - - (* this is the main text-comparison function. - It compares the text in the two chunks and produces a graph showing how the sub-chunks of the two main - chunks are related. The two main chunks may be in the same file, and the file - may actually be an open Tedit textstream. - The main chunks are broken down according to HASH.TYPE, which may be PARA - , LINE, or WORD. HASH.TYPE = NIL defaults to PARA. - The file difference graph is displayed at GRAPH.REGION.) - - (* this text comparison algorithm is originally from the article - "A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM, - V21, %#4, April 1978 --- major difference is that I use lists instead of arrays) - - (PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500)) - NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST) - - (* * collect lists of chunks from each of the main chunks, dividing them - according to HASH.TYPE) - - (SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE)) - (SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE)) - - (* * update the chunk symbol table. For each hash value, this table records the - number of "new" chunks with that hash value, the number of "old" chunks with - that value, and a pointer to the place in OLD.CHUNK.LIST .) - - (IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL) - (IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T) - - (* * For every new chunk whose hash value matches EXACTLY ONE old chunk's - value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK - field to point to the appropriate place in the old chunk list . Also, make sure that OTHERCHUNK of the matching old chunk is - non-NIL, so that unconnected old chunks will be merged correctly.) - - (for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB - do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK) - CHUNK.SYMBOL.TABLE)) - (if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB)) - (EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB))) - then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK - with (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB)) - (replace (IMCOMPARE.CHUNK OTHERCHUNK) - of (CAR (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB)) - with T))) - - (* * merge connected chunks forward) - - (IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL) - - (* * merge connected chunks backwards) - - (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST)) - (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST)) - (IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T) - (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST)) - (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST)) - - (* * merge unconnected chunks) - - (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST) - (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST) - - (* * now, the file comparison is complete. - Format and display the file difference graph) - - (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK - HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST]) - -(IMCOMPARE.COLLECT.HASH.CHUNKS - [LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 23-Dec-98 16:54 by rmk:") - (* mjs " 8-Jan-84 20:57") - - (* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE) - - (LET (STREAM END.OF.CHUNK.PTR CHUNK.LIST) - [SETQ STREAM (OPENSTREAM (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK) - 'INPUT - 'OLD - '((TYPE TEXT] - (SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)) - (SETQ END.OF.CHUNK.PTR (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK) - (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK))) - (SETQ CHUNK.LIST (until (IGEQ (GETFILEPTR STREAM) - END.OF.CHUNK.PTR) collect (IMCOMPARE.HASH STREAM - END.OF.CHUNK.PTR - HASH.TYPE))) - (CLOSEF STREAM) - CHUNK.LIST]) - -(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH - [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST - OLDFILE.CHUNK.LIST) (* mjs "11-Jul-85 09:10") - - (* * format and display the graph) - - (PROG ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK)) - (OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK)) - (OLD.CHUNK.NODE.FROM.NODES NIL) - (BORDERSIZE 1) - GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD - YCOORD.INCREMENT DIFF.GRAPH) - - (* * set up GRAPH.WINDOW. This is done first so you can get the width and - height of strings to be printed in the window.) - - [SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by " - (SELECTQ HASH.TYPE - ((PARA NIL) - "Paragraph") - (LINE "Line") - (WORD "Word") - (SHOULDNT] - (WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE) - [WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) - (if (EQ WINDOW - IMCOMPARE.LAST.GRAPH.WINDOW) - then (SETQ - IMCOMPARE.LAST.GRAPH.WINDOW - NIL) - (SETQ IMCOMPARE.LAST.NODE NIL] - (SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW) - 2)) - [SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD - (IQUOTIENT (STRINGWIDTH - OLDFILENAME - GRAPH.WINDOW) - 2) - 20] - [SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE) - (fetch (REGION HEIGHT) of (STRINGREGION - NEWFILENAME - GRAPH.WINDOW] - - (* * collect new-chunk graph nodes, while accumulating - OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks) - - (SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from - YCOORD.INCREMENT - by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK - collect (SETQ CORRESPONDING.OLD.CHUNK - (CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) - of NEW.CHUNK))) - (if CORRESPONDING.OLD.CHUNK - then (SETQ OLD.CHUNK.NODE.FROM.NODES - (CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK) - OLD.CHUNK.NODE.FROM.NODES))) - (* Start out with 2 point white - border, so we can invert it) - (NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM - (PACK* (fetch (IMCOMPARE.CHUNK - FILEPTR) - of NEW.CHUNK) - ":" - (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of NEW.CHUNK)) - 12) - (create POSITION - XCOORD _ NEW.CHUNK.XCOORD - YCOORD _ Y) - (if CORRESPONDING.OLD.CHUNK - then (LIST CORRESPONDING.OLD.CHUNK) - else NIL) - NIL DEFAULTFONT -2))) - (SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from - YCOORD.INCREMENT - by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK - collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK - OLD.CHUNK.NODE.FROM.NODES - ))) - (NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM - (PACK* (fetch (IMCOMPARE.CHUNK - FILEPTR) - of OLD.CHUNK) - ":" - (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of OLD.CHUNK)) - 12 "-") - (create POSITION - XCOORD _ OLD.CHUNK.XCOORD - YCOORD _ Y) - NIL - (if CORRESPONDING.NEW.CHUNK - then (LIST CORRESPONDING.NEW.CHUNK) - else NIL) - DEFAULTFONT -2))) - (SETQ DIFF.GRAPH (create GRAPH - DIRECTEDFLG _ T - SIDESFLG _ T - GRAPHNODES _ - (NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME - (create POSITION - XCOORD _ NEW.CHUNK.XCOORD - YCOORD _ 0) - NIL NIL DEFAULTFONT -2)) - NEW.CHUNK.NODES - (LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME - (create POSITION - XCOORD _ OLD.CHUNK.XCOORD - YCOORD _ 0) - NIL NIL DEFAULTFONT -2)) - OLD.CHUNK.NODES))) - (SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN) - (FUNCTION IMCOMPARE.MIDDLEBUTTONFN) - T NIL]) - -(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT - [LAMBDA (FILE) (* mjs " 2-Jan-84 16:19") - - (* returns the Tedit text object of the first Tedit window which is currently - looking at FILE, if there is one. Returns NIL if none is found.) - - (PROG ((TEDIT.TEXT.OBJECT NIL)) - (for X in (OPENWINDOWS) bind POSS.TOBJ POSS.FILENAME - when (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil TEDIT.TEXT.OBJECT - do (SETQ POSS.FILENAME (FULLNAME (fetch (TEXTOBJ TXTFILE) of POSS.TOBJ))) - (if (EQ FILE POSS.FILENAME) - then (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ))) - (RETURN TEDIT.TEXT.OBJECT]) - -(IMCOMPARE.HASH - [LAMBDA (STREAM EOF.PTR HASH.TYPE) (* ; "Edited 23-Dec-98 16:58 by rmk:") - - (* reads caracters from STREAM and creates a hash value for the "next" "chunk" - A chunk is a paragraph ending in two consecutive CRs , - a line ending in a CR , or a word ending in any white space - character space . In computing the hash value, white space is - ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR - Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the - beginning of the chunk, the length of the chunk, and the fullname of the stream) - - (* Note%: Most of the time in COMPARETEXT is spent reading in and hashing - chunks, so this function was optimizes for speed, at the expense of length) - - (PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM)) - (EOLC (GETFILEINFO STREAM 'EOL)) - (HASHNUM 0) - FILE.PTR C) - (SETQ FILE.PTR BEGIN.FILE.PTR) - (SELECTQ HASH.TYPE - ((NIL PARA) - - (* Paragraph chunks end with two consecutive EOL's. - In order to detect this without slowing down the gobbling of normal chars, - LAST.EOL.POS is set to the filepos of the last EOL detected. - This is only checked when another EOL comes along.) - - (PROG ((LAST.EOL.POS -5)) - loop - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (SETQ C (BIN STREAM)) - (CR - - (* If this is the second consecutive CR, this is the end of the chunk. - Otherwise, reset LAST.EOL.POS) - - (SELECTQ EOLC - (CR (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM))) - then (GO endchunk) - else (SETQ LAST.EOL.POS (GETFILEPTR STREAM)))) - (CRLF (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SELCHARQ (\PEEKBIN STREAM T) - (LF (SETQ FILE.PTR (ADD1 FILE.PTR)) - (BIN STREAM) - (if (IEQP LAST.EOL.POS (IDIFFERENCE - (GETFILEPTR STREAM) - 2)) - then (GO endchunk) - else (SETQ LAST.EOL.POS (GETFILEPTR STREAM - )))) - NIL)) - NIL)) - (LF [COND - ((EQ EOLC 'LF) - (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM))) - then (GO endchunk) - else (SETQ LAST.EOL.POS (GETFILEPTR STREAM]) - ((SPACE TAB)) - (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) - 1 16) - 1 16) - 1 16))) - (GO loop))) - (LINE (* Line chunks end on a single CR.) - (PROG NIL - loop - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (SETQ C (BIN STREAM)) - (CR (SELECTQ EOLC - (CR (GO endchunk)) - (LF) - (CRLF (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SELCHARQ (\PEEKBIN STREAM T) - (LF (SETQ FILE.PTR (ADD1 FILE.PTR)) - (BIN STREAM) - (GO endchunk)) - NIL)) - (SHOULDNT))) - (LF (AND (EQ EOLC 'LF) - (GO endchunk))) - ((SPACE TAB)) - (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) - 1 16) - 1 16) - 1 16))) - (GO loop))) - (WORD (* word chunks end on any white - space) - (PROG NIL - loop - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (SETQ C (BIN STREAM)) - ((CR SPACE TAB LF) - (GO endchunk)) - (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C) - 1 16) - 1 16) - 1 16))) - (GO loop))) - (HELP (CONCAT "Unrecognize HASHTYPE " HASH.TYPE) - " - Should be PARA, LINE, or WORD")) - endchunk - (* flush all white space before next - chunk) - (if (IGEQ FILE.PTR EOF.PTR) - then (GO return)) - (SETQ FILE.PTR (ADD1 FILE.PTR)) - (SELCHARQ (BIN STREAM) - ((CR SPACE TAB LF) - (GO endchunk)) - (PROGN (SETQ FILE.PTR (SUB1 FILE.PTR)) - (SETFILEPTR STREAM FILE.PTR))) - return - (RETURN (create IMCOMPARE.CHUNK - HASHVALUE _ HASHNUM - FILEPTR _ BEGIN.FILE.PTR - CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR) - FILENAME _ (FULLNAME STREAM]) - -(IMCOMPARE.LEFTBUTTONFN - [LAMBDA (GNODE WINDOW) (* mjs " 2-Apr-85 14:21") - (if GNODE - then (IMCOMPARE.BOXNODE GNODE WINDOW) - (PROG ((NODEID (fetch (GRAPHNODE NODEID) of GNODE)) - (FILEPTR 1) - (CHUNKLENGTH 0) - (TEDIT.TEXT.OBJECT NIL) - FILE) - (SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID)) - (SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID)) - (SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID)) - (SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE)) - (if TEDIT.TEXT.OBJECT - then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25)) - 0 - 'LEFT) - (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT) - (TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT) - (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT) - (TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of - - TEDIT.TEXT.OBJECT - )) - 'PROCESS)) - else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH]) - -(IMCOMPARE.LENGTHEN.ATOM - [LAMBDA (X MIN.LENGTH EXTENDER) (* mjs "30-Dec-83 15:11") - - (* makes sure that the atom X is at least MIN.LENGTH characters long, by - concatinating the first character of EXTENDER - (or space, if not given) to the front) - - (PROG ((C (CHCON X))) - (SETQ EXTENDER (if EXTENDER - then (CHCON1 EXTENDER) - else (CHARCODE SPACE))) - (while (ILESSP (LENGTH C) - MIN.LENGTH) do (SETQ C (CONS EXTENDER C))) - (RETURN (PACKC C]) - -(IMCOMPARE.MERGE.CONNECTED.CHUNKS - [LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35") - (while NEW.CHUNK.LIST bind NEW.CHUNK OLD.CHUNK.PTR - do (SETQ NEW.CHUNK (CAR NEW.CHUNK.LIST)) - (SETQ OLD.CHUNK.PTR (fetch (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK)) - (if [OR (NULL (CDR NEW.CHUNK.LIST)) - (NULL OLD.CHUNK.PTR) - (NULL (CDR OLD.CHUNK.PTR)) - (NOT (EQP (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR NEW.CHUNK.LIST - )) - (fetch (IMCOMPARE.CHUNK HASHVALUE) of (CADR OLD.CHUNK.PTR] - then (SETQ NEW.CHUNK.LIST (CDR NEW.CHUNK.LIST)) - else - - (* next chunks have same hash, so "murge" them into current chunks by adding - their chunk lengths to the current chunks, and splicing out the next chunks) - - [replace (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK - with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NEW.CHUNK) - (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR - NEW.CHUNK.LIST - ] - [replace (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR OLD.CHUNK.PTR) - with (IPLUS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CAR - OLD.CHUNK.PTR - )) - (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of (CADR - OLD.CHUNK.PTR - ] - [if BACKWARDS.FLG - then (* if the list is backwards, copy - next fileptr) - (replace (IMCOMPARE.CHUNK FILEPTR) of NEW.CHUNK - with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR - NEW.CHUNK.LIST - ))) - (replace (IMCOMPARE.CHUNK FILEPTR) of (CAR OLD.CHUNK.PTR) - with (fetch (IMCOMPARE.CHUNK FILEPTR) of (CADR - OLD.CHUNK.PTR - ] - (* splice chunks out of new and old - list) - (RPLACD NEW.CHUNK.LIST (CDDR NEW.CHUNK.LIST)) - (RPLACD OLD.CHUNK.PTR (CDDR OLD.CHUNK.PTR]) - -(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS - [LAMBDA (CHUNK.LST) (* mjs " 5-JAN-84 13:58") - (while CHUNK.LST bind CHUNK do (SETQ CHUNK (CAR CHUNK.LST)) - (if (OR (NULL (CDR CHUNK.LST)) - (fetch (IMCOMPARE.CHUNK OTHERCHUNK) - of CHUNK) - (fetch (IMCOMPARE.CHUNK OTHERCHUNK) - of (CADR CHUNK.LST))) - then (SETQ CHUNK.LST (CDR CHUNK.LST)) - else (* both current chunk and next chunk - have no OTHERCHUNK, so merge them) - [replace (IMCOMPARE.CHUNK CHUNKLENGTH) - of CHUNK - with (IPLUS (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of CHUNK) - (fetch (IMCOMPARE.CHUNK - CHUNKLENGTH) - of (CADR CHUNK.LST] - (* splice chunks out of new and old - list) - (RPLACD CHUNK.LST (CDDR CHUNK.LST]) - -(IMCOMPARE.MIDDLEBUTTONFN - [LAMBDA (GNODE WINDOW) (* mjs " 6-Jan-84 11:37") - - (* This function is called if the MIDDLE mouse button is pressed over a graph - node. The selected node is IMCOMPARE-ed with the last node selected . The type of hashing used is selected from a - pop-up menu. If none of the hashing types is selected, the current node is - boxed. The pop-up menu is always located a little above the current cursor - position, so a quick double-MIDDLE-click is an easy way to change the current - boxed node.) - - (if GNODE - then (PROG (INNER.HASH.TYPE) - (CLRPROMPT) - (printout PROMPTWINDOW "Please select the type of hashing you wish." T) - [SETQ INNER.HASH.TYPE - (MENU (if (type? MENU IMCOMPARE.HASH.TYPE.MENU) - then IMCOMPARE.HASH.TYPE.MENU - else (SETQ IMCOMPARE.HASH.TYPE.MENU - (create MENU - ITEMS _ '(PARA LINE WORD) - MENUOFFSET _ - (create POSITION - XCOORD _ 20 - YCOORD _ -20] - (if (NULL INNER.HASH.TYPE) - then (* if no hash type is selected, just - box the current node and return) - (IMCOMPARE.BOXNODE GNODE WINDOW) - (RETURN)) - (if (NULL IMCOMPARE.LAST.NODE) - then (CLRPROMPT) - (PRIN1 "You must select another graph node first." PROMPTWINDOW) - (RETURN)) - (printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T) - (IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE - ) - (fetch (GRAPHNODE NODEID) of GNODE) - INNER.HASH.TYPE - (WINDOWPROP WINDOW 'REGION]) - -(IMCOMPARE.SHOW.DIST - [LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13") - (PROG ((WINDOW (CREATEW)) - MAX.Y X MAX.X) - (SETQ MAX.X (WINDOWPROP WINDOW 'WIDTH)) - (SETQ MAX.Y (WINDOWPROP WINDOW 'HEIGHT)) - (for SAMPLE in LST do (SETQ X (FTIMES MAX.X (FQUOTIENT SAMPLE MAX))) - (DRAWLINE X 0 X MAX.Y 1 'PAINT WINDOW]) - -(IMCOMPARE.UPDATE.SYMBOL.TABLE - [LAMBDA (CHUNK.LIST CHUNK.SYMBOL.TABLE OLD.CHUNK.FLG) (* mjs " 8-Jan-84 21:01") - - (* * update the chunk symbol table. For each hash value, this table records the - number of "new" chunks with that hash value, the number of "old" chunks with - that value, and a pointer to the place in OLD.CHUNK.LIST .) - - (for CHUNK.PTR on CHUNK.LIST bind CHUNK SYMB - do (SETQ CHUNK (CAR CHUNK.PTR)) - (SETQ SYMB (if (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK) - CHUNK.SYMBOL.TABLE) - else (PUTHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of CHUNK) - (create IMCOMPARE.SYMB - NEWCOUNT _ 0 - OLDCOUNT _ 0 - OLDPTR _ NIL) - CHUNK.SYMBOL.TABLE))) - (if OLD.CHUNK.FLG - then (* increment old-chunk count) - (replace (IMCOMPARE.SYMB OLDCOUNT) of SYMB - with (ADD1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB))) - - (* smash old-chunk pointer. Note that it must point to the LIST of old-chunks, - rather than to the individual one) - - (replace (IMCOMPARE.SYMB OLDPTR) of SYMB with CHUNK.PTR) - else (* increment new-chunk count) - (replace (IMCOMPARE.SYMB NEWCOUNT) of SYMB - with (ADD1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB]) -) - -(MOVD 'COMPARETEXT 'IMCOMPARE) - -(RPAQQ IMCOMPARE.LAST.NODE NIL) - -(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW NIL) - -(RPAQQ IMCOMPARE.HASH.TYPE.MENU NIL) -(DECLARE%: EVAL@COMPILE - -(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK) - FILEPTR _ 1 CHUNKLENGTH _ 0) - -(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR)) -) - -(FILESLOAD GRAPHER) -(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1365 39345 (COMPARETEXT 1375 . 3770) (IMCOMPARE.BOXNODE 3772 . 4288) (IMCOMPARE.CHUNKS -4290 . 8476) (IMCOMPARE.COLLECT.HASH.CHUNKS 8478 . 9707) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9709 - . 18575) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18577 . 19340) (IMCOMPARE.HASH 19342 . 26603) ( -IMCOMPARE.LEFTBUTTONFN 26605 . 28341) (IMCOMPARE.LENGTHEN.ATOM 28343 . 28981) ( -IMCOMPARE.MERGE.CONNECTED.CHUNKS 28983 . 32479) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32481 . 34436) ( -IMCOMPARE.MIDDLEBUTTONFN 34438 . 37010) (IMCOMPARE.SHOW.DIST 37012 . 37458) ( -IMCOMPARE.UPDATE.SYMBOL.TABLE 37460 . 39343))))) -STOP diff --git a/obsolete/sources/MAPATOMS.~2~ b/obsolete/sources/MAPATOMS.~2~ deleted file mode 100644 index 299f47a3..00000000 --- a/obsolete/sources/MAPATOMS.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/obsolete/sunloadup/FASTINIT.DFASL.~2~ b/obsolete/sunloadup/FASTINIT.DFASL.~2~ deleted file mode 100644 index d58457d7027dca55ab59272e87657a72d33dd7b6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1430 zcma)5-)q}e6qaPyiI-;BqqG}i^u~jZrIBpeb=oAwM7HEksUitWZo0A;)xN2<+LFqOx-aK zkRM0WI70h=fI>eG1{m!_9=(vQhcE9B-SD~C8oS|i;0L%N)LK?w*9=MSo2{;7*{ZJE z!j`yfU8o!c*op8E?ct$^!=ZDqhQxblCmtUlabu$ftHx%%wpnWk%g{nQgPRpuP80`O zP5lnqalF_Gva)+n*4(_azS*b?%cp;)$K2OG1J|?pV~IxPGMlA~bWvhBHa$u{?W&s6 z=_!(}$ePjNnDlj0TD5FRm!+P}tGd~@SJR{jcP&MiSf!RXu2vH)RGR(ncT%zd67=4l3a$hOqh zlr+h~IY4T`lsXTk2aqVLx~=py)iT*MDZJ3*@%SYJTA7s(GBbIZ*0))B<4kFql*Pk7DE9?HXld@#0M5MiXjj=iYmY;^ImE~bk)qk?7P1suT0=jN+`$N7u=h;_ z(tSj6g?YP+98x zT6%Z|H0Qdy1+N7<6CeO#HXaD~W-(<1aglDJ@!k@QJ^h_alh5kwJouR3s3B3L25zn& zC6(;&s*d~#u6lSH#U8HyI1H<^slzYDydgK!<2>4a$4J}%FwB2tj#anE`A_JnzW?hx z^+Y{+H?ugW*TB|CNxm&v3PTT&)xo^*lE_W)F-L8X-LI44EyJXCmNc?PZc|InUH6JD zL(SD69w;_#)Kwpw0QQC;Ai{4KC^BV}1#?Q->LRbdGgjnVjv=cIOKyV+*9f}Eg76fY zR9~@(h`BESvmo_)()Z>PX>z1VAy?AlD~(G-swYp{*O<3$`p2IGb5#AKIsQtHVRGkF l$e-iioiiZK56Bfju3Z|r{qIMxTOI5rk=SlYm0up( zJt@1l%{RNoXk1i>O>y5I8oQ>lqV~a3UX?9+x-D9}r+P!;(Kh9Mad|#|`*x(IxxU6F zaTZ4MQr;Sh&>43V!?=3)?)^N~W+Id~4~_IpuH<_fUFWHhGi-Gy3OY-_rfo7S)~(JE%SCCk6$Cm->=o0p$`ICcexh zeiB0&lzF;|?PuviNI-6v|TZoyYKyckZcsIDk58SQH*TC`64!;YRxh;nCXQ|w#YoVb3fGxD=M!`|b0 zY&j=NXTydbY-2C@=qC#cR&JPl7Piw1_GL`*zLQpzN~LO|^2CI(BrlGH3e6lCO8n5k z{gZhp6(eZHlXIcx)GP1AfUl0SnFnCnxw*2I{d@OJMfKc?>o9OaNnZwm{6Ta%5 zX``fwHD8Nnn9N*j6;IQMTV|C3qdY0EVg49M?K-i@GO65DCd@n$on8*SD?Ld2o&Zrc zQ;*Ka;+dV%BeU4RB^@kxby>CNSdD*-rdKG$ot+BwgC!>-Fi^`~uvDEy!`0^wZ`2&B zwtTd-KkOKWw5c2N>c>Z*B`Wtjm~Ks@);?mgXv*#LnAZ00@a4-%tY`z628q);zR?^O zD(ycazok4`B1F2;PL9`lbSAv@BJX=N^j3~0PP>ykMUcW@5^$lV`^}UzW<|bso`iKM zk;`M7S7$0^caY9x6uFk04iXpqtcD+l+9N+ypsiG`zFW!5v&D>*)M>6fd9*6vN7Lul zvJrP+oQ6hzB(e))ni~T2;>eC;I_!Z_5DwhVQN&DKgOSNO|1IGU)_6H>2;aK0KsN5V zAMPnZ)?GM1)y-F&^Q*7v>ZcD^S08@<1kC>rXy&0daEYIGdXc{jV_KRZyanz-I&L5g z5OUn(2JDckKGa@$ZYIJ+gQXC?sY-JLHYA~D*l9@UMXseHaCYyNAykk%gzAmwuJ38p z8z^&Oo62r~K;$3AFvp#d8ONWWdi=rJ+OY{TRp17c^!baB_Gu}i1%%>l@;YGZ9y)RA zJGC*BDnq~yLO=IF2XVxR2vctL&g7;qhXp-Ec`!&-EZiQM+=MDkVonQ~V9U7$Xt;ra z^pr^41n$p~`cC3}04>gux6&j2nXoyr7l4)1d^Uq3VK2x;n>+}*aSn@d z7aa*~-m#+S*jf01MI=@U8d7t`<4a?L{Z=AKOv|cVKz&blmR(rNy30U z<`O92-E@09lWB|(A}xaatSci7k%%6S45xjfP-4|jq{D=e-rALaOWzC!|)h|%$H#W-bS9^eIJ|{LV1Nmd#LW) zvaa^0(h!*92cj5wqLUA~;^T+Ee?TdR(EbI*+oNNOO;bO*a_yzofj<_0#C4OO-k>bW za)X$}uj}*d&~OgqMIF_lA*EW$OTww2uFFK`9D;RyiTrZXr|HW$l=I6 zi5ov}q3$aS3kW}9ae#HgEx3UO^W zWrf7_^k6GOszK#&3d4|hxaTy3g>e>zUT7u@xth3A&WlowSHZ+%0yt_Zwy4wB&t$9O zZfn;Uba!YwAzi_;DSwB`Tu}3eE7~WdPu6J=w132KUSzxWCGCdiaP^0D#Zs7{ytq4*+cgY>2SZK8x4K07Zt4T%fT`LC;$oZah6;+= zK_)mEr)<}jB|%<>``CVWF#QEp^%I6nP3x{Mzu*%3q4;L`^gXtsM(1PVqWlWC^rB84 zz%yI-s=>p=5r7M!%Q(I9^(FpT_U4*MlqIR+%ck9t zGCR|JGb@aSd9`2XkL|uOD=I2#H-@sRXwggCyfr(j*Cd`yQ#|I^=NE5BxFx9b)sFUC zDvRBg)^$UnS(WBMAFn^q-!O4S&qceTe~c$fEr(O{=5d2_?Nxlz+fgd@?JdL&6F-pG z@?KMb4({NIVO+g?cR7nwJr>HD`C2+UQ}U8Vw^@v{NALPe-hH%}U0e*?(`D-6*pxi-68iUk*V1EY@`^3S2J9yW1%wm3l0pIHBI!r2OeB6HO$n6l*0NGo z7PD*f2N-=re91O{{F;9;WPab)4ZO;798TO2_-QgugfkaYNuEf9W5*qfG?n48-@8H$ z1ILR2kBaJwJe|<4hN5|EwFd^C3yAVyXr1p`)10_|k|yLPS%SUC^Vo7$l+K0?ZA@dX z_~>T?3s!cRTo$&|3-)Ck@xGH*luE^Ftg=Y^p(G~^g!1(a7>Zn9!~Nr#FBKzb$&)jY z&Zt-3iUD68Wz!o(hjnvh4Ey)tKzViO#I+bWp`2;aIgKsN4q9PTMV`&~Fc*UeX) z^Q)WE&4>3lH}8M`1kC>rXl8z@;Sx9Q^dfiRhqTb1e-GS)bnJldA>_En4cH-8eW<K_sL zXEDrir)9$N=f)0yaCU0h1PRHr14_F5MM%4}5WyTm@iuwuF?A1}Fm|oln2D7pU;g3Gz(9IRM0NuAXGnb~ zaXx?+=g52M5dVzXoY)J%%1JhzLJ_|gWSr{E^SW^ki<4&x*R_0mauOFE32fG}qUhLJ zxPV0kG8ZRgTa`b|P26@aRP{6zC{(dUs z5FbQZ0Qp&0Mi?RyJsjyz`b43`vY&{RB>)^JmB&y70r=5LttNoLd<>h7wZh7iYe1WB z7A72jY+n#q$V-zx9`W1NF7FWk%u(xSYs3FnrtH-vetKF$I1g7|b zCo1C`*z|BPQ`{`#d`| ztOI#bM|EgOJ%gS+@a3f5i4;_ z_2)K_x+-qF-=RuDMF!sQvD+oZ6PS3}b_7APN4W@cwME6Yskf$S3ws`@+GcD{8AqUX z^`0O6l7>R*fs|3E{k^3PiqLDC8?)`|j1pxa*Ky{XX$~leQ8y12;>xUx3W@1?V=6+b zLFI4?!;p8l=QM-)VG{U`ug7z_9NSXP3E~v5g0aH{aMV(isMA*mGFARin$;CO?AuOA zTd=H)-=Q)W)coO!_8IAubs7ZipF^A%*{*#FJ(iJ}1hOy5Ib9nBF|tg{N>}Z=qUU^v zH$oR&{UKekH% z4EM499$@+_s_JJ9>6%tuU5>XG3W5Ba;nR26iW;4d3G?DB+|r9W-hgLH`>Mgi#1eoF zq3bZdbJJ`5vBsafF*ojpho=>W?Q4arD*A{~Rtpt=An#;wgFYWJywE<|sKiX9y=Z)K za+n`&c2DF7Cl`!)#pfvHi@5dung4eNlmfu&Yr6q1OLd&QJ>$Q>oV_`_JDZJ=oJAIB zTm9Y8XbRN?svZd1HGf76bP)QH2#7oUF5~o(=$9oI7iT}&Q|-@RFZuK4>TOI5rk=SlYm0up( zJt@1l%{RNoXk1i>O>y5I8oQ>lqV~a3UX?9+x-D9}r+P!;(Kh9Mad|#|`*x(IxxU6F zaTZ4MQr;Sh&>43V!?=3)?)^N~W+Id~4~_IpuH<_fUFWHhGi-Gy3OY-_rfo7S)~(JE%SCCk6$Cm->=o0p$`ICcexh zeiB0&lzF;|?PuviNI-6v|TZoyYKyckZcsIDk58SQH*TC`64!;YRxh;nCXQ|w#YoVb3fGxD=M!`|b0 zY&j=NXTydbY-2C@=qC#cR&JPl7Piw1_GL`*zLQpzN~LO|^2CI(BrlGH3e6lCO8n5k z{gZhp6(eZHlXIcx)GP1AfUl0SnFnCnxw*2I{d@OJMfKc?>o9OaNnZwm{6Ta%5 zX``fwHD8Nnn9N*j6;IQMTV|C3qdY0EVg49M?K-i@GO65DCd@n$on8*SD?Ld2o&Zrc zQ;*Ka;+dV%BeU4RB^@kxby>CNSdD*-rdKG$ot+BwgC!>-Fi^`~uvDEy!`0^wZ`2&B zwtTd-KkOKWw5c2N>c>Z*B`Wtjm~Ks@);?mgXv*#LnAZ00@a4-%tY`z628q);zR?^O zD(ycazok4`B1F2;PL9`lbSAv@BJX=N^j3~0PP>ykMUcW@5^$lV`^}UzW<|bso`iKM zk;`M7S7$0^caY9x6uFk04iXpqtcD+l+9N+ypsiG`zFW!5v&D>*)M>6fd9*6vN7Lul zvJrP+oQ6hzB(e))ni~T2;>eC;I_!Z_5DwhVQN&DKgOSNO|1IGU)_6H>2;aK0KsN5V zAMPnZ)?GM1)y-F&^Q*7v>ZcD^S08@<1kC>rXy&0daEYIGdXc{jV_KRZyanz-I&L5g z5OUn(2JDckKGa@$ZYIJ+gQXC?sY-JLHYA~D*l9@UMXseHaCYyNAykk%gzAmwuJ38p z8z^&Oo62r~K;$3AFvp#d8ONWWdi=rJ+OY{TRp17c^!baB_Gu}i1%%>l@;YGZ9y)RA zJGC*BDnq~yLO=IF2XVxR2vctL&g7;qhXp-Ec`!&-EZiQM+=MDkVonQ~V9U7$Xt;ra z^pr^41n$p~`cC3}04>gux6&j2nXoyr7l4)1d^Uq3VK2x;n>+}*aSn@d z7aa*~-m#+S*jf01MI=@U8d7t`<4a?L{Z=AKOv|cVKz&blmR(rNy30U z<`O92-E@09lWB|(A}xaatSci7k%%6S45xjfP-4|jq{D=e-rALaOWzC!|)h|%$H#W-bS9^eIJ|{LV1Nmd#LW) zvaa^0(h!*92cj5wqLUA~;^T+Ee?TdR(EbI*+oNNOO;bO*a_yzofj<_0#C4OO-k>bW za)X$}uj}*d&~OgqMIF_lA*EW$OTww2uFFK`9D;RyiTrZXr|HW$l=I6 zi5ov}q3$aS3kW}9ae#HgEx3UO^W zWrf7_^k6GOszK#&3d4|hxaTy3g>e>zUT7u@xth3A&WlowSHZ+%0yt_Zwy4wB&t$9O zZfn;Uba!YwAzi_;DSwB`Tu}3eE7~WdPu6J=w132KUSzxWCGCdiaP^0D#Zs7{ytq4*+cgY>2SZK8x4K07Zt4T%fT`LC;$oZah6;+= zK_)mEr)<}jB|%<>``CVWF#QEp^%I6nP3x{Mzu*%3q4;L`^gXtsM(1PVqWlWC^rB84 zz%yI-s=>p=5r7M!%Q(I9^(FpT9#hH>@o-TQf}%|s|~9vbPHT*>z|y3SK0Y4q;nWV$kPJRY{`l@4&6 zrcs`RX+qO9HBl;j>374!JT~+fy;{NJFu3*n2#Qe%tl_L;VIv4&Q* zXtt$oE}&_-r+Z9MTNB@vXY{YbzNP!EEvh{oc2IZJPYi+!FZCtG0!k$^OnjM1{3M1l zDBG=NrJO8w-xhbauFju^RsvO|MXhJ3AHV2TM*wV4#+}V5vHZhO5sV-l#cLZTVM2K{wogA*e z2gYe==RmFH$6Of*;u(VMC?H()~&YKEPLgkI!YDgtNsUKv6KIYX%4c<%b1R=t5T z7q+SF_6J1%SqyXB8JThX`KiYroUI+3AVURiKuMp!2x*^|B3eKw-X^aDrtYB=r@m7g zGpRBJ>>%`W4|EVmjEFGhR_{!1`f^y%LzD-DRK>#Wk;zS{(j?}zfC;voTY!ce7)Vcv z#7*G-9I5Xl&Ii!q9C<4};-3kd6MF$zIn8G?C=&L9Oti^^pd06~IC-Y_#o0E$j`bm!Vrn*;mB~>CkiE2{Y0u90pK{P0)`?8AWTkbH3b9~6WDBG z6jq*G1KRZSIOF(Z3v+d&NccCQehGK3jyMdDQOJB5R^V;q`Q7)yi6N9#NVJFQzAfu& ze<}@uDSjY|fhRiokSjiZ_{Rs7a0u;RP_#Wdrr0#~qbt*1Y907v;YVCI`RNVHk}Nlf zN&LD#&khaeKwi{Q9U9Wip(hUoQJQ5d`sbZRR z$l+xx_;@jZZ|Yux5Xk{q}|0)1mZOaT*VVQLqLOJk^TwZ?~}3w0F&7~1*>2b z2;sau7s}^K7chbUoir5s>@x=2k^&{A!>9h!K!9+R2b%vw)yV7QnucZ?osJxi+>_X0 z%%Boh;+X2sT_AN;-0rYPm4b>4yx(KDONu8j@v`j*g6x2D5#;KMid|FhY}1zRJW#dE z*qkzsKARaMnR0ad8iQAc2ibJ zOivHCBBUBr4yP~-d53#WGgugBQRszcvXHBZE9JZ>)p!j|JSKpnmST%Kef>`QV^*A_vHEYq^m zRlBL^so3L<&;?h2NLMU{3CfGRL%ChUFnBQ3RD7#Tr0=FaKn|FyeIPEj*>0$ym>pz- zlX1#+ZCMiJWw?*+cL&p7P*p!+$kep%>hcRNp&yEGmQUYfD{6E;CN9daa7!=hjrnOeJUp#1>|QHeRnbR`vRbI{BY7jEEA;u0;br#O zMI~ku6C{)I$zgu9xjji3om?>C6`vE$7jf(RGym@lC@GrcIi?J>$Q>oV_`_ zIh&7=oJAfPSN&blXa>~;svZd1HGf76bP$J$h=@D9#hH>@o-TQf}%|s|~9vbPHT*>z|y3SK0Y4q;nWV$kPJRY{`l@4&6 zrcs`RX+qO9HBl;j>374!JT~+fy;{NJFu3*n2#Qe%tl_L;VIv4&Q* zXtt$oE}&_-r+Z9MTNB@vXY{YbzNP!EEvh{oc2IZJPYi+!FZCtG0!k$^OnjM1{3M1l zDBG=NrJO8w-xhbauFju^RsvO|MXhJ3AHV2TM*wV4#+}V5vHZhO5sV-l#cLZTVM2K{wogA*e z2gYe==RmFH$6Of*;u(VMC?H()~&YKEPLgkI!YDgtNsUKv6KIYX%4c<%b1R=t5T z7q+SF_6J1%SqyXB8JThX`KiYroUI+3AVURiKuMp!2x*^|B3eKw-X^aDrtYB=r@m7g zGpRBJ>>%`W4|EVmjEFGhR_{!1`f^y%LzD-DRK>#Wk;zS{(j?}zfC;voTY!ce7)Vcv z#7*G-9I5Xl&Ii!q9C<4};-3kd6MF$zIn8G?C=&L9Oti^^pd06~IC-Y_#o0E$j`bm!Vrn*;mB~>CkiE2{Y0u90pK{P0)`?8AWTkbH3b9~6WDBG z6jq*G1KRZSIOF(Z3v+d&NccCQehGK3jyMdDQOJB5R^V;q`Q7)yi6N9#NVJFQzAfu& ze<}@uDSjY|fhRiokSjiZ_{Rs7a0u;RP_#Wdrr0#~qbt*1Y907v;YVCI`RNVHk}Nlf zN&LD#&khaeKwi{Q9U9Wip(hUoQJQ5d`sbZRR z$l+xx_;@jZZ|Yux5Xk{q}|0)1mZOaT*VVQLqLOJk^TwZ?~}3w0F&7~1*>2b z2;sau7s}^K7chbUoir5s>@x=2k^&{A!>9h!K!9+R2b%vw)yV7QnucZ?osJxi+>_X0 z%%Boh;+X2sT_AN;-0rYPm4b>4yx(KDONu8j@v`j*g6x2D5#;KMid|FhY}1zRJW#dE z*qkzsKARaMnR0ad8iQAc2ibJ zOivHCBBUBr4yP~-d53#WGgugBQRszcvXHBZE9JZ>)p!j|JSKpnmST%Kef>`QV^*A_vHEYq^m zRlBL^so3L<&;?h2NLMU{3CfGRL%ChUFnBQ3RD7#Tr0=FaKn|FyeIPEj*>0$ym>pz- zlX1#+ZCMiJWw?*+cL&p7P*p!+$kep%>hcRNp&yEGmQUYfD{6E;CN9daa7!=hjrnOeJUp#1>|QHeRnbR`vRbI{BY7jEEA;u0;br#O zMI~ku6C{)I$zgu9xjji3om?>C6`vE$7jf(RGym@lC@GrcIi?J>$Q>oV_`_ zIh&7=oJAfPSN&blXa>~;svZd1HGf76bP$J$h=@DhZe&uRsCYD= zwqG}=nxvd~H0vN@-@7iSPE`-C=#mD`keoPKDt|iDbo24!4c(dYV6KV8c1x=G{MhVC znZ2pMnl(nlygY33hvrb5H5DZ_kA||cXwXZWyfJ&KHYA=*T|DI1m&3Pj2dUJzx40xs z{6JpIdrbj4Jaa`}Rnt%7)v+Og)I0(jbfcIHE}$ z>mU}cblc&69viwHuU51=U2dxFwt6ng&$KDFFi2h-s!hJ#9%)C6GLiU+G$pW4yOxz=`(B!T zldoW@yYwnT2U$$tFg)=?T3<_Fc8YuGk_>^eGT`IXTDSnwk1!_L^`8R zc`F8db&^d#B0j8}OJmr-t0U#*u@%>1;Ea;4^gQ{U0EzP9L?=kKk|Ip`S~UG=YFo>2 z5(nJU%LEwZNqGzNhd^rE2}P1fWv3FMXOU?2vfy2&y|h;ZSg@HobUx)rc1DNHd;^!X zu-sJ$yi2UcKSt9l6ynZS1^UjCW8rD2WiME$R-*puON%$E4`ow48QLFq3`5$01f1&W z31|t5{SKyE)1Wa=n9S>9dmPf*tPY<)pT$b50aGusT8DQjhlPr}kI3#RixvoxcC?k_ zwH~br@14N;77d-1gR#}_>`vju@RtN!XkmX7CAD6Xn_5r8Iuyypsm-es6|*}iO=J+* zmYwz@8~m(>8~Uk3uCKswv08q!l9wm*DJhx8nR4XGs(>F&m_lL19T=ykfg6ZqM9iLj zfR0Y|IHbcK7zN?L?HonS>J`|Xtn=Rz{$P!l)B5nON&{r$o`?RP0>s~j^K(^y!8yOW zDc$_|{^sWW&mV#Lzkp`ury4GC<5n+n7k)?!?fLh>JxIq6_#Q%zd)$B>V%3G(E6+`Z zAEjU^L~pF(OoI(cs3~@866rikrD9I+ywZmX@{mxS@$B^-tvWqr&P`pK?RSX$yBOxU z(=y@sb7O};I6Jj$f~@D+0VQ4jBBWhfh+qz(c$>WSn7aE;7`s+&%*09)u!GRg9MC}+ zFe3bzTb(nx>B@dV2T>mMVigLzM@DzPildOz0w&mUb^#i8peH>gB0GWmGo-$=IPXD= zbL72rh=0axPV5C>sr1&JBf=<1U73~QMBwVT)-j_ zOPU3J3o2&BF&;1C$*)~21qlQ}*Xce!s2yQ8jTe*vIeI}tgFI#uDB#_6e?OIRhz}wy zfc&g0BMgy<9**=UU7}E8*-gaC5&({q%3~;k0Q~5zRue#AK8DT4T4CkcHK0v53lok% zwlG&riiCUTr!V2o6&Hu$DGHe{{Sv&5Jiq%kI5C7$4T<(pJ~TyD?$4zmFvWL7(ep$r zA9BTq_y2y6vJj#D3kty}%M_csda@=h?nt9mtDX zszXES8T8~KFNl+5N&i_HWCa6vIl}VfZzJlb+7x9ij?hli-`XoZE_d?8@e;)!CVuG?Uq#WxM}vJ z%-+;r%?hJoULMx@LvyIjii(n&jiIb88uZd8Z_J*mHHjxv7Z3UMK`Qm_EiMTY zKakh*UQ>V$&p-gLs_CcE^4J*KANSRv*MbkLdBcYtB zucf0iC23pio6{}*CF9irP~ho^Vrbsc(tO_YF%x&)pJok(z@8fBzbM9Hu-jYq-~Y2U@Mc?+rrdWP^;L} z1EvT%@?BX%|78O_Y)xM7>9B)(gKnbNKsd20DHJe7B>l*hiNsH&DS?67wXBr2u-P~H z5@y;EU$V;|zT}UF%bN73rZPPBJIAVi;B+w{ zQc_itrxV(<|MJFaf7sD;0a2EQ*7?3M^_lC(X+mz2CD?m9k1c0KX>C~3#?lQnsZ^{+DvPuqN^-(LC|^$jqR90%+&`N7QZd>VJUJEVlse_D z81U6eHoZZFST~o(uz#0F%FAObuEoF^C0*%x@;d<%<->_ikZL7GnDVt~`q9L;7U4J! zxTO~fFv^qi7UmCu)V33fB$3KaB|=Xl(duQvyGVO!-xCKO%+#UtDL=9^I%MW+xTJ;U zu0rHpVm1CTnqHw0ceX0fca|IpPeUzx!CbWx^;ch7yit89o8rmP{;*>h(i$w_R8LPp zOHk~0Fx`pTK!iYOCPE7+h5XluWef9x* zb)v^19rnN|2nTNGC}Li(!0%+8|CaCvYrLG+hi_FHARG5Q^!F5?{x+PStNIJh`PEJ7 z=En~=Hy?if1kC>hG*ds-aETkYdXYQ#Lz-*PzX$F?I(ESK5OUn(2J8^4F4SImZX*0B z1xq1%V-;r_Y)C>)uv3#rXIUy0b9(2MK2(s2gzAiEukUEp=_zw&>e6h#L*(DZFvp#i z3CEusJN&`fsbv%7JGBsL?b2KXGYG}ooq(ANwg%XQyB370FaGX>gLlFevM`yJf0|K)VY&OygE6=V0ZMs>QaQv}_ zxn@!%+&e#g33sl!I1Eow$b9LS;BDmj-M7JsArxy!w1@JcDXMaRE)9Vxz9WjBCtCTC zD?Wbs_XiY)2<=}`3O-q;Sl88)t;t?$9r$DB23$9}@g2&NB-4mV{MtUx_6_SmUer<@ z8d6W8Cl7f+oFohS&(a_(7`V$3mM4F^qJFAPQP$!J?KJ(ZEi_+|!^>9i@vH~S&5z;O zRsJ1r3xz+6+lzw$#H$gwiYL+p0S$&l`X_k5OUe=ej3(0g!A%LD3|MJzy$uc z(va`6&lqfT@|2VopXuKQ0)(T?OZh)k4V+f4v9HI$`N-kOJ&PU24C-qoPO1LV22xwa z?GAfXDX7T6`yF=Mq<97sFWXKaNKl(Ix!R&)S64ezH-$Y9RBbahr;HQO+Ir6qen~^2 zbWh4C(|%}ZgCg{rX2$H=I%A76kn1?})zn86#HgG53UOuDMTx}pyfGyq)u3`XhhfOu z-*cY9{4fc8$Je8oT#Rff=LB(z7sSY60yt?Ywy4urM>1u;+?v%DE%6SqHM%WW*2V8o znG0(Ea7Fu!^vOE)f_6_L&Wmi5+{gA? z!t_^ER?isH6|LI3{EAEHP5#yJ>3eKNjn2n}dGQ5q=|mlEz%yI>s=>p=5`Yb%>oC4^ z(`)>(#-H0UH*Safrxk|nYlW*S`iN0h3l)AK?__X;J|EIQ(LUR##7v~UXf!-K%#Sv^ zC-Q@{3r4)+bCmK$-1_#+|2qRp0bupD-2j)RI!@kR@ZUc!-dx;WOb1BLA`7&w{%&Y6 yfocL(4+L$SKcfXY2>nO|#2tQ@ar#K~%aY;n;-B_Z`}41B{=B)kK;z9H|N9f9X=LL7 diff --git a/obsolete/sunloadup/LOADUP.LISP.~6~ b/obsolete/sunloadup/LOADUP.LISP.~6~ deleted file mode 100644 index b9778e05..00000000 --- a/obsolete/sunloadup/LOADUP.LISP.~6~ +++ /dev/null @@ -1,96 +0,0 @@ -(* " (C) COPYRIGHT 1991 Venue. All Rights Reserved. Manufactured in the United States of America.") - -(SETQQ COMPILE.EXT LCOM) - -(* "For 4-byte sysouts, must put 4-BYTE into the HOST-ARCHITECTURE list") - -(SETQ COMPILER*HOST-ARCHITECTURE* (QUOTE ((4-BYTE 3-BYTE))) -(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))) - -(* "3/5/91 JDS: Removed from the following DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY [before LOCALFILE], FLOPPY [after INTERPRESS].") - -(LOADUP (QUOTE ( LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS 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) - -(* "The ethernet eventfn was removed in the early INIT building, to avoid trouble with turning on the ENet in ldeinit. Put it back, now. To do that, we have to set up the Maiko ethernet-handling fns from MAIKO.MOVDS....") -(\MAIKO.DO.MOVDS) -(SETQ \MACHINETYPE 3) -(INITPUPLEVEL1) -(MOVD (QUOTE \ETHEREVENTFN-) (QUOTE \ETHEREVENTFN)) -(MOVD NIL (QUOTE \ETHEREVENTFN-)) -(\NSINIT) -(\ETHEREVENTFN) -(\NSINIT) -(\ETHEREVENTFN) -(RESTART.ETHER) - -STOP diff --git a/obsolete/sunloadup/LOADUP.LISP.~7~ b/obsolete/sunloadup/LOADUP.LISP.~7~ deleted file mode 100644 index 086575b2..00000000 --- a/obsolete/sunloadup/LOADUP.LISP.~7~ +++ /dev/null @@ -1,96 +0,0 @@ -(* " (C) COPYRIGHT 1991 Venue. All Rights Reserved. Manufactured in the United States of America.") - -(SETQQ COMPILE.EXT LCOM) - -(* "For 4-byte sysouts, must put 4-BYTE into the HOST-ARCHITECTURE list") - -(SETQ COMPILER*HOST-ARCHITECTURE* (QUOTE (4-BYTE 3-BYTE))) -(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))) - -(* "3/5/91 JDS: Removed from the following DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY [before LOCALFILE], FLOPPY [after INTERPRESS].") - -(LOADUP (QUOTE ( LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS 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) - -(* "The ethernet eventfn was removed in the early INIT building, to avoid trouble with turning on the ENet in ldeinit. Put it back, now. To do that, we have to set up the Maiko ethernet-handling fns from MAIKO.MOVDS....") -(\MAIKO.DO.MOVDS) -(SETQ \MACHINETYPE 3) -(INITPUPLEVEL1) -(MOVD (QUOTE \ETHEREVENTFN-) (QUOTE \ETHEREVENTFN)) -(MOVD NIL (QUOTE \ETHEREVENTFN-)) -(\NSINIT) -(\ETHEREVENTFN) -(\NSINIT) -(\ETHEREVENTFN) -(RESTART.ETHER) - -STOP diff --git a/obsolete/sunloadup/LOADUP.LOG.~10~ b/obsolete/sunloadup/LOADUP.LOG.~10~ deleted file mode 100644 index 788fb21a..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~10~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;6 File created 30-Mar-2000 20:01:05 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;46 compiled on 10-Apr-2000 00:11:45 File created 10-Apr-2000 00:11:36 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;7| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;5| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************************************************************* [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************** \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~11~ b/obsolete/sunloadup/LOADUP.LOG.~11~ deleted file mode 100644 index 9fca2c6e..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~11~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;7 File created 9-Apr-2000 16:28:23 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;47 compiled on 10-Apr-2000 00:57:58 File created 10-Apr-2000 00:57:39 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;8| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;5| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************************************************************* [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************** \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~12~ b/obsolete/sunloadup/LOADUP.LOG.~12~ deleted file mode 100644 index b6a48079..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~12~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;7 File created 9-Apr-2000 16:28:23 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;48 compiled on 10-Apr-2000 01:45:23 File created 10-Apr-2000 01:45:05 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;8| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;5| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** *********************************************************************** [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************ \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~1~ b/obsolete/sunloadup/LOADUP.LOG.~1~ deleted file mode 100644 index 2b3fc417..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~1~ +++ /dev/null @@ -1,335 +0,0 @@ - -{DSK}disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>FILESETS.;1 -File created 9-Apr-90 16:57:44 -FILESETSCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>library>VMEM.LCOM;1 -compiled on 21-Jan-93 18:50:40 -File created 20-Jan-93 15:04:46 -VMEMCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>MEM.LCOM;3 -compiled on 25-Jan-98 17:45:42 -File created 5-Nov-92 15:57:00 -MEMCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>library>READSYS.LCOM;1 -compiled on 21-Jan-93 13:56:18 -File created 9-Nov-92 03:25:43 -READSYSCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>library>RDSYS.LCOM;14 -compiled on 29-Jan-98 16:34:48 -File created 29-Jan-98 16:34:44 -RDSYSCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>DTDECLARE.LCOM;6 -compiled on 25-Jan-98 12:59:44 -File created 8-Mar-95 10:22:57 -(/DECLAREDATATYPE redefined) -(DECLAREDATATYPE redefined) -(TRANSLATE.DATATYPE redefined) -(\\REUSETO redefined) -(\\TYPEGLOBALVARIABLE redefined) -(TYPE-VARIABLE-FROM-TYPE-NAME redefined) -(|BitFieldMask| redefined) -(|BitFieldShift| redefined) -(|BitFieldShiftedMask| redefined) -(|MakeBitField| redefined) -(|BitFieldWidth| redefined) -(|BitFieldFirst| redefined) -(|optimize-FETCHFIELD| redefined) -(|optimize-FFETCHFIELD| redefined) -(|optimize-REPLACEFIELD| redefined) -(|optimize-FREPLACEFIELD| redefined) -(|optimize-REPLACEFIELDVAL| redefined) -(|optimize-FREPLACEFIELDVAL| redefined) -(|optimize-NCREATE| redefined) -(|optimize-\\DTEST| redefined) -(COMPILEDFETCHFIELD redefined) -(COMPILEDREPLACEFIELD redefined) -(COMPILEDNCREATE redefined) -(TRANSLATE.LOCF redefined) -(|new| COPYRIGHT |property| |for| DTDECLARE) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>RENAMEFNS.LCOM;5 -compiled on 29-Jan-98 15:47:13 -File created 29-Jan-98 15:47:09 - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>MAKEINIT.LCOM;9 -compiled on 25-Jan-98 17:43:59 -File created 27-Oct-92 14:10:38 -MAKEINITCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>DLFIXINIT.LCOM;12 -compiled on 29-Jan-98 17:51:08 -File created 29-Jan-98 17:51:06 -DLFIXINITCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>CMLARRAY-SUPPORT.LCOM;2 -compiled on 25-Jan-98 09:51:29 -File created 15-Sep-94 11:10:20 - -{DSK}disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>FASTINIT.DFASL;3 -XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 -Source file created Wednesday, 18 July 1990, 13:20:03. -FASL file created Saturday, 24 January 1998, 15:46:32. - - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;15 -File created 29-Jan-98 17:20:41 -LLPARAMSCOMS -(\MAXVMPAGE reset) -(\MaxMDSPage reset) -(\FirstArraySegment reset) -(\FirstArrayPage reset) -(\MDSTTsize reset) -(\VP.IFPAGE reset) -(\NP.FPTOVP reset) -(\VP.TYPETABLE reset) -(\NP.TYPETABLE reset) -(\RP.TYPETABLE reset) -(\VP.GCTABLE reset) -(\RP.GCTABLE reset) -(\VP.GCOVERFLOW reset) -(\RP.GCOVERFLOW reset) -(\VP.PRIMARYMAP reset) -(\VP.LPT reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLCODE.;1 -File created 19-Jan-93 10:45:33 -LLCODECOMS -(INEWCOMS reset) -(DONTCOMPILEFNS reset) -(INEWCOMS reset) -(MKI.SUBFNS reset) -(NLAMA reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLARRAYELT.;8 -File created 15-Sep-94 11:08:59 -LLARRAYELTCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>RENAMEMACROS.;3 -File created 27-Apr-94 15:43:27 -RENAMEMACROSCOMS -(RD.SUBFNS reset) -(MKI.SUBFNS reset) -(EXPANDMACROFNS reset) -(EXPANDMACROFNS reset) -(INEWCOMS reset) -(MKI.SUBFNS reset) -(EXPANDMACROFNS reset) -(RDCOMS reset) -(RD.SUBFNS reset) -(DONTCOMPILEFNS reset) -(DONTCOMPILEFNS reset) -(DONTCOMPILEFNS reset) -(LAMA reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLCHAR.;3 -File created 12-Jan-94 10:12:34 -LLCHARCOMS -(INEWCOMS reset) -(INEWCOMS reset) -(EXPANDMACROFNS reset) -(DONTCOMPILEFNS reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLNEW.;16 -File created 2-Feb-95 16:21:44 -LLNEWCOMS -(INEWCOMS reset) -(RDCOMS reset) -(INITPTRS reset) -(MKI.SUBFNS reset) -(RD.SUBFNS reset) -(DONTCOMPILEFNS reset) -(INEWCOMS reset) -(EXPANDMACROFNS reset) -(MKI.SUBFNS reset) -(RD.SUBFNS reset) -(INEWCOMS reset) -(DONTCOMPILEFNS reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLBASIC.;13 -File created 31-Jan-98 09:55:50 -LLBASICCOMS -(DONTCOMPILEFNS reset) -(INITVALUES reset) -(INITPTRS reset) -(INEWCOMS reset) -(EXPANDMACROFNS reset) -(MKI.SUBFNS reset) -(RD.SUBFNS reset) -(RDCOMS reset) -(new COPYRIGHT property for LLBASIC) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLDATATYPE.;12 -File created 2-Feb-95 16:27:02 -LLDATATYPECOMS -(INITVALUES reset) -(INITPTRS reset) -(INEWCOMS reset) -(RDCOMS reset) -(RD.SUBFNS reset) -(EXPANDMACROFNS reset) -(MKI.SUBFNS reset) -(DONTCOMPILEFNS reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLGC.;4 -File created 19-Oct-94 12:30:11 -LLGCCOMS -(MKI.SUBFNS reset) -(INEWCOMS reset) -(DONTCOMPILEFNS reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLSTK.;1 -File created 6-Jan-93 18:07:37 -LLSTKCOMS -(INEWCOMS reset) -(EXPANDMACROFNS reset) -(DONTCOMPILEFNS reset) -LLSTKCOMS -(LLSTKCOMS reset) -(LAMA reset) -(LAMA reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>RENAMEMACROS.;3 -File created 27-Apr-94 15:43:27 -RENAMEMACROSCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>MODARITH.;1 -File created 16-May-90 20:46:21 -MODARITHCOMS -(EXPANDMACROFNS reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLFAULT.;1 -File created 2-Jan-93 12:26:58 -LLFAULTCOMS -(INEWCOMS reset) -(RDCOMS reset) -(EXPANDMACROFNS reset) -(MKI.SUBFNS reset) -(RD.SUBFNS reset) -(DONTCOMPILEFNS reset) -(INEWCOMS reset) -LLFAULTCOMS -(LLFAULTCOMS reset) -(LAMA reset) -(LAMA reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLKEY.;1 -File created 10-Jul-92 16:53:27 -LLKEYCOMS -(INEWCOMS reset) -(RDCOMS reset) -(NLAML reset) -(LAMA reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLBFS.;1 -File created 17-Dec-92 01:31:53 -LLBFSCOMS -(INITPTRS reset) -(INEWCOMS reset) -(DONTCOMPILEFNS reset) -(INEWCOMS reset) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLTIMER.;1 -File created 16-May-90 20:13:11 -LLTIMERCOMS -(INEWCOMS reset) -(\TIMEREXPIRED.BOX reset) -New fns definition for \SETUPTIMERmacrofn. -listing? F -(I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) -(I.\\LOCKFN (FN)) -(I.\\LOCKVAR (VAR)) -(I.\\LOCKCELL (X NPGS)) -(I.\\LOCKWORDS (BASE NWORDS)) -(I.\\LOCKCODE (CODEBLOCK)) -(I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) -(I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) -(I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) -(I.MAKEROOMFORPME (VP) (uses NEXTPM)) -(I.MAPPAGES (BOT TOP FN)) -(I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) -(I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) -(I.\\SETUPGUARDBLOCK (STKP LEN)) -(I.\\MAKEFREEBLOCK (STK SIZE)) -(I.INITGC NIL) -(I.NTYPX (X)) -(I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) -(I.\\MAKEMDSENTRY (VP V)) -(I.\\INITMDSPAGE (BASE SIZE PREV)) -(I.\\ASSIGNDATATYPE1A0001 (PAGE)) -(I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) -(I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) -(I.\\CREATECELL (TYP)) -(I.\\NEW2PAGE (BASE)) -(I.CREATEMDSTYPETABLE NIL) -(I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) -(I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) -(I.FSETVAL (ATM VAL)) -(I.SETPROPLIST (ATM LST)) -(I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) -(I.\\BLT (DBASE SBASE NWORDS)) -(I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\OLDATOMSPACE \\ORIGREADTABLE |I.OneCharAtomBase|)) -(I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses \\OLDATOMSPACE |I.AtomFrLst|)) -(I.\\INITATOMPAGE (PN) (uses \\OLDATOMSPACE)) -(I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) -(I.\\STKMIN (CODE CODEISBLOCK PRINT)) -(I.COPYATOM (X) (uses I.SCRATCHSTRING)) -(I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) -(I.MAKEINITFIRST NIL) -(I.\\COPY (X)) -(I.MAKEINITLASTA0001 (P A)) -(I.MAKEINITLASTA0002 (V A)) -(I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) -(I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) -(I.\\MAIKO.CONS.UFN (X Y)) -(I.\\INITCONSPAGE (BASE LINK)) -(I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) -(I.\\GETBASEBYTE (PTR N)) -(I.\\PUTBASEBYTE (PTR DISP BYTE)) -(I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) -(I.\\NEW4PAGE (PTR)) -(I.ALLOCSTRING (N INITCHAR OLD FATFLG)) -(I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) -(I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) -(I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) -(I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) -(I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ------In I.\\MAIKO.ALLOCBLOCK\: -*****((*) - |value| |of| |comment| |used?|) -(I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ------ -(I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) -(I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) -(I.\\MERGEBACKWARD (BASE)) -(I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) -(I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) -(I.PREINITARRAYS NIL) -(I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) -(I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) -(I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) -(I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) -(I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) -(I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) -(I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) -(I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) -(I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) -(I.DCODERD (FN) (uses I.CODERDTBL)) -(I.INITUFNTABLE NIL) -(I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) - -{DSK}disk2>jdstools>lc3>lispcore3.0>sources>MEM.LCOM;3 -compiled on 25-Jan-98 17:45:42 -File created 5-Nov-92 15:57:00 -MEMCOMS - -{DSK}disk2>jdstools>lc3>lispcore3.0>4-BYTE-ATOMS>I-NEW.LCOM;28 -compiled on 31-Jan-98 13:41:40 -File created 31-Jan-98 13:40:25 -error during GREET... - -2> LOGOUT(T) -LOGOUT -> IL:LOGOUT ? yes diff --git a/obsolete/sunloadup/LOADUP.LOG.~2~ b/obsolete/sunloadup/LOADUP.LOG.~2~ deleted file mode 100644 index e69de29b..00000000 diff --git a/obsolete/sunloadup/LOADUP.LOG.~3~ b/obsolete/sunloadup/LOADUP.LOG.~3~ deleted file mode 100644 index 183067d9..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~3~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShi \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~4~ b/obsolete/sunloadup/LOADUP.LOG.~4~ deleted file mode 100644 index 09889358..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~4~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;5 File created 22-Jan-2000 14:54:38 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;40 compiled on 22-Jan-2000 22:49:01 File created 22-Jan-2000 22:48:52 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;3| (REALSETQ \SYSTEMBRUSHES NIL) (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;4| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (DEFOPTIMIZER \KEYNAMETONUMBER (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CAR X)))) (COND (CE (\KEYNAMETONUMBER (CAR CE))) (T (QUOTE IGNOREMACRO))))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;4| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;2| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/presentation/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/PRINTWHEEL/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/publishing/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** *********************************************************************** [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************ \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~5~ b/obsolete/sunloadup/LOADUP.LOG.~5~ deleted file mode 100644 index 12cb054c..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~5~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;5 File created 22-Jan-2000 14:54:38 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;41 compiled on 30-Jan-2000 22:11:35 File created 30-Jan-2000 22:11:28 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;4| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (DEFOPTIMIZER \KEYNAMETONUMBER (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CAR X)))) (COND (CE (\KEYNAMETONUMBER (CAR CE))) (T (QUOTE IGNOREMACRO))))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;4| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;2| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/presentation/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/PRINTWHEEL/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/publishing/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** *********************************************************************** [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************ \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~6~ b/obsolete/sunloadup/LOADUP.LOG.~6~ deleted file mode 100644 index a31491ce..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~6~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;5 File created 22-Jan-2000 14:54:38 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;42 compiled on 30-Jan-2000 23:16:22 File created 30-Jan-2000 23:16:15 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;6| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;4| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;2| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/presentation/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/PRINTWHEEL/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/publishing/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** *********************************************************************** [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************ \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~7~ b/obsolete/sunloadup/LOADUP.LOG.~7~ deleted file mode 100644 index 29e6a7bc..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~7~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;5 File created 22-Jan-2000 14:54:38 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;43 compiled on 30-Jan-2000 23:47:30 File created 30-Jan-2000 23:47:22 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;6| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;4| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************************************************************* [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************** \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~8~ b/obsolete/sunloadup/LOADUP.LOG.~8~ deleted file mode 100644 index fed6b4a8..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~8~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;5 File created 22-Jan-2000 14:54:38 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;44 compiled on 31-Jan-2000 00:05:28 File created 31-Jan-2000 00:05:21 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;6| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;5| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************************************************************* [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************** \ No newline at end of file diff --git a/obsolete/sunloadup/LOADUP.LOG.~9~ b/obsolete/sunloadup/LOADUP.LOG.~9~ deleted file mode 100644 index 053dd6c1..00000000 --- a/obsolete/sunloadup/LOADUP.LOG.~9~ +++ /dev/null @@ -1 +0,0 @@ - {DSK}sybalsky>lispcore>sunloadup>FILESETS.;1 File created 9-Apr-90 16:57:44 FILESETSCOMS {DSK}sybalsky>lispcore>library>VMEM.LCOM;1 compiled on 21-Jan-93 18:50:40 File created 20-Jan-93 15:04:46 VMEMCOMS {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS =|{DSK}sybalsky>lispcore>sources>READSYS.LCOM;2| {DSK}sybalsky>lispcore>sources>READSYS.LCOM;2 compiled on 30-Jan-98 11:49:54 File created 9-Nov-92 03:25:43 READSYSCOMS {DSK}sybalsky>lispcore>library>RDSYS.LCOM;16 compiled on 20-Dec-98 14:54:58 File created 20-Dec-98 14:54:54 RDSYSCOMS {DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6 compiled on 25-Jan-98 12:59:44 File created 8-Mar-95 10:22:57 (/DECLAREDATATYPE redefined) (DECLAREDATATYPE redefined) (TRANSLATE.DATATYPE redefined) (\\REUSETO redefined) (\\TYPEGLOBALVARIABLE redefined) (TYPE-VARIABLE-FROM-TYPE-NAME redefined) (|BitFieldMask| redefined) (|BitFieldShift| redefined) (|BitFieldShiftedMask| redefined) (|MakeBitField| redefined) (|BitFieldWidth| redefined) (|BitFieldFirst| redefined) (|optimize-FETCHFIELD| redefined) (|optimize-FFETCHFIELD| redefined) (|optimize-REPLACEFIELD| redefined) (|optimize-FREPLACEFIELD| redefined) (|optimize-REPLACEFIELDVAL| redefined) (|optimize-FREPLACEFIELDVAL| redefined) (|optimize-NCREATE| redefined) (|optimize-\\DTEST| redefined) (COMPILEDFETCHFIELD redefined) (COMPILEDREPLACEFIELD redefined) (COMPILEDNCREATE redefined) (TRANSLATE.LOCF redefined) {DSK}sybalsky>lispcore>sources>RENAMEFNS.LCOM;5 compiled on 29-Jan-98 15:47:13 File created 29-Jan-98 15:47:09 {DSK}sybalsky>lispcore>sources>MAKEINIT.LCOM;9 compiled on 31-Jan-98 09:41:08 File created 30-Jan-98 12:46:00 MAKEINITCOMS {DSK}sybalsky>lispcore>sources>DLFIXINIT.LCOM;1 compiled on 31-Jan-98 09:40:56 File created 29-Jan-98 17:51:06 DLFIXINITCOMS {DSK}sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2 compiled on 2-May-99 14:58:00 File created 2-May-99 14:57:41 {DSK}sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3 XCL Compiler output for source file {DSK}lispcore3.0>SUNLOADUP>FASTINIT.;1 Source file created Wednesday, 18 July 1990, 13:20:03. FASL file created Saturday, 24 January 1998, 15:46:32. {DSK}sybalsky>lispcore>sunloadup>LLPARAMS.;1 File created 31-Jan-98 09:16:51 LLPARAMSCOMS {DSK}sybalsky>lispcore>sources>LLCODE.;1 File created 19-Jan-93 10:45:33 LLCODECOMS (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (NLAMA reset) {DSK}sybalsky>lispcore>sources>LLARRAYELT.;8 File created 15-Sep-94 11:08:59 LLARRAYELTCOMS {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS (RD.SUBFNS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (EXPANDMACROFNS reset) (INEWCOMS reset) (MKI.SUBFNS reset) (EXPANDMACROFNS reset) (RDCOMS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (DONTCOMPILEFNS reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLCHAR.;3 File created 12-Jan-94 10:12:34 LLCHARCOMS (INEWCOMS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLNEW.;16 File created 2-Feb-95 16:21:44 LLNEWCOMS (INEWCOMS reset) (RDCOMS reset) (INITPTRS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLBASIC.;13 File created 31-Jan-98 09:55:50 LLBASICCOMS (DONTCOMPILEFNS reset) (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (RDCOMS reset) {DSK}sybalsky>lispcore>sources>LLDATATYPE.;12 File created 28-Jun-99 16:57:50 LLDATATYPECOMS (INITVALUES reset) (INITPTRS reset) (INEWCOMS reset) (RDCOMS reset) (RD.SUBFNS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (DONTCOMPILEFNS reset) (new COPYRIGHT property for LLDATATYPE) {DSK}sybalsky>lispcore>sources>LLGC.;4 File created 19-Oct-94 12:30:11 LLGCCOMS (MKI.SUBFNS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) {DSK}sybalsky>lispcore>sources>LLSTK.;1 File created 6-Jan-93 18:07:37 LLSTKCOMS (INEWCOMS reset) (EXPANDMACROFNS reset) (DONTCOMPILEFNS reset) LLSTKCOMS (LLSTKCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>RENAMEMACROS.;3 File created 27-Apr-94 15:43:27 RENAMEMACROSCOMS {DSK}sybalsky>lispcore>sources>MODARITH.;1 File created 16-May-90 20:46:21 MODARITHCOMS (EXPANDMACROFNS reset) {DSK}sybalsky>lispcore>sources>LLFAULT.;1 File created 2-Jan-93 12:26:58 LLFAULTCOMS (INEWCOMS reset) (RDCOMS reset) (EXPANDMACROFNS reset) (MKI.SUBFNS reset) (RD.SUBFNS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) LLFAULTCOMS (LLFAULTCOMS reset) (LAMA reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLKEY.;5 File created 22-Jan-2000 14:54:38 LLKEYCOMS (INEWCOMS reset) (RDCOMS reset) (new COPYRIGHT property for LLKEY) (NLAML reset) (LAMA reset) {DSK}sybalsky>lispcore>sources>LLBFS.;1 File created 17-Dec-92 01:31:53 LLBFSCOMS (INITPTRS reset) (INEWCOMS reset) (DONTCOMPILEFNS reset) (INEWCOMS reset) {DSK}sybalsky>lispcore>sources>LLTIMER.;1 File created 16-May-90 20:13:11 LLTIMERCOMS (INEWCOMS reset) (\TIMEREXPIRED.BOX reset) New fns definition for \SETUPTIMERmacrofn. listing? F (I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK)) (I.\\LOCKFN (FN)) (I.\\LOCKVAR (VAR)) (I.\\LOCKCELL (X NPGS)) (I.\\LOCKWORDS (BASE NWORDS)) (I.\\LOCKCODE (CODEBLOCK)) (I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM)) (I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM)) (I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM)) (I.MAKEROOMFORPME (VP) (uses NEXTPM)) (I.MAPPAGES (BOT TOP FN)) (I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC)) (I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)) (I.\\SETUPGUARDBLOCK (STKP LEN)) (I.\\MAKEFREEBLOCK (STK SIZE)) (I.INITGC NIL) (I.NTYPX (X)) (I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE)) (I.\\MAKEMDSENTRY (VP V)) (I.\\INITMDSPAGE (BASE SIZE PREV)) (I.\\ASSIGNDATATYPE1A0001 (PAGE)) (I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|)) (I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|)) (I.\\CREATECELL (TYP)) (I.\\NEW2PAGE (BASE)) (I.CREATEMDSTYPETABLE NIL) (I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS)) (I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS)) (I.FSETVAL (ATM VAL)) (I.SETPROPLIST (ATM LST)) (I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS)) (I.\\BLT (DBASE SBASE NWORDS)) (I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|)) (I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|)) (I.\\INITATOMPAGE (PN)) (I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES)) (I.\\STKMIN (CODE CODEISBLOCK PRINT)) (I.COPYATOM (X) (uses I.SCRATCHSTRING)) (I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING)) (I.MAKEINITFIRST NIL) (I.\\COPY (X)) (I.MAKEINITLASTA0001 (P A)) (I.MAKEINITLASTA0002 (V A)) (I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA)) (I.\\CONS.UFN (X Y) (uses I.LISTPDTD)) (I.\\MAIKO.CONS.UFN (X Y)) (I.\\INITCONSPAGE (BASE LINK)) (I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD)) (I.\\GETBASEBYTE (PTR N)) (I.\\PUTBASEBYTE (PTR DISP BYTE)) (I.CREATEPAGES (VA N BLANKFLG LOCKFLG)) (I.\\NEW4PAGE (PTR)) (I.ALLOCSTRING (N INITCHAR OLD FATFLG)) (I.%COPY-ONED-ARRAY (LOCAL-ARRAY)) (I.%COPY-STRING-TO-ARRAY (LOCAL-STRING)) (I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?)) (I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE)) (I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) -----In I.\\MAIKO.ALLOCBLOCK\: *****((*) - |value| |of| |comment| |used?|) (I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?)) ----- (I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|)) (I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH)) (I.\\MERGEBACKWARD (BASE)) (I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS)) (I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.PREINITARRAYS NIL) (I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS)) (I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET)) (I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX)) (I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX)) (I.FILEPATCHBLOCK (ARLEN) (uses OUTX)) (I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS)) (I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX)) (I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE)) (I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS)) (I.DCODERD (FN) (uses I.CODERDTBL)) (I.INITUFNTABLE NIL) (I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA)) {DSK}sybalsky>lispcore>sources>MEM.LCOM;3 compiled on 25-Jan-98 17:45:42 File created 5-Nov-92 15:57:00 MEMCOMS {DSK}sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;45 compiled on 31-Jan-2000 00:18:07 File created 31-Jan-2000 00:18:00 I-NEWCOMS |{DSK}sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) |{DSK}sybalsky>lispcore>sources>LLFAULT.LCOM;7| |{DSK}sybalsky>lispcore>sources>LLSUBRS.LCOM;2| (SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN)) (PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR)) (SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL)) (PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLBFS.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLNEW.LCOM;4| |{DSK}sybalsky>lispcore>sources>FILEIO.LCOM;3| (/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56)) (DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT)) (/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106)) (/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) ( EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) ( EXTERNALFORMAT 6 POINTER))) (QUOTE 8)) (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) (MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) ( PUTD (CADR PAIR) (GETD (CAR PAIR)) T)))) (\NULLDEVICE) |{DSK}sybalsky>lispcore>sources>IMAGEIO.LCOM;4| (/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 96)) (\IMAGEIOINIT) (SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) \COLORDISPLAYSTREAMTYPES)) (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) |{DSK}sybalsky>lispcore>sources>LLBASIC.LCOM;12| (PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>LLGC.LCOM;2| (SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP)) (SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP)) |{DSK}sybalsky>lispcore>sources>LLARRAYELT.LCOM;2| (DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT)) (/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14)) |{DSK}sybalsky>lispcore>sources>LLINTERP.LCOM;7| (MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T) (MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T) (SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100)) |{DSK}sybalsky>lispcore>sources>LLMVS.LCOM;2| (XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT))) |{DSK}sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2| (PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*))) (OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* ( IL:HASHARRAY 100))) (IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE |expand-PARSED-STRUCTURE|)) (SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE)) (IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0) (PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*))) (OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* ( IL:HASHARRAY 100))) (PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*))) (OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T)) (IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) "Flag indicating whether the contents of structures are to be printed.") |{DSK}sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2| |{DSK}sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2| (SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.") (SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) "Make a sequnce of the specified type") (SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) "Returns a sequence of the same elements in reverse order (the argument is destroyed).") (SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) "Returns a new sequence containing the same elements but in reverse order.") (CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander)) |{DSK}sybalsky>lispcore>sources>LLARITH.LCOM;2| (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) ( MIN.FIXP -2147483648) (\\SIGNBIT 32768)) |{DSK}sybalsky>lispcore>sources>LLFLOAT.LCOM;2| (SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0)) (SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1)) (MOVD? (QUOTE FGREATERP) (QUOTE FGTP)) (CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS))) (OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10 ))) (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))) (SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8)) (\INIT.POWERS.OF.TEN) |{DSK}sybalsky>lispcore>sources>LLBIGNUM.LCOM;3| (/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER) )) (QUOTE 2)) (DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT)) (SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14)) (SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA)) (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) (\INITBIGNUMS) |{DSK}sybalsky>lispcore>sources>LLREAD.LCOM;2| (Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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))) (\MAKE.JIS.TO.XCCS.CONV.TABLE) |{DSK}sybalsky>lispcore>sources>LLCHAR.LCOM;2| (MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T) (MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T) (MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T) |{DSK}sybalsky>lispcore>sources>LLSTK.LCOM;6| |{DSK}sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1| (AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE \SET.STORAGE.STATE))) (MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T) (MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T) (PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST)))) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) |{DSK}sybalsky>lispcore>sources>IOCHAR.LCOM;2| (MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY)) (MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY)) (SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY)) (SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY)) (PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) ))) |{DSK}sybalsky>lispcore>sources>LLKEY.LCOM;6| (MOVD? (QUOTE NILL) (QUOTE CARET)) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (\KEYBOARDINIT) (PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (\INIT.KEYBOARD.STREAM) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (MOVD (QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION)) (SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION)) |{DSK}sybalsky>lispcore>sources>LLTIMER.LCOM;2| (PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0)) |{DSK}sybalsky>lispcore>sources>ASTACK.LCOM;5| |{DSK}sybalsky>lispcore>sources>DTDECLARE.LCOM;6| (PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>ATBL.LCOM;2| (/DECLAREDATATYPE (QUOTE TERMTABLEP) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG)) (QUOTE ((TERMTABLEP 0 POINTER) ( TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) ( TERMTABLEP 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) ( TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 ( FLAGBITS . 16)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE READTABLEP) (QUOTE (POINTER POINTER FLAG FLAG FLAG ( BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)) (QUOTE ((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 16)) (READTABLEP 2 (FLAGBITS . 32) ) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 ( FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) (READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 ( FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) ( READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE READER-ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER))) ( QUOTE 8)) (\ATBLSET) |{DSK}sybalsky>lispcore>sources>LLCODE.LCOM;2| (SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG))) (SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) CODERDTBL) (SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL) (READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL) (/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE ( (COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4)) (DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT)) |{DSK}sybalsky>lispcore>sources>ACODE.LCOM;5| |{DSK}sybalsky>lispcore>sources>COREIO.LCOM;3| (/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((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)))) (QUOTE 16)) (COREDEVICE (QUOTE NODIRCORE) T) (COREDEVICE (QUOTE CORE)) (COREDEVICE (QUOTE SCRATCH) T) |{DSK}sybalsky>lispcore>sources>AOFD.LCOM;2| (\BASEBYTES.IO.INIT) (\STRINGSTREAM.INIT) |{DSK}sybalsky>lispcore>sources>ADIR.LCOM;2| (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T) (MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP)) |{DSK}sybalsky>lispcore>sources>PMAP.LCOM;2| (PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T) (PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T) (/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8)) |{DSK}sybalsky>lispcore>sources>VANILLADISK.LCOM;2| (\\VANILLADISKINIT) |{DSK}sybalsky>lispcore>sources>MOD44IO.LCOM;2| |{DSK}sybalsky>lispcore>sources>ATERM.LCOM;2| (\INITBCPLDISPLAY) (MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT)) (MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM)) (SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) |{DSK}sybalsky>lispcore>sources>APRINT.LCOM;2| (SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME (QUOTE NULL) T))) (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) |{DSK}sybalsky>lispcore>sources>ABASIC.LCOM;2| (DUMMYDEF (WINDOWWORLDP NILL)) (SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT)) (SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT)) |{DSK}sybalsky>lispcore>sources>AERROR.LCOM;2| (CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*))) (OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL)) (SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) "Last condition signalled. This gets rebound to itself in nested execs.") |{DSK}sybalsky>lispcore>sources>AINTERRUPT.LCOM;2| (INTCHAR T) (SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0)) |{DSK}sybalsky>lispcore>sources>MISC.LCOM;2| (SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0)) (CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME))) |{DSK}sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2| (SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 " ")) (Value of PRETTYHEADER changed from NIL to "File created ") (MAPC (QUOTE ((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 (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD))) (RADIX 10) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) |{DSK}sybalsky>lispcore>sources>CMLEVAL.LCOM;2| (PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*))) (CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*))) (OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* "Variable specially bound. This string should never be visible")) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS))) (XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT))) (CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" ( MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) ( CL:FORMAT STREAM "#" (\\HILOC CLOSURE) (\\LOLOC CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) ( QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE CLOSURE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE)) (CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" (( \\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE ( IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM "#" (\\HILOC ENV) (\\LOLOC ENV)))) \\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL ( :ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) ( ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT)) (PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT)) (SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE |expand-\\MAKE-CHILD-ENVIRONMENT|)) (SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|)) (PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COMPILER-LET|)) (PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MACROLET|)) (PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|)) (PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS| )) (PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR)) (PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|)) (PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-EVAL-WHEN|)) (PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE)) (SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|)) (PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN)) (PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|)) (SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|)) (PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|)) (PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|)) (PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|)) (SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|)) (PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|)) (SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|)) (SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|)) (PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|)) (PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|)) (PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|)) (SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|)) (PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-RETURN-FROM|)) (PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FUNCTION|)) (PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-CALL|)) (PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-MULTIPLE-VALUE-PROG1|)) (SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form.") (CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*))) (OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*))) (OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *EVALHOOK* to suppress the use of the hook-function for one level of eval.") (CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*))) (OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)) (SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) "Used with non-null *APPLYHOOK* to suppress the use of the hook function for one level of eval.") (CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP)) (PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|)) (PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|)) (SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|)) (SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|)) (PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|)) (PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|)) (PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-UNWIND-PROTECT|)) (SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|)) (SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|)) (PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|)) (PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*))) (CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE XCL::SET-DECL-SPECIFIER-P)) (CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE XCL::SET-GLOBALLY-NOTINLINE-P)) |{DSK}sybalsky>lispcore>sources>CMLPROGV.LCOM;4| (PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV)) |{DSK}sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2| (IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|)) (IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|)) (IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|)) (IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|)) (IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|)) (IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|)) (IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|)) (IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|)) (Property IL:* of IL:MACRO has been changed) (PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*))) (PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS)) |{DSK}sybalsky>lispcore>sources>LLRESTART.LCOM;2| (CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P %RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) (IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE %RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) ( INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) ( FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL ( IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE RESTART)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART)) |{DSK}sybalsky>lispcore>sources>LLERROR.LCOM;2| (MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT)) (CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" ( MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) %PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG ) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) %PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) ( PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) ( PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER))) 14 (QUOTE CONDITIONS:RESTART)) (PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE CL::TYPE-EXPAND-STRUCTURE)) (CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE)) (CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE)) (CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE))) (SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET")) (SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) "The prototype proceed-case object for NLSETQ.") |{DSK}sybalsky>lispcore>sources>LLSYMBOL.LCOM;2| (IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*))) (OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0)) (PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*))) (OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G")) (PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*))) (OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0)) |{DSK}sybalsky>lispcore>sources>LLPACKAGE.LCOM;3| (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE IL:|expand-\\FATCHARSEENP|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY| )) (IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) "If OBJ isn't already a package, turn the symbol or string into the package of that name.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE IL:|expand-\\STRING-EQUALBASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) "Compare a string to another string, with the second given in base offset length form.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE IL:|expand-NUMERIC-UPCASE|)) (IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL ( PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL ( PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL ( PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL ( PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL ( PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL "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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)) ) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER) (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE)) (IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) "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.") (SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE ( INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL %PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL (( INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) %PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) %PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) %PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) %PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) %PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) %PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER ) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))) (SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) ( PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) ( PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 ( QUOTE STRUCTURE-OBJECT)) (IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE TYPE-EXPAND-STRUCTURE)) (ESTABLISH-PREDICATE (QUOTE PACKAGE)) (ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE)) (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "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.") (PROCLAIM (QUOTE (SPECIAL *PACKAGE*))) (OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) "The current package, in which read symbols are intern'ed.") (PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*))) (OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" "XEROX-COMMON-LISP")))) (IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE VARIABLE) "Packages whose deletion requires confirmation.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the lisp package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL)) (IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the keyword package.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*))) (OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL) ) (IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) "Global for internal references to the interlisp package.") (XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT))) (IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) "The maximum (inclusive, prime) limit to the size of a hashtable.") (PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD))) (IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) "The maximum density allowed in a package hashtable") (XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES))) (IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) "Some valid (prime) hashtable sizes.") (IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) "Make an uninterned symbol.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* ( IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL)))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) "An equal hashtable from package names to packages.") (PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*))) (OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* ( MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL))) (IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) "Index to package converter.") (XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*))) (IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) "The total number of packages that the system may have (excluding the 'uninterned' package).") (XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL) (PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*))) (IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) "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 .") (IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE FUNCTION) "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH| )) (IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) "Returns the atom hash of the given string") (IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE IL:|expand-REHASH-FACTOR|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE IL:|expand-SYMBOL-HASH-REPROBE|)) (IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|)) (IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE IL:|expand-COUNT-PACKAGE-HASHTABLE|)) (IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) "Return two values: free elements and total size.") (IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.") (IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) "Given a name, find the package with that name or nickname") (IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) "Make a package use (inherit) symbols from others. Checks for name-conflicts.") (IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) "Like Make-Package, but also makes the created package current.") (IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) "Like in-package, but confirms creation of new packages.") (IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) "Change the name if we can, blast any old nicknames and then add in any new ones.") (IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) "Make the symbols external in the package.") (IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) "Check that all symbols are available, then move from external to internal.") (IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) "Make the symbol internal in the package, noting name conflicts.") (IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.") (IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) "Hide the existing symbols with new ones in the package.") (IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) "Remove some packages from the use (inherit) list of another package.") (IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) "Return a list of the names of all existing packages.") (IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) "Add a symbol to a package hashtable. The symbol is assumed not to be present.") (IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL| )) (IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) "If the symbol doesn't exist then create it, special-casing the keyword package.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) "Intern the name in the package, returning a symbol.") (IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) "Find a symbol with the given name in a package.") (IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) "Mark a symbol in a package-hashtable deleted") (IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.") (IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE |expand-DO-EXTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE XCL::|expand-DO-LOCAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE XCL::|expand-DO-INTERNAL-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|)) (IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS| )) (IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) "Find every symbol in all packages with the given name.") (IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) "Short form description of a symbol.") (IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) "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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) "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.") (IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL") |{DSK}sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2| (MOVD? (QUOTE ERROR-MISSING-EXTERNAL-SYMBOL) (QUOTE RESOLVE-MISSING-EXTERNAL-SYMBOL)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-MISSING-PACKAGE)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-USE-PACKAGE-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-EXPORT-MISSING-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-IMPORT-CONFLICT)) (MOVD? (QUOTE ERROR) (QUOTE RESOLVE-UNINTERN-CONFLICT)) (MOVD? (QUOTE RETURN-FIRST-OF-THREE) (QUOTE RESOLVE-READER-CONFLICT)) (SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) "Check whether a symbol would rather be in a package.") (SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.") (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS))) (CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED))) (CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))) (OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:SETQ LITATOM-PACKAGE-CONVERSION-TABLE (QUOTE (("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))))) (SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone.") (SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol.") (SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.") (SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.") (SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) "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.") (SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.") (SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) "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? (QUOTE EQ) (QUOTE EQL)) (MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH)) (MOVD? (QUOTE ID) (QUOTE CL:IDENTITY)) (MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS)) (PACKAGE-INIT) |{DSK}sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2| (IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) "Make a symbol, possibly in source, be in source and citizen and export of destination.") (PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE ) "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (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 (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) *FUTURE-CITIZENS-OF-CONDITIONS*) |{DSK}sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2| (PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL))) (IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) "A list of names retroactively placed in XCL; do not add to it.") (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 CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL)) (CL::CHECK-ALL) |{DSK}sybalsky>lispcore>sources>PROC.LCOM;6| (/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (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)) (QUOTE ((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))) (QUOTE 66)) (/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) ( PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) ( QUOTE 10)) (SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T) (/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) ( QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) ( EVENT 2 POINTER))) (QUOTE 4)) (/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) ( MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) ( QUOTE 8)) (SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP))) (DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT)) (\PROCESS.INIT) |{DSK}sybalsky>lispcore>sources>CMLARRAY.LCOM;5| (CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander| )) (CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander| )) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|)) (CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|)) (PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL) (SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7)) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT))) (CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*))) (PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE (( 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))) (QUOTE 10)) (/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE (( 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))) (QUOTE 8)) (/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10)) (DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR)) (DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY)) (PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sources>DSK.LCOM;2| (SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor")) |{DSK}sybalsky>lispcore>sources>UFS.LCOM;4| (SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor")) (/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 34)) (SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20)) |{DSK}sybalsky>lispcore>sources>UFSCALLC.LCOM;2| |{DSK}sybalsky>lispcore>sources>LLETHER.LCOM;2| (/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) ( SYSQUEUE 4 POINTER))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (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)) (QUOTE ((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)))) (QUOTE 324)) (SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE))) (/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) ( NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6)) (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*))) (DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT)) (\ETHERINIT) (MOVD? (QUOTE NILL) (QUOTE BLOCK)) (MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS)) (/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 36)) (SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP))) |{DSK}sybalsky>lispcore>sources>PUP.LCOM;2| (SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q)) (PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) ))) (MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T) (SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS)) (SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready")) (SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready")) (/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((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))) (QUOTE 16Q)) (\PUPINIT) |{DSK}sybalsky>lispcore>sources>LEAF.LCOM;2| (/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (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)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) ( SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 ( BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15 )) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) ( SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 (FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) ( SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER ) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) ( SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) ( QUOTE 80)) (\LEAFINIT) (/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) ( PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24)) |{DSK}sybalsky>lispcore>sources>PASSWORDS.LCOM;2| (SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8)) (SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword")) (MOVD? (QUOTE NILL) (QUOTE CLBUFS)) |{DSK}sybalsky>lispcore>sources>FONT.LCOM;5| (MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT)) (MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT)) (/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) ( FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER))) (QUOTE 12)) (/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER )) (QUOTE ((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))) (QUOTE 34)) (/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((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))) (QUOTE 14)) (\UNITWIDTHSVECTOR) (CONSTANTS (NORUNCODE 255)) (PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST)))) |{DSK}sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4| (Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) |{DSK}sybalsky>lispcore>sources>LLDISPLAY.LCOM;2| (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6)) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE (( 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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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)))) (QUOTE 68)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) (SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap)) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") (UPDATESCREENDIMENSIONS) (Value of \MaxScreenPage changed from 0 to -1) (SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT )) (CURSOR.INIT) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) |{DSK}sybalsky>lispcore>sources>APUTDQ.LCOM;2| (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)) (SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50)) |{DSK}sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2| (MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP)) |{DSK}sybalsky>lispcore>sources>DMISC.LCOM;2| (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) (SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP)))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) (MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS)) (OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))) |{DSK}sybalsky>lispcore>sources>CMLMACROS.LCOM;2| (Property CMLMACROS of FILEDATES has been changed) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (Property * of MACRO has been changed) (SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET)) (CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION)) (Property CMLMACROS of FILETYPE has been changed) (Property CMLMACROS of COPYRIGHT has been changed) |{DSK}sybalsky>lispcore>sources>CMLLIST.LCOM;2| (SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH)) (IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH)) (IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|)) (IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE |optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN ( QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST)))) (IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST)) )) (IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE XCL::|expand-WITH-COLLECTION|)) (IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ)) |{DSK}sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5| (PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT))) (XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL) (CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT))) (PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT)) (PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.") (PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) ( CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST))) ) (PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN ( QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST)))) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE expand-%%CHAR-DOWNCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE expand-%%CHAR-UPCASE-CODE)) (SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR)) |{DSK}sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4| (CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*))) (OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL)) (INIT-CML-READTABLES) |{DSK}sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1| |{DSK}sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2| (MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP)) =|{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| |{DSK}sybalsky>lispcore>sunloadup>MAIKOINIT.;1| (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT*)) (Value of LOADUPDIRECTORIES changed from ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/")) POSTINITARRAYS: There were 36 allocated but unused array pages. ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** *********************************************************************** [FPTOVP]********************************************************************* ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx****************** ***********************[PageMaps]******************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ***************************************************************************** ************************ \ No newline at end of file diff --git a/obsolete/sunloadup/SUNFONT.LCOM.~3~ b/obsolete/sunloadup/SUNFONT.LCOM.~3~ deleted file mode 100644 index 2cbe4510..00000000 --- a/obsolete/sunloadup/SUNFONT.LCOM.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "28-Jan-98 10:46:47" ("compiled on " |{DSK}disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;2|) "30-Mar-95 20:33:04" |bcompl'd| |in| "Medley 14-Aug-95 ..." |dated| "14-Aug-95 15:27:48") (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|) (PRETTYCOMPRINT SUNFONTCOMS) (RPAQQ SUNFONTCOMS ((VARS DISPLAYFONTDIRECTORIES))) (RPAQQ DISPLAYFONTDIRECTORIES ("{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/presentation/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/PRINTWHEEL/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/publishing/" "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/miscellaneous/")) (PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998)) NIL \ No newline at end of file diff --git a/obsolete/sunloadup/SUNFONT.~3~ b/obsolete/sunloadup/SUNFONT.~3~ deleted file mode 100644 index 2a800582..00000000 --- a/obsolete/sunloadup/SUNFONT.~3~ +++ /dev/null @@ -1,28 +0,0 @@ -(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}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/presentation/" - - "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/PRINTWHEEL/" - - "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/publishing/" - - "{DSK}/DISK/DISK2/JDSTOOLS/LC3/LISPCORE3.0/fonts/display/miscellaneous/" - )) -(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/sources/ACODE.LCOM.~5~ b/sources/ACODE.LCOM.~5~ deleted file mode 100644 index 0182292acf7c23298f114046382dfe3a51a707e9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 19277 zcmbV!4{)2ubteE)vg3pdDN{1b(CQYJWs(tTd>{TZ8W|u63LpV23_=nmGlD3BGXFrN zO43Q(&P`=^;v~&Yu2JGRPA}tdcD0KpPQYe4oVLc z+0-m+aHl7VrHRLx=If3=_9y}N^z^t{acmI?xU0FEzgG_ug6qe?yxn|!kt%9>uNLg} z_}xsRY@)UvFP#NFzL1BFPmaw#InvQp}j&wAZ)QGp{&4&sNhok68P%6gL!=3ER{KO}w<{n!RLkB`` zrgisEjCY51=Fxk-KFrVi4NU87h(%MW;TYk|diz5S9VynKvw=)Bn@t^M8lyq-4D&Fs zQzy$JCwVZ#bMb-9FdJZg4QQsb;E-HzZ&!j3=ewi1SR$E^$MT1A@h$?45qtI&bHr{&Ud>3!On&2J0ZMCq=D85$TG`;p;`L0skKRv;Bty}{< zZ=1PPXe&%v*2q-LtoDy?wFJ^jyVpVY;waG``0uxDCFC zyQ%TLXuON>SuHTDaV8pPXnZfg(D)uSzPEJi?YG{V{i*Zqq8!0@)$=Qcc>lC~6m}SD zgx^)qXL%FfQF8S)mUr_VvMREQL+yVy)b_|{ks54&Zm{i`!8=Ozmp}sEMb9py^4_l! zuhcdFuAbnBi$LPAQP^jpxKE(CZ$*&2(Bg7A3&rW{7j{=+do0)<0o$`u7%_NprUuAk z0eJ+FXQco{iX~SKlx{)k0!m*gj1p8`4V2G<@(C#4O5r#`)z?4;EU18h3ak`P7`(;h zRMcE@->v9&ewRx8AgaoqtJMARWRrS1|A3j;Z63`z%8MQ<9~r)@c4z8B&za2wMwB^g1@N1dn=9~0vwO$B~W3% z1o)Z)*k5sc0RVXXVHKS}t)lY)KW3tGm7iEG93a*mMdhb~%z^U5sC%G%&_dLwqYW{PBpA?+x&tK3ZSlNIOWh8c0{hS~j> z(A8eKAil4r8uRgmzQUl@t$hZ>r1jgW)Gw&iUqdBpjtc{JDh&uK4S-4lppdXrDM3_9 z2r8L$7z7>u{c{%eZHyq$NZHXy2{ck$ppmhokr8NQEHtuqG_r(7R-jQ#wLh0?8wC#A z@aL37I#+r3Um-4%?I7H{|5vX3lb}#jvhBzGWVG*tG!=#XbCq{rk4~*E-OuxbLioN= zdDlP&s{aVp)1vx+OSipLdG~uf@5~68mw6sCWJsi6q_oSaDvKAFGbM_Cf;VScBvE~8 zYVDapSH_XIZ0_hCcbtQ}u4ym@|L^Y(q-&GGSRI;*0|G;i3)Mu!je z4P>zALeJ6(Ez&PiJT{bN-XPwg+V%4+Ls2}J<2h8Sf$_6ZXdc~aZ|+B;Ki*CH33MUN z8}u>g5^9InLw?rl?e0682bp!yuh(b3=stEZ#rvYEVWw$*PZdn_c&lKZP?)KA?d3x|AG1KL3!20;1Oh40uW+goku2#}9m_x(y{()RP z&UC-mg!cJa7A*^HO!o#^(tN>)RVSE1rfbYSJGaOzy?cDFH~~F(6D~D%I*p~E7P6Gq z*~uJjPKU!4X?8jib<6e9CTB6){+(#sNtcmujg=ezN=3x`yzI1*U@OP z&Y4&{-;zj1h2$WVB5O;n(I%JEnOysGQ778hCJK#c#r4-kXQ9RUW6}zKh#!~pPkBp` zMAFhd2KK(l+7CpPh^#zC_K#AKD zpyV1_jr?Nk21<2Qew!9tb<1^6R&ISt;4D!3Niuailv3}HQtEwBqViu8B}Jx}lIh#w zlzxAl((i*4mH)ap5mJAT`QBkPH#J6fI*g<_cRR$~?O3^*?IK!=ys_o{Q#ZGrf9mnJBire`Tk(KLK5vGi zwCO>POMxEnse~7@+_nlIjKyNZu_(4NNc^p2yjZ*tuR-RHjmZ7gRw%2aCkup7G-=rb93{yI1^LsZCLE6wCf~OS?rvMbF}7`H73;_>FxStu1eOX8 z&n;F-i>T6qDp)F;AFD4GTJ5T7E2*Zf@*L5)yhC+<{C3z+1F?Mxr`IL}DVKA3TgE!-ebY#!lY>K2H%zse2Rqy8ZP`emhx*F}Im z<2^uruZ7`Wf#F^tzYoawtilptR_YK%9Y7w(ek$s+in>Hm7i61>{5J{rHH9~w41O)V zJ@Sb0T;;vJisT`q5HJx4iC#iLAizVwdZXFk8V>;L&}w0$tpJsPHHtPG2ng#cvO{ez zT70f6=-hkJyCApN;d<2} zc;W%U+RJupp2#oN_tDCg>Fpxje51K}jWtL1^ff#0pN0Xi)Wln_KUZ<~CV6X298V3Q zxy7XBHkc6Bygx~B($k*AgQQq17;FdgmCaNfe^YX;JtLZ|I1Ch(>Z@fx zEN!>SzC&equEC&zE*;ZKfmCSNQIZ%KvMXH<4f$`R1Rb*b{+Pw$3>^byfQscGnnARzXF(IVbJg)bSU zJD<36W%c;wM=^^YF}4 zkCOub?!vEwMYkj2T`be#mKK%A&td9&o(FQy#4s)}_$w*ZCEl{2t$pdEMzT83Zfl;QU%)frUMb`(=$Y$F9X8lK7Obht6!I1<+1_iL-l!rJ4qM=` z!Pm6CQE4cQRDtVjfj6oVg<}f1wA-Fg+?%{**K*LlI7J23V=bu46u_13kC=E>wjWNL zY;nTavY)2ktem7D*Z@9battbCBht&| zni}~cdPQ#m18O(4cAves!0mer+_tv>dJB}xJhQy5;`&G4E9AS_jw-I7D`I~_QWaGA zgX>QVq|Z*T7WS{3=>672@3&2~>vMenuQk#8YbM(DusI=1_IZ5&Sr>jc(_eOg&bbG~ zp-vK^;`}!?CU2Fu%|^ejhItr_^c2tWJTcWpv*J%JgnqYX;9M=On#_%je?vBhropGj zK3jd0?mrXb2w@zl!B{#C*OoqNV;6(x#9p?1hd|yw!xd+fg{jmcoZBrufwYK!RTO9y zI>bL)Wu!w?9GA_?VwX3x2nJn}hg}%CFR)ZC3C11s^n-^?UaeUqhFp#p} z<%CV4-&tPeeXjDWW*jg|w>LW0^%h&B_>^8eriuJYg3 zE$yzNnC7{eRiT8MyPZ-JY0SU!^W*q^(9$UWGc<=8o+GWK@~eB~fS*N&Iikp~wwvs` zP6esF^M530H6O=xse)AAd7U(ncm76cAeDE1>ge!#VJ}2X4~~e;>xHX@&Wai(VV=(? zknn~XEb`2&!(E{Y^?+C9d2};RgL6s1d4gV%r!%hy&Wh3e(QKR|R|axCojH{5i|0^) z*bdc}2WM$Y>g4EYEi>t>w&o3mFC2nIY+Z+&%Ni5;hN>?b zPVr<%5ChcUS5j?ja2ly*G}t0UGa8H!W*%(6BF_VFn#%K_7nw&BW75-u+UAQERvn1$ zv@n=KcBh32N?@&pVFfXBEymG8VF{oyEd*-}^`nKrbgELwBBmDdm}Jv}7Bgx=zod^A zguz=?3Tm)tpi{IN2%9{uRcBcX_`&tm6Zz^C`)mG?g`XcxEXw_g=yF_s)vkQ=DNa{! zaH&$C^3AKbM7?=y%0O+?4;!l5iC9RNqz}R0Xtfkl^AQ9f48?+#gYXk8q=OdI1byb1 zgZAEnXjGCSXpt{~^6JmO!4`IYMnMHzx&XXBuy-alcqk21o)1%OCLs(DWsbm^k8HTx6#z*!p6$s% zZbPJzdC^Pm<59SbbKP*4eSUNcz1E7Xkgzq((r{ZC}LuOKv0t@g4z#Qf{ zN08wD{zI8Q(J49atu*-YAT;-wHgWxKw zAc!afX(1KXS!;%ShVw(i@P@$e9VBvA3sMO7NFf(YCFr0B;W<%6(*qzH<&FRWKjhMx zPmIkYg<1L-gfiSYGQ*3-EJmgS-zqXXWWqp(1TEHVwZ|$dIz*zaK%t^TfJ;<#uWq5D zfp-Kd@WX>&hLbViEDbVDRK=!jrLgHyMJrOLcNd;s zbV6arGz`%uT*5S%5xy z$IhIYD2m=7JwTe63^vLV-DwzXVR3AJ@ys}0X`onCNI?vv%Q279 zEd4x4hL!UNK69*5^8UaRe75xtM_uz;WAh*16YYzxo~*xl{lZ5gM?BJpa>OIfbBAtBClZp9k3Ng=( zMrP*H@$x_NMzft#oz;kM$jlVyEh`_5?-H@qEe2fByoK+e*y>&AVu-hF8jJyW-U3@f z3u3ExnT;ONrAG*uk;NO26~YpRj8@BNs$zOpt{u@!uEACK!c8}&X<|o}QXNV*@eE(w zGDLg?hMetNM2OQUHuo8?j}ZTHX`4xtX;`)>lzpE8e=SUIT||){L6Lo%d3Ub?p6>%i z_JJZjD%5;>ZD}X$%1`YDm4UJ4&e^jL_(x>^{pCaIaL zq={fnZoR7y2Wo-xZ6n z6kWRzJbml*zc=r2B@;K!|8^uP@{g4~H?KcGSPEbNa&q~DQ%@ylE*&jjo!l|GcHvIx zai#DTY<@Kwrnupg6!$Z*IpLfSKevn>gwxyh+G$4f*+W~Z*k&PyfbWwo!neM;*_i+@ z9V_)j-nfDOXCkNHd;Lcxmk4LN@k~Mpkqd_suQ@(6yYtZ6g(0La!nt~(4~ezuHB<>D zimy0lE+2h8`TB?i-)n-G+l4JAQQGkjuaCU89XB+-n|N*e@1XwK$sHH!A{ZvPV)Sq{ zmF$o9BfxNY7#cG+@|qk>4Z>pCXn($c_{`Y&MBmuL1oAK$2qcoRhFLBG5r-`StTB{9 z2UM4Sc^3{EDQijWeoY9xo!C#FeW>#NNZIBE*JGgQ!QgS6$UsRbxlsU9=HBzce zY!JQ|Bj`8XXe5&4Ap23})`DaZ6&MU1PMlak73|hZL5H>_qEivmu#R#JM@DxvcaXup z#$x7et{9?9Ss(V`84B>SNQ+>mc#eXCO%~dmw64nT-;A_~WV&)MLYEN8ge_+JC5XnK zyqFrgah|2GMtDtkW);e@K@E$rSct_o>Ukl{|ivuZD1-8dDMoBNE`MSj)+q1 zNt?u4k>`GkU@Ho8*fQFx-5zb#PBz_kF;0PmIk4ThlyK`Vg|EVMpTe`lDC{-yti}uN zOvnAXJNBfFhE7XN0eFvhb- zg^ox9Eb5_?mbna}2uex5%|ViUr=!Up$qm_Wt7%p8QusEZ%Q8oJt{;*96oVOyLQbL} z7L|AYHbiyfWGm#W8R!j3`VjVy`sOA_B--~^5izA=Yl|)IX>P(k_)7ikn&a)*8?zt2 z_4c)&*Bg;i{mkm?v0wb$ad+&=$gA}`9VGn8ied>GQ-+hchqSL5fEc=z`IJA9N#GtU zjM7zNAgiCSN6q!9>SAktW&0IucBMNLh>$sFlu9ZS_TC!%5t{RL7a_STvT1ccERK+7-LlQcEN&#`J6?J1MmNsU{+~6T8^-+V^cU zMIo{{yl$jF&O~e^mg?<=owz%h&Zd&FWWIYSezaQ{6A_6lN=Y}_P>Lyn5oL7!U?k_l zWU>MKZnzn68@azrOl~UGhpWd!*0gHuNFq*~IKtvE%s;?Hx|%(%h!k~VoMyDJ3K~B8 zgNRUHMVVA~BZ4sU7J(eU&{71%NODRLN#-YHy3`=mG<7ZEh2mg~!w}$tXQ56$2-5W9 zmWDT_T3c zL-EMc@(5*kOXW{Z53DRitL}kAnV3)tp#@@2s7ufi1_X&3#XhGP%mDJ0F7iV4t-gd+ z8g(e_&^@&v3<0&V;hhcDahglcnj7<~Fy?*T%5(l*E9nG++_?KeA!_Cwzb_k8N6YuC zEekKl%B|1Z%Z@!&`iPvv=B5uyE%eHj7nA2ob!VrCF5yhN`sSN6t23*o-+Nnty_Ceh z_qD`ydOFoW0?}clQ$i|<&YjJ5jR?Y1cZAh(khlNr?lg3X8n9-*+XPd$eYu;!5O-Gt z*TVOha4JBTcl_+`L<*2~mxfZmR7lX<=pPYULnc}zU5vq{J(EUSwqTyH1*W*N>r_Elkg!=+ z(=cdQ`C>b;T7X?~qx_|{GkTv8#r@GdTz9z6&H~7z?;FUqg9Am)xrrpSc^l40T`0Sy z4~JCKN)Cgm+Tp#hf(o@6{u5Y3VNAt^!)Ow#9p;+*AHZD;7`kwQi`=ZZ>@)!77`r{| zix1$MybxmIxQduCbX!%LVg5;G4yNJ|W6s~FqnD6Ulaj?tADArKEHh?q>!!KxO>;lG zX>M?{+)2S`hI~Yp?-Js%;&@YJPqtMYt3@Xr3!O*nmi7uXlTNvn$jAhR9&}}y`n-fu zAf*q;=HXPg5|Z7{f2!1G;*%hCTZSB%qrJ~owxMvJy>LURHB2-s0?+QSQ}<312j=~o z2WZ>#LMAHPfY)-xRek1`$BA51UmcEKt@AHE*pLL;c5=+=m6L- z>*#{h$eo>^nq8cleRSQeCwysxwnWhwt=MWRlSf%UDS5d#KDW^j#|9ly0rae&Q>=gX zsP$owY>bRa)QoVZWa1+-!ry9GDy(RaoC>T%-n1o4uHBE#$*^aG{Z7Ha|w6g^AJ!RUWi`l?5Ec9-UYelRP$CWbiGBw7T#{yf=lf zx!~g4n8gI$bd{E!EWzl}!&rWDVgXm?<|o*hF>*F6PRzsqP!xCPN~O6^!aV{nWcNON zQf42cE_~hOZ!oXe%}?MPEeq&pY;g*==z81@K)1?4TQCrGWpNV2rCJ#^@rz5wV; z9_&7xj;Fin>o7E3FzX2}@31~3vyOi;m19_%_#+m^4MR-MW4L{2T|^vzoaRj4d6uiS z_G~DRiq?^E!{LLlz(6cXked5scWL4i6D4+Xeqs#9F4?Gg_OLYFb<2$AJ|D-YZ=eiN zo$AC^g+YTg+FZZvaZBN%)NWFq(O7&W8_o2KnWq|6@lh*Qtoca6Zl@Sw15=m?+vXl#HWD1Zd8FbGMM%?P3d%KU*y zm86`gotw(;)Jd97u2JGRKbN#|+$K%h2B4&y#E$*tc%8;}FH^};Zm8b%MzZDJOy{mc zot)`(TwC|NyZilsKeETt5ZG_`-Q9QJefQn>??cBxVlb6WbPuM|iSAT(khAt&EIu6D zmtfvhwvfoDQzJPqYtJWQ1BFiuF~2Z3J6?XUJa-JA zCnieeiPQd`;DZZur{<3VAQtBXiJngeJJGkdJ9cs&6Zm{gi}d-lKELi|^Apwt4HKU^ zS)MvJwOBs=@jlj{=fjCCmdd6uaYl^HFf_}>@^LnJs$6Cxr!mbUV}b7M+~YK`pY`H=+Vh? z%pYc5V!UqZ*M%C*$5LW}Io8VtRVl)9s-&}2h@e<1fG;1jrc5zE)+dQJu+w z8S{O8T}eJt=*AW&Q-wslus@&Z>SPVy(cG>(`kyP`d9>abJR7a}q91bM--V87spOBY zF6}U)|Hbo)>oKalUp6&F=jiD!`VjTy`u@q*)>c{GD$30_o10fzb97gKv-{)I#hpgE ziSNAeY}MVD;ydFXrmltRIaz%epKFSwSAY`?p$4p8<^5Hz4}8Z z8qTuBXmV9yxTfj1Du>EF7CU+LE~9#DEL+SP&UuPQ4B)Y&e8;33CdIR=RQ`xr zm*nZv%;jR*C^E&WXRGeN=M3Chb-!Y_wpxtbDj2zSSy1Xz9*@U;VN1s2E(uDmo~?Rb zQN^Vm%nu^`PoA~TM_Qhb^m6&5Z(hOq$nqntz_aT5f!XOE+39=yh?^hrpskp#y1r<( z?v$;cw_0be6tk6C)%>(EiKinba0jjbQ<$BnF;$zjf;O>&wq=1pMU#jx-49@JN3!hU z>6K!;1>G*7+a)wc{CWm!_PC3OFEsKr%5G4v`p!R;>Yg_EVN|Q(+Ie z;fGBe@5P84fDzPp(2VOepQv*lvW z+$?u-%t-N^Vgo)_n!d602_t3iv)5X;SFGE+T+Cb0GdGqx9I(4A*j)m4*K)C7!IsLN zHAC;Vz;_Gq-OI%T7I?X?cI*xdxI+MUEEh*@;QCtNE(^Fz0Cz1HA5p;Nc9YY=qe@g{ z+{H%2+(m;o)?H|)C&|a3Qakf)L!Pe5CW5Y9RohxDcbEh6vFX*Pd5$+;d6MT}=Pf%f zgq?>|bWk(af~raZT;2MpiC1;&fsDx(M~qG9Y5HLEY`JO8v*lmjb1~aK;3QwPC;7a! zm>EM*sq9%P?y0#qQ+y9k^RbzgD`+uy7b0Uz77gkkecvpc<=NlInYtpxth|E(b;N$G zZrP#Mb&rF1c}eYR{l8iGv^j~JpLM&gm@vOm1N??_fNQ+4Vgj7E2AMa?XL$a`pK~$5 z6Fgt+S+lktYi&J_wbjq_9&<^zU0YAh+UolhYI*T}@Mzn&c%Cr3#t-0c^mF!8G3Q)g zuH!|Aag(CLjlB%G>@7;J>AbnH2Cz9&)HAKs1xHTVH~Z&c%Q=f z6ApGUcwXFP7w!;^&K<70n=DMF7UAA%=?SDo{Hq#or%+4&*=i#lqUyS0b{5xc)%A*k z&e}^7vSzY4U=;i7F0dM`NYVKkZry@lqpIr*Zh(Q510MJ4SNMRtvcmg4l~>F;meP)+ zriM)##lgA@_tp-()Nc)13Au|&8Z#-zOu8%ogAaNt|E+GR-9|CP^D`?#2{ms!r6kgt ze;wq9@%ezIQT!)p4l_JYT1oZS_s9i*9TVn>BEQ~hvhNxdr25wXk)U?{H%t|z`qo9# zK;HU0rGZr6`kAZ4?+*nS91t)Oncp7_GqM#mD*9NqkVL`X%ixk=em&A_HtHe2s`Ke) zofZzsI$zi?>U8G!g?wzRa446^#xjY)JkMnJXZjO)Gz6`FKEF?a>%F0%7((w2!n_rD z=)D0sn#S~AKMYb;>yxFBFT;Ee3*rJK=;wcnA7>t+kDV^)dXTXtryH7m!kC&l)zf+)lCX$y%ytW z5x8FzY$PaoO^bl(RHukVOfBLw$)<%ZX4Jw#Ngpljmz$_FEv&(xAy`EV^_o1b*}JTT zg5Y|rNDJwhQnJ4mj9B;u!Nj6HsE97t6;$KOr-0&g^`tupuK5+0$TplZfsc9uwa4HO z9N;+?0b^NZU6MWme;#2kpd)HO!T{WtkgOaI0Z<|xwwNXyFxMP*&KAa?k`!T!d?B0< zbF2`~yj50Y*H}pP5-5ax0Txf^#VHDci>)%&IFcyr&rwS(pN}14!7vziO%;xvLN*vM znLUV8Z&rdU%%b91odvC<7r?qzb092NC|qON0t>*mCFn#hDtd-gFhMQ;@>?g@AGQQo z$RriyoEQSaN|z8v8Fg@f}u$EDb|We#+93@n?q{Og9qX!@_C+TfdCr=nY)$S zYygFUgmB4$TQ_Th=hGhmduQWA`!jIm1+c|t5yEhP_8^!D)p~#_0Fr7v*OP_ZhDaOC zj$&P*UN*LWB$4kP+25b=`@}In8$|Z z2@>2tus_=`CiUS2T4nI#L!g@AXkV_{YAD>4FyYxv2<&at7$6*#L({*r+g^UiFFqnmV9irYbqm2qAzq3K1qC?p`w9z1S*ii;Fpn9960%ULGNrTjuM(tM`Cu9$$Vf}2Nr5FA66?T^WpMR%%b&T z5K#*W8)C<4)mkJF79L;l99-3c5?VL_o`LTdvJeZO5^y0LRPqs%eDtyI(Qdf4aeB<5 ziKQeTYP5XChnkL& zoF_J?7t)Z>2}eRsLRi}oB4)N3!>)&N;HZ~`3-)fzUP0Wr>w&{KrW=eL1P3|l<;dXR zLHOcBy7;il`BDqb5uvcHj0NCJuvhyli%EksY5qHCw_e=q!3W5UudC5SY%}g>OG5 zp{NNhLyU>Y4=pA&dwh=S1B7aN4go4QKL6N)s3Ht!$4^YK#qp!%2~;&Ol5t+a+H=Q` zFH9^FoF7C70wTI4I+7-fip7Pg-5zI z$4{P|D2dr1JwTdxnvWpFkt4d(GT6f6`26C@V|b*6;!vRkF^nn4K}HBR0+~56HH#I8^5R(}xjrdSTXBPz~=Vy_DR41(cg%%_ui&g{IyRoA@Q*!;)$#QI|^N9*6YasD@=2YoVz za?mI2x>)}U&-V}A_|9b0!NAZ#pCi^{0fwgGkSo_szw}}@bMxGNyz$yWeJH!~QyFP_ zj$F)V(#zKYl%2VJxbly@(Hy5-XAKeUB)*mjOE@xiS|d=b=m~_1t{>FP zo}rcEdKWvolJ-3tf+%Bx=Q8;q8P8WBJRqQf~UW4!AURuR&v5H+Q zmaG5IgrENjc!;k9p6|jcc3~B}%eUVANqLJ&lWBOih$4H8VwVAzTNjPhBgWdZQe5w- zy$*Q32V?EQSUqpNG5a(3n~3r(ZHJ#3k+y?; zL|TtUWQB=J&0eK8tWBD=ilL05a{cA!hw<@3^_}m#Izr%QrN4zNO)vzBPsc)IL0puo zWSMJ0%X|vpFq#G!m|UDBvh6g>rq!S{*wr?;rpywl>soV2TSHWmwI$VU(}IC455iid z=qU@5;w=impKeVO^dW@I-1xyB}ng-Jo)3q8nF}#)UB&KUaRJDV*ZWvYtJZ}Zl zwSwu|Ha#3g_$FNEH#r?i-o@YF=}=59SMWXMwEwE))jyD5kRED<-&5aT=S_TD+0)-x zY3JKyS5%dT+x~L6_0i9vG}QL&Q0pTG?*Oxc1iXvByNv3)zecdM`M32XKR~g%0|t(w z8CKpSgvcHljVrcLU&;5flI+hT|Mcx1b=G zAiMNsgp&YOR|6HWpaKFauv|P$Q1vxXAqy%bphC+OuWYdbiA&zQ72VG5P=z1H6s4c7 z*8TBhlX^IJzgcKE3)@w}3@T#JKdS`E@wTN;@KHD-;fx%^-{F;F1cDS0{|q1bSK%X% zR9*iI!W3V>6q|GqUGBHL6#FFj3ktli>iQAD@%5YpD(;m4-%tR15xxWfzJ6b!g~|TH zM(2M1h>6NIeq^O6{J3N2{4|hxu<|haK3I{iP(tNC8(cb2H3b^2>;`DG(k20l{m%QL zpYDf#aX;V=Q}p~xo1X6P8~w$+!JEXA5dzIO8r65cq!32Bfk}#Q%0==qknSlyD(AXX zJX-p%F8uo|gC7;w__Nh_3jAoQ?QHd(G(TE(Pp;b$w{Doze;HHlmIvYo3N?`Ei~YqR zYg*?Hh)o-y)tOWp5L6ndp^~-7#X$l!sWd34GzcmQfMU`~r6f@)DX3)9VF+~i_s^TF zUx!B8iAGwWk=_K2tP_o_KqG6Rv00R+lx}-A-8u#ww&2e#iFCI5_P;`0q}o8ZxBsu8 zckw7tYf82LgddId3#F-8c((fX#n{y9(#LsWNa$G4SKl^Jf$l#>_l)TN*O}HAt8agw z7u;C^^AayWh761H3sm;FRcGMoPx0i=h$6aAO|3pNBpaHt0-ucd92TEL;xjEi zDbuF4waL|?1))OcVN&NQ>ns=yIUmRyV7A~swI5*QI3D2Cvah!X^82%Nm1#k8b!=4c zgAKJoeE=rohV?LqHmrvqV#9h|;2YM%T(+lWnjad*7j758Zg~%(B z^}{SAcpYXl`HRR2Nz3p-mkO&{gBa0TW)RCaQ3!$~$S**qTtD9rub2*dU7||f3abn_yCn%t#W+jnEFM?FT;Gg|ohzA$>VmXR{u)$iS@UNMk7}B{B6lyY;pgDG=U%C!{h!7-clkl zv~-VwfMHanyhUXP0>kBAa=(xoj=uIrb6o@9VX8*TzT&MvzdJQNvl4v`X3eGmWzXb`*aLT+l zPMP<>iQ3;UPK4CoW52f<%}tHb?Jgr_?%g(_6K-3+mg3uHR$fx3eHOK6vdh;~P*Aq5 zz+^DN8wGeHz{_>ivVoa?2_r>c+jReFn%nL_&3N0DZFk?Tc)%yW--*QNqJ!*~LLB}x zSs?$a;}kv+kH<&iFshzzN&GyaQej2xia#K**M%{ zv)$?$8Pc`R9|j=`|JSj(*@dZv#fjNP+IhUc9J%6Vp z3#}UKtKkii?4J_WJ8m>Y(ZNyjGSLFg$4*P`D=xD!RW`qf#E891*>`|&;*G@?=T0P3 zkngU0-E_U&_-OORHW;I1L(t-&rax6~f{~syPokL}3QN5e-mY!d5j9WrbxN>=3EyJ1 zw1~sof|O|--i?j>OU0d}J#QDL&cQyulN9xx(wu3$uuaW=?qi(1a+Q`CQZ8Dd*z#6b z(A8TmpNu}t7MQ`kMxC8+wsJyhDH)?OeHfPnuz6TBj6MNGqa1D;V9$>#dN%K121MGV? z^7Nq-ut(GS1WY(6753jI7Uqeb*1Zc1K zUtH%QpdFz+HM5iHv_L1Iji&XU3PRh)cDVHgi<0kr3x^Oki!BvHq~2OGGJpV+{p3gJ zDDg1-X=GeTZ5{$61chGdy8#F+8GnQaO~fr>=!h7gMmnaHE)KK6KD9ZxC`}M0LtUY2rL)~*qRzF24)T$8z>BnoE$$k(LcU0Ar}a#BlXA}7fR-c zb=7DLZJ>vGHH2&^5@6ZTMJU8D?<;4flv)V6-2KTi-3iMwSoI?4dob8D7>-! zK8AcV7B^qSiX*(k`Vo_w!R0+>krr22B2Px1$wC{G)>Cc&V5G&JaP?kX0=N=z9`q=#>wW0`AF-jrTPwHMPfm&YnsGlwD4{{-Ue%f@u}sW;xp3ek0;SrPu+y|h!6 zofty;V(NKgqmX`=D^FYdC&(!_Q3&&zyN8#CF6nC3=c7P&J@D515 z-Mj-*&wORW5ywIB#=|>S5cM%TnR)!^1U%8SK5ZXTugi&N7vb5p9?w0%^WCG;2?fDC z8bfBVq$VW;n-kh%)`yhd6-0x~7W1;Xj!vE{$SK}jpl>9aYiQO-4$A)y{TeA1roY5- zj6#&gBZUeJLd2>w6@+jSVwa-2vLM_Tu(`=SATlLL3?tP{96riplVbXVox(WJ9kQf& z46isM>qEV5hrp-Vx^r$i7AxR&?{ZZfC7e zTCSg2xfuWDFI;!WpNzgzzuiT`A4IbSjVZ%P+zV~ou>i4jDf4MzgV`irLPe6MO$<~G z5ccS~7FAs+(=Ttmip#EiXA-f*vqrgoWwdnlYEmG5sJY3LiYEWYNKOBu&PWk&DHqz7V^F*bn6YDh1LS-Eu`k~|fOzHlQ z3c^SakzBvfQbh03)RZ8StWU~vxj`CM%H{NYX{g0z2ynr(2(LZ>(hR`ssoU?{!nO_~ z_ei|`w zjH$KzI~(lRrp+T~?Ts1w#lEjOdG3olNhc8GhF_0f*)(G|UooZ*Rm{j69v-Q*J`Ex6-hESmy_kYE`Hkds zW;)$KBGF}J(qcd{y}P-t5wE4Hmuc07&D(x{cLv%-4Ola8H^JyFMr1c|FM;7r)Ec-J zzRQGD@1yaKpWmHK1G4V&aQasY33?j)LqcoVM2qB$F|@R6(#XgW%$yT}DT1(Wb(Mc9 zV;Yf54`Vemm)AJ51X8e(i%ljbrj>k+V#T;S*Sol`U&7>-2PCPN?q5Trdw7>Q)E=>T zSamHu)zkQ9pk!Z{fR;3J4u(^Mij4{FTlal4jADS!)VI*IUF>7~jSnJ)e z_7fY{hBvC66pUxcujqxlgutx2UKiDqtyR}b$xVi$`%vA|Zh>aXEiacE^q@UUM869=)x;-B3b=eJ$6W1wj<$7;dz_8yTCHVbSmCF+!%5vcNj#X| z*8Axq^kb7%_KY7gS!VFqZnH0MN=P0WDElbjN^AI)gJ;Q-$;J>wdX z?YL;@84RpYl&heOSW0688~bt1J%ojdPjp8aFG-x5J+*+}z|hctOfj^$I4JFsQVPTP z6$<2(`dOqC`I<;D?4~SD%~=Z~c=tmE6&aEYKIHk+_ze%_8X^IaO&mWyacmL!n8-sq zJ~w}29A#Wr-txq3w?-+W@IRB!T6mfnyAOw}BZo6wfR>yg)C*zvSwKq3EHM=-9``8*ExB4LsF&Ld#K@pYBkG26)`|=6=o<>6gS9VnSb=d%? zU&F{9VjY=SJkLk)(-#!Pq+vw5aW*k3e*?oBSgNoX50hYE8B0Z<5xPgsO!tO$X}gXJ zGjq5TGQ_#E7=AkC^zUrCG)FX9h6M3T7~;o696<$#FUodOlYfc=4GvGaqSgjlq+Mlt z5NH}9x3L2b92`XxosJqz905n$L#A+{m18$Q$r`+p?hjB(S|;@f5(ALkJI@}QSQMK) zK3ihQz7=H^-XPwa!q2H7%rR~;K{sW&vZH0VL3$V~OinCJAnSI5ogAlh+{KA`WaySe zq@-M)`?Q!s@7{x-R@uX7iaoils!Vz$Yj8fOgH@k3kIiO2Lc16d2E2rPA5yJ z_r>u+9q@%!;q8Kk3?GQ)Q@CUE;=Mdc0orW13B?)du+s+DaDQeT=Nf;+{|H85XHOwe zWyP$Hou&;}xyAa*HRXi#cADdQL{F`A2I2L#oqi!FR=g_5~> zx8o=ihL}Tdu;;81Uuz|h9Tr4Paqc8hdqEwFDJ0C7Pn%>Ci!pB!*3saUf@XCMaW*+K zu+3v>!5BTP0BmqCfOrK?GT7!6To%$OQ$L)9bC5ffPwh(<@QYLjCT34fu-$BQVt(#3 zaEs2LoSPTtmNMk=$_76C^bw#B{Dx95E?Inp=_7&sources>ACODE.;2 70480 - - changes to%: (OPTIMIZERS CODEBASESETATOM CODEBASEGETATOM CODEBASEGETNAME) - (MACROS CODEBASELT4 CODEBASESETA3 CODEBASESETA4) - (VARS ACODECOMS) - - previous date%: " 1-Dec-92 02:34:00" {DSK}sources>ACODE.;1) - - -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1995 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)) - (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))) -) - -(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 15-Apr-87 17:59 by bvm:") (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 (QUOTE %'NIL)))) (CODEBASESETA NEWCA (+ FIRSTBYTE 1) (CAR (\FINDOP (QUOTE RAID)))) (CODEBASESETA NEWCA (+ FIRSTBYTE 2) (CAR (\FINDOP (QUOTE 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) (GO DOSCAN))) (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 (QUOTE \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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3070 23591 (PRINTCODE 3080 . 21406) (PRINTCODENT 21408 . 23589)) (29591 41748 ( -CALLSCCODE 29601 . 41604) (RUNION 41606 . 41746)) (41749 50457 (CHANGECCODE 41759 . 45241) (CCCSUBFN? -45243 . 45954) (\SUBFNDEF 45956 . 46218) (CCCSCAN 46220 . 48975) (\CODEBLOCKP 48977 . 50455)) (50458 -55551 (\MAP-CODE-POINTERS 50468 . 52011) (\MAP-CODE-LITERALS 52013 . 55549)) (64369 66803 ( -\COPYCODEBLOCK 64379 . 65074) (\COPYFNHEADER 65076 . 65957) (\RECLAIMCODEBLOCK 65959 . 66801)) (66836 -69241 (LLBREAK 66846 . 67345) (BROKENDEF 67347 . 69239)) (69568 70194 (PRINTOPCODES 69578 . 70192)))) -) -STOP diff --git a/sources/ACODE.~3~ b/sources/ACODE.~3~ deleted file mode 100644 index b9c80ed5..00000000 --- a/sources/ACODE.~3~ +++ /dev/null @@ -1 +0,0 @@ -(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/ADIR.LCOM.~2~ b/sources/ADIR.LCOM.~2~ deleted file mode 100644 index 22e6228c181f9c5bdbe58064bd77021e89a50ffb..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23208 zcmeHveQ;dWm1j!|U=rlCWW^B0V;%}0k_U-?ufGLj`l-9+Zn@RB>24X@DDK#98Odr} z9$98c2o!NV4#QCSFyMgWF^LxlBur?jB`RSUn#tDe&SZCMvbEGM>>snWnLlP~Kbv88 zYinzF*xxz#-S^RwfvWjqYpSS{`n~&o&$;J!?z#7#cL!7H@oYXlJf6*^hqL){p=~dw z%~aVO%cZq}Y`&Z>=CY;2fVRD0CU={=Jds1)gH$ew66JJC8_=S|<1>ebjX)rv>Cw?3 z{$c~#;K1R9V<+ZnGgWQjI5ItyD(!ywt`mz3M`sQ%?L0P9t<8KTI1=7@a^ckC;hB>= z%~ZBHa;Gt*bq^Tv;faIChvRWg*GG-;s1X>@4lT~u_02qZV)5iHquQjoJ6+mW(&kWq zZhV(!gt?p%&_+f^2DIwIB{V)@$5QuVsBF{-4SX~WM&x7nSqp{YdQ>|+d+_-EGbgpB z1@vujJYUkftsV|(Cl+TOm|Hk?k~@Xu0V6hSo>&}?8=4*-4aP@9;g8##KGdB`=V%19 z(NwH^FsBU$Gztz4X}%tx&)1Qtet)ht+gja}xE4X5-#4g-v}qJdmoekY9acw%A%cXajxe>Ft3qunzG?7cC zOJyw_)bidh0Rj)e5y@*?ew-+Gb7LhzlJ>Ei`>&m7u1D)o67-RxG-gRw;~w>rQ7?C^mxy{9 zUb|IE;`f@&%6dOPT2J%iasEBSGO#z*)zFe_{fX*a>vFXbl_I;(OtP3{{auZ}PF8Ez zw9Ypdh%dia+tgaUhF?=W*oUre*8h~@@?4_I&u5wvgO4W6O!7J^w6Fei-=GmRv}t>& z48wqISvq%^FabVi^Sd-X9?_=F0vMlyo&YMQQ(}b2ury+pN2mhGDzFVWSuoJ4W*3^Y zkT(n=F`x|!W;w&)GXfDOpi5LS&UB!G@TTiQO-z*;7RXE3i^nXS#5hbi1*R21BQXh= zI2R8GwDevxSti^{N(j0nu9z!S#a4aj8%PdlgM;OLg|s%7&6~x2&_jAOuHwq+z2%{y zp>Fi(3c&d&gezLwaYVEtjwzK$l1=;rK#nT8rXuS(Pk(h{4#%)^QOLU+0@7)T&Us68 z4*5(eOXr&=OX;D`#A<(a_4))Wc|T+oy8c>6zeb>MTulb`D+pI;!*~)9QWTbaIMTtS zl(LhBTzUk?L&`&sp<(*YK@fB;H8nZ8&!tUvcKLi=V?8%@X1dm{&-PYd9b>Gx=BJL= z8G{r2n_!eMq5IbUO{Q~i{g=MMFad-bENG!9I+xr{0TSR53o1s`&H=faOizxXzabrx zmfA}iekw0^6n zmFszHZ=!m6x$os_HJE5M?rkQj%+kgr-h%$dxD=@in3l&<%yB=buiTQr6#pCM+I4a; zX8Zg7{MK6SI=$StKjA;*`=)HMnV9E+tkxcCJ=Lr|T<@#a?rS~StbOUR+F`K^aRI$+kRVkeBU2`m7l^yO}U;lGoWw3d)aw|1_b5q=YZn@(&F*4uNdq5cCb#A0`12@=e^obk5 zg`eOTMB{g7>lyL-{M(h+oAtNF>s2xG{)(`AZiio#_z7nNlD^o?>9nDKi)u#FNrs3JXS8FPI2@5EALRj+D_F3XsG`wQbt-U zzbSTDgH-941pGwwqlOpodq?ZM*fEbm(Z!CsA$EvcC8gU`#%-K&8!~VgkBh z7-gVmD#d1{0HhT}Q6eqxLfQl)Eq_I%<=q%kNXsS+4 zRG8cNUD2MClEexj&F;r*ES9e+q>YILAq@o?Y1{;80Mf?L3XnFgkQPz$5n=g=upo^~ zq>Te<<3d^;m6*yHg1cDf88{S`}a>l(p^hf5!A;Jbd9c;Am zXur*){mi5N%%lBnJW|-$kR)J(N!m{&S=g|NvamrZ5*r?l0vnv-X6acO#n@1p6*k%# zG_B~KX1b@Z$e;r%;{nci;0g??)PRkffsLAtjaoZ4GRs$=lHeet_I(Q(EB^_&s6psA zwJcoJ2p5}v%?N31gF+H+EpH0bPpv>9}dh_4ZpP>`X-O@IbK z=@D_3pmbV6X;BHlA`8GGOUh{prPF}YY4M1J(vr%!#2J@ZQcll{M+i#vbfDD6qX%pr zJ-|GAfO+&l8;?K`Pcs{m1Sl~{`-vnAN;Xjzlqf~KLDP(fqks~pxLJBuMtL$5Q)!xM zXV8O+?gyFf2d~JWud0k+<&0mw0)r}#!JxYdP3-^p3_7nep686`ufU+n^T0|BSb5&Y%JW{V zOjsKhiOhax{eecfZ9Vjt454=bq2~z$M=c0FPY~*q^Q0eJDo@U0t2U#;ELdbwJ=6I&U`sUdVBxw1Ve=e}>}k#H$@ zF@c_OkI?2-!hd7sN}o_MKAWVmQnN_bnx9uy;=DwiqEE2(h2cXQJ3ZAo@R^Y_f3W`*Yaz<5BzyXZC+i&ah4rnHVk5m+8rXcsCTb~VPx7Q>c6o>apzPK zbWXimrTuS^XnqrW4cLl%`*n=b+m?hb|KE$){taR$H($;qGiEU;m60iZ&lH`C#=)IDiB<{kIEr(69*jkG#kgP$Nfy6@F*N1M7KI?V zI~R-^-rfcyF)z=8;TX=xTtgg$jJHMLsMpm-2t({C5P~FoB7#vbn}b1|{dsa2>mndS z9wr8LcqDk3s6%#D77r5{88#Dja7Qsw$BDPA=YdF2%bBHeGE)#>aR35l@zIFmWY2z& zFw(5SGiW5-ore&4S!l$9UV4pan;aUEcw3Q3)IGdLBi(Q z7Xfk=!&oqlU?}e4DNcXGb{02J4c23dr-lLUSUfchVA|oSVZb9oF;0&Kop+B)GU!0p z)7wDID>O!+O(gUupqz2E9DfqX949^+mhK*Vxk@boLxO91UZ7KhXS5pFy;lM9>f8>#dAG~ zV|IIv(P=hPDF$TD)rNuT#KTTQ_sXPB0Q2Msv>{y&7;QxYM4>(V#UXI+3fhqqYtv3K zFwUJn+7^yL;d^)=fgHM79|>8R+tzKhX+Adu^?s!XIO*a72G2-I8}2HmEMz0 z!qR|)gnET^IeB0{psMmzF|P%qc6Q8i_K`k@nIuueoM63x0*(R71Tl6DWoI3vL)j7%_Mf zhWQDpvuh1t%vAuUFa^|Tz-1NVXD7xmQCfj+c!ZHCpcy>^DRP&AMvw`R2Ihtyf+b+r zg3(f}(e$8{8y%(}^$fbiAyGH zhRH9F+BS>S`t2Rmy5DEDySMuNMC(V1uJakRdTz|0akYuw)&IS3&@+p9TXj~Us$C+L zNR}Q*q!y^rFS3`IbWW_+%5?Z#YOVH|(k}-tiM(`&vnZ`XtH8CVf&5l?t?MmmJWs z{Jv-&7}Bm9=<{{@W_mh&8EidonLpTdk$E?NkaxM{A<%r!-}dxqTP89%2IwkI9IR~b zTJvKMWq;=V#ufy%`j*a$))d=2D%+din59>Z_wpJy3T@>JLJMwcd`@h)hUmvC6$Rwz zVF&J0LaTPI%JbP-j^!<_W#50SRt7q(k}F%9*Z}nXOEJ*dvDTHnZ`t>jlafQqij^|G z?0ZqAe4&{~$}__MRQABK@7q=myq>XgJl7PP8^2@4S2ow@Rmsmcg}-qi|5Uc(ukTUm z{`zjGTyNuU72jJAI`Mst+f;mC{R@)Fi(>1mDstlB)`|6Q#;O#7Z+A{VY9xWyg&`_tI& zm%D;*B5VEUvJ-!3w}S1&Un61dI&i1scfgvC-*)l6qAmNLu2ybVoPUlP|8;S*WPJUU zMe83lbB&``>~y`NICp(B-zW+Hli36H-B#*>x`HV9?QevwXt36D>R9^%4fu2*G# zpEnYP#nP~Cv8uZEbTjvI_KmZWz9;iP%)Uun{q?f%vW$9;jxBvpgVe5UWiy-t zZ5I3ib>tzL;IIF-%zh!)nB^#tWCwB8M z+$8&Rt6OWMxp^MpwV9lX&sSF#_?S8NX+h#N0;qs_^x;3fy<8V& zH&`q>d(A>^V?S;>pA`8d{N%A_a0lEeF#eouu!o%hmbk8fJH@lk)D7$zBr|A9$7}!# z*M5ifWX-jD02ZWUzUTog80{oXye_K)lZdl#7Kc^l6pLeZN2^BO#fXQauA~^uW6uJU zwtv&bq9|f@5ZicKg|+40P7J|HclRTNMVLhjtz1eOF_lYUN~GQJ4X0_$o09qMj@UXD z?Virjo;jOM1sKZo4M2`84(u0VmFyJWmoJ-p!BX(xmJ#~sAiPm3)`siL(0<7Vv6!DX zh=u*UE;fd>i){^QF|0R~Q4zzaI+J`9|3)FIRtZ{P z@QN>jh8)Wvf~MA2MBBukifCiZs)*KbTu~TikhSb2d*7)O2MP8X5-T%n?HR`z;8#KzX9-nU5G-739t!iPyiQTlQke>KDT40xalyqBV zkO*LbzWuOPT6zE`pIkf);e!)rNfHO|X%!Ji69c1oLJkKW#uE}V@DNrPw4BJ+YBTpA ztZ7H)W@=UXKG5mq$=brwKsVWtw90VzL2bn-J)3h@TjU|M(0< zG78NyzGjCp^NE@GiJ7QA8?+40z$a#+_K(L*w7;$V|6?uY#4dawY=66n9Z|S7(2i`? zhgCc;g?Vv`FLQt5gjOebYsrb=pxmt8D8ym7u+EPAm%;!nj3F!)D`>B*7gqz1ct zda9HrmnSUQ;3hGRO-%Zxf5aTeSLGw=y;*#rjcEE{JcoNf#-_$$C)1S>be<)PVI707 zhD+)4?)1JfVHQ(3VbZ20#W;+>atvu@Q8shsEcQ8ZDB>v&d)jVwEIlrY=@E-tSe#6c z=cY=TJ(FVh-Pk8}`UY)qF2w@4nMvvGaznUwQk2$C7tnnEmu+xo^Jq8QxUkXy;R9r?4DX+P&>+ z$gOa$#>tS8AG5Z_a)Wcc_2FdYX8DJT*n7v>FP3F;%GKZ{fYqXPWI}6Q zToAW%sACcyzaofFm-rTL4*PK~RGVXAP@CtA5PwZ8@;N;4OkP zIgUsPRSQ<)Z82E)N(ob0uzs~(x%)U3wt_58I6P>}u99g%8^Ib=UPS{JnE?&UO|Z^Z zATCLK9Fpi#AC3SxZ!90RP8JXd7Yl_HwQ5)6HY-(r(k#zgSian^F0pe*b4~6D-dV#2 zm`j!b;dM%f_jxuFEApvyiw%yaU3Jmcl{*z@fYZ2Jf*hsBvwLwo0-;nwh9llKr2~xw zUk*Dn&Ky0JeS{DpI}f)t3OY`AJYhJdxWm|Vu%yE(0RK8~1bKo?W=n85G|O<4@Px3} zB}GHE))vMl8w&&Ls*<@Uy=T%jv0(EhO)SanqUnW(_ao$khjHaLemGLI(c7F$5S(Ajz6rwxmjE~H1L)jV&j1MR9_*lBl*%^Y?p@I1<4NT(c1WyeNLcfpiR)T2BGM0LZ zdV*YMJEBb7pQTF?z~Q1+%8riiz{(|=8J2r{!{bFUxdR7`*jl7CzGq_?GcD98a_!K@ zai=BCoe>$0jOi4{rj+K4a@5>o1G-}CGLD0{AKK(N9XzA<$pQx5 zEMoj8OG8@6S2lI|I^c-FLU^yge~t~5dwctPy1KGF7xXe~aF0i(x1&eDhQ7Y-$Z#A_ zDo5W#ct=ih(mFN#k@Y;+oZ}DKJ3gJ`0{p|`)BM;?ehJ5$|02;SOjf&A(sI7xE;%n4|0Ts9-8t+W^~z)vNJ6BO&VGY-O%RvFx*lx@%WaR5OBG^dJ;FJu;o>f1)MPeQ5(q)qFXIc+#f<1Xx(#=Wal53s*tx-(6l8uEuDgO!U@Ik@ zow@Xa8*%_iOzw5ugjcvt=2K!Ex)@HFqM*T&y#?+`aBPQPT}Z>0z%D2?Oiik099cQ~ z#$7K+me)~{ifxCXHVF68NwFvGp{^aPxX%iQE`zXw<&oWpt1U~zAWH;pS09>XsM|Fi zI};Nx=4fh4lT9gax@$H1t(RA==Z~!Cc~%$o&+~(|#P3%-U|uHXGoRhO1&8+U)0z`3 zw?3x<`S3z)IQZpb6DBjaxKSNnk)^ruoYzn zn2ptGaZj2ws`LRPJYfwkZKS;A2bMTDTOVM0{%qUcqpeq2$z**SS4KhOSf)-P|?x{#ee_JJv{L&}11;L2IS&^fSmjtMhoiZwe>tL>Uu8asTVR$5w| zJAOYw0`RxH4?AEwdwgkT@yNl$Glhfq&oFfm9y^C3P&(k!$i;c&RwEV>w3NiP0rHBN z%&!tm#;nxStPlNi9U$L%w5$afM#gT24kX(;3dwgmiuIYDmkw~(^?8t{_VT_YCLSy+ z%NpI+i9iVi6$|D)_t+7*s*U2c!5!M2+Q6xkGmFEunFnTS+T0xr+Ty~grMcrXCkKY) z4VfwHCQJJ!N_ou}^bKo1Ei3Ow>?Uo;wt!3RVI?J_)J1KsOV8TwDMM@E3C#37?DWCz z$ti4N&^=~SBa}u8*d?L5M##Tc#1A>Fgn6$^KwD6qqqhO z3F^}G(0w55IU!bCe^9bEYrBcJlAn`ivIt-Nq?s4_Y!Ww#Iw!tPXLVPsyP*-YRKksM zFg0CyiQ+xCl5XVy`a$uEzX==S|BZy_VnbhrBm*5Os8??0m z<#bWz$!Ti`JGWQuqbN&;rMSDvx=>}PUVN8lF>C}7agSmVCWY;pSzy zM-1%5|D6N4DwCw5EWoz5@sj25_AE@~VjgWzapeNFi-J*1ipkTpnkao4Eu9h~G@4($kLnJJv9YlsQ9XDH zT^@4B>p?U)9*PZpG|K;ugo;ok9tw)y!*d6Z-#dF!oLU4y!+VTkNf0lRa;h{Uh9~nS z(MjZpII%Q)-~8g~liYh08`5KrOsMka#*#FN8(~8o6Dtl8o4o}xD!&1=tAaF=~7vQgCd{4TZBRsaT~n` z!}Kcj2tPDkl*-WjDG@ebP<#Y>w*h~yMHjjf+%f+7H1)~ik{*C83)5x5M#w^%>p*o{ zfSU@dL|6TVbp+7sG+@z-@@{%j0h6FAk{fii->JvxC`oetu1&~thAXuCZFdcvE0nV` zZ{$Rf@CI?ioRoxaidqv!GMO%wAam9Yh@EJ-B4JD{?H~~$e zigBg^4TLvM3ko@1W>_FEVJ{vtaT4P&;S`v*02+xYxWu`5I3Ut{jbxc{t0*DplDZ0v zPiDntedrrV4v695^1eb^Ol0#$aUblE7L8kR<@Db2$jC@93T^U!- z3Q4MozX!-sCD&ABJLl=IM$F+DHZB(O?u3GLo2qlcRGmXUL+R3mmcd$js5`MTSY5d` z!A9N>U4^Z`+Oe+@*c(@qL2U!&3auMY3POg$)DK5Hn3Pg>s*p>MVYZU;(4z~Ci8&~O zCQ{Q=Q~O-jWJizB*E7*~LwBZU_1bKI_0Z05+-!t>c7c!@2&sb zHykE_P=f^#ilTGL-4q}N9y6h$N9`QYtEu$V1o|7&plPXnq&ZQ=EG#Xm+AyUU*Fdr>udj3Upv?L*4{+*^76n-)oL)&ZrtY<99?*KKjI!WRwJpW z5xtA!zh%FzDm%(;O$`qI(_PhLAG8~Hwx+mSW*=TQdK!PlS&Zu%|It;C->C=P+}vcF z?5}md^ONL!`_fbwm$6Lrd}ULsHlE0E5B4{bne^kk7T$e$S7l49GSD(si>dD=GjRd`*PY(jD9@^a6=HMEto&Oi9i%z|M=XDj`@BbUs{c7#D z_H)(R9pG+e;hnFwGJXB`B#wPxGX1vp^VQmpcH;{zxsqu&Hp@-VbLD6Gx6){3GwtRr z$NsiHqB3lin_jY#>YJ^%Zy?v>naWD**awx@S_!!#Ut_W>I<%*|$;_{eEwmfgNxjP5 z;^vX|T{Q+ScYhNpKkxP*Z9mVs&-}dm8?{usa%)SD%~j>CD?Rh9UzP3dTwnWBUuC#; zv~n{wd}B-AdVaa<7CE-i*MC6j@^x;cvXvWbHwWZaaN)=J1=0B3(SAz4zVLSC^;Z3D z`Fd53z2A^#Z+w4IyQST@RSwIWjMs6->yYug$cXO0dzPOpl>X(e8<KX-#`#mSR7cB`nA^F<>f1P?SgF>MH$$cO0iWb0BHqTR7lIakhY7F zmfsL*c{heEq-9!i7m${*kv8ehMMz5lX%mFBL`!BEX}f^5dt_d&C@l)vS`=a}3b7W2 zSc_I5ycN=-m8#se7HKItAzuRwCXj6crUsc9X%vt8sW7+kyRtJUCCLUM&F;r*td_4? zNSlxeLK+G((zprG0HjTz6(DWWLR!Sqj|l5WgcWI0A#D;!o0MwSQHfa@W1KO@iZr=^ z?gMG`bdc7;qj8%@_Nau_MU0Hoz?q~$ut$K|WP!{bc5 zx!LHsynOZ7Ib>Xi*ZYCE92EbWt4ze@2yvhOKioJFS5??J?!v}V#>Vjtv2on3^%gef zTJk8cF=u1rh&vZyqY7*sB5ZuACFd9$M;RN(Eo_u+xtCe)WtMxnL+(|1bS*Zj@(^R= z5TtU5v2m2KLGh^Hg^kXf4mRw5bYSC<{1RaU1sNOM1ZV&@4#}g0jUyH|_E-|#!xG)Y zqCcXraRk^nA`dAmu-D4Cmox5V(H~imhX@<=bgdBd}4ku~F;9MrQfS(+V6kseRu>M&myN7d0sTRc#X&HNwSJzvPDf{A*2IF|Lfu zP3M<;ZZqefYCl8G|1ub9`g-nhP3RtVLFpVr>Cp|L^r#yo7L?AmNNS-4oow1;_WGTQBE5H(K z${7WvGl0?=`H+IrDJ$bC&UlJ7<;;S7h@eDI2TC10y3gj(eaxf#m`C?@@CXF)FtaX6 zfD)6mpGY#HWD{jViBjYnG|YH73Mg@ko2BPelqWMWm4=y42HkJbeLvHE|Aq|uik0yz zobf9gFsSkfCUiFdN{`r3dc-@STkg5ln#}!Ap3MCZKegZ__% zl^0xCxy)F3VMDCE;6{OkmG8IYWnks|HdZdVa}ida0ah*&R-S6f?=w~|Gge-(u=1F# z2amBHJjQzPSce`|<>j?lc}8AjtXzbYE;3dwGgc@b^}DdrnbX0F-H#5eT$E1{R#1?! z!cBk%VCAB`Ojx;OVda~agulrW{wAx!C54qsz{(|gQDNoVR>p60#&5GKTw0J92`lt; zu+qV!^EQvpGmp+QkIr}S$im9HBmpZ-(taYz#EMOni4{swSn+TaSm6{mOV6n&#)_5M z!b&HDp0MbCg6V!@Lk3;2GG5?}7dBu}i7KzM$X8nO?xMMx^ z7Yw0y0HNmy14m5=Jx37gR^y}}TPlywVXHe|!)o`2-RGCPi_-tB>|eclSEawT+?}fU zTlN373%|?Vv3#|5L;Iy_?RIQsAg4g+VzRL{hy(+r|qU*l>O-99J-v5eyq!0ZdHDSal1gfKR=Q$v(nM-kM-U; zg3EsFXDy@XJLurMm3pi43X0FA8tH_5Mb=e$wWrypG5%j$WBi}c-j7u)_I|8a;<4|4 zv#b$oRngh({2Q{re!DYuc+aZ#uc%t9l)D0|_6Mq3>g`YF|7Z?`@BSedyr;e`w|X_d z)(60!r>xDZPjZ|&k1(1#vBlaQBDPrXUJZj}IyCCPvqo{}tRm=~^=g*(zd@?`4eT{w zEAH*rA)~iV4PE|!&tUsEh@ISgIg`xbyjZ5vI2H`VMQM7%-24seIFdlnC`%j!>d}Bm z71Mig%7vUdHjLdlu@~&*#DT`lbYXI=oSrJE?d7nBy=GT_4K3UG12Iosfe6=Sbs~V1 z7$+-^Ppm*Fjx!Ob&QLrYait++M;}75D2_c{Gs&SyG~$pPibSH` z;*ns;$*OVVW~W18oZNVt3I`+Jh)}$vGogT27@=UOqeu|D@h*DxSj<}`$;8tro%(nq zz)MdAG1nWR#l%fF8O5TpZ*;7oe6ajc9? z>AR-sR5T9m0Qy=)E!arWoQp|6R64tbau)Z)6Ai5hg*%Hm-n zBg1B*2JTo))NtbM>Ukg%6gi_*PG$-cEDk`yOg`#yob1`}5k{IRJe?%r?mU#p%R)UC z^wO(GJM>VG#5;;aqHgi(k)T(#^)RUSG#c(;vL1?i<)#PMM1Wk2VXT;XFckOj6sNyo zJBypAI@>Xer@9XAm^{^WVA|oSuEQh3Vw@HWI`1Bnq|9*M2kTaovxsDFPL#!>upqv2E9DfqVVqVv=Qly2!mV?6SXif>qa;1bllG3W}+4j zD5nrcw-y3-OeSg}z}eMvLXe}FS}5QN24h}8YC#;pn>^QoIA*uU7>!0FD@BLSx!TY% zoOnppHLp%;1TasIKnK#bfZkCgKor`eUmObOuAmb+u@37L1LNHJqaEQ048Di=5$K_t z^^x%U>KoB9%vstS0Z&Z6hvRPD4R;P79^8kZejrT^YdFcZnH-|}+y)cUaCi`O6$@fy zaKst}uize$!J#U9*3s<1DW~JG+-goo_wD91HKQ=Ck%ke>%BDr&a6yxXJbV$zqG>4S z?iqPbcw8_r#1dPKse*t4s`Fs$fZaO34zd3doIVNy=;6@_C)Hsc13yh<;J_oo8U%wj z;fAAvF{l=KZ-q736L$g}JY2y5ER;J)W|NBrFii7Xh(=2F76V($vQPpIp(v1_oup9_ z$S9_BMmf7DZ6BnIU=kx0m$46U@A-j zOB(R7h5YQq7zRo+&PJ0; zEpbTHbS>t{2`cJgO&kET>WsVi8HF{WZbcyqSFa*4JQN)Pd`Lq=PzW>_g#RaTBnFM3 zCuta5dmRgIdAZW4ZWPJI2-Xx%Imrz9s0QIZ*aPpuiGQ+i=o2kN9rNv5{Y1u}Xup`~ zc`92?T=zt4V(;%|X>~cV@b<&_um4;2q;y$r+g-IRPfAHCZGNJ9Y&&{i&2ucG~AK+at#d zN_nZ7`!6qbdRK1c)^WOSdSE`Oye>I*&heXqhOg@x#iO1%HUPb*oy80iyq`|Ow!*O# zMqgQCXp%KLVzsn0olh4rNMWpuSn*8Uy3Sr0@kT^JV621#teno5DFDy6qAbHxj4DCc z#U=`BR<#r$&qix7E(pk#tTu*t@5o2vxidl(l%KLm2)x-WN(%7%qH$nETro7@>-Np| zb@?*bdfvQnu;&@(-NHfM4B|YrGeL{+A&x$&qo#R;E z(pvWYr)p)W%PiU0+`^;lAx15w5QW|E;%(CwVE9LX8JW`&L{wJ~r zmVMtcbKv!?nd8}(+|>LXGrqE^zF?L7Tub_!2l7v3EB^W(E8Sn;?Ud_p-f6}6*Mm;{ zK=T$WexUw&MdUMb%d1x8ma|s@RlZhtcMt8ueXwo0>u+rSH1-gcU4JRX>L)>C*SpM0 za(w#{`Md#t!|lc>m{{wU!rcF^)*hsN&o7b-*9hF=j{WT!Z1<~O!8eh${!`V7KeSuH zcH%FQuzC%+)Ac)GP1kR`_+Amqz9*}d8!gU1%Z&e;yiqZ}e%hq<4_dkAQ8RX?Ua>fL zZ7bg_N&n;71NGfz>VdiiQSjT}44ctlt?AU?_-r2P!ey?t%KScWBuc@$Xmjf*=()aX zb?wPk?xpM-=M;U9=YNoWleqfJW#45L^(-A*`kn--J=w}8I0f1)_yg+511iB^|8151 zVy-#IQ6R^iv%h(l%GqDvsd7Fe2b#a7;s)wLcit_{n^gQ3OZXS%)>l>3)^lPU?9R5oGxtY1`h6o$zi-M-S?qbk)ld5Q1>2`9eawm7{0le9!Q9H0+IVh(CA>PD zv*PpB#v;En$C|&%?|C!Zz?Vqry7K(!?wT8{8+qtq~C7fF{vCq+l~J!{d0qIQ}t;(ZBX`C zpU#pu@s+Y4X#*GJKsDQjP_|T8ZsCOM4P*EJJK3|$csT$`Qqxd#DW^f1GDVY2@*)Sh=0$Ad@0`3&gI#biJXOPUGB@LqiX1Mk{W>4l=s|7HFbfzy_ z01HMt2?MWd)`3C9**A-0R^}9oV|7QXM&8AUhoi2f7^cUb1tx9(ri(>c#Offn{;-PK zmU}xfgju?~A0aHlOj2m&Qp(8bTna-X?S`*AOk>*05;zbdL7SdD>LKM47$; z$kB`g`-NB~JB9b<%f?=?6g;?Tj6OODua}Co;o35^U$Rat#^-fnF@IhY8^hYgo(+i@ z)*IHOA_l2CgM1WnqFiDH$pcJ&y=6veatjY3t;612YH6<-7mIWvO@np#^C zZ4-McqKz@LB3i?7MPW>X%w;Fd_nkU%kYKMNu`)B)ovpGI+SH? zXLPKwJe|>LgT`{K$EO=MjaZqOt6EIqIO1fud&xn?wRRQnp~c+WP_W;3^p<8oBlCl z65sldrT1p>g*Kw;gYg_L8kv}$#5|da@Q554a z0?RR^m1Wt;m9yCA#G#0%IOfxKs}t!-Sxk?a+`{5yW->Qj%IukvyYIw4snb`?`tb=l zchby^rJOs6Lne0+Q+!ponVSxJl}JLK1m5(WGIpm+`$|e$S)3a1$|h@l%`1E_Veh`% zVX^auuU~olf@R6OFU)@WvfQ^&`!sK=aJ2KOvQt>em3D7?nrbVYt8p@9)W@tHvE1N1 zZ+$pfxmo_9?G8wc1w_X^Yn4DF0XkZs!55~0!wPIu&{BFGg`hQ=M}+jHzqFS=^=+ zG@R~u!f;G+hq38kYKK_>{&n66@&uX6mf&z`l;I}f31P2GsfN{BM;M!ItPE_cO2(e_ zo+;PBg3XsSu_U*Xh8Gg=hv)~3v2hDO9IaXJZQi8_PC5-O9{8^j6nO8b1T4^cHid=^ zw{)>L(=n(JlT2viFy5Q{*NYEl^cMFOw_M^-5ipQSekurq=nldlx`U2?Ye4}XF~Pyn#RxzPuGgp0y>UKXd|Bn#2d%`e0xy1FGU_*N}- zsn_k=hVl5~>Eb9Zrb)pKphUt@EZ?qpKAAIiQluufvt>-DAe&N} zGb*XMWdpjf_~^`uNEH8djUtCm$JA2=h}|ec1L!KUu3vqs$JYf{1Xjbl2L|VPigNds z!M>iJERP2L%pBb0k?HU1yX$KD{ocvvws`fM{)tJMbbgG=Ht_;;L*7|NHYXM&~@X?&y^nO#Hl76P9TI;35rccpfQ*T@K{~{7=LUkLbV{hZA^Uu`h z3N4Flw1O~$9$NrnjL1pPD~_9yR(H-x=<_$xG1`71SXDKG`nugy9pMlUV zUVGCpzwq5slW=T3VPONv?!?*XkHcs z>b(j6Rq)J*V_-;NPh%&#j}0X(Ev&()%GC0R3-jZ|Lgq7@HpA=SeOfew<>vQ5Byk)<7UA!cqGd7N--yY1M?|1wRu3_m zbGgpBf|}1;iw3nA3%n~lL)PTDu|Qg!7TWg~u?{lT1HT@7|IyKw9SL*3_;1>yLP$XSBX zLAH4ii+S2K4^0BF-#L3~;_!)D>D1Ev@q5vE9K5k))Cz~Lk2`*9cIn8$!?T5h_s%kP zP@XjeDi30kT%0Ah5;2LOwJ`2IP>D7R3^7DV;w)dveIU{L?ag_Enndo-)`QHl-q~E_m!E^U0GLmmS4YP(@ic z&AD!E>$qqQt$`=7Ie9EJhI^-`u?s^Nu_=pC8Y^I%hw2(5KmEIL4J>U-4Hv{P(44wc z3@hujwo(;uUFS9;FnLu)amQ#fXB5-8y)-3ZJ7LZeIccO2qH%%i27hiBy+cP9m&B>L zS#fCg`0SDSQ)2N52XT*V4Y#J+2hasNhjpkQ6RwougU74l#KBW@#}DE*+7WT@>?u)2 zWyf*%>#@^^=R^(Hz%Ee*)KG2lVD zLUoR;oz7~mSa(BXMyZ4=?=V+(%wxq7uy-sT6l<*kh21 zkZe9%R!O~{g%u9*#jtG!D5r}uPfpu9*txxCA4OR+OvBwvvkR*X)r$`cO@@sDB5o;m z0))Xrc7_%&j)X~10A4~7C60(*ipff<+);^-R+(9Q(d3rJwtUW*GEf~o2?-Pw>pD5O zwTIDRS;3EDT6*2a=%WRwp#eNOGt?qX!GcLY{v&hg6{NFx=i$h7p$`Wkr z5WXsZr)QbY9wIzA-02K7r~>;{m=hJ$MbJD=E@pRT%4llO?D5mH;%2dTc4_f`kz8Cl zvAA^b)coRc_|?ZT>%tFau5s+G;3q^sVfu;C4{qy@V~<0N!waStzmyx_1>l3s04A7P K6rHE7h5ru*@eKL^ diff --git a/sources/ADIR.LCOM.~7~ b/sources/ADIR.LCOM.~7~ deleted file mode 100644 index 1593d04807d02fa83bdc88d13a5294e8ebd6d99e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23850 zcmeHveQ;dWm1j!|1QO)5WW^B0V;3G+0S6q$BwiqpFwp9jsDxo?CQ~z;N$u2RYpEHS+M2D+{E?~sY=+sb zt*zZ*f9KqH-$zRVs`AIyR8b}Md-waEbIAJ;?U zA$>?29y+vm^!R*jwyG^2(}uL(`%|Ue58OI^a`wc@9SaAJ*A5)pky|`;ptj@aY_&G~ zrQle2M{WM(@k5IzW_O%iyywKB*^@iWRJJ&FOLPR~S3i9>g${PtNBE`P95St!&si@on^hU}EO(-nFh4~_ z(3xmdo7tHzQ%|_@NL-uA=5pzsW^T+Z?!+KQ3{B)x=~7t>2eo|q4lNX-h@0s(7^YXv zi10% z%S2cGg>?p?*J(h}i}G%IQ2~=6D-s)YwBM=6=_rll`dyn4R8|$FMYJmdB_9$SSZ6I9V{zsb&|Nw2(IpAu*s03T8RO;4`4k?0_y& z#W>S}2Ev=J2Q}zuh6VBx_Tn)MCov8aPJw9!&`3BJGyia73& zM3QXc*8n-HCW`5UYYH$zB0jBam`O%uQ3L9@o$1r!i4Ty{dbw}z4f2_ zhQkC9YOtV%qUc<5Hw8$5$1JEAQ9B3ZYAQW7f&PYcNLp$i$sW3wPL>7aiROptyt@ut zd12ZqvFPcV$YZKZ=Teh7nhn+XkY?;jm~#{JZq4Ye&FYb@B-c%~n+$8o9JN7^1XXwg z++-)1rxde6ZwCJUpwD;df>bbl|LE^)U)|Rp>udj3Upv?L=H5j0;_|?Y)oL)&Zr;&K zRGFpCDZB;!%}FUz=P@l$q?qG=PH$YFz!d)*=IRx4Fy;ma{ruKm={dDLus`8H==-{C zv6WchfvncC=P+}vcH z?5}md{o~|(`@&Qgmr*KuzOt!R8&71o2m2ezO!~213-3I%tFon48EBcS#ng8bVnA%+ z^!jG!eN7)1-u^LFHX%85ak=Mj_$`s)rdAVcI{#Oy^M9T?@6_veURTlm{(q9)uhwpE zKU=Nc3hrhW-u`MU)7O7z;^_Mp({FA+SFP=6H?D1ol}x*_S!{ZaD?iP@l}0O@X*X{? z`p@+dnc*t2=|z=P->lxgj$DsrDl4s{?^j-JCB%w&mC3Fcke==)Gruyn&~9uMMwPq8 z%_HqQat>VX{svNh-t9lqevWgW`g!-)YpHhSrj{6+tBRXedgfWaD%;(;zWNuw%5dvQ z~hzQVr-$W|1M#O*SL|&Roq~^IUueA7k-3a5RKm*?I*=+3vX3kYt`Qp zuT{m^dktar#`kx%8{3VW#IU$Qy#B9S;s#{9p~acnO}tP%>Ziio#_z7lNlD_z?=?eC zKVCH^p{qkSc?cfFFrL)bJdBZ*HFx z+ZQk>y4YSf#CCCmq;#vwxRo<*MaJ(SBf9_2X@2sc^e=Z^!#p~GzP%|+ZnJr`jd`?< zd9;mr^d@L|lX&!|c;mgZ%f7EU#eT{p{gg?%+9GK`k@Sn&j=%I-d?TXL#Lt^KMf}uG zX^A(%_I4ApMP;a7YKyycW}VEGxcvTC)-Xs@bZbnvwjqOtRK_9BIJ5zSDuI^Sygv1m z2vjeyG(Ic>7HUO<)XHWHlA>X@UxYS!7cW~I|2g$EN?ct2%$KFMK_TGqGc|71Z^4;) z^;s!r2>_CZRv`q7X|_h@~jR zQnZ4>TOlc0sft}|k(Lq@;#I(40@)^@YLJPMM)9bh3UeF3D>`#hl4uap?0&q;V)?2< z+Js0D(om3*#!Y|*AZ-Gz0BMs7X%QtK5tfe#3(}-S+9Z%RDWug=iK&b+&KP4snp{Bl zfi!wLNbBIyxXq(+=FvFwXuN|*Ac&E+E=fQdleC{mvXEvIWg(4H#H)lf4@ZGCPI0sJ zjEwSRCZ-b7IvI4UqWe~+`_>H^v_oaw!5MdKz@SPFGv&2FTFypVu5*4|zWm!f&$OGH z&7O+_0a2mEnqcWn64J zyWDfLWq->33~B#mFw^w)-03pt9&thG3`6OW4Waai8zc%!r(5C-pmf@X(kXW?g3?2P z(t`x0ue8KzhSC`}=pIo9-Eql37<9*3Opddd9A`0c8+2#ZLg^v#ARBZKVh|r>gYFDN ziQ-W|VwFMHnUj*FL1*`)!=QUme1)Kdf(#{Y0yF?h4~jDcrBez@CzJr3U;#M6l5$Ey z=@g)JN<1i`w4^dFamFQ?&l1-EaB}x&m(=_AZD4@hCZkC>rQJ&1iRGMZw8FZhb`#z@oz6}}lWtH*Eobk&W zFsSk{47zIorH5@OJ?u5;mV0he#@zp4WA48LLJvdOFZn|YLJt#!E_sF<^nWC*JnzEF zMaIhW8)D^oHwqM1zSj~LftBysSh?WNMOb+nSUFEvd9o$G$5^?@Sb1Jy9%VUr zl;z;j4mqfbi)*p+v^dXLIge2~&se$0SfO~-@4`xFP6sP?KRU2-UOY)yK|#g}Hvt-e zmGj~vVda9t$~V*qe}hN(8!QSJBvvi}D;LChiIs1ujNjsn-(pd?uprJ8R_N(qrGrOj zZ62Lv9-U<#o$cU}!pgcN0V_<>ej>@jicOS-6-tp<@o*Ga;S@JZ&&Vjoips38(#fF5 z72S_B-H&g`pmQqYInH=)0|r%|1y*9f%Ck0Bp7mm7m$hM$$n0m<-_;CvtcU)NA@nvN z^ekcEhy|f%2}0d+p7di&<*_+zb?0kX?OwC{>~eQe_@5E|tC#Pp^tYC~Qx$)!{y%r& zcey*3uhy<`sq#(Uod7)Jch!@^{PP|Zyzx$+kwYI%| zajyPX($uQ|2^xFKZt4Zmk1o!k%NgOvy6mM^<%gKJ3$*+5L-7&|9qs<8_s$ty^kYA3 z8Aabl2j8jGTa}kld@j{UC&bI5F3Zb3%{I;P|5nZMKcl@LRV(&>)GP7W_rG|o5v!`` zYa&(K=|$-aKSt4+j6Uy^J{$o{CQGs zUVW0|EIYz%8pIa0J49?z?_LSR$aF~5e`AT_&Z#2koO-oN`(G!~{5tj;uod^#YZ#-q zED2ryzfWWPH;A3wd^wZMn8l<>rEx46h-;Iy`-F4c(uPGX#_I6hH< zP#k9>PMx86IO0k}#*RLOVo@A>y2uU1a0t_xDT>Zd?Piigk!ZvrITVRRy~QKJkdsyC z#;s0=!Z^9{G!+g;yb+;zM`uC-?_h+2p^hR!?8dw3HDWPul{6-vM(NbY8v$N=B8a)( z2tB4)}ZNYdfU}vFi{n7mN)I_?d1>-nYMyB-b({w5t z2Y2!$S|z;WD9-75Fc#Gnlmk4RH`M z-VuSLURN6-46&y`2$JlH2u8hZ4hC`d=gDELiGU1wm>AUKhL?#tWLIVJFp-gAGf@Y3 z6ccrvc)NNYhy=BqSt=(p1pyWZAYc|BjW|yB?Dq&G%^Ey|M#9~B2$7eCMl9&1*NAq= zp%IC96p2LL!)ru>UePwfpx)DHxP!??DDE9MBe*64db@XG9p}dYGt(fmt`Yp{L_^7B>_1a6meRFuHYk z>?kJcA;8(yb3%|Kn0hGS2?k?cKI5)Pjz9;}^?=b)BtR6}vtJwn=dPd=Ik67y6a(Yj`J)}-2o%1D_YugUoAr_K`r;cg zFwH6HjesYX@P^}V*$sD2A0FI?AbucCPHQ;HwV52E`rHZ=qv7x%=qeV(%-{@b5WIqW zL_JD?fm6=FVYzC~K=+&v@D36Bc~ zrdVQ&IaSagfbu+89k8qO>k#`d!Re!*0X;k$;iNijVB#l31`a%0SjWJiO}OF6U<{%~ z-dkZE`ox_82M<>;01f31lG@~A0Zh~U7NVI_zQw@SvM7{5LnsR5XD4Y^1Tu>0oLSE9 zN!thMS}=x+JwXEp?yFIOU&PM#ngs>{3>E_X`6ozaNLL#|YK%6NmAX`HeK z4Vn`SW2D#iIxI)rl?{`?I@zQN<79)CqovY&vPoDPaF9^1kS-?=%m-9eo-XFKVARfz zS%6qNfhn(=z}L@e^tT z&rm!X=4TW`NZ|;k3VMd2&&abb1V7DCI23dOussl<0oNkNNH6Haz}s1=Jv*R75{7O? zZ2_RxDFYFq-XI|u55=^hoADCERD*VdF{ny0f z0Rw`?&0r$-6w$-FOn{n}?FV3G4=a*_0VoLc0uyXpKB4qftuQTOP9Opya&^Xtgy4~6 z@eKxos~G7j>Wl$yxQg^*bOT@lrEq`24Z{c{22a8;KOuE?tpSX=3cwVmfEo>W(PI4U z#26+@E6@v%FcJkcqemb`?lRB_G6B-S+|Wa?1ngQcT8cHA9+YyU!}Oz`L6V_V3 z#t9bplLMYobUVcI*ml`BO=y?6l8e)<=#Pl=M=w_FrD? z^sc;$TgU0T<$?Kx^t$BOImd4b627iy6wi9r+yL}idKMNWct4$lZiQnhl)lu&kR&xb zVzsn0olh4rNnx&xsCXuBU1u-Mcq3Xt!(0gmSTUV1QvjZCMNx*Q7*&F>i%k^NRkai# z&qg&F7c`73X>CmL-kFc)b7zJqNIzwZ5O}jGN(%7%qIqCMyJTp<*X^6_>+)r=^}KoE zK+n_6yM+V1%Owwi7W)3NuTR^&D}!Tzp5m?pm2Ew%e(a&_&%D>%jG$KE++ERHVp~^b zTkC6c^s4b*Uh`_9H9jx2;APFvifz^q{ZOT%fE+#Sz|OQUR_a}K1yS(Z-wa#PV6ElU-}r1E;=*OFRAqjjHxh-$vS@Sb2EB9jd z^)r&b$MWCLzCm35<+AUhjCzKSEqzab)Shf*6PyBV7W@HqWn<0z2h z&e`9*UFPhs@02;876Z-Sl5qp|pgZrD=JhguiyHj%;;L6<)KzE1HXhIx0ciREyu3Tx z{`TA-<>>eIJpH~QHf6Er4Oc(m=ND|BuJkb{cJnXXBnNXVTWaIE1s>tm*_?{cR~w7` z&Kzt0Cco#cYy)2;q3g=?qq}Qvux{qLEA7Uw^3uJsas!uWzXW%)Tieg$7hY(a^K^*(CgS1CI*n=-F=k7vY~96q~9~*=d8Kzxq^`yooOr z{YV=)CkCq7HU?!&b>&7*xLOQ=$=on@|G%9*&5RcV7)fe+OSQ3s^TlMP-Cc+ZYRzl8 zL={Bw5~mPA1;$mHbp_lho^_^fV9y|#K}$Mj16a8BJFF*buGIsuARY5X4`9J)Ct>1s zSsj=}oPD!6tTLxq9IHE8HS#V-JREf;#b6$L7MQgCn=Teb5vzmP`qL_`E%$a}2v)kg zA0aHlEK+FYQp$+wTnbYn?S`*AO=I4a%*0E^!bdL7S*=#DnP^NDHa%6E}zYwcr zr|`af+1v}3f(O@+(MJd2^-{4mTw8|rOV)|S{Jc&q?B_MHF|1u|Yey`hYX7)I5Z z7zf7P3VOiT518Xc#XAIh) zQI7Tabi<|*D-&x~3lmQ4rbUJH#MjXRyX2#!+bV-Z01Nc(hqcnu12FmI;$Z|IoH$F8 zICxL1h&Y-U8pjiIIP?IXkeH$SvAUq;M7CC&z575-J3K#ItJ3F%PA^Z^7MF&4$%dp= zhPw}HD@GZ=9~+4F4EnKwSozpM{MbPJ*g*W3XCRVMXqNGrJdBx-&BTw*MD^LAWpD;Q zHWP8F!M_wU(f+pb|Btnp6Fc#Nu>I{Oc0}RUKs&NkA6D_a6z0V#zRdlR6I$8DTT4y^ z2jyn%dMQpu=Z*8tVbP2A5q~OPfWbdjOizs^r!?5zGt;FsxjbRX1~-WrY+}+k{bS}N zzA7I}@6F;1ZA8-t<2hU?GBG^~JDIM8pz|zQ4C@$tHC#%Ucc=GF2(y^N36nM>DaK(0 zmSadOi?W$3XR*(TLlIAL*wc2a6X{7&OpjUI!s29RGB;hy?3og~Z^J&R(^pvi_=KE0 zX=TPz&K<-dlRF3#U)F8qrh{HNBq2`%Z~9J|yVJN|M2=P#rv|*T$*Qk;HQ!%j@4nk% zvGaznUwQk2$C7tnnEmu+xo@HNY2H-fXy;R9r!c?CeLFeCoQbpZ#s*hPo4Y;D8#+pH zQbv|K=;Pc8`Q|?WFf-Y{b>;G z?j!<^kkbAHfX4JIF`~^L*`QUwjy1A32Rh=7z!H`tQo^nU$7CH*KrgR|QNLQ1qh=}R zsu)($)+>{QvuP{HGL0jQj_fK~E~~L%9;N*aERM12)%Y46IPDB+SO8l$@bH?~g^eao z)m#eAkuv9vg|ODmQrOqm#gfOVA13_!svZ%~_B4mAy5uL>^1O&e-ny{kTBlWaA~)%Z zNYJJrc;}Wq?7gkgmn6IE3OU&9kuhu~c0@qq%-|{v^6Q$+?xjN@!WoSMZDnCI!X>a! zs7lD8lPwX28g}nFkQ%l{97oz6N){-E?~2{pn(lnC2m>N4Yt|U+!0u!~1yVFs`HnEQ8uz^emU0TQ zH20+UOu1%S>_(-D>A9UW-;%t1h*sSW9Wl1?&ng`wq-rOIoqTsZk21jxW{-53m2p30K+{6^`4#Hc~9dw3D z)@ExJt2Bm+6L@m9RIjsD2Bk;?^BEeL#1jdgD;d>(A73^FE$`8uQBRQT?8K>wOT=_3 z0sxv;%8rk3$5Jkt8I_xzqmxB3wH+s}*lVRUzIbF5rU$einn``qB6PjHB4QMx?Ix%FrmJ{#kCQJjL;FouS%!XYNn zT{dxftC%#%ZqYZS$M|*WVKp;}!{T)ayRy66BCIHl1JH7*qJ<3tGliaE)AiAWUxphl4ch69A5fMGX_kbtSuh}QM1Pxbh^`uwace0K~C z&a)AA$Ckmqo}MgggMMZXt~SZ^clF(VIen1a^(x2ltajvGgfHYIFRg>rA6U<`t$F^o zzw5yq7vLWjpw>rj@(ZZ`wgiqs&rMZ(8k2G+<4!tNPE}V1aKq0_LBDn9+7yn-@Hbz@ z55EmE*6z4!@X%HD-AvX3KJVbOO0ns^rZFY_Oii`cOQ&z2qSLqDw(S3TB-S+9Z5$WA zg|pwkl;3Z(6xqo8GL=HnUU_gQi$0dq>i<3`FNOP*eB6p}X>tpqe^cXg@@%rD9!Izb z^@2l}!>>1Tc}{KRWUf{|cSIh7vgO>8@2#A?z{bidt%Jn3r~Fg+#tu-W;)V1|Il z8zyNWJ}o8-a1;vRbjP}Gj)O1~RYn|w(F{GYubeL7jyZ2WfE|?(-nbY}FkE?YeBo#Y zK3Z|Lh|dOaMkBB2!>0nOIdZU?DWuc80T+$VE+=+l@}sqw0b{dR$dT~!=Pd>-N%!fT zfv%|&M7*x2C~@uy=M}5N?C1*bs?zRkp_DG*!v^?tSv-(Vuyo@V=5^O9lC>=qLI_x* zyRbrhQUlc%f>nNhUf={JiB;VL@YjNyC+0NVs>D94borivVKeSl5jLL^ zlbChTyeMd>_j)*-;Zp^8N`^FS^6W&{F}JFkaR}+m1nzo4GP9Y7uQ14#87m zPufFWr>emXWuSi;s|HUx_BfTzb!2TfZ?iHu&7|&|c(J;2h13y0$$o#%FYih_pItcm zzR8Njp9SIgu*z8>(#gJcG7URznx`fWu-`emG;!#7t+aGv{@C58nK zB;R?otknZX#%_j=m^(TO$#*&m>)y^wNAhd>JWS{>?@MCdWJuC2t_YMsP_ba%e!He3 zaQPm^Ys1^MTeP8ja5d~`ZT8;Tnl^v)qILqew9X%!JvlTYFG5v{&%Rq!Ufc$K!>Uxv z${R0xNqw?01r}(7Sp)XH6@@sq0SOHVWtqG zd4cN&e{RuwhYl~E(3a+AwS%+AW)IIVX^V$Bh)Z;9xG~l~kuT7}v_t)v=1LhpaIC5w zKd>}+?7-34lOx*QvrAePl^w&~w@2?eG^f>Y4ekl5fEubT9;n`Pd~B!}BzovW?{kQg zL_t3(hw=jMP$YiHVI|Caojf{%>SWyIlF4xD&Y=5EXiGYiQ+xClA~Uy`a$uotQnjv`AV)JNc!POS4C{lS>#E1%+N~b5dzdYYl9zr>rGZ z=RE9Ma-vx?mEtZ9dlWJelFet!GO5?Iu!2{EHf(DF%ITualhf7?c5biQM^TmxOL6y- zb)m{oz4+47V%QiU;vU6LfG}7{&(I!;Gr}Y%057445=XRNipdJ9+!2Y7R+&|M(c+e3 zTRvw_nW&DQgais|>w0~-rH9d>wBSckExm4K^ic{x$9jPJQ58`~u@Atv>VBs%Z8BOh( zJ$BEmc7wKe_Qc|ST5|Ek@x>DdmgX0a;X{KstS3J3DZx6exmdf!w=ko adhtuS@u391Pz}JqgauAlnS%n_U-*9mbUb(f diff --git a/sources/ADIR.~1~ b/sources/ADIR.~1~ deleted file mode 100644 index 191ff1fa..00000000 --- a/sources/ADIR.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Feb-2000 17:37:26" {DSK}medley3.5>sources>ADIR.;2 44917 changes to%: (FNS MAKESYS) previous date%: "28-Apr-92 15:39:45" {DSK}medley3.5>sources>ADIR.;1) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 2000 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 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 13-Apr-88 17:19 by MASINTER") (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 (QUOTE {DSK}REM.CM;1) (QUOTE BOTH) (QUOTE OLD))))) COM AUXFILE) (OR FILE (RETURN)) (COND ((AND (IGREATERP (GETFILEINFO FILE (QUOTE LENGTH)) 0) (SELECTQ (SKIPSEPRS FILE T) ((%( %") T) NIL) (SETQ COM (PROGN (SETFILEINFO FILE (QUOTE 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 (QUOTE PROGN) (QUOTE (SETQ PROMPTCHARFORMS (DREMOVE STARTUPFORM PROMPTCHARFORMS))) (LIST (QUOTE PRINT) (LIST (QUOTE LISPXEVAL) (KWOTE COM)) T T))) (SETQ PROMPTCHARFORMS (CONS STARTUPFORM PROMPTCHARFORMS))) (T (* ; "Unread a string") (BKSYSBUF COM))) (\SETEOFPTR FILE (COND ((NOT (\EOFP FILE)) (SELCHARQ (\PEEKBIN FILE) ((CR ;) (* ; "Eat up the command terminator") (\BIN FILE)) NIL) (* ; "Need to rewrite REM.CM with remainder of text") (SETQ AUXFILE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW))) (COPYBYTES FILE AUXFILE) (SETFILEPTR FILE 0) (COPYBYTES AUXFILE FILE 0 (GETFILEPTR AUXFILE)) (CLOSEF AUXFILE) (GETFILEPTR FILE)) (T 0))))) (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 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2548 7427 (DELFILE 2558 . 2658) (FULLNAME 2660 . 2894) (INFILE 2896 . 3002) (INFILEP 3004 . 3093) (IOFILE 3095 . 3192) (OPENFILE 3194 . 3594) (OPENSTREAM 3596 . 6721) (OUTFILE 6723 . 6832 ) (OUTFILEP 6834 . 6924) (RENAMEFILE 6926 . 7166) (SIMPLE.FINDFILE 7168 . 7425)) (7799 17163 ( UNPACKFILENAME 7809 . 7958) (UNPACKFILENAME.STRING 7960 . 15546) (LASTCHPOS 15548 . 15833) ( \UPF.NEXTPOS 15835 . 16052) (\UPF.TEMPFILEP 16054 . 16486) (FILENAMEFIELD 16488 . 16725) (PACKFILENAME 16727 . 16933) (PACKFILENAME.STRING 16935 . 17161)) (37801 43561 (LOGOUT 37811 . 38460) (MAKESYS 38462 . 40106) (SYSOUT 40108 . 41008) (SAVEVM 41010 . 41632) (HERALD 41634 . 41735) (INTERPRET.REM.CM 41737 . 43314) (\USEREVENT 43316 . 43559)) (43743 44558 (USERNAME 43753 . 44222) (SETUSERNAME 44224 . 44556))))) STOP \ No newline at end of file diff --git a/sources/ADIR.~4~ b/sources/ADIR.~4~ deleted file mode 100644 index 70e619b7..00000000 --- a/sources/ADIR.~4~ +++ /dev/null @@ -1 +0,0 @@ -(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/ADIR.~7~ b/sources/ADIR.~7~ deleted file mode 100644 index 35819d67..00000000 --- a/sources/ADIR.~7~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "14-Oct-2020 11:14:03" {DSK}kaplan>Local>medley3.5>lispcore>sources>ADIR.;7 48306 changes to%: (FNS SYSOUT) previous date%: "14-Oct-2020 10:54:03" {DSK}kaplan>Local>medley3.5>lispcore>sources>ADIR.;6) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017, 2020 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 13-Oct-2020 22:51 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) (* ;; "RMK: make sysout on a temp file, then rename it in order to get version numbers") (LET [(NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE)) "-TEMP"] (COND ((NLISTP NEWFILE) (* ;  "Coming back from doing the MAKESYS, so just set up to keep going.,") (\DEVICEEVENT 'AFTERDOMAKESYS) (\USEREVENT 'AFTERDOMAKESYS) (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE))) FILE) (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) (* ; "Edited 14-Oct-2020 11:13 by rmk:") (* hdj "29-Sep-86 12:14") (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE)) (* ;  "FILE is special so that BEFORESYSOUTFORMS can alter it") (\FLUSHVMOK? 'SYSOUT) (\USEREVENT 'BEFORESYSOUT) (\DEVICEEVENT 'BEFORESYSOUT) (* ;;  "RMK: Fix it so that sysouts are versioned. Temp file goes to same place as eventual sysout.") (LET ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS)) NEWFILE) (* ;  "update the total time field so that the run time in the sysout will be right.") (\SETTOTALTIME) (SETQ NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE)) "-TEMP"))) (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP 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 'AFTERDOSYSOUT) (\USEREVENT 'AFTERDOSYSOUT)) (T (* ; "restarting") (\DEVICEEVENT 'AFTERSYSOUT) (\PROCESS.AFTER.EXIT 'AFTERSYSOUT) (INTERPRET.REM.CM) (\USEREVENT 'AFTERSYSOUT] FILE]) (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 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2794 7673 (DELFILE 2804 . 2904) (FULLNAME 2906 . 3140) (INFILE 3142 . 3248) (INFILEP 3250 . 3339) (IOFILE 3341 . 3438) (OPENFILE 3440 . 3840) (OPENSTREAM 3842 . 6967) (OUTFILE 6969 . 7078 ) (OUTFILEP 7080 . 7170) (RENAMEFILE 7172 . 7412) (SIMPLE.FINDFILE 7414 . 7671)) (8045 17409 ( UNPACKFILENAME 8055 . 8204) (UNPACKFILENAME.STRING 8206 . 15792) (LASTCHPOS 15794 . 16079) ( \UPF.NEXTPOS 16081 . 16298) (\UPF.TEMPFILEP 16300 . 16732) (FILENAMEFIELD 16734 . 16971) (PACKFILENAME 16973 . 17179) (PACKFILENAME.STRING 17181 . 17407)) (38426 46850 (LOGOUT 38436 . 39085) (MAKESYS 39087 . 40854) (SYSOUT 40856 . 42599) (SAVEVM 42601 . 43223) (HERALD 43225 . 43326) (INTERPRET.REM.CM 43328 . 46603) (\USEREVENT 46605 . 46848)) (47032 47847 (USERNAME 47042 . 47511) (SETUSERNAME 47513 . 47845))))) STOP \ No newline at end of file diff --git a/sources/ADISPLAY.~7~ b/sources/ADISPLAY.~7~ deleted file mode 100644 index 1b54f17b..00000000 --- a/sources/ADISPLAY.~7~ +++ /dev/null @@ -1,1281 +0,0 @@ -(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/APRINT.LCOM.~1~ b/sources/APRINT.LCOM.~1~ deleted file mode 100644 index ebba077ebcec4159850c03b65268f597206a39e9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 24602 zcmdsf3vgW5dEV{~?G*aalnO{bo6hS+=FkN^Fj|D4cxaw45ih9}b5WH_Cl(3PD9Es@do zC6!=0UrrXY=~5x6>?|g=@v=6SZOR_gN=YR$u%{zL9VAezoE%qz(ZTTK(G%glBg(+Y zXmogVU?ix7g2zuj{K&j9TTxD)P=d%pcH8 zpTC#3AfXqN_m}jkVj@|x<~Z_%GBUJxII0|M4(?G3%7}8LoJyA{D+>T;llgt+6!M3aKDNW*qBfpB*oT}UnUgFfv_g`y z24z+P@TH8n%;5b{R?N;ikj(Ze6Uttt&q5PQM+Pv5WHHyTPmEJCq7^{nf z$}adY$Z72~(lRuvVSW~JhS@HJSr>a0&#{{}d3@SuJ@~hU{&ep0O?Pdiud6<#+L&uB zZ%IveHKpd z+z=akcC0er_=+hYcdUJF0A3oKC-89?j`2F4K(+DGrwK}D0nuB335Z6bLmvjx$iT1* zra%Az(-GjY10CfC3`d-xjtx3f(Gh2=1r1^r8o0ra8LUav771HKZNb}yu0=?as2#*c z%z-e+qDX-z6W}AwIN_q{fo7VHw9s^GpH4F8BLi75J;x>zXR~N}d~*{`cY3D-%_z}D zG~G=!y`3S&^bVr&&e$d=)ee0q)qVtV#x1CZHaP@ZX_Es&&?bk)8noHdd8-RDdq0%;{^?1q{9(Yv z%J=v@Zm!hnRa0Y({c|DlcIZ;d=rDX~KZ%1Vgd1=++9C;}!;($3PP^JvI=g&wLa(LLhHuhO(}DO;XS2zDTDD&+ z?rWJ<>_cY7kkB!!#CY+5mW5uC(CA|iB=>+Ma*It^WG}E9Q;&Om9-rFwHPv^_XR6*~ z9<#9A{_u_c^ru(-I@U1PSZY&`dra-?RgERI<32Os$)~d&^dB;j@iS{K14^Dox5gsv zvkxQP?e%)R`_=j`wbScKVTYbK7g8%Prz*x>E9cD=+omqobtnd%B%Q}H(&PQC^F4B? z67=3=$r{UoMxMa%U=tXiRY+CAp(#|Ds$k9?s`sd(c;of-%6UEmQ>|22mbTfzG8BTA zx$s`?ZvZmr2ouF*DMe~S3%sCD2w^igAirV}mpqE>l?5(Dg8~M`w3ao%ltfz6E+Dv9 zbtp=mUO6?1*mIZ`DREBCW}RW|sY`WK&XdOa7hW2x@*~36`WQAsFz+s-{jaNy`n}E^ zA95CVnkuXE_7?tgF9549r2Jjas9$!>`Iv_lzqJufdPIv5RVBhq`R4<)0`Lyk0tO;- zqeiSP8y*&#m@+t`OpGTFD1%n5m?h{VL$am(V2T?|D58CvqX2jEppo*S0;AziVf8+> z5>w7IOg!fKH0?tV;p%da_DxmmWf{HODBDc=0xZe2SDsb-xhFIjQ^t$QoPHn)J^KiC zO?JgZQP0897)us06HNVxoC|CaCEk>dp`o)p7IUYuJZCvun?s3}fOS)bN{e%9Z&(!v z%2u`h2{jh@#)7(XfwL+zz>8EUcjrtH%h~GnA8!T4hhiVWui|pUm38os0U(@67Zb2! zv$~#{DmZXnADc`j$}Zj^s`AYvW!Dmjq9mo2Qq1C|LYHO?g#JBm8xXq4Eex!fkx}Et z)bi%J%3WSxfT!#Cl-O2W-LQ#4e*Z~=FgGEJ``NF#f8iQ9(>ygw#R7H3-6CbTn4>Bz z$@(JFjK-Bjb~ITm>P2vjy-GsQC$zExvztVSmH_Q5L&H>O6h;OuNEx(h0XrPEh(xFY zfWFsdqQqS(@SHMa+@Mm9pe9VZy-KifYW~Ed;p6kCjvKRKg1_iLCi0%1n&$ggZQ}*cDNg0+E_9h{&*0x;Q~0^PMlxe-vo!{&8e8O)Rw{? z4LKG@(~dH%b`1`zH@`Nnz?8<`340m*cPdeyD#9Ly2(o05RxE0VNC^Ge79Xb4`OHlz z!RLBSj`crKy$oWIgPyIm|27xkY*3xP(k86EO9F-nF{a_JxZ#s=8nA`eRn#)Vmh0p}h7!ung$bx?ho@A;PPimPv-$ z762)rA!J8c0?vhe1}c5j&ME6jnEeF&BgFOTNT%aPD(^k`&KYv_ut!L)lY=(0X&Sm0^ z<5=8;L(EDtl&~2IHWthRQU`ybke1q@Si%x^*-e(Myw+}7-Z7?Hg3w`Qafn-*F1%bkN1A5f1{Q?4{k=!=>Ft|5 zZEAbPXm5PCV%*wz&Qvu9jX=fN(0K8p=YMpnZDZf59&0xb)Vm$zf7tuONuT#ps=iZ8 zu?A-PIn7Y`XX<>KNY(TG>A-T&+~sop&M7Wn$hGx@YHjP-%HrQ@jD!Q_v6cEij9ngE zxP~z_BgA{iEPqP%YTS-7i6d3o>i3~o3~-?S3qF_nb&bgy-bxiMYM)rR_CR^1{-!q1 z3ToTxJ??tEzGm!UA3(N+#w!)WM=Smk_oprAjWcY9Ov_mw-b^wPMvSIT`ww&7eRAdH zNv^w3vYPXbRW5Fy?ylW2ClsT%<;T)=*U~N1eq#$fd`oRpsdNY17&eO(ubk#T06<%# zenL#nw%xJgAfqHzp-*KMFF(Y;V% zxMmYY180BHL8z>3T4OY=s9X_u%0@}ywI>~gx^x82@bP3n+mrsXmd?TZ5{FnW6c3W~KhE}xEEw2YX<%#IwzuMB z*seFzxMLYDGabM-uh%d}4yJXM7=!p;w~XMhZl};>Ea3w0DWUgzb)$qa>r8-@W4j*! zQ;DMIpwf^35$t~uA3_wC!%d{Wu2f{lKx;b^IW}1$%^@}EZ~*$lbh{Vg%VyI(o$wCS zZ!cHQjV-rT-|O`HQoc*zP)1wY-*s^LW{Z8bEh(vr_XV>v(3bLYiMKW7Te>;rv)R~) z%Lxm#bx;nJNS2bz)W%`;mP$A&ktQ#xTc{*i9}HclORd@J!}ex^4!*2SC#4>!+v;7% zW?bIrlbg}Gf5QP=;x0Zi?XPb)d|XnzwekA2f8{(EzosVYZP;}AFc&1DOOqLL7n(w_ zgkIN-dktUKZ>BD!_*R)~3)B0VP^k@R#^>0Vvw`t>o+UedLo@C)d^x|=H|EJu906f4 znA3Jb3zLk7bEmk?N1&U#SW+a~l$7A%9YHU5aIDAxN(DnAo@M)l+|V1coLP`sU`IGI zQ{b2vUoa3YsNj?_Ci8JXVCNHw(1A=)Q5j{d#at!uTM%O6qoXA`AxyLc~^o% z_mhcC7$>L4ajmruHz1j3)S4v`Qm+U8k%Emf-xJ>(HU*5`+|?NZOS9V0`GB2pj>h1} zWtLo7M9J&SZCQY~iEke*@=oTGS-jQd5QDEV<=@Iy&h1LzMGW9$@|;e-_?k#2_MTN z_&NmJ2d{u{f4ygc?*IsM|H^sJ&7@zEc?mVz6YK+=_ZF^V)v#3rE=vC(hl4Gf*PGCK z9ORizm=JiyPR(d%#w=W zzHrs|v@zaz(9A4ce_(QD@s8ZH+00Mg@_ZqixpGP3!ka3N2=e~g&&e~2c!|63<_0@6 zhJ_9Wsw9^$nLrcig9s29wyLps4|tAbGks#Blq@UI7Of2=--xq0_AY{Qv7^9sfvDu( zZ&Lo`whk)!(imb6;KPiGWALbw-j_!V24G$U4v^!rns;+)peX^>)cks|_ z<6>_fSa|RCxd-1&EZ;t!dHBY)2PUzZ_{8q)US|EtG$`-&H`2zY)%u_CLgBbW;mhb~%e#hljaQ%4es&n%?0=Vffsbi~ zd42-M&-3}OT=ZPXE%wkb`22F(xM}reExn5GGg`$6G`?<%R=-^BXlf;o z)rLgDDc-qA4WQqji+LDZwAIC19R)uV1w1Rk7rtSW>>!(DmJ4GD!1$>#PX9^_3TCm8 zmB&#~Z*XeuOb-J(&NQ)ZM>+yOiz|&&Cs(?ue{wuJnu8@Y;ZY2zWiv+w29BNLBr2tk z#3YB40O}C)+pQtvsi66Im7P&L&Py#F$%<8JIbugImUCfWGG98Bg9PyYo0~U+_ICmY zUPVAcq;0x)d7GNj(v@?J$S0?JxTzXY|8(=!&6^&mBG}|#F?%xe$A=nUox4=~X?i(0 zt~v3kC#LeY=c;Fut=RNficM9W-Y!UIfZ}PEdZ%{?m(nZZ_p9dgjfzi zC%KpEg6^LO;nwfT7|OL;pUAB%#?j2`D;eW=RuRw>Fa|RCUD}*6_Tm@SGc(=h43GMG zJ48;-F1_3E=>dQ3i^TV$I0AC;E0`rtqcTFO3oN;C@*v!jdGcBw%8lvpI6)Z^1@Ns~ zxxiv)^Sy4OfI;Leg<3CFq<-d-ME^>3P!U0QVKRxrT1j*cq>iBj!8>CZe-t5FX?Rk} zk4og=Oh;ow?lc71=(s+OLjgqTMcu>`fiFSwWaxu7A%TCps4Rlb>dPb#P3y(+u$X3_ z0z=%=FD;S5;9f8oVI(jIec5-8f^$KihG*zI~h zQO-;hq%#vYk&@IiGi2(YT(~~-Nj<(&&uz8Z@8Ios_yc2%yv^FTrJJvIP6)+|H%@aq z1LRTFyH~!ecVE0Qjj#7E-YDop7xbw9Nzmg{^m}DyV6yR&K9FwIZ?y*5ZjM2H(6{?d zE34NW(+7~(>%VwoPVcJsSS34o<(>XoNe|Qusf9-UZm#MW{f&CBRZrpd6u&t)6R3Sc zK*h(Ii=Qzz#&4kd2qVYyAU0{v9F?0nvI0T;fj)Xc z9};_j-z&8Bf%+5K`Zhgo+*tX(9?$CWD+Kj>&&(~}$1>}8h z4hjSUkjl1Y`kG1+BUwzQArFUUVYRAX)Xg!GpIN~lt)8ng)y?Rt~ z#(Oahv%VX}V2!(Ee*IQs02RRxZ$b%Ui1(U$e5TKw3Gs=BW_Fu;NbkcCyJ^!0%!?oV zBk{!{Fe2f;hua>Gq!j#a5hV%+d4$tlKX-cfC-f_U7maW;*BT9mi}=v^X|gx z(*Jz;g8(Ez{XQus5ZCjpnOpqZYG9#p9^>~TDn*q%2a3##&~c0{Z0!19~WKoz~HY}k+l30|u8i8cBQ-dy{>p;a8 zOmrh6>De|)!+U0@IPNq}Pzq?E3I&Oi&233t9QnDuW-y*zxZ``H8*yKZM|GavtSxs> zbGF06uV0+*!=_y_w6t;ayVqWud*H}}56$=?LrLiQ^=^J#T`!pUbXvj?h1;9+$U2@O z#g3cQ*Jpa0Y6ye4wyP3T8}-NaZYEN<6G~E5Tcqxw^X}{Dt9PaTfF4-9HT&(%H$_Yb z^h*-yKgh9zx0h2mXy+nc?Tl{K6+Yn?FM6LakziB)%0+L4$@z=k-_*O=*9_$BC-fZ` z^zC{V6R`Nb0=fW8?^&%M1H;D8q~2qM8?Wd+72`K?UdVRvqUSG3Sl*U_9=y~(7r6Yz z+*e8EsJ=G;;6=}WM2mYGO93%eHnI9#0J(ct7ysA%>!OQqA>(&e7yrgMieb>dp}afO za~8jlDv#(rlhCet7YNF9NzjYx^9&kC~mi zVnO$=rW$VO_UQ_PZjhi$Rc+`(*zE*#cj|Yoyf7co6%G;Q;s+D@?hATQ-^n0?-z!Ap z?=nG%*zH^foR`kUh7egJ{T)s>$slfxxTN18q?W8G93xRk6RV>rf^TFwbEJ@9({b4Ym1EE&{niep)8 zYVSf6@z5)HGv8?gJ1Nyu3&!T_#+K^~*To6yIn&r&+rfZI^!)-?EeQ#L0%whlsL8oC zbnlX7y=rA{yKdOj8aKO@xhc7ZERJi1KqGIVX57PEsABjFCaYb$oy`E}=$L~%93yn{$y~1yI8mfU2+uqz1Q}-gL~w>!OlFY;a)5(79r)yTXRU#!4t!5-|kbPXbu~Il@nUOu1h^Gy{}nQR}&@Rn&B1 z>ZDc1>ed7n_l~VitjtS>rsc3B8m5VYz2Cm24IZ#w2+7B$cL?%(x>LhN4Oqb6HGHb% z@oKfRcyrDr__>fb-I>zgc@X-(_=*>FqYl5LVMA%?PsdJGFEF7T0*pQQtg?vzR4R*?>Ju|Jt*} zQUZ`q0o}i{sOjAoNV8?L#4k+8VB^(1e8%6&ryAdq?C3Qu#X`qr`m&Zcd>Mc3PqxY& zoGoIqS$|-9JKT9$9H*#a(HL%X zaKNg_1s?dAY$=3SgoKhK?%kGU&aUZT-P!YS-0FvQjHrjEe#z11XaQ6wp(c1x%wdk% zp~W%BF@?<%BjB;38Q8AP9XatZHnKL^&}}OFt`wL!W8pbS;#^6?T`MTkPvYl_^bCbSa#|LSjV^!fztX{;jc-nLio!B? zVuupJRRD=V451>>dt`>dREOf_>m zY3ryd2nxi@y2R^F91Dblyj=~e(g@}eHF>ZqN3UZ zY41Z@NTq4Gbe9-UGj9B~9Qv(|3qScOtMcQGY1rfuXun5z=mYqG_#)xX^9BG=_62~K zQuVO$keNdQjqzE{jv@X`PHvpVIQ#EcEyCMTZRbx`* zFfj+9HPGl+g4X-h#&gCQ+WFPRtX4sCaZlxaV^?D_h@W6%@pk;|ZY*}=C)D^p{{DUA zrT2}M#&a6KNm1M8xZ86e36rswWZT3 z;U0pmC1qBjs6&LnS7a5zEaeR-ddxypoaysi(p~vnWIc-M6c`(WwaHPA1+B?XoT$oA zxOK!QofM6x%KBl%rbx~~*L8WZ5QC}oMEU;(vj2vS?4!TFczdAoKA|4*par=9|3lii z~X2H>|oDBcm3Rio!|Fv48>!`Bwy(VIh$veK>w0`c@WEXf4AZip-R3P#I5T5uFdP9;8uB>AUhb%9@d=rgu;pIND#*rlvKXPyXYh|Sohow(m?VlO{ezo3X{6bs(rfU3wRe0vF&VCs9r7U9+(447I%q07w z`#k?w5uuza>Qno06Xzq<3L6=qT?9Q$y8xHJ6_TE<6iSPb;sM)Cp<`dZB)LlRkWr3x zmA5H?T&grYY{=7rfxOH^V+F!tbJ+bB(F4w+gJVZ4%Hv0k$7U6{Je0mi*d@1PaCh`k zY+6n$uy z*(uI>BrvRAEvPu*07lsAZv@_5LrAD_M3H0vN5;)}RMX~j+3-8?G zp}(6c=f@i{_~v)oH<{?)XJXg+maE+%Q-1A6l(kP2Z_;!L=U0F`yK4WLZtj6F$P>#h zC19`ET?Y#YTz)sXgm51MjN&8eMBqh}$^kAd$jQy zTJTP72Q@RFa%AXiCk~;qi#bce29ei*MEELB!Cb?F1@Z2htTmt}nNcNeU;tX3WJI_d zNG9BXGCq~d9imtkbSJ73)9`FW0Ig43C?Gi1@fd=vVn0%VOOKq}>`~HIsARgix8J~W z+Svh&HkOc~e&j-yghNzlO@PmpZxea;;25`!t5~ zEQeeU-8(l^CJ07t^NJ9S`gU`^cDHoP{<-}43pPod4nHmJ6xG*R+??^gp}qWR>STFt zvc8Qw7*c8O@Mr6(6*OG0|1NXIXMEn7K)tW32UcFx15e_Y;&tE>@UOh0`w?lm@&X)g ztSa0XU{!hmXM7v=Ky_tK`kG(QE%#I(s;<=Un|w9n^ZC4s@yTywe7~P%&EBj1cVv3& z+w*wPp?(_^CBo{!TMmDh7vEX&o3E~XYw`!In+vi`ljJHdrO`<-RBHYPMHKEWqFWw% zAu|ycATn{fn`dYR^atg*J=p9(!S(hBMdzjuBJQ7@#G-P`tu1!W#Nx3gvgL_fncYpI zm(Ms+eu$?#MykbnF6)@%PEIqciGX3Si$w(mYX_nOt7wH~LTUsZW72d4v2NdVS7aS` zIE*RQGb|>n&M)N`$6c}!B{%?CFSbL{t^?&gbfM785K|S$Pv=!}$q?KZ1m@UJ5ESt$ z*F`E0d9hjykUSwUADfZZ57vd%xaf4fkv? zh{&};+#SL%3|dCzp+XUd1^z5my zG5h$efj1uU6o&Gd$4(r7bpGUt)4@ILF-XC-iM2)9H-B(IJc6L`r!e?iP>lWY2bg&1 zjbQ#bG(eH#phRAO!)pTaaYqQ@P&%J3AAr80gq%+;g0THLsO{oLcpe3t zz;0)<`XOOra3ck8d}6tzdGi=C9QjfPo3DIIQVi2{J)Zg%Sv+(;w0}x3^CTh}|Q<;@_0XV)bO6?6dVT0NIf=LqxhI5?bW5 zU~XcsVcHY%cAX;D+TmEN^X4L(EvDC!?j{`!Ku z6`^TbArkV#HulzvA#I7d<0}y%DUMJI_9+A&Km0rbPXZ}d01G{$)MTj~X>oFP94W2o z{5;a)5QF{M>KVZ>yxfNr1Vmm#qS8x z&rfB+kjmIbROQ$1`KCFnRw{DtmVWH?Nn`fWS?4A(eV;1YyU>I!99KZ3TmX~~l`IGe z#>rWEhm(zq65*Q?Dd~n1NzS%KLNaNQ6b#x*ad(vDs*)+oj@a{DebRX)7_sH(Vq0YI zLy++eGCz-=s3@N~H9vczV(~-H`>0Up=Pu1zwzRcbY@EObwBbf8dt%WkGQr7F$lAgJ zVYBJL+Z9@tZD>D}OHK&dl;~3AA>x@7buxMv+z5La?4W&*D;?u{6CefI3qF817fGI5 zaLs46oQD4BmqZ;)5_)kx1$xX=?CnQ5`u2#193$M!@c)b# zb`U<7b)Ysv%h%ykzZ#p8tVg1U0OHzwN)$@qHvwEETi8?w^kf}@upvCEN5^I*a);SG zMHxF(PBLbrgzm!=9#lC(oO_+>f6 z2Sx_MBa!}~5(*wY{_u%8W2USeKc)ngwl9tq)4zT1lB&ZxYIb)5}c69deu`kS=x_d-9l$*>Z3aNNsKBr|9d1Ve$$g*)145W-dY8XoK zH!#d2N+i-dHggpHhKH5DzP_MRKKuwK9dzc0hejg1M`FXlPqy}7YN<-w@X+A!fFc&7 zJaQcC361B9jf>i)oH#l2*xd0)Pq8VZR!|vaYuO!E!r_rvbR>cu`lU8LysM2s5LQOU zhTB3JB@|W&_Da99f0vS1hLuC5WU5G686Z|Bk=s*BB7aEfVUX)BXk)4UJ;)i9If-Ii z%O@ynKxV~(SCkQx8N46LirQKG5}6)lT-mMkSm;UVa6jgdC}jKe@i9tBRvSL)}@&r!3p$8OxHKRJ7P zVmhEED>qY?8t{a6$CN`f@|aed%(A8KNtB8uY(N&6I5eOfa%}rxMBzmW2+`Uj+Gl;T zl%Fi21&3zDf@VZ1jFm<+$|r{^XBRGr+R(Bfnn^HdIY4TI9lLK$?iU8AoW>`ECLs2u zo7Q_;+z=amdbB)Of65e)JJPy3056Ts5%@R^M|mAjpi+P7a|ER`fatCN2#AIwgC7Ob zaQ~1Cra%Az(_!GT10CfC427Mbjt)3ekzr@52@Rqa8o0ra8LUdw771HKZNb}yu0=?a zs2#*c%z-e+qDX-z!+pH4F8BLi75J;x>zXR~N}Y-0mWw|l1o zjVRGUG~G!wy_F%w)Hb5=_UHyD)ee3n)qV_d#w@6;PMjYF9f=eU-f9!41sRJtEzsED z!#28z^A`b(oCUV~6F>#DS>D({o9$kUHaP^EX_Es&&?bk)Dzw?veya;IyFZfn{^?1q z^ijaX%6IuZZm!hsRgQ^(JC-?HxWjq1Tcr!#Cll=|KFaGMU64 zEz_qJ_B72Z`Vq5YNa&bVe5|lf%RsM)YxJ=TlDl6Lxy2?dvKLs5smDA%k56s+y6QXP zGga>qkC|U;efY*+`qQm`18bPAFSe*hJ*M`JipCP!QJ)#``8=P2sg^6ti(719 z845wmoPWRi*8mxGgz-Y6m?X8K30}}Ags>UtmtWDaOCE)H%K{goK>-6|TFdHZN+K<3 z2N2w=IuxaLubi4h>{(2UlsKnmv&Jy?)TKHq=SgGzYcGve{t@A8Z4?_Jn0JTK`d5{D z?Otb&4>=3lO_f!7dlUb;7l2jglm3n;)vr3{e8j_w-&&6*U7|&ZsuE!){c{0Y0eFXN z0sUdQQNz}j4GjrROc@wf#>W!-lmV+&)DraJLD^D%FvSg~8_~YaQGh!+&`9Y(p3(4U zv3j3cjwi&Z^7+FH)i0oijl!XDZj<*$j#gML&jL#pH%7Yv3OPKyN%% zh{Jx)=z4lG@4$I|bRrQixp;@D$~TXcT}vQ}lB8BlGE18ZU79fv`ggr8Kx)P;5>w)tkwl@O7r-%gD{(y+*GkInVTDA976C|IZYR#K?rng>(#B*| zS!_vSj|LqJqiIJNR=Wm=)tg%#S71tG?}WV!{yP~jO%`AeLj+keNGlYy10;n0bdwKL zX@Byjq~LSiCdc~kt6l~%$U)EM>i?Jxa5kt;buRurud(pA{Fha`G<)!JYN>T1;8oeO zSmx^!=hB&-m!HVYc0cf1%6Fjp^W=l9VDZng?02rd_~WUr#g{~f&+^|l)iNucUwPKd zF`QHx)=m4(TxGh$oDP_JK<`*tZ28i~8x`HJcl>riR8mI=a9CuK-AjxP zyKQ#_&&H6uHG?0R{CJ`iPmZS&nK6Y=Zo~pvZ(e7%MQ<^qmx{_@nC3-Y_v+&cIO{62 zf!^lIWupMyU72j+z^L$GKQIU$x(sxPvEGud#Mlsy8E_Uvf*qc`Qob1t`6fsv+ppL> z%hI-1<4hpPWTHSoNC@^<1Tv08_wuTFhCoXJHP2wrKtCHO3+A-hbmq?;m0at|IX9c( z9E5Y37~?n=H{lSok_;tmMuLq6vw+mWUnry{xV|LgfU@J}8#BiqnK{|aHg>f+oGfy0 zfDCzZj0la$xm6BJN*b21gk5%%Wh<|?o0fNssg@vgSXmt6mZl3Y7tfKV8MuK3A#Q)~ zQha*r22YFHS~gniFP4p4>(7{~#-I@>8|&&XT=e{}cC}^nJC!4?=Du2|gZvMAe>mau zUP{)sYf09?Og*C+3ja)=PZ6nlzBd(E>YBY=s@*xs1q`{izF(ORdXYkJs0XUF-wMHeY|GZ1`x!U*Z0=rJQk^&5&t1OG6t;Cc=o()G7Z# zuDeexzdXTp_X$>W&aujcty7)VJ7$Gq^tSw1oa$J-Wy)`Cf`@OhWipv+V;jR}k>r(A z{09JNsn?E)$$Zu|nGm0h&#S4)l*W2^dlQ>yy|$hGE^L{r-X;gVERz!&ap42ZplFdG<#n#7TBvY5*4>6O|Xv{pD`NC!pi zpjgs!@q{t}8UvRb;n_ATv@68mu%J?up)>HoVInDf!bw4P5-)?#0BK0?L-^2(MR+Wg z*lwtj&^GoZ3Z=gBjINc?s*meZN(}u7O(X`FnwH7vaWO;`x`m^gD17O%8__rlzUwy7 zl*n$VFkG{Vpn z9Jy>|)gKmzW5t>SP$Tf19bZ_ca^b(_mQ7>#>;RrNs=g303DMNCCtlA*@u%`6eK zlw-Re08@#e=b+Mue_`x@5FbJmmUJ}7>*H zb(_8G*o@2TeR4C}_paM#OWcJMQ~ugk!^b7XTkEe+`Ipag@oQ?L-ntE!4{|{gx-^j{ zccCc+OXzjYxYzJy{ATh(l5dr{x-h+;36<)gW_*!-IU5+i&9h{uZ)nDyhA-=v`oTV%N6qoX=`AxyL zc~^o%_mPQA7$>L4ajm%yHz1j3)S4v`Qnv^Gk-UvE-xc5MHUx~F+|?NZOS9Tge85gP zM`Q5gGE1&3tmJg&w#>uZ#J7(Yc_(wpEZpjHh{4yG^lxS>=XNFVA`0*^c}|fpz9y21 zedr4E9D_53fJZdJewu2mwdmU#7X1=aCAn20*4(g4g!+|WZ!fsrAebFO{TR-cpZ0q9 z+Y2Qtd<}x_fmgt{x7Ib!cL0RBclkW$X40?7yo4I<3HAZbdka^wYS=0Q7o~rY!@-u# zYfWe^4)Wv%ObEPUyJoa9aut~L>7?l7 z`fIMTFJ1MWHOA@>n(6uL4@@jC+>w1clm78ro-bw6S1w6hcvD4)Am^|Cj69>e2b8<- z<_0@6hJ_9Wsw9^$nLy*I{Wu^nWL0D5OyD_^&Ghl{Vxpu#TeLQid?U{0*t;;w#f}2k z1)`FBzd`wv+d81+ilaDl03T*lgux?9YEMotz!#ttfCJ=|_hx|2>)TInsHiK?tB+UI z_xB%oZA|RV1M}~{KKtOC@ul0x(huLb_P~VpGdMkrO}c-jme&17e>Gzh1=OMj!Xh&AnOukp|_x_D0Isuu}U0FBFbD6uyj(Hoa$P*Ld{_?WYIf&Hnev z=lGaLFVBy|_<1(>)J4yQ>_Qg}gU_#~jGI13@KCP9FK>Zu0X!YyWBF6l>NFA>x zfTmXRNOe#YoaCL0R6qLtnV5&MNn2UC)lu+MQNXj}eBtXh$PO|IX1Oqi0F0j;<@B#a zp-Vf zNmQuAmOIbkB!D`^{C2Czcq(WNud*1mBVKChNY+`ErVu-Nv78Hg61n1mEF^&U-`>0) zw7(rV@G1@@gj=S%m$s-$Emc0ph7(Qc!agT%Z+>Z{wGKXQc${N(c@@x z+IGgAZGU`IiaI)kp593PiSKF)JAm_$nVi4AKfAo}Snlaek};^{mCM>hEp2G&m4)qT zgnlD zbDE#}c{@Z-&JMlP@aX}6^~=QfaG=b|uV9uqjmj{oF0kZ!6Z_$o%#qjfKz3Az#|g@a zD1dL>$^{lXo9}iL1q>o*Db#wYBK0wsB>Gn(1By88*Gnc*uT~VD1F56vK=95e#vj2E ztrR?|CL3bL0Y-CKILQnvw10!zY3B#8lc{21tn~=c2T~rpvX7!{K2d4DG zSg)97j{-y7(PV&vC!AP%DI^6i#8_f~kBcVl<=SjMo=n8kJYo!XpHJ^8Ch`UFe0z zqSmi!iP<_Mt7-qkH|k%X2R_Y_FT5KL@|CaS&-;{f`QPaNO8q-?z%DeJy1(}6r0%~K zUn2M1bCqjj?BgqyYy9W~*#`G7pC4r;Z^oBCKelu*4VLiVcrlQ)%N(5migx)C+;1Pf zUGF2xnT~*Treh{jl6s~GP5smJ*QYWF`9;0+;*BYMy?^mWULU-mNAypF9-pA!E7ScG^_TSiRK0eqHON+T6zYS% z)o)r^-R7v?kGyXG#T&DFN3F{$+0H9(_g9O0pq5Y0*K2okRmbS7*Sf8G3a_X5&DrTd z^-}^WKF(bHjIl9(1Jy?uIi3fxNptRs-BW5a7gC7}m9~q`9Hh-0c5UW}+|1!+2;vX* zkqi2u*aQ4tp{)TeZ9t^RQHof1x z_~AbgUmOG@67GAr?cqpD!tWMVB4Ch*INkMer*~gmpG3SnG603wsVOoCoRGmby+NQR8K&rMw=V#8|K3(gCNS6stYd2M% zpjhUW>26MK!OW|AH>b8O6Z6+z%PzL-9ohPedPlDQOnUy><=NLS-uSK2#ebMczc;_K z_`e_iFaQZqyHAPfXBVzKd?S#3 zcA`w3oi`u;F#TR&f>aH1JHoDVo_G%ru@fmG+#Z3sWy2CGOq-WbG4eyzq;<(c=K`EetDs)JkY;H^HBIM`xn!$K>;g0V=cjDX^<5BHrHfl?q zQ=ILv{CX!3SJ(0;KAn~@MB&!PJhG0b zNwMQ5_4VoQh8n^kuI?yD)q3qQy_1R5t%QwX#Qa&oL%{_S0^PkZ6p88@ywxKE3W&_CGy|VCs=3Wa|Rxw7!r#$gQj z3KGhD(_Lrq3;A+F@0x)2on5#(cUg4vs`#yCNe8d)F*c>%uhbX+Ft_lsC|P(;ew;%u ziTc70{1oeuQeDP)ePJ_x#_E5FzZte|H%`pG$)-~6MBX$jd5D+noBiR%55EXF2d#~C zctNJO>xu>EyBcb^;oPGu49-DIdiFy zh~$Ih!P~=Dp>vcln7(Ti#KmMMVi3qenZvprWPTTl=z-1$Ah0rt5*@W55jdVIP-qD= zm6@27$VALTW+J9CmfDkoj|Y5;7e^t*i*Uz4(Z*pp)=d~;GnVD{Wr|TalOYEtVw3Qq zS#qh-JjVi8)#!zI;>WSz;e59RET&jX&Kn!A8=J1rUl&o;bEdJex{ZOAX#P2_ZW1~G z8O|8%QIm6U=;KApqSZ>=o?W-0`7G^b=DOrsvk2h|Ax9oW&A5lTRmJcZOjf&kJDUMw z>zIQK{C>sJkre@8UED9ckYRvAs7Y|FNGlQEdQuY7%pM9Ou2@K9kOZ0l8J$jj^2IY} zF76#TbS%OE-WaZY`3Yr1bOX?YciUzb6hNRM=_a_SB)$-&wB-dIAmjOHsf1A$?D_oh zlMna6bqiS)JUL^`96mKurUPGa<=$I-Rgp>Q9rr3GHGZV1jtr?v_5JKL_|@&>Hp z7Y&~(xxHFxFWj7UDFa;ao9;|Vj!ua2tZWC-=&B%u1ca`T^?~JuyY#LLIy6bf_VIgV z+HVA5^!k(a+D~)y*WawZm+P=O#?)4uWe7{^l4b;1Oiyj!yU8^kbKW;j;tXa9^)_J7 z(!csFv6KKLRY3PIFKBw_1=4oeEb$9-GFX2#2S4(6a>@F)B|CaeOS0qSGJRRg8NRf? z`h(3f2k}NsHscRWZH0?ZY!ojf|Af6dc~->}ior7ATqOo_w%JM)hwxmoC<2xxMUPWx zu@f3@6S3c_$VHz+s0uL_22$H&QJinJt|{2=?0G0=Rbw6FB!p}x!xUJIqXkf%tX#o^ zq7D5ycu@TrNm*~YiX~l<)dr09=ZLI2F2EG?Gla$Ol{X{?Ue>Y`R{6~7=yzb9o*vIj6MS6=uAUQ1qXGe#>`rj$oXX{=r zOog@X#17nKwktA(3gf6k14cPiFlS#ljq2(O4iwpt^#n04(;PK{I1$@>5yqiwiC&l# zKUjKz=g=^89D=7f!U0vtNOY)Glw_BSWJe@kH&a|#1_J4pgouB#yEg6~>5{JK6;~N- zTz2(KeO@7vtr>0g+MK-A(R$XnQU98$R&Og`Z9NNT*KNiPE}wA$=H1q_W<{p1-qH>$ z8%kSSRlz|)d~B+2L9pwaxWB>c7@MA8qMxPI$~)^T0lonAj8V?1+6UD;wGUJz>kEo% z52SqnZ6TSW;Zhx9Jk7ZAS90jL*3bX=C#=dl>r=4P!*pYpABO-R5MLzRd0syN%Dw>b zVp5;XjKTdyr}0=O6d(RU*BB@VUi(=6TvK9{Q{qcAa2a9{r zx|h_GUgzC}gNa;POHWdH5+|?e(@_V^pyGqVj4&hMblkdZ(^>~`dQ8>0UF?cHB&r${ zB8Q1N0IiNjzYw%OsMMb^PSeh>EM&AYk_)@a9~e983qkw@>kGHzXJ>t(6F;H)_we`c z>Mwm@EZ3jW`0a}77RP;`3tEv)?6kJjq8;(UMYK}eW8oc^Q*$lnF1aq@66dHh&z7To zAPQ-2)!oicKKY)AQ#)$85uKtI>O|?(A;Xd=PCtt;$Ws0lvCu98=Z?sO^bud=IAv`q zVg<>?u5g4cnUyc-5FxP3tRh?j;SK0SnT4o`^YdKNUHM#OJv!$pFg6OilcO9v$RJXRhxzzP)lTX{gtKcnp_~R%%=ElUn(< zDo%*2JfdrEJ}Wdgthx~+BNmg2zz@K&fDRe*uP`vfLLy80aQwoFTvix=CP25^BP;UWB2^d%G1Xl zxm#O#RW<&dBv(nk zGRm>8_ck0VmnscEO5|z7Kwjpdu@1*!bJ(31(F5Ys!O_EI<*~!YqcaLz9!k#%cJb{9 z+#Nl1UM;KT*^@Swx@4bSq9e~?g&gVQxWVjrdxPH>alWQP`l0J325Cf-u^@x&RKe|s zPeCQLZmRIBFDd7%E#irm)h@%>hg{aa{UYzRc#`W{J?lp=#Gj7i4(F35znB4CaIz zRu^3>vQwP%NMKmKT2OJq0gSNO-w3?BhGU|_5k;Q#9~n2_QDzJ2++>!G_3!#ROuFlh zyQ}PHfL|sdR$flM6Ei!?vz-xBwCFQ=T)MMIeuU)5PWf?{S*~;j=#L+N-o2%t{cShP z^Y7l`p}!j`=biN!eB-;V8%*@?GqLM@%hk@1DZh5&b%=U0F`yQ=?{Zu5aK z$P>#hDqyeJ{RayOTz)qmtjEJn@FdACUA;~iUNos3;39+k?1$C-b4@=MUo6VvJoCDV;Go`+)wtsYTd^}Mo(iP!Dj1uMD zf{&X#LmAeBcWOJRnfa6@LuV^-2$fydSrj&iyc#5qv?4O*8Wt>wch_L8VIRqiDr$Hx z%lUc}GvWG`vB_-q0G)3^ccLmW4bOTUs`Y8}c^p`EJdhx(*bf)rA|&TFyOfl5d@|M8 z+pl3ctt=FyjmG8iKXM^UC=(T06X0{@+eDr{I7Tgc!g%27U{1nY3LeMqiD1*bBXESb zd=5i-mO?Iv?wuPc69l8Sc*U`e+E#O}dbf1T{+ayvb2dptjL%9tMfJ58Hm1FAXfJ<` zI$4^XsBPg6hGdF6{MmY{c@0(tdWOYh)%i#H#c{uESPAw+){E`1l?V&vJ#@*?%Meo);ivPexOfQe3j%ZO zCkTpomFseqE6FI%*}|ea2bFmS;Mc+H8guo9onxD#tA9`_g23~^1^BBtKA3b*Tk-6i?P6c=I7b7{_roR!!!ucZv;$Z}ZKaauRhhprH zKgz_9;|S)DpaF^;ff9Ko4lfMI2OlAXL#bS4rw2+Ix$k2E{bJgq3tK6lN_srP%{5IPv_sX1? zzZ}7Ksi+7|(>fv{KWt-fwR5FS=kWMS#E}%oQ401c1Rf859)c%ay`dZ8`qfvZQKyI}F`X^p9JgbR8n87fbB? zjv)QqWCjeWgl$Aseiff@n!{?PBIj=DM@}6#W*(VwZW7b?siM6L4cNkQ1&40904N?P zS`ZS9le6+RCmRyJ?4na-f|H|= zwS@)3X48iEEVK;U&^{)YoDj4r(WS^scb1dUyWmFH%U}oXdrWB?(;EOO$X@UPyu(QH z+=6Q^qh&SpN53TMSd!3->nWdgJ<>|TN#-|*e=FN*l8`Y#+75cLRRNhLplB%sR=!&; zu(H`sI+cTl5{YK^pb}4*U$jwAXlN}Fv8lB~XJ}~RR2&+LB&IqyOwLAN?J7kMRidH4 z)%6Lxl2fa&a#z(YtkRFvFf0W_R(E0_Q#0B^_u%?&Nzc;*pJH!6#?iM+G~^iJW`@5U zFKi=xF6lsR95-KsPyJ$SO0ph_9s-D~^C?j%f!_ddk!)g9ZP1f-9ElC#p*;$l70DfD z^Au(DKq^)c^nh diff --git a/sources/APRINT.~1~ b/sources/APRINT.~1~ deleted file mode 100644 index 03323663..00000000 --- a/sources/APRINT.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-Dec-91 11:43:22" |{PELE:MV:ENVOS}SOURCES>APRINT.;8| 86972 changes to%: (FNS \NUMERIC.PNAMEP) previous date%: "27-Nov-91 13:38:43" |{PELE:MV:ENVOS}SOURCES>APRINT.;7|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 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 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") '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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3932 12558 (PRIN1 3942 . 5346) (PRIN2 5348 . 6453) (PRIN3 6455 . 7406) (PRIN4 7408 . 8503) (PRINT 8505 . 8745) (PRINTCCODE 8747 . 9024) (PRINTLEVEL 9026 . 9752) (RADIX 9754 . 9928) ( SPACES 9930 . 10280) (TERPRI 10282 . 10471) (FRESHLINE 10473 . 11138) (DEFPRINT 11140 . 11652) ( LINELENGTH 11654 . 12556)) (13220 17709 (PRINT-CIRCLE-LOOKUP 13230 . 14460) (PRINT-CIRCLE-LABEL-P 14462 . 15060) (PRINT-CIRCLE-SCAN 15062 . 16999) (PRINT-CIRCLE-ENTER 17001 . 17707)) (17710 61509 ( \PRINDATUM 17720 . 20662) (\PRINT-USING-DEFPRINT 20664 . 22054) (\PRINT-USING-ADDRESS 22056 . 23469) ( \ELIDE.PRINT.ELEMENT 23471 . 23645) (\ELIDE.ELEMENT.CHAR 23647 . 23934) (\ELIDE.PRINT.TAIL 23936 . 24364) (\ELIDE.TAIL.STRING 24366 . 24591) (\CKPOSBOUT 24593 . 24762) (\CKPOSSOUT 24764 . 24982) ( \CONVERTNUMBER 24984 . 29265) (\LITPRIN 29267 . 35802) (\LITPRIN.INTERNAL 35804 . 44159) ( \SYMBOL.ESCAPE.COUNT 44161 . 50929) (\NUMERIC.PNAMEP 50931 . 56846) (\PRINSTACKP 56848 . 58159) ( \PRINTADDR 58161 . 59242) (\PRINSTRING 59244 . 60625) (\SOUT 60627 . 61345) (\OUTCHAR 61347 . 61507)) (61510 65438 (\FILEOUTCHARFN 61520 . 61633) (\JISFILEOUTCHARFN 61635 . 62905) (\SHIFTJISFILEOUTCHARFN 62907 . 63981) (\EUCFILEOUTCHARFN 63983 . 65166) (\THROUGHFILEOUTCHARFN 65168 . 65436)) (75641 75813 ( \INVALID.RADIX 75651 . 75811)) (75917 77926 (\MAPPNAME 75927 . 76926) (\MAPPNAME.INTERNAL 76928 . 77565) (PNAMESTREAMP 77567 . 77924)) (78609 78997 (\MAPCHARS 78619 . 78995)) (79328 86384 (PRINTNUM 79338 . 82397) (FLTFMT 82399 . 82800) (\CHECKFLTFMT 82802 . 83374) (PRINTNUM-TO-STRING 83376 . 86382)) ))) STOP \ No newline at end of file diff --git a/sources/APRINT.~2~ b/sources/APRINT.~2~ deleted file mode 100644 index ef6926c8..00000000 --- a/sources/APRINT.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/ASKUSER.LCOM.~1~ b/sources/ASKUSER.LCOM.~1~ deleted file mode 100644 index 26ac995212ab6e86b9db614983ea4b16f17dbbbe..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11653 zcmbtaeQaCTb?1j{IjN;dvf|l_lU%d@puEa?@A2_V$s9g@$f88P$B>k1E6`!`T5MT? zCHtLw@8f%@nGJcXN=2F(zw&7PX}0S^%*P^aC+77tQMWs zV}U_T)d&`Nb|$VcRRi={HEd&c`O?KRn_FwEn`bs_>t{Y5PmSrZa5T!+>Z=!?T))Jg z**ZSUf+OdQVu{Jkq^x{tnmv7S{qv2j%a=HI7!yzxj&v-_fL@sP_kUem9hn}HYZ!{6 zsPv<;*>r3qSYRqEWoKtkrHpcFex{fyFBQ$1xuTUn#R^Oj-_lF@{PN74Rh;3YPO&+r zF{@C{T4pI%D&sZ87BkDDsk1^6av)y99DtcCWy%lEoHKGunQ7)Z;~VmM8i{eAxA>$7 zemBpD8%H9bS9V0XCbgmRqQ^joi)#52GheVFcM&Dj0LtXth22rW=9|u zgH#OJRMZ%$L2_vhRQq%k4Y6`24^rwxN<71ibOnvbt!S9=+cYfKI8An5?k))eHt&)> zuXM-9d<{;x1 z@aeX$$*qTOwbMgBpDisuFW&=pu-D#!sxjIDumawa$GcDz*qKH?BjkC>tYppfOrdC% zGpRBOdI%C=mW#`1YGHPs9wG72*r}9drn4mMGxLU-&Si=-Nlb^FlxQl}cuN%^UPl zXI3sD=76dA4gT)Y?ahPZcV{)pPfi-bJ0N3S0#+Zlt5yU7X|8u@jG|NO2^u%^?0-f1i}xR8}#vWa#uBg<;^P+3lr!_ItdQMCZ20$U?0pD(OmcWBjKRl{1~;#@dY0aRzGdDQ=goYcIdl5W&F zw0fxPpfHv8EY@|#uO+%04 zaJXNV$h{$-?MZ9uZHwg{0QKh@+mqJ))!D8U>m0CV>r>TOHPW?oUsZ1n->_y+RAb%d zf5`dU>=U7{RTB9{&i0kg(aM>|&YudlRg$k)&In>w=C8N>`PSa2H{N~6-JS5E|BG^& zH|6tsYpBI{D7M`ix}N7yR(L1h;g#0jqh{ahL?sDc{Fs(+>jDs;ba178TuM$(;9~m3 z^D&YX-fZo?%x8bIhk)lB1PHotP0p2%@v#GZS|vBt;KEZer^fvUtssXpaX=2sw(rT- z{IBuO=7HVfX|XTYyyMnT*D}0TA$gh0e6w7xP!A9phSO}wHi@^1k?{{BjcTAPwct@fO%AHTx!FDh<_bnb zIjN2LhnrJEw8fY!E&sbVfG(H0*3fOc?PAN{GB@6Bc`t*5_i_$S+nn8L?_%a3xtRI? zFiyYX2*JwLyvf;gYl{V}&Ty<^HdZ&=Gg95!ha50(=6~Pj%wvL39B9`%(*A9?5&8o; zce~!xS?}TI!!Y5#fA_Y$7cjPcIbV|o5sLf+GNzw%7FucF^K%e>%e}s9VrQhX0C`SX ztmVCr+h6FGZ!Ot*zU4bDv3WCZ%kbyO#DCvy;{PQ7ybE&ACO2Pk)_~Ev>tn4|^Im)J zce>#8IZh!bQdu3a!U4-}DN}6)Y~eKCK0!wSE?J-C`}tN$ovztZ=@M%W2zK~+mvM$& zdZu}Cx4p9_xLx^6j-PetNJoTAmGY4l@arwH|6g1!S2~+6&BPg{{j6I{+(#3!;us8W zedop<+~9u2Wn=48wx{IV;XmKACTiH%kIbp+M9Xv2JH|KNZGDus#yYq2g{(=@Ip#i9 z2o$7Sn1{5~tE{{6P93iQ(=tG~)bG}-0Xonm#*Mozox6emnzJJC14PxIjay?^S|22_ z#p|sP?j!H^L0F2-+qP`tO90aOdcI#GS|2@G^Sx|Z6F$E4=gh-6n9T!WLO+Wm+5*<4 zZHQg9{&UL{)FL>zA~;1b&9sOTp>sc?Z-ggt5ul~ejD>itprWbZ+@8rSqE|;RPRN*> z7ik$yk3`wo{+@7zA8&Dt*L4J#JnW?x1kH3xFH$6{=?G2IRuVCx&Vz}piIqa}IHTMS zwNykONE>8Qi%92ap=gXH7kOl%g|L88DCCyW9ah;RCZVt41*H>%?34&&5E_v zI6~BZ%+%QK*)hF0A*MO}RAZPe0mYOk;#z$d8EoWDAk5oEwEKo8@^P zda4l!!T?5*sDcm_foTcBvL1If5JVhkOSA-pax#<4VH(j>;w27bQShM!a9cZ0;o8! zbtTpl00ja$_!YWuBdR!b0~$+|n}F$|99oLSBQ_i3up*9uh^sQA$6}DFyg@7|v)G_o z$3RPIIFWI+k?3t+VM>Px>XDui zlomzTqs}mByI4_2TB|o1fclXSL0avvAsDuSuaTbpRFRD7y~qX0vJXs9deq^%98!=v zk`kslS||9gAvZ2?)WCkqwjjlmH495{c_5C>Z4E|Ht|CUO5IIM~fV5DssLY~C{fY=e zL(BkNj0pGkCjr5z^+R?vM~;B}^^Jfhl>Q1xNN)wpEPWN^hnR~j+JHfZM!CH)P~S;xJGwsl;~qM!0v8fdrm*&QgtoYR88kfTM!J zp~t{h;hW-McM8ccd+(nfn`Br3i|cn+3Qr!+H+jbVg5rKrRr_bZ6&deyN^5^P_DO-It) zy>T7-R>~AmZU|wJn_X%MDBA@JnC8ATaUZ)>oWyu0UW5HaLSBOzPr(nsg@8Wn1Rgkk z@KinA7G>hZXak#sO{`eHKYdMn9^Vd)206pqZj zl_*Y8F6KqyF?W{TxAf+WHkhD|H&Xn zSPb$S0QLbE1IC{`nrWbHfR{Qoh_skS4qdijR|CwcYS~2`s%3!`r826tJh9K~8}76_ zCHQ%oeLf2&WKlcdwW=%%2d=VU7WIR^WPBEN1SeUab*hF4ap1=w#aWaQ?A$+<4P@4x zY$}rawAwWD-0k;z_LatuiZl-o8~Klj43F*gqCN;eM_6;DMY)Gcd5`4J0TAp*&(!l{ z0eCAcq-(glh$KB6FPP?7P{D39x%4#30jP6`GAP<8fb>eDz;eIG=kX>AM>=~F4<7LW zCo`KHp?{}-#=RnkO8Z85L|aawCW1$=>H|;-kJsZ%7(1Q&3focRMmWK@`?$vtPv7Qh z;^te4&ELHFS}n23-rE`5Ts3aKWl%@L;2m`$2|_!0dbH0X(*p<{vqc~RRH*7B%0OI? zaD)Jt%oIIUSuG>Jp%}!mhgx&|rOM5Tf)e(E^P^p&!e0J-*yr&h#2%XWclIyb*q204wI9_G7ko?O@%_w6vVR8Dx=9o4t`Hnfk$Wj8V)+G7kRnKV6u=qNIhd-jH1@$3A&9hxQfgq&WhAmY5P=JqgT)~TXHa=S zN?GX)jBDR39FJH9vZ=!QIHpd8cH5>ME(zy04? zgMVu8WIO%_ND7NCDWEb$%X0VFAS@^CAqMLYKYF59o^yC8d%~f=Flo|c*5-mxz%bCofn(9{8Hz9N0@i9-L=HF&(L&)^_ z*7l0D`#HY%^PN47=Dg3_O#A%X#}i(RN%+=$7`S`bQ4G6F4)J0P7-Em&;<`5Gu3YVN zM0#zaGWxZ~+CE$g027w@;2Q_z4S^fC(-$B{WaJb) zai6T2vouw)9r)a`k!X-ka8E`KPKXhCDd(mL89bL@kl`y7Gv{1}532JcPVO!2!g z%?kv4pEXwVza$LQ3*teAuYc|V?v(qWt+Y?(wq-43=UXD9yz{zUgUWy1&RdE+jCT$fa%qi%4PC&-6u_KAuTn08XO=f?BKVn!fg+js&QH;J+LjaA zJP;y~xaV;Dgu(^a(F_o|#Pcf<-cutG_i^SOPwYuFpQw2st#g@6zM8LbvH$5yqS*Xg zo~QA-6!Q@c{+r^z`Pz-iT4U$!&{*d)qN7fAzuw=s7dyjHhDW}*aN-?^;gKX; zB;)`E`m#0&b|~U8|ODjBt*gMj(jjhT@kXY;d`}OeY|o z5|ld5?^BKhiv{Ds2W`ElJ{AnlnI*f&e#+yTJ(tcyvVF{M^fIa9;9=hewC$1{E_B{e z#c3AIn%OeH=^2#4ja1U0pmZ>}%mV9|aKVrTP24v`1Ai;YIh{f1 zU(Dc+XxhTXTU>)n*DG&jjan%m^iZg_`&7hcwE7rD1!W71Jcy{ diff --git a/sources/ASKUSER.LCOM.~2~ b/sources/ASKUSER.LCOM.~2~ deleted file mode 100644 index 60c193499a331ec1c91017be273249ffb7fdeca8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11847 zcmbtadu&_RdFMlZB(*e3Ry3k|Q;S1&%Xe&yad zre?AR*3OFs7*=4Jr#3fP=^4Pk%A9zgK7HEHYO7a)ZU26PbDGJy1jjgAy2wd^iuSI6_tIy2FK@xo~5Sr7%AD7hH%&;P! z0ZME1qqDhGYbO_Ftj6>ZOL7yN0P7ChtFKfB%4abH zn!x;97uVU=<8u(6L5c<~it3CMZ+&M5A^7W4TEDWqzUwMuq8~F?S5+Madz}5 z(=>Jz{kzE!vdHl3ZCzJe4}Q>24|_b8#CY6d57@z8YX_Pxb^xq^x8m(C6eV`1kxxt6 zUN$RPGc{W%@^U&^CZP`kj9D(Ops7dMd3uE9Bg9TYd{S8w{MiM=Oy$zW*?CNde3WP^ z6kRBjRDev*I4gQ}b_(#5>2wMTR7%UCl01E?0&#&PCKq@*mC2n2JP4enFZ32=CMN*u zV}yh`lP%`edl;W-wt5X&DoRs>0L1f!vJ__O(Mc<*p)rVRiCO_>n57DYzrf;3XEn5A zf+YnOWyuADK1LYNrOM^`9NJ-4!g-QLDOR7CxzmFlZ)ay|146a;H!G={+xrc-$0N3Uva`36 za=SN{Hr^IgR+QQE-<8zp=usZ>cD!F`x!U!y>e!9e`(NOP#Vla%4ufA~-dlV4mr4EwK=glaW7b;`%V|MKzb$H2pIGG`K2r6)#C;Nn?h@E(j{z&kox*_k zp-Regt>yk4_dTSRAiOTN+&A6Th;kC%P|us{`9k$@x6ypi+ph75TlKZ4q}cO_5CD&x zuo&6kzTX&We-^{Ul#>I1Uh1kZU!jJ#JuY6a^9XI_{eNt<-v2uu@>D~u_q$TzTX*hN zBJvSTmK44<#7~XcGStO>-vGU<(_QZ4(;heednP2|xlhm+x=JgmeUjY}%xxb5 zuO;6}Tj>Qbjx>)cd6%QEwY)#=0qF`UYzm$J3<=zwXIq}nDoaFjGG)g< z+=exw?qcxHHWMNtL{4ETWkcB}=K*Mgmj|^PucWIT0AGa4ZBLP_Ai(@GAHmw~`_K2} zQ=rjrzFmLpG~cjVjpo(e){q|(Hb-gxv16UP1+ta%$ErTCt|>|JtE(z(*d>R$!l7w@ z&Z#p_KSr#?$6=7`JGbr;2KlQF8(g30ouz_0;-~8C@! z^$vLiB|gu6N8s1xfH&o8PFwE=T+@0~3&Y7TBG_PhB&Mq<8SO|!M1x5* z!!j5_6djHtEJ&x9&>IdTmgiM4qz91;Nap1HU>JefN=cv;422Obn6ixsq<^EqK+MWB z^s*`;rt8tzz(5@Vi%J$yGzS9eM1~c!Y@7!fko>Y=v{(#L7I4NW4RoMP0?4c(%hA8O zhQOzv%o@T}8V-;e*x4hq7KmCT3}D|16O|g#1F;@~15q%($B#e+VV2-WARO-j0K16? zKq(Leq5Akt$wHAr&;y|Sz&C8Ne`PHmvpJ&0qt+T)Jkq19LQ;zd22(m(EKVUUQB#XW z9e`qy9-vq_ir6qej}g04LRt*ek{_dxchw>ZlQ5$oxLIBh0k0NCus48w6rsLJUrPwf zkxaAXOpAcT3PvOrRDdH;m;nG0$gn*L0p#F!}iFlaaMH4MGA&XI*7)Fw92v^G15+y%5?VCx!^KZ-Eg zZlMdno>+(mp!RAq&{(Df2)HgaE*`VQC=M>#wjvHwBcaE^pu9otGK&X#dL=)`;*`e{ z_A~|sQ>*kgud^5wNv;$NMS4RA)h31w2#tyk(liRFa()!V=_f%HX3OGU6cp{Xkw8+s zi}q|nGyvNNIX04%^^5?R1RDXJRg2Q2#Ud}BU=fInT5FO;0!q9|z${S>Tb*RY`_T$P zudQJrkX}+M1l8>IBHuGGM{|4y=>D%kFiG`jNdF9)jUbd@U;+|)sz+#c5Ejdlw;;q{ zeUs9lgXR)P9R`N-J4h;J&BAh-PLm$*b>!^SJT)44+WHocD0M?RpT1k#2B{+QLg)Zo zDx{6B1f;=!^+DFa*!~W^w`Vm4hC-cW8qiP&Sv+bTV>n&ps^CSR>Ot`PPm{PqDs-F+ zmWWVxH3B8LcNi`KY{|V0r+TP|hR6z{W6&!g6F?`i0pgLCt8K{PL2%j1#p^nb1xli- z%&0SQinB68WTP4d+Cqg?8=6BIYvk|KWy)K_3KPn`cbKidC1J7p37`iAgD6J|Jguy% z9ssBB$6*Ki=A5s^u|VEPBC9LUfH)9S=}a6=R`wJp54;+XNQ*&bVAVeoNQfDvp84>(n#7J&1DN&+AudNqiJv0Ua!5R=$Jc~*^F z4+rW2Sm`Mij|e)b-NtbIei$w>Xzu+ihV`6#i9(DWT!_+vWJ^Jm%00Fagu#lVER2Q0 zkTCM!5aAG%4_HxgDg<4!5e#BSjyIS^HB9)5wt$ekcs~R4ooK;R?o+Oqm9LgCphB=9 zK;2)hR{aoUkY+lWn-fNsop#Vb)fi?V&@j_}_R!ka#m5_$pL_&uJph9@*abzLjsl$- z9Oqhem`$V3rUk>1kAfeE2KuoPKZ}9aAB9XT%>1Ids-veFJ!@xED8=H`=6zPgI#URqUO+-!_T7hVCVR=C_pG) zA((*&0eQ`$`e2m|sM?^C^+9{J8Rk0fb-VVLMo)O`KwJdOG8CNL>qfCr6?g>FvT_8~ zW)J7j0iiNgS(F%vlOBAAAi$J4hCAy~%DWYH*c_VlSGJ(`CG6@ff-8N4yZj5^N zn)#n?AE}I(B6ePqkDV9HjUPYS{5Nys?XmAIc+NM!nNSH^TTmW;$;gR0w?1Wec7`e= z^GgE!;?A`v?>x6C5{rLR@x7XRF(>2pMNm+KBCF#YF_-OY!dLJ4s=Ff)sGjtWVbGM+ zS>X~D^5iWG>B&G}m6wy`sWiiK&R19~=@COVHF+>u#}C3(%ZTIHf?mVeW8J>OFG{WQ zB7v;jI=Lu4OTj)-Q3an?y)MX{l~0GVfnP%wpB|LCjqUpuRU>FMPAz)3rxrH^i61m} zwkH<9ll6A?5jTF|@wR`FHN>a(PPXH1fTZwq6a_Q}S5s{l8^m!(d!XYAUdWV`Cc2K` z&>u-OwX1*-R+2zj6efl2E2Yw12q}?4OH(18l%TL`v2+8XSHHKF8Ka_(YA;E&;{?y3 z1nX4RKZne@M}4kD&AZLkhLF?otnHNvxpQLg=R12E%>|FUneuqI?@hQdCgEB0VBqdy zCot@jYKR+Szz}Pc5Z5)Iv$iF#TF4J$m67KgYx{A(08CgGeYXy(%LcdZrY}H@%mO*D z%E85~6r=6RJZJo)GghFPCzo-lIA zoQ~R~I^MWlJ0MX`VF0q&Ihpgr0?ncJQ) zrP98ko;OXEnauyGRU?oY$KTnxnN*(+5?IQ}f4Ytp+wXMMoaR5_T!DUC@ip9V%R(Y& zSl}gb1p`N~mD$pwy_Ov#S@MJc&5DlT4_G04FDkcK4`2@?bC@<$2+xtxvD)xa`^C`? zU#t~+)<&2Pl23Sd@Pr|JaEoC#AqAFAg>$S{R6X!|?a#3D{a5~<9+gO_skpayjOUG|v_!(P z_44+J+5p5`Q~E;3yYTbzv@9pIc_0`danIo*3k3#*zjDp6gphb~JIsA*7~($4+@py- ziRR-q_ak*7U-RG0*M!;mpBMAu`CMM4?}ZeL5e@O16u>jZ0!(! z^bCSR3bp8VC~R=Kyh0w3$nq&GfcFwU77NA$4_KCg`q;GdUZ?d%nFwnxxwEQ0X*GKO zn{+&^i-ne5Qp2Ur+p0Ljrn6?Ye2!Ak)3ydtC_62gI6b|>{OebS{TOQE<{}#SW77(t z$h}M_d10kjy%C>NX$1MjG;X4%IBpH&PGBO(ad|3*fWEN8aAg#ea6t|iK0!+9XA&$x z9wwJ3Pd+9n+4qgsbpjS(iL!LBk=Bv0i|HgUrb^aS>rlkxvpGI*<`yE#6BWZ3;aiB^>?4$hfhfsBR`a_8d z30*EjO$#=`2q>=IEkFqT=hiPiwT@%x{QBjs-($(G%a^t;uU>6zU4+6=@dZCo{J>Vw LJ#TD`!pQ#vs$>uM diff --git a/sources/ASKUSER.LCOM.~3~ b/sources/ASKUSER.LCOM.~3~ deleted file mode 100644 index 3079276b33ea49c61057e1e91651e9679f07714d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11793 zcmbtaeQaCTb?1lt(bUo?S@CSy@vb>Vri{wvdyk)L;_!*2EJ`FVLsF)dFGdlSkdd>FQBJ3rUklEdPdzcC2lXJ+;OUtEn@$_emX^@D|m=`Z$oFK-D%?7nuL-(`CF0Jy1ZP>&&(Hj?i4Gqp!}9v&gE8S z=6P{Ov^vG+na+5joZ~b2FVYZZBk?kU^Py`h5 zGR<5G&mNDfkr?&3i%+=lcd|3QMbFY5^xF`>-Q{!g<0q)D<1HPaXMJLAzv$v~1;V-| z%Jlg{*39HtC}h=SIbT{XFe502)tDY)NuI|fp!$f$X7jw5GqcQyGu1bh&Sr8Mmq0GN^VV!L~J`3;+O4P6J9=FBex()T8V?J;L%4Vy6I~REB^*vtZ^^*>rJc z4&8x|5_Q!j*QcZb%xBHBqE=_8KtGvIr(i&(v}`KH(`PDx3y_#x;OW$S_AKZDaF)H$ zTa@KF5l|l^1m^inF{j?c_)NXkYsfND>S}-x&lSoN%v7V3RZ>A?fNF_KL1yMl6@b6M z;>u<cd;sLf@=3hHLliS-u_&3#*)rZW z@t#YUXsDogQEnk)`I%%kZRVE??)v&f=JgbA7`MWsfIX?P!- z1h`)*q|F7GBvFhrS_RJ+iup3h2`($ROFO94ezB_2!nSg}7_4Gu$PvQ#*p6|U-SNVS z11@(Z)%nDuMJTz{~i+WtVm`cWz> zq)*f*DvJ|qi``206=llV=I2D?uKcYxD&rt=f~f4)*A^5ZNxprjlenw{sm@UIg!gsTsd;B*p-~sq>a|LKcpnYlt(-G_*IWC4 zRGIJWY3=`^_qEDAEOj3B7rZ}tSB!SGwg0=Kn{xD(d3SZB+uHw6?rK7^!$_rHItG7nAc(CF=`Vp{Y&RQ0u| z6n^rO8SeAQ!lMKjQEct~h9K~!HDB1mcZe9C*Hmxy81>yL`c(=O4FRG`abnban14zT z8at?(W!k@ysd--$mCb{@Vag|ezvdowAK|*3=|PXTv$M1TJnbE>q-t*Ox7;3&nDWWa z-b%{t-dNgrM@U&oX3sxYQlq0sdC1%Gexc=R*T<@3*IVy@fgcvVz_~jNIE;C3?%`t| z7%+g+Cwj|1Q=acF@xy}A|GkA?{|H0|gdqJk%Bnsw%Da4|>U){{BoEyssMBr(RgO5p zaJ}VuzmoD?ZMmQ2z6aG1#MgzE`-Zz3QTu~8)$@jWzF0lnZ8RV7wrf1%R(0(uiFh6n z0Pwhpi;)fP`?Znwy=W%7oE#wZa#wx%3KhKVaq)VMM`$YV|9zwN{@?JBry6R#-<7uB zx_!5T$VVtyO8DjwKQ(4!sEhf(3VBxpUGC!nj~o9z6H@TpC*%upHL6oxWfj#vWH*Fz z+ee^lsdutgdI60i&0`Ahveng=_a{9fU4g>Z(8O+!+4BB5_ieo0a$kW?4WZK+OV>N? z-RiyGuilU0v`*WwsQSJM97;F(!OjfK#RPM@#oVp-N%9BnBQ}{g_{a;EnjX$60CLv; ze4k@_fx2x!K^_G_JKB6$cy_Pb4b-7w`)NK>Q!Wyw{g>olKW&czUvc6idA(r`?(EkY zuH-RbnoqXe_X?K`WAm)dcb;!~?p6M+h6zoRzyFcb-$UllDT+Ps+hQeviQWn-q$7T+zAish!{YNF+&57@)N=jIEsed~x_yR^ zckU2_@x!vx=hT8yOrMq(0G@hvvb*tCy*h4rivPDl#g^GomRm2MhUFgH~_4u+XJ}1&PV#;(YpQFn&+GFafduY z0?%{b5p3YH;Fq}1U@NzXL1`9phOM8Tbp`ZDoC2&Oq6(%*!f_Q2ql_&qMXgB`vA?FM z1L1NwjDS6zUP5iyh%xM|(KjbkN_tq=+1dUY#1ce=BBmhX8xc6;B^1R#*xMH=CdQl2 zQhW~4WhfHqF%tqaYSd6D$|y&L2H39WIT91;s&A+lvEE1;&LlNeU=W%E45pv4d@^8>6623-JOrKCS1hf5O))1&E zF>A=1^~4;6Zq>L!%v*7yav*vz(i3nnj8Lwpk6<{c^bth#ViAD4Ne9q;P=lcQSPBNi zGFPC*A^E;ZH;L0h&6^5M_z28Y0MV2;#-TwtXXL>Ou^DKUhI0zAeYX~ zAzp^~21z1_mLH?huvLNp`hUUA7ino<-%g{a_U=e@;Zx!Vrrxq zk_yW8#)1Qqi(&#I`xYIPX%ti?r%?!}f09w;E-dXuA<0*%=Pq2vX$tGDiuHa1ov!EId8d7PY*q~-Yplvk^0iSaG5S&Y| z7KHkz64D%BLAw8|5$lOoL!M_)4#qC4GmyDcB!p!fn2&`wBiJJ*(V%0+kUZ+qh)Coh zdz8r+mdjXi;8~RJb>KkJRIS0MZEp~-G&kiJENhF&g%zL!aoNIVR}z9@_fvLYU$xMC zb5<3|=&6-V0~=}~gMU)XSWK!Hxw?U68|m`?)dWj(4;5I^doPqmC55Xgi*z5>`~h;h z5w>#bSbCwvzUF#7ZY5%|USb)bqXw1obY?{HQJ4uGKA;RIDGwsBG(xPDibi5SU8aOI z7B*tB_l|6B-;f$K-{)&|oWDT5l>Bt0OL4LlX7|zJ)GR`YOyw!D z6gkQmSW@MAs1|QltB8O+jYnT15Fx&(9f%fzvK+5rcqzwg2;O84#<&DW3y?VYg+Hck zNdX5FhHY??Wg{BwNm(=Cw?9nEkWEPB?sX7H3SY;zCke-nH9?18pTYzC6_MP>x^OtCl?WxFy4Tz?oZF<|XJ7Nbp^bn9X+QS7N4 z(vQ-@V{1PO3v?(yjGe(z7RJDLGZun%VPraH3IU`x69&AO;|<#`)y#mN91=Fd8W_U( zPJY4zaF1D;XGsG#0vCa8jK5l~`hi@4Cy>m}3NOk|J0`DA3#NfMcz8d1aBb_tqCqVUIS=T*tj`*Z$Jz36C9Ni%3|; zc$0hGI5t#AHG*k*21KVV59Q8*p)#G9C>V&P9C`*2;JX~nohM6bOCnBGvn&wAY}47) zG|mHX&>`oGGEP8xa|f3PTppJ@Q8?Dwleqtw2R!97*Le0)av71pq-1G&fT2kX0uiu6M?Q2;Nk=}=6E>O9Qa(vfO&y_;-f$WuxTm=g z|4OCv00oMe3-)~0xfSN}C;L1uZ(`IOTJUxbEZ*Edw|J}lK;7qFsd>NZUbE6H$%<8q zFa2=>nOdX>9u%`}o?P4*_3X{({(JjKWh5_x<0bjnc`?87<42nRn%{V5?E4Fz^UZH3 zRQ}Zl%0n-kS<&a_Z`zfep~}eIk|4jhbM?vF&n=2P;h$A}uV-J%%D{XP64bCYQR{OA zd+A=_sli29n^E{@1ubhM3)7R^U-;mGPjnmbz9U>5n#wBy@(k9gMS#yzpEw(Zo>sjsV9rX9!`Ps&AxlpW z2-)py-?OL+hE+JV=-r-L+z=vuz}(rMSo}`L+u29j_@T$!{&~g}pV~W_j<*4kV#!q! z&=|!!GE~C^v4f{M#IOY5M0!f1i7pm6>_-Ys%_=CsN(hw4yJV1khoW?=K_b$yEEVWP zpkkpDZ@6w^oy6P5jQXhK+?EjSSXkz9nCdjvKLqC7qdr%n=G|s%LrB_q*7nLw+c`1! z^PN47=7PuFOnJQ9cPHFvlklv0&~SIN6KHmqYT`y4D8yo>Iw66Y|4YW#sFP zwf(p$03|Gox|;{pwSk*=&=)X9Zh>~E6d(W(*b71)S~v#A2H=a$PJa!SBms47 z(&$Mzg(L1s2U`uOxF>F`+zvTL;QH+IZrFCXVi-J%!TgwRBq6u27i> zc{6)x@@Y1G;n@fpWD^1aw7^Li(JEzM8zG1100ud}LNR^L;rL)W{|0FfC0ee(rNpbN zF}k`>9l+Wi=aJ4Hvw2=+l}|qMqM5HxG*6gWq(n#URvqtReIi%;n#x%V^vos26`AG* zBEFydYTlQmgZiR;&>7di^ayv#ebgRlpUiGg3ubq(TmFxsS4`Egc3tQ42 zNzhRsvs4da4vlQP3$qkKFxHPxYynh-a2(-8n61cD?F+gt_&zVbU$%N(WuS%>z*Y z!99yBDHIV9|7vSSrb1H?_q^Pvh5`3c<{nM#Ni-j?xgV|ze9e73R}*gMe_qOo=W{uc zmlr4&EgIrCDSmUco8z^{&L0`R&L?F>osRW-f8Sr~?1M2p^!(z~TY%!V?AZC*#%S?C z-rE`HzA;mrXS^r|Xt}=Tt{xIZPU6fGXHD|7Ru0EUL?eD!Eb*e1{2+?*+ac^m2H43c zb{s4r70<^yhxs^;^~Z2Rk@x%n$E81}TMoB3`1n+HtlRu|oD7>z^CcZ38DwQjbVONJ zSp$~glW={FQ65{Ckh95(TSZ9Rvt>~NY7s-T`tI*rO$&H6~MbPp~s=2gz+Z3l+Ad}CO z&ryy!U|SG{vH>aSKwyRW*DnwI(KL@ch$!HX1r$LMItP-xu+lr85ua0OMEAus?v$oD z?*HO;Un0wK4Jw65zOce@`4gRR)eToSAxb+82jyY9NS32LCM4PSjmC8n7Gz1Xv@fD@ zB<*54$&0Cy)zw-Q(fMqa&zV^<+u{D%I$0PPrJwx|9#b(Tuvgg*qHSwh?Apumwg$ae;0DAn>1Czwp#L qmZ9_Om$rV3CAThJ+`6=SrLlDZ1`|g<0Y6dvz*o?XZA^^9$o~VDNCx2m diff --git a/sources/ASKUSER.LCOM.~4~ b/sources/ASKUSER.LCOM.~4~ deleted file mode 100644 index 03b141455a2eee8409f32a088b8f598d4115bff2..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11782 zcmbtadu&_RdFMlZG_^EJRyMTxwJAt}?!i%~=+WTjZH z?F7rZ07-#t4GIjci=;`7qJxXX*|IJqW$uq=D_3B^HelEWtXPx$zpeXYo4gHe`p4q^ zzH`pyy_DjnYXqD3-1GR(_dehEof}MN=CW31dM=yGOlPe*&W;x|X1Z+7<}z$NYn3y_ zT((pgXU7X>YSBE~*Euy9q;)B*C}+}aTnkN`Pd_=Whx8EB5;I0@MvIQK;P~q1Qx_W> zYc;lcfsM1lFQrS1&)vIpdF|5WGwUlCH&!m3$!)H#Y@B&&t+uiDtZ_PWW}|WW;_Bw5 zwKJDDpT4xZcKM81T3jk+il;vxo&t!(w0ZFo_6cF1_)JKfG4yfv_@%YpMuV&Ml?zX< zUA||AsgzlEXf4@ktNQ0 zkL8-+%JysBCCR?#XH?I(yTburLoji5@5t|}2KacO$43whiLtOI(9gk_FkQC$xuqxA z(W6Y$*irQFW<%I!!>>lVu1GgNiqgYApRF-Iub=@G?6oP-bU^{I0^UltyHJ$aS!O;X zb$iLGWUcgcp~%abRGF0C02r%WTt-umvGeqZ$VZr+g8HPhr1;bGrj^cRiqo@L4*e+6 zQe9$wN*cgi&O9r6b#@ByQ<+Q}22{$(sggZ?rUG?=CZ^_jCOwxs3wTgC+g|7`#w<<% z)L@j9c`jSbtM>?oX|;L{+a^j&4FKZ#LRl&^_2^`k)X*4IwM4BDGp$ku%3oj!WwRRE zaUqfdi?P(aNrO?wbLnzG0gHG)iiyAW=E60n$DrS}(A$*VH7^m1>FP=Ey@mA8E zPd!F{Yc*Y&ugtA)3<}-dVB#_S)6vRoXJ2D=w)MXSzJ@tHxXV-sNW|tM_)B|7DZ7b@Wc4S1M^f zv?#?M=$xp`Hnv}va;wbUsLV=UR&v){{>NK;Us`|n9d~!yhyH7X;tfLfdTZcsH};7o zlGxV3JA6pIR|A4vLD<#S-g|lf`)4b2kis_Y-i|4x#kxb)KzmZ@jwO-d0iSF_Z zt-aqA0N%Fgg&lmCfZ=&ftyYiWz};e9r7+eI3REeM4f_xC&k8^z2i3G}`!}*R{~MyS zd2qLi@`>NCd5676xGpI@=<|2B7uTUndj~7&n%Dnrug@n)KH1q@NqfEPi|g+RE-TLL z`R7V{c=#v}`#b(Gw><6oNOk0T>%%Ye!(tUM_eP)!BmSFv_=pe23nl4ey=|Lm-}e^z zVS(uX-omOMLmPvFk>ierRRdy|_xVsY@G1{T9J-4Tr!xnl9C9ne^_K6$O4@g|<$aC^ z9#UHnUKd*48{TSE#RhMy=MD9Ixq7(UXg=s~*Lc*c`r4CH+j&$dfX_=<46XCPuMM^D z!!)tvatkaHK zR0H3F9!eMb(T)tr#RYP@johvFN%9BnBMz9i_|QwXm>$V11>~&#r9Q{>5-r<$k~|6& z?P&86;nn?KFSHI5+t2W!nsSdY?Y|-4`Z;G0_=*!Bi|Y-0bN9N=V8z0Q89veS-Y48K zjLo+?*Lk7kyHEMI8VH&qU;o!`Uk{!?uORlkbMtivHaW24clKOO7`d3dy~Ttg2t`xu zks6^qlKZrCz{^uv%~v|r4nZ2i(6%NiE)ZaTQ9vLlC8N65(@KFxzti^op4(}|SADU0 zWw#IHhlHn5_I~VG=PrS4<@~W~03vHjR{Zh?3eR=XWu%B++RwQy#T~SWo%kr+aDDsc z-NFrj&EzjP2Up-p4zfkji3qJ0UPjKJ`9yo&FEeCuF z`z*q^1#C)GND5m&UGxO?Xq+PXA~Fi5MX}Q*V*i%NL6$LJD7z+ZW$R@LT3+Kl-28aiN{eSbDS;*18q%3Qvh;YuE++I!Ct;@Rk;Kl4TGXDX zNYRK5%U0Pu4>o9VZ9>&Q^iZ_N;84VH$s-hwDtUyE2iX81Zju2cA3~bgj}pp9vQD5S!1=y0Ede6? zch(Y7MI8+qM=>mk%VoIS|o<-T$WC4?nELe2q^R-sLJ%rOpCx)gqdj(s3lQbp3UTPAR~f8 zt5i2F41U`xsf8nserjPOZtEx78q1lba*AnTDnO|HjQCFB8xXESuxBX-3J*Z6UrP+s zlzUv)!F4G1P$}S8?U5IAX^BjFMLOr)5wL$M$m=3o|MI2O)vQ}ZKj1wo+lf90@ zT%YW9;OW>KG((yjYW6}|l(j)Yh|y3w0GBfybR}zG*!_@UiaR>=9?fbAs(I=p(}0FL z$Z*=IV+==u+!eCu(=?bu|7k+UkgXMP8NC-Op_0HA$)ePUj-63}5efBz2!pDJ(m%=R zdLm*MVR2sK7@%tgRqk|GLoq1Kgf1S?hLe<+5I7p4wN!>iQ9e_qVlg!- zs=xLf-yyhtS@?97N^z^DvHNkjA!Ko*i~}2IiJ3yF7Q4V%CV-f#QQ~xRwXv~;$}NZ% zZ}zMxr0I-A!9t9v2tky!$nU@V)2n}r66!afX+>ie*5>V;mIOJ$xy^_av! zMN=(=^UsAkMG2EEfkWBpjN_QS6E1N?kN2|}1#vEoi6N$PaX&@}k0bpUJh4mo5jcXQ zEDV8ROS)SMODQN`8*qINE=J6-ry1}`F4h`2_U?!C>q7)|^l1@7R$0ZCTfsQs8xX&Y zSF6==s4S2OrgAgFeX`Ros?`<26jTkaeVjeCx_RM=#-*noL0b=j+?`#}mtYL&OwmCd zA7nvXlW9gc_HpnNp$K5zkNW3sp$)#3ETvO(-e2oeMhZf~49_gnUL4uz>; zOR0<-Vo}Z~>7H^I+o`NCitF=P2qcU90#Urr(tUw*S(wF@L0<_zi<<+dM4!d|ff6aw z6vPJ5&@3(w?212K7N}ag;p{fWJjeZB&;HWz37?Z%ixgNUcN2TPxGPlmGXiOO@k3WE z59iMTp)y^PD18(G4CE}$$u-@5ourN%agCZ|!4Rm;md-P}rmIpjO zk2hI3*4dMM;Fu3MS=rnm{daECNXsSDiEgAdL~=?KaC`SZ0G0H3J-(#5-T8cBD`wt| z$g26{9#fG0xNl=6dF!p@#&6$xqn6xY?`;P*R?J&(nbeUqMMs@jf-6y(is0Cnt*IRd zP1q_B1uAsULzk0u&jUH(yn~di6g?5fh(&t*c_PmcMdGv+&{Z;tNma-;9aiyzvf-F>no{>-AXL}NfISm)CL|B)HY8ptPlJ4 zTKWIpI#L<3L{_{gAKNcm>pyz5`LEXcdn4bU_nmKkC#edrj-ovLs+kjOZvLjz*%_z| z%`OV?3)@$py8ZluC=mWxCGckMm7L7T7r;TyNmAg^ohVX+2ehM5>BPJ`}W=2;-*x7 z2OuwA-BN_|+2Rv|g`8IW9_XB17l*MyUIVtA9u&OW-nw@|H4M9PYQeuXxv(x+{GhqL zHMa2GtiQ95r13+azy0&9DTdnH*^a*fmLh^tJkb!2+T?;jxI&_Vd_R2Uq|_$*n!sg0 zl4**nkWg0AK&hK#kn(_5OrlR2q(&OHr9wNAiuA5h=>vw|^}A!tm=$wf){;iM4wgCG zpt_CqkDznj;eaPu^KY@$0aR;zt9xaM?VOzsOx!)~ z1g3pPP4Qw51Y*w;>be?mUros`CFHdcJUEOrRxp0 z;=H+KZh!irq#hUd^|78n>B?FhkF8Hgz3jXP@qkLk0Y@pBEqW^bp(dEI(n!2f z6SUjNJo?oUi1l|M1W+Bqb&!4{b3*J3?oC0((2T70uXUh2F!=H2lTRA-D%`odf0)@V|3{wv8w-4r5E(iu*9lK7}WFjHmS zy<{=UE1*#~2I_=SbZcc6;bawF$!>%+wZmcKK~10$xm$aq<7(DHoUTRkLz zoWx}%E}7&tt=x_eiAnshIO4@DIUt&H>=2@n9q42gIxdt@gXbfi!+aF?`6IZRuzWwj zJ?W3=(}vsYd~~up(rx}bu7pju`H~EgF55*A9c2W&twERJlkm+NL#0!-kR<2Cr$ngO zvnA1j)*^Xk4=mw3CS9 zRJhoo8OWyGJGg=opof&lKt>}AW|Y{Vx;4(GDdoU{9vrte@p55Pd|$_|)YsU`hFadWYuUyKarD$6eY+#_mmqv_xx7pf5EVde8^?PI*c1!q0}r_SSkV1hrahvZ zkn#^A9#ZWIdrB{UlYxi*U7+ok)O2a{jww#DVAjf(&rzWv=vWY?vO&q|U~rj@uU#G- z$5aa+9-@Ii7E}O5$s?HJg=Mf*-ph#LbOvdCF@q0D(;OfD;*-8)j^o>>G*bA&GQ$_2 zScEto-)r`GLa+dNkiH(vQ;Z2t+T@8b+Sd(OfF;h-XNk0rgk8*}crjhFm)eIS7N5=W zSu-c79qgypMb6G$`qBUBJrxo~$w)JumW@FxXXZ_8Oi!Xsyb=SY=?%}Xm+ Z8k-kjFbNc3@DsxidFRt#Hqy<<+1DI;=uFW-ve@bV#x5_u0pQl_03qlik#NwHkp z36^yM(gN)o6c`#8Ns}5y2N#L6WnDuxqNmeXU=hUw3Ib66(g0;GJnpj zWJ~#6x#(v{i$;3UI5SW=JshBZY4oUMGt93AXN;$xoY8}Nkm=g27N3m-{Vd>L*?8(= zbA7eWHZCwf8~#$Jy!hOyrOT_AE}vdozPP@8;dFjuWqJMdQ>*p$)n`K|Bd6D!moKht zTv|PSdE@CzE321J8|B5Na<+8x-pDkDNX!@)FJYcwkYSRbHXG9Y?D0#h{fUNG8p{`+ zT)lkvEK@yM6LS~D1Pn87C38^`mbqTC{MGCmsX!?ZajTikdF?2Ejm+Jes(4S zDe1Gp@T?a3tkTz}hm|}H2w$Tgoy}(A!+|2xSUER4dm?RA((^N=Y-Oor&dil~;RGwP zp!}9uDiqGo%<rV=F8d212boh{8AQ`5w@5; zFWW^~u>^GDWtzE?o?RYSGdb#Um!5Rt?|653gP!F(=(j0;drN2K$Inq+*IV94&&I^c zUeU$p3Pf~Ey4iEZypc0mIBeDAIbU2VvQSV=t1&&y(%b|SKtohxvnDSUj64e^nChF! z=5vJ{tOww->dF<6dNxc~Dwsib{Z282EiwFRtm}&P&_{84(BrWX<8ccfz`<^d15Fnk zfGW_fbi0E@Nu6mFvJ%@%W;JJKW{M?V$)+m=`VfXOE2Z-&>M?eX9ufHnvlD<%CP%=Z znK#T#K3keep*!$VrmniA`h+xqxx8^k)avX6#!qLn85mGGE1OF3444Yw0wkvAc{Veb zKZEfAILlt>Eyhev1E`Nt0`pw1R8a2`e5T&&HEfwEbq!%4UMN;1n5jl5tE7U)0M#;; zg3K_>Re-<963S*Zl;c7rMHXY}d4oPi8P8`bl~f+(2rFZW$)Xe%J^=D#W*V>X5T)E1 ztW(BPzJhm6yce=%nkpz>lv~JIekPsI8s<`wJWT;Yf?EmMt|Js?$_PRcW(|ubQ6|Pj zDJC^q%EJ5DLxB48#jG(8lcW(7j26ao#gbVeIl*NGcW4Kd+9#_TEo>{tONdpC963Vx z9@{ZavpZfqw$J6Rrn;YdjQrM0sybhtTU#F%*j;DhG5YiIYNorVxsvI9wYhb@?fU(_ z)b>XL){jw9A$_7TQC*l=S?E>suPRf{x4tME_vCM*S*_ejJ!%Jf)%m)&GbODAFP@e8 zYr?yV!CHsx@;9zk=S5|&u`;g)lEZiIateRZcI^S%F(HixtIlPCa z?^Vx+eAnB1|DrnA-PPXvXWrMVbFkDo)L-!a>^(8t)%M=kL^tK=t8?z!NUy#3r|w!( zlEX*%!9}qO)O_Octw!7Rx7>HN?fOeTi{Bsf5h0{4l)IuNI&S`sUG7}uNj@TacUJkh z{h>R=4>l&`=;J+pbn^(G{OGTfJwDMnz$f{Hq}1v)*|XcPqJ_7_mDyo^NiB^JMLGkDu!9=cgMJwNtg(9*=u!@%El~`01(I zsb1?pEEYEpf85Z^)f69Dlxp{Nk5x0xt=FX9s&hB087a$Z{(9T{czgE?Ywx`6tWJ4Q ze~n1ILBw8f5B<&h9??ZI+a7wGkBIl0Pp~T(yV~A;iVwcuQ=NkrwrKWFOc5>m9jN&_ zQwlq#B!>GuvhWyzMHJh+zbyuM%iH#&ugl;dW`z+68);hiKYNhwKOs6J;?77 z1C8xh&2pVz&(*!Ji^|sioe<@dzgKsUx({((a=PE+?QSiu0ZY4wtEsx%`(3xkBUnD( z-Ca$&-D`_$?+Pg^$?W>)YHD=!Fb{jX-mkP>oyJ&g?0WmdukeGS7btf}0EIE{&0T!V z1LFlq21IY!X3Fz}MSf5a`aieO>!(0tKnT)rBdq2Vv%JSgYQ9&vPtwp^ggWguQ00gd z4A=S#JNy=Ln{Z>P?qZdKQrl4$2q z0RWGis2Ew}zF!;Z+=phO%kgakz0y-(zCi_VXI#8q<56Pe!+&VDKm0o$_SC}d4|~$i z+qdsl5cw1(O9|f`;wQ#z4E4bOYmj#>(BnQH@VN2cGa&`feL}tvSF<+NQ&v$MKz36o zw{r-(mU<^^r5B8GsC7i)UADT~_WrCtNKc@!Jv6b?TeiJ_&V6g|wB1*r(~!{VjHTQdjN~rv2CCTfbn>0bglv zW6){4e%I-=;j6yby0X&;@&m%tD0@G0qRKpl(Ee{Zud4Q);o9wN<-KdRQp5p(k5V`DPL(`~D(Y_}&YA_xbE5$F4 z@mVYts8b67A0vT(@K1dFYWw{$@P57h{++ZMzQ2or`vbbTUiC)=SUz7CB!%=S z0tQo-H3T~YZ0WXK`iYe=)AdMVdqXX12~detBQcyeE5<2|4r;3`dnd zf{2n7;X$aIbO4fq2qFhbLUKuF5wrv(Kk!XUfXTs`wFHo7sRu9C99kmW$D1Nji`$~^ zSH&!@v^ZGk4-}8s_28h8Eu;`hLwwt2k85G|F@~g_Y!-t6B%@jkU^6T8BIea%JG;lw z-K4K&rbQDWd;Vx#rnxlK$E+!$(B!uHqhSZpQHXW>ci^qhR5ZBbdnAGATo|Ypi6M5E zxmHU$kqFWSio6JNHhnYGBCr)$4w<|vc&7#PlW=kbrI>w^5C!1uEgn~B# z%z|npsFW7oVesVOt!7~)V5OwO5JbOrhn0FR-9m8_d3#c1G?8ir)_UQhBP;1^aWUy zwE-X`Xn+ob%N91dQZz8^!I5E#+bZ-v&#DV@eQG7sK!#e#u-d3)3`>EW6}lKe8cbnu zHKAq5LIqq#|Ai8)q;SQuNCcu{`z|093HG-YA<8XE|0J91iHMb=#d?WlfDR#4GSrzX z#YbT#bS!}~oTNOWz>1siLLkwzjHv%pylhr# zeW(N=GRj~Rf@M>1vp|qY`@`TU`w!cuTHwN1s&JfS6-f=0Qq_W3{~V;#E@6r#uqfM= zaV)bRM@t;L$NO1~HgOKb#IUDwNIymkkFEU}Jh4Oh5jcXwEDVKVN;-K8OD!l_hv52b zT0*gYmN^8Uqv6L$~QWnX6((VaoDxQ-5 zBK1C>gF5U*-9t+U{%)^DVAgDq|C<>2a0|Pxv zb8<9y9yY1vMjW!{Ss(~*v-!+4jtFq}A^Alaha!F6LFGP|$K_5Ik92n>A2{LxO=d1X zO#kh3HbS`+I`NILhFDH(V%+}e5Qa*++%8Yj*y`R}+>9AFBQmG{xXTc1KkivyPTqPm zx&GU?Uau$D*}Gf5^=0GMn+8=R4N=h`k>J2oh9X$@WoddFL6a5)q9BD%f#~RxPJy5& ztas3onWiVUG2&E>^o9c>K|S$8^edIl0Td{Lm$-eD1z!GSkH_Urjv7Pr-tNAIn|o6W zw>l3teD3pg?>F5mR`w-bwMvP_KTaZni_F18g4@>dg|$)7ZnN;8n}@0+rihal=B9rF&H>f#(#-V%_v&kmA$w;03|Gmx|{peO@f(?7gT8m&E9cYIJScY zs|H)rK|o`RBA||aIXwxdaKwG-V2=S6_r;Bs+aX5;m5w*qiv8x)xpgr_X+17Z^J9I5 z(t);gT9gMFI3;&#ntYl)zVK`W4YCOV09xQI7Z<{cWZfhohvxtWIlf{kd)DFjU^@Q> zX%8jauD_>ztgAV?yhokM+8*c8?k=NsP9>XqjsyVccC#+sK2OE z*#bSOw750Xx4Dj)lC^z|?OfxDG~(H`v_&u>nc(rDjO&l{%7LKePl zCF5mw@i(__q}8YWG%OOEx4+Q9jGgy-s!!`5v97>At;ktNW7~sw zr5`nHYgNgPek?p8^s?d}><3gZj&T&oEY(x$4>`fCnL*%32WZA{U^BRaZ80l0ixgD9Sg*Zt6%OD!+`rJbB`u>C0kF_-H$W` zzEa;S)P>vmua^tr`Fug7>jjEMi>CNZi{C>1=6Joi^+zFJ_fA>Spwqto-wzkNdteL? ze|cf*Z9wr_e(YR*ZM3w{^mfO&Z_E(K950Cp+O8MfwF6?1<2cI15tKZ{mDBMN(TE=u zOT1_$KZv6Ib^yDPZRF$>IS!JLl}EP!ARotR{}>J~OwW&Siux0}_;7oTk5A!Pp!M%K zFgBd#OFBfjY$ZW-q!FyL1}wuT;YJ%nrc;#=BjEGB<~JBa9DXl~U2RAJ!1z*uX}nOb(4$NsUK|i*3k2H07MZu^9n*2zf$? zXk@~S0vlwv{A`9o4lL*azqx^z3mfA09lO$4Wy_CmJhMu%h~GJCWyh=)iz4i!r-$ig zkBDCa@WGYJdD;O{0@Si`aV2v&P%0V^Jm9Qj0p~qV>x*(i%0GzxkSb4FP5S#cx$&@W z4O)IlHJ3JTn<6fXo?!Rh%lxInBJRRIv(c=x_2!k;OUvslT{?c5uH-&}ySbN7`q4CJ z<|^V|X<*p4HVS(KDXEq~;5-XFd=Fwji536qWnAzjdS%W}6vg%t*Epx?j|I%Z9vjXM zh&`$EKo8MLu_F>Ln5=jn3YDiq;&Ud8q(Ui+ORgD?JIc6jn9OtB%gP{uPy~rZL1CqY zyQCFniHZgTJ#@3JKs#LM(GsrsM8rA=7Q>QW>B=O{BgZaf)4Y@^TV1Us8ITB^$@7$v z7ZMzlpM#z4vka2|(Q_&yN;ER2F)|scB{Odn3=%P(#F}^|sY~G9@9>%b4_X}lB)vO` za4=758PMf0AxY`U(GCoJteS=cNSk7NRkT$=gW`_hJb>yyyL#d2RV=ILRxfS*7E5nj fy0~#^`AT!+0vtdB2_^i*@B`mR_tYUO3XA_2*9b-8 diff --git a/sources/ASKUSER.~1~ b/sources/ASKUSER.~1~ deleted file mode 100644 index cfcfe2c5..00000000 --- a/sources/ASKUSER.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 12:04:15" {DSK}local>lde>lispcore>sources>ASKUSER.;2 48577 changes to%: (VARS ASKUSERCOMS) previous date%: "10-Aug-87 15:50:33" {DSK}local>lde>lispcore>sources>ASKUSER.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ASKUSERCOMS) (RPAQQ ASKUSERCOMS [(FNS ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER$ ASKUSER1 ASKUSERSETUP ASKUSEREXPLAIN ASKUSERPRIN1 MAKEKEYLST) (INITVARS [DEFAULTKEYLST '((Y "es ") (N "o "] (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-87 15:45 by jop") (* ;  "reads characters one at a time echoing and/or prompting as indicated by KEYLST") (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) (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 '% ) (EQ CHAR '% ] (* ;; "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] [COND (KEYLST1 (SETQ KEYLST KEYLST1) (GO RIGHT)) ([AND (NULL ANSWER) (EQ NC 1) (NULL DEFAULT) (OR (EQ CHAR '% ) (EQ CHAR '% ] (* ;  "user typed c.r. 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 '% ) (EQ CHAR '% ] (* ;; "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 '% ) (EQ CHAR '% )) (PRIN1 (CONSTANT (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) '"one of: ") T) (ASKUSEREXPLAIN KEYLST PRINTLST OPTIONSLST (OR (ASKUSERLOOKUP 'EXPLAINDELIMITER) " "] (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, bt 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 '% ) (NULL (ASKUSERLOOKUP 'KEYLST] (* ;; "space is echoed for all confirming characters except on a terminal leaf,in which char isused itself.") CHAR) (T '% )) T)) (COND ([OR (NULL CONFIRMFLG) (COND ((LISTP CONFIRMFLG) (MEMB CHAR CONFIRMFLG)) (T (OR (EQ CHAR '% ) (EQ CHAR '% ] (* ;; "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 '% T)) (GO CONFIRMED] ((OR (EQ CHAR '% ) (EQ CHAR '% )) (* ; "C.R. or space") [COND ((NULL NOECHOFLG) (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 (COND ((NULL (ASKUSERLOOKUP 'KEYLST)) CHAR) (T '% )) T] (GO CONFIRMED)) ([SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS] (SETTERMTABLE OLDTTBL) (EVAL (CDR TEM)) (SETTERMTABLE ASKUSERTTBL) (GO CONFIRM))) (COND ((NEQ CHAR '?) (PRIN1 [CONSTANT (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) (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]) ) (RPAQ? DEFAULTKEYLST '((Y "es ") (N "o "))) (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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1228 47656 (ASKUSER 1238 . 34656) (ASKUSERLOOKUP 34658 . 34986) (ASKUSERCHAR 34988 . 35647) (ASKUSER$ 35649 . 38557) (ASKUSER1 38559 . 39590) (ASKUSERSETUP 39592 . 41721) (ASKUSEREXPLAIN 41723 . 44918) (ASKUSERPRIN1 44920 . 45396) (MAKEKEYLST 45398 . 47654))))) STOP \ No newline at end of file diff --git a/sources/ASKUSER.~2~ b/sources/ASKUSER.~2~ deleted file mode 100644 index 92b109dd..00000000 --- a/sources/ASKUSER.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Aug-2020 18:03:26" {DSK}kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;2 50823 changes to%: (FNS ASKUSER) 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) (INITVARS [DEFAULTKEYLST '((Y "es ") (N "o "] (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 18:01 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 '% ) (EQ CHAR '% ] (* ;; "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] [COND (KEYLST1 (SETQ KEYLST KEYLST1) (GO RIGHT)) ([AND (NULL ANSWER) (EQ NC 1) (NULL DEFAULT) (OR (EQ CHAR '% ) (EQ CHAR '% ] (* ;  "user typed c.r. 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 '% T)) (GO CONFIRMED] ((OR (EQ CHAR SPACE) (EQ CHAR EOL)) (* ; "C.R. or space") [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]) ) (RPAQ? DEFAULTKEYLST '((Y "es ") (N "o "))) (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 (1262 49897 (ASKUSER 1272 . 36897) (ASKUSERLOOKUP 36899 . 37227) (ASKUSERCHAR 37229 . 37888) (ASKUSER$ 37890 . 40798) (ASKUSER1 40800 . 41831) (ASKUSERSETUP 41833 . 43962) (ASKUSEREXPLAIN 43964 . 47159) (ASKUSERPRIN1 47161 . 47637) (MAKEKEYLST 47639 . 49895))))) STOP \ No newline at end of file diff --git a/sources/ASKUSER.~3~ b/sources/ASKUSER.~3~ deleted file mode 100644 index 83968ab6..00000000 --- a/sources/ASKUSER.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Aug-2020 19:36:30" {DSK}kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;3 50753 changes to%: (FNS ASKUSER) 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) (INITVARS [DEFAULTKEYLST '((Y "es ") (N "o "] (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 19:36 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)) (EQ CHAR '% ] (* ;; "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] [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]) ) (RPAQ? DEFAULTKEYLST '((Y "es ") (N "o "))) (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 (1262 49827 (ASKUSER 1272 . 36827) (ASKUSERLOOKUP 36829 . 37157) (ASKUSERCHAR 37159 . 37818) (ASKUSER$ 37820 . 40728) (ASKUSER1 40730 . 41761) (ASKUSERSETUP 41763 . 43892) (ASKUSEREXPLAIN 43894 . 47089) (ASKUSERPRIN1 47091 . 47567) (MAKEKEYLST 47569 . 49825))))) STOP \ No newline at end of file diff --git a/sources/ASKUSER.~4~ b/sources/ASKUSER.~4~ deleted file mode 100644 index f61e82d2..00000000 --- a/sources/ASKUSER.~4~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Aug-2020 19:37:16" {DSK}kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;4 50739 changes to%: (FNS ASKUSER) 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) (INITVARS [DEFAULTKEYLST '((Y "es ") (N "o "] (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 19:37 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] [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]) ) (RPAQ? DEFAULTKEYLST '((Y "es ") (N "o "))) (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 (1262 49813 (ASKUSER 1272 . 36813) (ASKUSERLOOKUP 36815 . 37143) (ASKUSERCHAR 37145 . 37804) (ASKUSER$ 37806 . 40714) (ASKUSER1 40716 . 41747) (ASKUSERSETUP 41749 . 43878) (ASKUSEREXPLAIN 43880 . 47075) (ASKUSERPRIN1 47077 . 47553) (MAKEKEYLST 47555 . 49811))))) STOP \ No newline at end of file diff --git a/sources/ASKUSER.~5~ b/sources/ASKUSER.~5~ deleted file mode 100644 index 84927ed4..00000000 --- a/sources/ASKUSER.~5~ +++ /dev/null @@ -1 +0,0 @@ -(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/ATBL.LCOM.~4~ b/sources/ATBL.LCOM.~4~ deleted file mode 100644 index e3c6e8598b40a8437a940f158ff7ba2c12c64004..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 35321 zcmeHwU2t5-mEK?g{+O$Q2P9-sv_$nn{u!`L8h2*!$K7b>0vK=x7|e`jh9W6*Ly;WV z05~GGB(>S~DpiVi9mPp@E0Qc}9q-1mE0Mh$Ck8>H68}!3Jb39!l^&ubN*?wl>q@Hf z5U7;LR4L!-pL@FdUP!dPZ?URG-0st-`*io|b55T=-IH4=FIMa2 ziC{(q(o*>|a`Bno#jB6i zu3f&^d+h1eZg2H>3nwNY>#g5-=JK`ctB>8d_U!e`t2Z7CJ9D)YzcxJ%{8`<|#DoZD zPEG_T3;8i|>H2EaN@n$Up1FSG<0r*=!fKa0VjbPlTmRJqeWSMP*p!-eGx7l`HZIWZxg2y5eF5g)B``*f{?&p>p_E8`+{Un-qSKVI6ovoCBOxtz+T z>eX6?{?B=p=0B)XRF+K*q|&8c_NN;=|6EnKwtIzz5310j^23VC-oBrHFrh`O-g$Hx zOG)*;)>a*#uYlBys&U|h>zlOd`=HS@bk5!bol`$Yy$9~0-szvC-qHuuYgH-5&A4ca z{EVOx#fRalCPo`vC93#4U%~X{XT`BdL>(I!gZ+nzK|Ykif0t4Pv2`N+_w@Z*DLg=b zv!(Eru)DtV$Ne)W_fp0e*JZu}j_eGN{M#c6`|Q?*v{|**6;5Ub=A*%{H=E-nx+8{2z_csO9wSDA72m+fIK? z4$s-GZm2r%_UOVx{R>BAONaXxKGJU-ZhVAVdZ=;ujmBZLbc9+ujFt|grH8nsYLsXk zF)dA&R3~rWuRs1g>h{e0b~`;X@=#-Hd+(uJ1MkQxRE?V|vGa0oX7fQ))yw_f{x7L^ z?hN%lbav~;Jq_r``WMDzH%0%#(SAcTj#4*2)(~$r1iCp!-4y7iKsP@Yb#vfSlxU3U zZVuER&h}sm=8-e4^jTH9kSqeyWjs zqmcu($B5b-sLg@ePes(G?nH^kF->jipC%Al+B~F)jA$F&IJYsma?hb?Bt|4U#->3r^4Ea zuysnz7N^BZ*sO%@ikO+oi}R;C(W(!`^lUMLPESmG(5d`H1f47tJZNz`h@i!y4=v2h zM$p29Y!{}{iZY1uv&f+2d@XFZJB|6qLK!lv5MczfQ(kMqB-cmSPB*4NIrYk}ZnB6% zW!YJ!eMNEBL(5~VP=pB4MO4OoC2SE%Fj-~`GZ2?yOVK@>pSDsn)04u{?b8_HX$V|x z_cg@~X2VWm4C{?@dtS_-Y5Dc|=|-n4W`cr{*%L+jt1_o&CauP%r}K6SGvhQpC8h(C z^-dFc% @2C{cwiDyE7v!W1mb3SFu&p}tg+ zAh3v;oVCYjvN+|EHYp}Ch!!oA`6(wkQ4nFRQ7>bH@?x>tg5oMp&m!+kc&;sqQ(k>V zQ3QoneZ_)PUon^#Fw3iFMR8(Aw41f+d|4D`iGAi<4N;gO1!!ipfC;lwfj6TCQNXH* z7#I3v5S~ zY0+T=j0IB)Z{?)!VIxeOA ze_vT7>4Mn)sA^*CXlYIgzEU{%D`ZOavnq|!n|~RDrE&ol>Us3rTId0Z40r7ZSgg^S z5&`5U;m~yH@uF$*L`s0&8fDRJNg)>4JOIWAR5q*R2bM-m>;=fP1$ImX1z36((}0m1 zt?DVr7Heh&mbX=A%2^*En|VMKXm_CnG5EP);VJ%*Ta{*HRf0R@Cf4E)5{2SppJpp!cs-HGO&|Xtf^`G zzNG0h%MnfHOVL!`*qlr5%=c7hmLf#+6?JB*^u|th89l-dDXS=#R+u5$x5Bo^O#klJ zAAfF&Zk-~l=r@xo`GKOO7ExlpB1&o?0^1)=#O*`6`fusK(yH2iFsaefW+%DPAF4)I zqDIYE)aVKt#okCa8m;j!_cyjbq-HdmT=kDs)n)_mwUYUYs;;AIY>!~~Oko*e9ZEB2 zath1NSyIrp21q)=eCHv5qi?8S^Bqh}>mynwf~183LiWbiFxFzs{+No|#Il-#SYU}h zi8XAcW{TDt6q8VW)>58?W>7Z6BqY0KGfYDCSe2k#oGQ-R%UTp?9C=U#X=H5_C#Trj zD9YNk-Y*u4kxd|q(pFK{g4F&+C^c@YFzci+bQbjm*obzLO^ZTgS`-}9qJW81)<6Mz zPgw(GE^2EakGbWx^ANCB$~80cu(qtW^Al56Su!vgGnjFNVle4Q+@R=KaY4SQ?TY~B zg0?RL)UND{NoOMLgh!7vC$q{BkP`U(e4}~J)6s#LgJurL;T;LnsZ_eO5pML}yYhBs z4=KQsUVV4QL-}RWy#v<>EZ2+tXCysPsg6Eh#fpJ_+$ziU0=t<0hOJh3PGA|FUuis1 zo;%kmw?R(9HbUVuum;UapdhR=5u7NDXB>TKYz)|3MEmqWDm75*7P4E1H{Ko@NLBU> z+}XELd1r0s;LD|rx3d71cD6=KT`Bdiz}cXTjBJT0Cc|yMQ4e6)i8>Ji0<}AgRP|y= zmW@=yrdim`w6#ziN*)kWWkkqD4C0^~rc0?1>gb9yX)*wQ$aSN;4z7 zk>#B2qY7pZu^!!i^`I(`?O0JXPb;Z}WzC}uLqO+~aIj6#Nju@#f$-_@;9IjoV-KrT zjXkz{T*!=qUZ61YCd6W$x<5rc1eXXXu2$aNdgzeio4e27$(pZ{WSDGNeWTh-m#`D9 zUU}=>=36P^2)&_1%g%-f#%9zwVB;A~R;SgdMYaT18JU{cRgwt-I*t<^N(o#_OV<6# zaB5>`ZAbI*i&vf}8Y|T|hf^5VK5>C#QV|J`A%tB}B)6NIh$eX1Y(34GfEPdt(NGv9 zo>cyvOR14xO+Q6zMp+4Z{!`zTc~v6~kpAAOE|bP-uis2D248LE)%z(ToJ?v(wpL_d|;zEWF@zPLdEFOz-eOcxo~Yq zt@)7w?Y3YS(&2tZiHsrjw=_D`zcp}B87Et_1{iMdxt03ADmPNxf2wgq!b$yQ@1wF6 zeE!E+Gh?Qiy&){K+p1bM-J^Sf@pavx&<*aVV*k)7w!gpmdE*k=dc@RsAl&LY#SZj0 z+q$x&y0ZJit&&sbzW(N?qpFUYs)oa@2c2TW{lBaGbgrx9(5wBblt-BJ0{H_P_4%+P zNN=?}t!n*LQxq`&=jq(1+-fyiu(1P5Vp~w2U&fwM0!<3sz_5VKiKt`%z#@!8bJG7MT2RNsb@uCY7Hjsr3ppj)EYpyC`Pa0a7_eoaL|X!642IGD>LNFD9=|K z0?o<4uxKne>>A+FdXqpXCJTt+w^DFL=&B&RsI**hu=P~K{-TQnm|kkBe@y~xL=0$u z@LAtM_*KJZL$^}TD+c|F=Fg$ctA6Q!Y)bFlY`KN^Z-$0-qe2HZkGqBL+kD6r`iiM( z_x}tMdd;FC!}tU+9ilWO7tAAz(E`|xHWVYwoE13!2pogX zFe_mtSa|T1M4SUMEeK3Xi&5axwD`njF-*M82QFdC14m2*(HqS?eGubBDvQM|84}8M zBz=R>9B;$;8Y~TN&qcCU3DwjHL@sS{Pw1(B{%cwi-F;pP%k9G(oA-AIjQb)zxcz_D zvX#;s=X!^K+TGZBtuNEle@xsf! z{hQ+^A3pT#=0_DElHb^F9{vL<&#Ksw{?*9f&@$OSOUtz%zkq+F>2e67E)P}enN`7z z=d7Tegc&hxRLmZUFkM+iE|}9zn3#<-81E?<&PRoFyz?)R_2fIR_e%fu?Dm0*9O!;UPc?=Wo#!Eg@OL(< z7&dk$MaC_aCyOa!%18_?)=uqaMrD)DsO-;cMuD&x9c)D150l9lQQD4^1W<=#ykM&g zBX504`@U666Y-v_j$}tPeq1?C&p>HSuF8Z8_3ok-RuQyeOhh=5V&ZEWsEiGQzBFwkNPeoM$~d$MwDj zI78tDWC``wCam}JxhX_w;I!YM|-f9Czr#!flZ zz(%uR`50#<@)fAUMoUnH%lT%jx)RlZESSkAs~tkl-jB$Sfu>@%%PFl*FUzG9pOS(_ zj1(hL&FsBqZYI4pP?BdAcLw23kW1S(8)X$Ff2o?7`-S#e+KF)z%0MshyD6vx<)++C z)x(<&&3+K7*6bnZh?d$QGXiIybOeg?DWg0=M!`Pn13$19OQ4sx1eSn;UN8$eVc;>) zpG;A(M^_HVi>2)LP*eM7UkhJ(3L}MZkKQMZR8%__y$=C>*z}*LGl*!s5lp5IC2a0g zRsW#=O7#z_qao}$yH{u>cV%hpBK609 z^Krm@+-E+9`y=7d6=?-kq;-R+2PgG_lNxbSYENwNKH|VKc1qIoN8JHC4~E^2%(pXt z_KeK*UO^QPCqN@Bo0DA3l4M8rqAB2 zg&0uyfmaIKQZEah*~rI6>j?EkreguZ3+`a-gh5thL(<+{+mLy6SdRh_&=Fc5hU1w= zYoT3kwgm0gm5W>sP=JVq`A)0$1Wa10oHm6J{*(5OB!Edv_-f07eXa75nIzn;RFzJ` z!%1TdF`wixD(>PTLXV0fH!Wu2X&}@>Fplm1w8$aIlMeXMgJ1?(s9lyqk)VJyhEx?1 z1yK}}P z1UL**BS0YxCLCqhBZ8X{B|_fwfQUjBa9Du(pneeB0S$_+9GDEA2>AGm2v-eo&M@}q zqZx#)=Ed0gF@fP88zWyQC9w5SKv1WApDueCvjz&xJ>4dQxeK4);GEVkCG&C5vi$H* zl@n|GK&V|s*hZzRw2i7%mwueZKamF*vJ!+@zG+$lyt_s>V#i5P!B9iQ$zWpe56gcX z-f{x76iMJF=8qFf^itZ6h%qAqHAXsz#$gRo*mwuOWqb!OUeUVX#SJ**r8L=jsh8H7 zFZK3Xx%;BrK`VDi=SCq>L%ls(oyR+QE z$brZ`J1h5vs#|Ib|53I}rz@|SBNb_mylT!@jB$ds>TF5r{71Qnu-c7>2y$R$StT&S zQ(_MB@2A<@9-X>H775PN7PJ+ZccTVU`Sd_)K-mE5Usn00S4s#Pd9B})3)P7?h4-Bz z9>fR*S^%p@izt-=^z)Kg&2Xwu2fg|v1qNYmOo?Q~C6W5i*+=32`U zafV;8H0Ah84%R19i083_-!Mr<>+BTuMBR?nCQV^Crir5B^}w3oB)wqc1Bkli;xr@p zGZIO-lBI}1c~;zxDEx&cBl*BAtq;t8j>(8d(B4NW-o%9LvXNq>sFTva&}=pAY7mo3 znkW6p5Vm@&(73&H<=t1;l=!Li2H*YT-q1yrx}yFfbBF%Fv!^$Bab$3?m%gZ#($>R$ zwblR0(9qI1ZVmj3N-e)RG}OZ3+^bI%J2#fMP* z2Z_apl8W!&x3u+#iN*Kt>uXzJYh1PXlRf(|jPG4omir)|7!=3+8f7$zgMLRFO=_E; zm`!gMigdcB^?=EOZRuqdU}Sh%6y;$K=gBN@l~+hUlig|yQ?ha$8enGFX>hw2&{{-z z53dG9wNA)giCps1G@(#W zeFDMVpuj4UN5GAp#F@_NcDY@xnVWQaGo~)kQJA9BLY^$5#>z^gUO#PIHMCK)tAwY_ zO47-Nopd84>D*P-M~1mP(Q=hGHcU>B16V+Q33tfRU$PJ=Ow(%D4Tr*x2=vdDTXZK7 zd?Y5JbaEFl`xlg&9zx;Z)-jbBNL%&$u=aZkS=?W)xKXh8gZ#;SyZx!{q%5 zmFd?sI~DBv%yNK@ju52i{K0L*s$M&cwb_Dcf=z)Ipl2st17_eSd&u7;?YS5Gr=>l2 zN%{Abh4Grs)K*PoXh2?)^H#-xNR>tcPlaVDANx6f4udSLm?DHLYY1L-rTd#X?@QNkj+lc&)J@u-&mmZh*B=gy^>x zPBAX?T&`4{Pr-;5R>2L6E=Vs;bVZ`zirIpDtDpcqU{|HiBaJ{Rz~gB{v3TsHd-;MQ zGc0I+#wnb4LniZZfY^oIamd5=wV@bZD;dByVkdnm=hW;+IbsuG<3i0@NjFAS?%1Po z^v2D>^D2$m{ZQPt-A@8UxoeaM8b_;r0}Ye`x#D%#)pTJ;?O^0g}Hy55C9 zua2$~%B^L??FFl<&7<7`I@eV@jBi&INZCn;Q1O2+C02r9!NbXr@XF4e2a-Y9zJN*5 zZ{zHQx6DexU1p`A)2tLGd!@WGCty&}UPK1!3-B}-f$xzaP?8L>Z?<501<*_8>Ir=J zok|(rO{_7U2RER~!@R33_$t%~W?SArfJRmsaKEUsb_^>Tj=0BG81h^~>kB#&a(82+ zq?ejTO{jhDWs0?vn;3^9(Fb*xh5WKc;qAgc-%HWy{a-KpOj+!cz#PeQ|MM~o#F#yk zh&zj>pZuv-3M|5@zYacu#UeMo0gO=1CJ=ox3)j9PCXpH75&73*5t+6)gwk^A=%9@_ zM02s3K^!SY2Ws`Sd{v!r8Z(^83^8>ry2MYlH-#q%7t;(5N*`;hSvR(c0e?0|{%`4WPD zwD0gq$z(8i?(A7wJ5s@2hir()%$z&@Y!wJ?@X9Rp-IOe3e)No9LK)lpOl_LhO+Lq50rYJken;o z#y+IL(GQlZ_Fm#x$lLnZTO75xNkc>fBD+tgzNsG}T2i0-;uII=JpGHa+};6l*&qSi zxZC?U`6Rl%qcCmp=Q-HLeM#jb>=}l#mhOWq>fp2Yn{uJ(#AocpxShz^iI3ZfF+1^1 zJ8{%XR4_6!1`aaT5?%pZ`o41kJmY8SQ%xHYyGp+l#@f$9l%$u1V>2%Y%u9k_iB}5j zbe9p11KkYRzBcdEF{N2kaCp!X(kljrgR_7TZ)vSB3cRz|A3|>vLfvVvu$zlr;5>{@ z4so;vQALN36Jiz{TghV|aD4UqU?*HBku$V|(<=RS`)QT)Qtuh-Q0lj$qpIsx?u{t- zrj`3_l)GrdF)3aT0hh@ajasLh>gJ3X z_#F0*gW-T4>F?;j-_(C!>aYKu{@RzrZu(n&bwt_^_33JQBtKM151#F&;V|9oFWo*? zF|{B}b!PLhuEM(w`Q+{YuzY(iD(W{VUx^UAP(xLLoX_0;Qtfsjs>09;)Y9eyu?}ni zCuQjbE=fh8x)*e@Xt4+8eL);P^_dbL;e&-cm4b z8hSB-H`jFJA3>m{wZz78Jp{HLWtu0cV`q40e&CY=TzHZEhF=G3)J}rAq`D zGPtKku?Newl^?%=es3O^b3uREq^hmgkcL0 zCu)sua9E>Hmm{qtIEaN4m_Y3ve-?v^D?0%vBftnr4@4(v?dF%WiY`m?^`oGxw_L<># zUNvIvOjdd^ah&n}C*{}O+;^9jd+F+MUz#S$bgOI$y(!53Anf6FoZ4_-#e^$(-#~vD z_CAd#kcQ362PXeVVeheCx<0(Fd~dhjyGgSN8=MT$HkJ_PQI18puz)SRJRfPCh9L}P zYR>3|oI1*d39<;kS%n4!i-24}df>=#)}Po4=r0^h=r8DX9)F6gH~CgJD#S}BV(iyj zs~5YSiIostq`0;Z6iE67+Un$o+$9(TG(hy)K zOjOz4^!PxOMUkTe?+zhaS*m^M+PD;fy8rUaom~t@5995@mLtQykwyvyS z5z~9FBAc{Ym&Gk~34f$3|3Lk~o<^MH<^7t|&dK7v=Trq%m3maCWJ7(Gxo($OvlCWZ zy(3q?|Gnkz(z{z1`_;<_`n?D3p7kEAXq_jUk^e}wc!&p7U8=i$Uso-g)a7AWOj5#M zS}IyycMcerue|k{TkriIJkb=+7r8@rp8uwh2&JAKGm-19Z^MG_X$fvN}BVCmbe&*igF&#Q=sob(fs0v@g zp()HXI)luE3=0kRl$8QAS}9mp-mFj*@5djVKiz`=q$7v*QG|se3^kDmr3!tAxva)r!QJ9rE#hDzfZxnz_sT#1?@ zjYKE^Ik~)ym6)rAD{~7W-U0=q7<(aCrWKGQR5>0xe;mgT1qcuOW!F6R%44n)qngGt z7?&9z(iy`dLg1~UKpCvmh%}fH;|k+E2Ah*WViRaK^2+a00&%x=J5EEXR(U8)5evB- zj|y6sgLgtqqc@3wpfKrzg57W!5W@kT$?Y&8hJ*9&WE=*>a1iXAjKhE!4txyBI1Gs4 zU}lnW7!boj)O9ir17bLstz;Yq#BdO8os7eP7!G9eE=U$6j>R+Xu@5ANsV|PjbM9j? zB#yYrtV=*L-#WU|?F(i(~bMIp@B#yYruV=*L-#T?*cF(ifs zonYqD!?GZ8Eam_oiy?6=<^UgyA#p6`03VAXaV+KlAB!PzEam_oiy?6=<^UgyA#p6` z03VAXaV+KlAB!PzEam_oiy<*AL_X}o8x|yv#T?+Z1#86A7sp}_@Ua*Y$6^lfu^1A^ zVh-@J7!t=~4)C!U631c=@Ua*Y$6^lfu^1A^Vh-@J7!t=~4)C!U62pQ)X6DkvvLJCR z<^UgyA#p6`03VAXaV+KlAB!PzEam_oiy?6=<^UgyA#p6`03VAXaV+KlAB!PzEam_o ziy?6=<^UgyAu%jCmv-R|3lhg-4)EH-L9?kZj>R0{V=*L-#T?*cF(i(~9N=RyB#y-# z;A1f)j>R0{V=*L-#T?*cF(i(~9N=RyB#y-#;A1f)hDBSVWCPZM#IcwIytWWYXzGh& zF$efq42feg2l!YFiDNMb_*e{yV=)K#SPY3{F$efq42feg2l!YFiDNMb_*e{yV=)K# zSPY3_!9QT;(!;VKaV+KlAB!PzEam_oiy?6=<^UgyA#p6`03VAXaV+KlAB!PzEam_o ziy?6=<^UgyA#p6`03VAXaV+KlAB!O|EF6~a!W$MOj>R0{wT1HvQ(qj5Il#waNF0kf zz{g@p9E&-?$6`nvi#fo@Vn`f|Il#waNF0kfz{g@p9E&-?$6`nvi#fo@Vn_@N9&$66 z9+m}(V=)K#SPY3{F$efq42feg2l!YFiDNMb_*e{yV=)K#SPY3{F$efq42feg2l!YF ziDNMb_*e{yV=)K#SPY3_1@O@C!W=dz0gsu$YmOojOqB_E%my($1|{GzBgF6+lz_*q z5W{0o0vf>3U1UzPn z7#@QX@R%uLcnnIwW2T7VF(?6#nIeYApaeW-iWnY)67ZNQVt5Qnz+RJYB0b8!|El@u&3CO^#kc7r*@Hmt*itKKSJ_`2SE8 zxFT@{uPe!TJvZDWio(SG8TsS39H@kNOdScYUzpJ;3i2!1ahOOWGEfFG9;Zt1gOsWB z>A}>XjQ@J1v_0P9+aKZfZ?ttP-9I?DJ=)PJJo_PI$~ONK-R8tAy?@fbQhDcfT-^HD zJFn_!xPzN-sWSak4n70K^&;@2x^SWuE>zDVV8s2c6olAll0o151ls^{JR^fw-fw_# z$D;m39)p5E0bOjJP0@866$fW-x}|sSd_rfXbQEZ6=guLWHKenKcJ#Fac*QC5!9KQBhaUG$r;^Nh= zxVd`$>Gi7@d*UVq!rmAIW=03G;dh1?@b0v{`JOAEZ8lmR9mCT`gth(!6AHD~-$2Df z_VflJhdL=r>g`TgM_5$me7#NaJ`_xapTR{noW^gtv=(cPGpI#{ZsV>#2B?FlISdL_ zM!$>9SBE*uPu03UPjpFuq)CBUQAU~m=Rz{ZkkTcFu3<4*juO^-kkx`O7-DSgh2^eo%}^2$~Kc=Jrd`>JK@JN#_mA)7a%f}VOJfs&e5S5 zcNvR|m#-*hvh8-nnP!SXERlSoz(kf2$1)^ssA|nR%UHbP)aupM>-fR-8?r(PLFFWS zZd`kM6~Eh#)wX)$=K9soVI=TN^PR^(Da8OKuJUeYuT`O=)nPbXwzr4~=u=R4I#T|}Xm z&9I8!n9Sh@0AwF2gk#`a;Hvzw6Rmk_b3VkK2AKu+lpLzrf~3(3BD>2ACl(tm{8qXW z$ep$I8{+AUm(iJP&wg(0CVm5+dUx%!pIyI@-&BJEIz=&uYD124B-NeMmZW z98;5wHMq5vIKs%SRq0?VAZyOKbs2SLBD=l1s4CBZQS6f$TUh<9Cmt6i~vQ>RJuE==f~t7 z8e>rblsU#%Ypm>JFbn7b)#Fhf%DVbR3ZGg7@y`qRL1w(llWU4xG=_5Z)f)3^GBe_Y zAO_vNhGbEuWm`)Tk1I>+qmGDdggWQwFP@4gDG@5RiUht~|C!vUb&JtOfSkH{Xele9 zvvS&(gP)&~Lvqi5GX`O?7M{Y5{g8fR!&I8%mS}UM-9^IA#+D%|8;`g}*_Lv}_Fu5Zn_|6!}>>^zf59dVWvubWxO;eO@&ELJu^<$ zY%@*HY)g@+coUDF89b7WM))B+HoUt+X>@&L*#$j0g}eu6k89C`xXl)^XK^aVDVRIy zup}+ATyTsm7aXI?1*^90k#ae1MzWmMxC@^3$HWEWl09|JuHIfqR<-P9mJZ=Wi1r6t zFdkuoW!zEZ0|dWHYk3lRdbxm9wa5Go@8-(~tcIAHQuTe1WaE}|YJl8&98RV#dtjfT zJ+LiLeXjg#V5pB zn76+p=C56U<{B(!ShTp5Gm959@DHAxn8lqw{DTMYXYooT{=s|svj`c$KX~kZ0&nN5 Hmk|FSoImbG diff --git a/sources/ATBL.~1~ b/sources/ATBL.~1~ deleted file mode 100644 index cfba1d36..00000000 --- a/sources/ATBL.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:19:27" {DSK}lde>lispcore>sources>ATBL.;3 254062Q changes to%: (RECORDS CHARTABLE TERMCODE TERMTABLEP CONTEXTS ESCAPES WAKEUPS READCODE READMACRODEF READTABLEP) previous date%: " 4-Jan-93 16:52:08" {DSK}lde>lispcore>sources>ATBL.;2) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1993 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 \MAPCHARTABLE)) (FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE)) (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 (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] [PUTPROPS \MAPCHARTABLE MACRO (LAMBDA (FN CHARTBL) (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] ) ) (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]) ) (* ; "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) (* bvm%: "27-Aug-86 22:28") [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)) N) (COND (RDEFS (CLRHASH RDEFS))) (AND FDEFS (REHASH FDEFS (OR RDEFS (replace (READTABLEP READMACRODEFS) of RDTBL with (HASHARRAY (HARRAYSIZE FDEFS) 7] (\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) (DEFINEQ (\ATBLSET [LAMBDA NIL (* ; "Edited 3-Dec-86 18:07 by Pavel") (DECLARE (GLOBALVARS \ORIGREADTABLE \ORIGTERMTABLE)) (COND ((NULL (BOUNDP '\PRIMREADTABLE)) (initrecord CHARTABLE) (* ;; "Read tables") (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) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (45032Q 67402Q (GETSYNTAX 45044Q . 55773Q) (SETSYNTAX 55775Q . 60062Q) (SYNTAXP 60064Q . 63470Q) (\COPYSYNTAX 63472Q . 64555Q) (\GETCHARCODE 64557Q . 65223Q) (\SETFATSYNCODE 65225Q . 67400Q)) (67443Q 124231Q (CONTROL 67455Q . 70055Q) (COPYTERMTABLE 70057Q . 70521Q) (DELETECONTROL 70523Q . 75343Q) (GETDELETECONTROL 75345Q . 77253Q) (ECHOCHAR 77255Q . 102153Q) (ECHOCONTROL 102155Q . 103075Q) (ECHOMODE 103077Q . 103471Q) (GETECHOMODE 103473Q . 103743Q) (GETCONTROL 103745Q . 104217Q ) (GETTERMTABLE 104221Q . 104324Q) (RAISE 104326Q . 105150Q) (GETRAISE 105152Q . 105420Q) ( RESETTERMTABLE 105422Q . 107522Q) (SETTERMTABLE 107524Q . 110213Q) (TERMTABLEP 110215Q . 110462Q) ( \GETTERMSYNTAX 110464Q . 111073Q) (\GTTERMTABLE 111075Q . 111621Q) (\ORIGTERMTABLE 111623Q . 120464Q) (\SETTERMSYNTAX 120466Q . 121665Q) (\TERMCLASSTOCODE 121667Q . 122550Q) (\TERMCODETOCLASS 122552Q . 123361Q) (\LITCHECK 123363Q . 124227Q)) (131222Q 205160Q (COPYREADTABLE 131234Q . 131546Q) ( FIND-READTABLE 131550Q . 131777Q) (IN-READTABLE 132001Q . 132245Q) (ESCAPE 132247Q . 132650Q) (GETBRK 132652Q . 133070Q) (GETREADTABLE 133072Q . 133303Q) (GETSEPR 133305Q . 133523Q) (READMACROS 133525Q . 134140Q) (READTABLEP 134142Q . 134411Q) (READTABLEPROP 134413Q . 146611Q) (RESETREADTABLE 146613Q . 154111Q) (SETBRK 154113Q . 157217Q) (SETREADTABLE 157221Q . 157506Q) (SETSEPR 157510Q . 162510Q) ( \GETREADSYNTAX 162512Q . 167672Q) (\GTREADTABLE 167674Q . 170241Q) (\GTREADTABLE1 170243Q . 170647Q) ( \ORIGREADTABLE 170651Q . 174470Q) (\READCLASSTOCODE 174472Q . 175401Q) (\SETMACROSYNTAX 175403Q . 201017Q) (\SETREADSYNTAX 201021Q . 203104Q) (\READTABLEP.DEFPRINT 203106Q . 205156Q)) (237147Q 247276Q (\ATBLSET 237161Q . 247274Q)) (250035Q 253130Q (MAKE-READER-ENVIRONMENT 250047Q . 251135Q) ( EQUAL-READER-ENVIRONMENT 251137Q . 252166Q) (SET-READER-ENVIRONMENT 252170Q . 253126Q))))) STOP \ No newline at end of file diff --git a/sources/ATBL.~7~ b/sources/ATBL.~7~ deleted file mode 100644 index 9cb0cf49..00000000 --- a/sources/ATBL.~7~ +++ /dev/null @@ -1 +0,0 @@ -(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/ATTACHEDWINDOW.~3~ b/sources/ATTACHEDWINDOW.~3~ deleted file mode 100644 index 51150320..00000000 --- a/sources/ATTACHEDWINDOW.~3~ +++ /dev/null @@ -1 +0,0 @@ -(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/CMLARRAY-SUPPORT.~2~ b/sources/CMLARRAY-SUPPORT.~2~ deleted file mode 100644 index 9cdfbf3b..00000000 --- a/sources/CMLARRAY-SUPPORT.~2~ +++ /dev/null @@ -1,726 +0,0 @@ -(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.~2~ b/sources/CMLARRAYINSPECTOR.~2~ deleted file mode 100644 index 53ec75b4..00000000 --- a/sources/CMLARRAYINSPECTOR.~2~ +++ /dev/null @@ -1,268 +0,0 @@ -(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/CMLMODULES.DFASL.~4~ b/sources/CMLMODULES.DFASL.~4~ deleted file mode 100644 index e903d28ed3dafd6a70910351e3d4325998bc99f5..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2204 zcmbtWZExFD6!uG&G=169(Jos%mdb7=r)7FW?`Hb8gb6ASNM^4_ChDp4aC*=iY2E zean(2Nd8)*=DC63w_A;NOSs|(Lep;t6<4?da^bpc7jB#@HQk^&bG6*?%Jmt|uav!+ zHFwo>*QX~=&Um$Eqv8kdOvkP{BNerxA(u48o_J?!$lm3x61e4-yDAj@`f7RogfMwZ zAdR5r2~%%Qo;e{*O`Uz~)Y-|mCx-IG);bCNXOrjOMEAMZda1dfW4EFi<3Ov{xUkix#;>KeL?@qi}fY zABi{dB<3++HUs&lARE&%Onw~E=(S8Tigpr2X)Htrcx;5Lzo)<*z@#@h)LA5!ifP+W zYdY6$dM?`Jse>*=c$k7vi>j>Pr=`4K0t7l*3Csbs`!Jky!BpZ=IEWF^ks>JorU0j+ zFRGTI7Zu%!M+cyU=q?w9Ba^2@V2_C0*`dz8ko<4TBFOAyk1|^nZ_1wK@2VB9v!}uy z{uzd6<18=+cmS{nJ7}=%Htzg!sA||&98or;5>`WyLc;(`a?U8}vYCX>K0rj$h+5>2 z;%*z_!*O;n&T_}1@H7!%ffcRT#6DFSM$z z&|Gh}+_ec7n+EvXrXs0Ci?htv@fcKke0Ftu_RnaR7We_PHEZ_xMP-9XoeCU4jZB=4 z#~7AjDV4Al;XtSFqE3nm%{fWr1w+*jL$H1Jh2or{iQD7S2eN^#4E4Dz&B(D-{rtQ8 zf%gd@oWoF>ALymA8|Ek+0*Fhx(52LFUdL~66vFLrY&^yeMB%jTR=jfH0vhF37cjA2 zUUP+7^F?R@IOEa%#BFf@`|Q%*UM@XIHmaHG&r2C9SlU1Kh&(1w$d3i`lsv2wR7=!D#37F zCh&h}0)$B)GfX5n(IQ}VH&Q<$`V?I5(F`KLhr6FZHz_HWWmvfV77pP$&}E!`6x;*B z!EJ%Kq&oAvl0bzJ9Q0!uHYHL3`un7LMJkARqlkH;YUe;D)j2kg#D$kIWKk*3Dc0Wj zWYUH0PKGNqIn{Q|d~8g?CZ(w`sYWp!pH9SQc#QZ%6y~II{dIUSYxUL6OLfzxuV>(X z+^z*MeVxG+ZrT%Q@qHAI%060netE~@W^UptUZ;0L&ahxj=p{`9LF{0Hok5{rw6NGf z6%A6O1M(_ub*IDs`k7(iA((#gL%<(~>iW75fjt~wPR5rRK8qLdD4e7v!@OXr=jWYh zGZ}@47TtQ=6^;qZZs30c{~UsbACy})zYg`Ke!=A#F2CaP8!mqgQdhBn6{S0GTMY9^ XpEL{-zXBsa*rgVII+?FNdj9+`CS-pS diff --git a/sources/CMLMODULES.~2~ b/sources/CMLMODULES.~2~ deleted file mode 100644 index ba64762e..00000000 --- a/sources/CMLMODULES.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/CMLREADTABLE.~4~ b/sources/CMLREADTABLE.~4~ deleted file mode 100644 index 01f13a3d..00000000 --- a/sources/CMLREADTABLE.~4~ +++ /dev/null @@ -1 +0,0 @@ -(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/CMLSMARTARGS.~2~ b/sources/CMLSMARTARGS.~2~ deleted file mode 100644 index a46c8ded..00000000 --- a/sources/CMLSMARTARGS.~2~ +++ /dev/null @@ -1,37 +0,0 @@ -(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/CMLWALK.dfasl.~1~ b/sources/CMLWALK.dfasl.~1~ deleted file mode 100644 index 34d8ac3bebf27fc3b952557a358a513c295b311d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 11004 zcmds7eQaCTb$=feCE1cp$?_Lvr_YIFC$j0piDM^@oxMl$NskiAM?X@QoVasoi3*j- zl0!*x+#;UjIEmeHizUSjUy-C}(ZXAX4XOaEmMmLK(`++_{gFR9tVoNZz=pNJ26z~T zEq@f*@7(+NAzE>gA=@7lq<6p0J@?#m&OPVcb2TYc^#sC7VEE*zfx%Qp86F!wH8!gB z4`-B-;jv6_O6f{9mZS31UqQp%nu9^X%`1A8Amuy^0?`Zg^d=4*VRNqZ0MePVb0 zr|;yXO~Zm9Jj;Gp3qoU~NbOod@CcHaznpDo3x)N7rE3X27&ZfvkbfiVX^kheXi&3) zzECvQm1xapJ$sbV;ZwfB)QhP>+Vx2ZSn`*$HEmtdKq6#D^V8zEv zLi2|!2V8zFuCEgFS@*Z1V}pY)3-9EFHGHqMOYGMptUx=41Y0JG#nqs=8uY|0GbXvv zs3p3C;6|LdQ|$;&tOj)cO(~yk+OyvW0r?)^?+E9y$1i8^{d~EDH1|2I`)44JXj>%+ zOPo@wIWnOhi00BO>0Zehb@ovS@f!8_x>oLXS9SwmO=Ta)u&Sc_nlWj3816ccAQKDL zw36of3UY3hC3LQKI!!CmD$D3-XbtLtux4qb3-MN&Sh=<}toMWhTG)3)vqB_33{+vD zzEzJN30Y<|qDK?0vb%&ZV8)I@+nV<5tx&fS(Or<)8e-$yP%5|I?1~0s)Vz#l4P*!s zLJ{hC)mF~hTVJr1=j^Rd+e+Nt8nBgv_SU^vt1+%8d_gnNMawgSx7v!=-r7VoW30^= z(E^rP+;R>2n^}MSXvA-Zivz1^CEMOY#W{QPkloU4dsTarkEki^xz*lykG*kCek$up zy>u!$)aNs!0Ue+4(fnjS+t{O9W{)pmMj~d^M+#pD(Apx5y+gDgsG}8rkk1}IohB=D zIyw0Kz|gb1l+pCSh=SkI%veep=vPjslw>BQoJ`WNl2m$!Pn}VQ`vI3yuy`glGB7-( zoJi3qAxZTS;>rB91d6NUF+C8{!hAp9F0R%)+?Tp@MPM9Ey)@9998^+6FAijehfb!3 zMwR4<(x1#waWdJP86IKu^bQa8rZPjRzHeeBd#Am*pO-Di^I0{i3=WKp7O3n?^$sR8 z$x+ZbqV$esGC(?bMj04VQvLm@-cf~fpo}Jyj%cGRCt$r?F=G_vNU zO?k7)Y~GHgE)cE9o3N7EAUUgCH9Z}S7@~&}?IpXvc`$kML|>9vc&9yS5Cn<&0B|#( zt=qQEIrFe+`Rv+4v&>G(O=NP~^(c%$gZ<ZMC&1^Gwou1 zp?HEQeIr|SxXVoF_M!arD%d5t&9n%O)fM$6LJ^%zt-S*SQV1@Y9cxQJqFZqtQ1#_d zaSo=%E2f9-9d?LRtfOK^n9ryVm|;W=phmWXwqZwY|1*qE(SA}O2TW>0LRjwM(D^yO zSZcEGtFgDa)`NOacPL@_qIx$BV>E#vY7II!IQFx0tj>N~w4V`i9_pQ?RmsaVz+0vP z6%GXiemVIIqG%ryUD!4;$2(5n7Q2Ot&GzQ6Z0F5UNY__zoc>TW7>c&j?pvJQuQXm~ zKP%d4;y?p9ph_&p``=-~K^6+xEnnG&J#0f|(L=eYE63{W7eqVrf4NaF#Tu8hO$B%E zbG)Q4mJ=V1UrWy$@rC^^eO|nAnhi-Zx5S(EgU{tSfjom(U}zFyh>tuwHcyx^CMgBI)#c1e@F`{gqKF_6TAf z5Ur^|A|im7VVvAyE#ePq6z5xd43`SB441Ml{fHI@1qf_-FbOMb@5ohIsptOvhtH=S zOL32MwJLpWB6$s*V)glnR`kz7>K02*9sT=o`8wl_*R zmXc_4mIeEbFwh-88iz#Oos8CtPqAY9 zAy!P?$BM}fthltA6>o_9a)PXqOW&~;WG0k_F#ojdlXkv46vj7C9g^Ly|^7A zsx4dtL`Fmw#vps98_|$LtlULGCL&xGd?Iqb~BVjJo^u#8vbu}(jN)C0u0Vl?|e zU#dSjHaPm=E*^ztQln!T9n;Il!YU@Mn5Y!u z0}kV^j$pv0195Ni>_W*rU;cbmKhFYVUFZT~^5;c+|r1 zlrhtyO{T{OXt6(Lkk>mWJNcZ+adoj>bmmc3MJ#DHOd~el#+wK*J=3OVW*u)L$ZeW3oA|1470eAAEA3!;|7F!r8%blA z8YvNRLx4@%#H4WrW3pq5tq`yzGk zrUflM(Pc%csbF$hvk~jK^|m$yr8FwhXt62$Cq`XJ=g^q&FLY80jb9Ue1%pPTe{aiF z{4LEOk425YEK(s{!{jPvv1#Bh03{=Ir@C#k;yi{tcgE>*K8Q*X;XO?0b=YKeYJ~{wZsHz`j3W-}l*<)3?OxH`(_F`!2HY>&{94 zaZcE%`ftC5Ga6uLPs4c()K`&4GQb~W7cNH|T`Os0Z9HMde9U1MHB)NF&bHh|XMB5V z8TKo{&TaKaIl)wCJJrDL*=GM+bShvhJOND#5?TIPFHD7Bq=qVKekl+n8VeK$f+uR0 zPPms&xRxACJePLp{|K0>9QvzPqJIt7;$ql?6ypjzs^W?~#~trS+c@>y@m^U2E#&eS zkT=X8>t@NAG#noDZkg06WOEPHD=Yn+z5lG09Kux;nSv2yQk^`;$S7qPa6#phi>Zm- zEL`Kk5}Em&v`+mlSo6Hr0KUL-5KFLkfiiSbTNEl7WVC(^J}}3RTM7kawcE`YrQ{HL zaDZPxiA%}V3268rXI)-h$XbmB=XT@=<9?u3-1bo%*Te#4#MZ|Sn&E9OW##Ooc> zVtAG=si97Ms6^Tz>?AWhofJ{s<=zN&EDNl@K;A%*Tga$^4;vY)e!~y`9GF5Oc_Z6V zdEm*TnMoB68E4~NRkHn)>GJ^+!+3f;{kCdA1qPr1qyvVWGeqp+HUgW64GHlN?i;V9 z7iQLp3mtK9uY0K@;Kh*%N%J%R%x3xn@I!nm3x_rs@p$?>SjDR` zU=IR-27Yrvgu|no+p<)&7j)hzeUT?kWPAK2GAc;0`r-)-w^v_`nq}$X8nT%e8076S zR{Y5zE6)8sE9RczV?6GiQ+SIq$JHETOxy*YR&$&PX^D|sH4s^|^Fmfu_(A%b`u!gX z@2FxAi})Tez99&kFTHA5UZl=BH*D6&nG3FzG3J>6EkmPVWoDad7@{E=5^)+lG9-zE zLJ(Scc`IaFv+!qW{;x)j&i$6AcnJ*k-33dvQ*cqZU0#W;kR60X2!PU-IN`U}_ z0&5$B@Mcz50PYanjn&fRciG_2xi6nfafHjbIoHKHbKDGk!ehy~hdHEdvGU?}u(g?o z6O@Zi_;4}mHmzX1iH(2C*lOpqy8_9f9is|TpD83+VFB?9b~1%@G@^VbtBS-cOYEMF zJEs3?u1Xscgs=5z&B9XGk;W!jl|FL)HZQ-xV3PjXyFHCyNtmdcY@y%e1bk^;5$AoCxiCnukS zj4XQXu~@<~x}u$Xkx#2FcuA0R$1@y=Ej(q>`KWQ8vf{{AaR*T6;J1)d;_=sOfa6xD ze25E4Y+^}e;oD45YO|n0Jm3bdQR#*B_4H!s(z%YAdqd)l2)j&8Ma1#QV#k}E;qBMY zBS-wq0vVcL%(E$MLi$F>rE{G#+dIUYQ8pzPWw(m)^o`Cp!;$Ta=aEo82BW+%^A8K5 zj%6CaWI$XKo2r+Y-HOW;yZ+I(YL5lY-FOCSKXRNgdqEIi#)}}R;ZmhzOHysAkZL(2 zAX^p^iEfA$4}=WS6@fB;Rpa9oGGxsqK{`Vfv2K~{9{Dn|WAi;+Y7FUru`g|E1M?7F zQCtQQ;X+XgW{-JlQOOB)v^%mVODYeCLDvX}S1JBU#DBbt*D3j{jO%8smqo~Cv#fmm@zVVKS zJy7asu#3eKqGugvMm;a8cpa=;b~04ttQ}N4KL-^f zWM6UqzMMNzu$g`w#qI`XDv#jnUOLk4AtNd-ayweX?C7eM?C1?OOlEXd1cWeJmYGpE z%xJakm20>u75BO2@?fq)dGguSas6-?o=)*r7?Wd+v2zh#@EZ>d>*G1$e&bfnvf~T| z1>GQ!^rB>9H&h(P0u#x|GIr2Gq~CJ;x|OYWrI8gM3zC=e@Z<;!xfkLdv;S~FoIg$Ts_0B0htmRw<3;4tlFx1}(ORk%6pD%7 zMfq1U2B4a~6cABx+SN`fpAq@137Ow+=k~Dn+)h^H04loJ>^g}7RG5@~|5KAf(NaQd zXOB!o5ZM(TFgd-BzD9GxeFc46V%({eAX6VkViW@UY#SqejcsX;hl?Kz;@X_BR%P;- zMid1Bkjo{Lu)czm4n^hSFK49K!w~;!LgZJMoLFNc1mqVP@Qcy51&ksgu!j(Yx1VK_ z{=fGVf14hCq~h&s1RCJjT!pmZcZ_Eqs{Ti*`md$xKb5M#ELDG2s{UQ6`eCVhqg1_G zs{VPY`omK7ol^C3srpBy>Z`o^GB3t>agrA)UVNPwUA&0!Lg&RHUOdJNA206b#TH(y z<3&9$s(2wV4t+wtg0dZW+KnBxLhS~DBMw^K^99h};;=3&rd6)L$mpRwo$x+~sv@Z0t01!sY#v~?S}|TS+=S^z zgbCMXWFYSf_oohBD{QuG!S8Ww4PDW0JgE8*4A2JB z5bcwkriQSo1^J^qB@+v)NzQ5nc@dD*FaAMc^e(haa9XMohGlja;2j;{v|l{KLF9zN zv>s+2O5&{d0w1d-T72Dx&Tr~~aNQBr4mc|Xv_!xttn?X_B^_8l{&|omgI7d(l!Lie zkP|r0UAH5!!vJNA@^mK96<8MHNLKSqu&>QB*%@E9O^s$3caNF+6MPnn8;=xrQ&leW zO3Cjjn^9!b9jEO<4%Hm#3MWD_Csb0`X`2=S3Yu*i>tVBLfwl(PKLv^g0oor$e>4SJ2nYfc z1zPtzXYM{oQHq81XBXt1$2l`|=A1KU&YYPArFzI0cKc?gE=^3Pv+kMsxl8kN?(vzd zdv<0%JDPTnqu%|BKhgKqlk>CL(~~o!smarmW9ieA6SJ2_XR_(j5^?slFA^R!!+l4d zX{$|?wH?i-Q*-Gt_puY6Na~8`i$~qZI=YUZ=sI@1w%bgEdIkv+fjES zeQ7Q|H3FjAjQt_-p@K`%)clQ{vpWNi*s<<9<&l8tYHC=5wxN?zx#up2_q}=}DUYl!h+y-^x{Y z_eXunkQL1@s#mpr=+Na4bcdn=5A}=Y-IfbII;>bAs%=GsN~=GKE-R6(@rU98ZmjLf zFH%ia%=Gn{J%N0#CKOEu;^9ytMu;HKpESMUjR1$&Oa!*5`CR2I(fP^AuPT_j(p;J~ z&z7gY#@U^6;`v-%+lJ}P5=7`U3)O{LRDs4=+=}UYP}pjV&Symul_=NH-2C8Jf;d=Z zL$${IVr_m=V+5NkiTw3kjTQ9;JXSP3oL|7mLxH$8155xrw>M?h&XT28@`#xRr2^&P=6eF_js2I-8oj;+~jx z&t=l?$(hvH{G}uL#VR6Zz>J58c?lG@w~`Ke3R0s%x7t-!JVHfht3Tiin{kt*nxL8; zt>M5>$Y+K<#h$3TwlxqP2*s^vBoKv)6g%=+vEkPIqC@ONoog_Z40@u0LCiRswEE+y zYlvFOfTz%>Hx%`UqCJGm^<|?MI;k&=>q*1{z7PnB0lidP=!$B0^aPR~nqwgDNd_XZ zFvJ9*fEY+Z&K(mKyCrY*?kI_jsbp2~Uic5WN6V$kR~WRfH@N+Yg^=)x3UtmZ072=kS2cQSST z(ZCSI13Tg=!Yl0-I`s@Q03v!QMX?oW1(l1FtmbYAv&bewgQgV#U*L9&MLLpZkJs`K z7ig9YDONV|;5W)_)Z6RwT8{-9v`{y`J0ktzWGDtv4w&KofCt(hMs>r6YNGd8f$(S{ zGeDU${m^P;w#Ea={&>{W9k(JVR>~rBjzl1NhA_Rbvwf8DnMq#|nVJ9w^$Z3B)T5pZ zQa2UJVB8u+#@Qbo#1ipf=p?ucb~wY9>GvcjsN4q>%TX;KG0XTJ(FCbLEw&dZFP$!&+$zbU2uVdsP^&7*FWY~;Rq-Ei2@X|iOYbd%!Nk$@4|o6 zn&r|j?7eR7y|&_2QDr#`#dejTyDS;b` zK9*`^vV}VQq3EMz1p?bP7&l`vm@2X#VmDR)p@_`VT8i~2f*Ed=KP&orQB_0s86HtG zW}sAs&b?MR_KcW5A?<86XPLoC* z#sdSiylBHI$4W>vlXj@`=GdER_kdnFfYfUjuXY&27B=&CCFO}$^%zsc-mD~( zvqRs@jA{=cTUSMMKDQfPgL-uC-rx?YYJqzF^PsQ}q9(h*JKYf)a}OU1Fq>@ zdK0?c6SHt(vAe)wotSf9o|v4(+}-JyQj_z1*ttA0mvOh!Bzfws?vWXsYzmz-H%8~P zSquoLR&tFwGIoSm!c?z`{g1$n1Nq#pGH#T6QV(Uw0b+EXd?-o3JOR~rr>9?<$j(f&Hl=3W+)R zNT|^8(V0tE3R(dVAe){ot#YZaWm9N@rvP8s_7v_r7cD9EhV~&_UsjG_Q(+(cDU8yi z?SqQy5PfP58B(m416S#LP#mP>kYH9SpV`juF53BxByTYFyedC%G;+FHC!UmM<)^B6 zl5DzMwSSV&IoN&^FZS5H*z`QOq%^SW#2g7RONt!%nfB-$k<{eXZP@YzuZhpjgMCFF zY)0xY;lopM_Z@v7HvM1xs?%p9^x3ChQh|+R{*tM;%BlZC z6|MHvooro-@df3kIE;m~fvBS0#nLmg7En|jq9v;^TX z*oSh2zwAf>)Zkk=2OWRV_tE@P#YFmrpMU?wOqtL1xc0+}%!k)f(k5`}*0t0v<_(u_ zUrXICl(tVR%IBDv2IbDR)SW_o#l+ofsk;Ujxo?F19HK?j;hw-4XjlrG0zMwCP_)-R z#n0wt71k;H*>GuF`U1nCc3b(TiE`b2dlD+QmTeg*%9DE`+Jp+6RAa;1sA#W(&+3E& z$gY(q5Rb!4MtH0;F`PiWrSdtFmb%^IWcSmY?0SlmoqITGtmWh})ep(&2Dzj=CR0-* zV<~b-IATB(fLt_;TjdK|iT*f37G#n0IduqQg?ge^JU}|E8l*DzLDcWDktv$k$gJZJ zv$yE~*2{geKe}$LVhoXpQ*LXOVptVN)vfv5l|lFdZX)ThTiQL|L*N<7t?w}Vg;dui ziML(lazAk#9!M8)koQ#Dl%5<*kEiA*=bkz&y{v3{Zaym=Hy(sGBxqPWLc&DQZ)LF1 zGPezLQcF5{0i08B_i5_zLa)o{y|+4M=nE59GplC}l~jE-V5rikUfmU>iY00pbh?b7 zDH&lH{j63a%DtNgGpGPCN3^vOWo_l{_0_Ik8}PxWFDbf1H0u@EliD3x`4%Tt4??4e z!BDdD711#!Iw*ov%jXCLnh@Xc9P1Mu?czu+WLI@QGC)T!MVqH3M~a5U&l=(+gU{OZ z96+3F+W-KEI$#qB>HDVs{s+o$n(7eC{NAd^s8dzL)Koo>4|C%U<3(hh@0gmVzK)Nk zdL=i4vJLFmn|5}!8BL|B0V22ldxJUV-A0P%GW6AbhM}5v7lvkPvNM~%E>re7v=DsL z&aUo|QhL{r=E7wZk*)_<9yb>dH zRI)|iMSU${up%K;@g^hIQufQxPaQ`~%4fOSOWEhqL81B_S8u24gczZu8;$H>A{9H) ze`TP%8|Ql}wi2{dd>l{*?k5;lPs^cDs1!rMSN==rl>7(b(Jn-Ve=d%x`~*!Z*eDa= zZ-J#FT0;3BiHnqchjH5|d!72A)fVD9=V_GfZElM=$BXJ_esKo_<%(<*7q4=$kH5YA z<#>%661o`Ta*)40{O#s%fWLk*!l{qHUjEi%0Uw94-fMX82`o6Dy?9J4D_?B|h{Sc5 zIF7_&Yl~wuZK+8lt(YBND%c*aQJkm|9cX$}oWKxgjnx6ecW-sK_uH(Fyrf+|Q}fF) zy{m34XRj)YhGu#-pI?$tBFg6e(b7sZ}xlj(5vy(G`3S5 z`e$+dXCG{5=jc3-O;$E81_F+NMNea+X);zD!Gjk~C#KH}Sk4?%R47=hbw?3pA=OzH zPvgsH8=O?gQ>tmPVs!C@3mA!jubP53mM#RZY4xJBmRsHwoiN+YXJA5A^B&nfSd?!V znwRs7rnd>U5yK)J(jq!>{3|mSOXmtgb#8z*MK8d5?H-)Ay1Q06{xNmrHbFp+V<9^I7e&;yHy~ z2%CPI8*9~74#_cN%g$+C?4+wxs^}so9V>%aQ_&rYCex@rF1_iL_fs=f#n< z=)5RSJ|Q~yi<5jgAzR1PHqk@I;*@kKl)uh=XuzZRF?hu;)zRQZ^rP$@{=HzbX|#Gx z&UM+Ym2=@aubcS1R|HMz7_1yMf%niicCqBAAh!{XEzMQ4XNrJrZ`_9vlr4f4c97vxC~&L4wT+@Gjt z_%~@wQEumRhkdE(C+6G;9HtSXghj)fjHxt2POxjRP84%O*pi}Gk3zwawf(;sT_am4yLkoW5h?LlhgA@*+g+r8H zDGusY(6rN)5A$U8fao+t=P_|oQJ=udb_YK}w~7=YjV_&KR7vUMQ1jS^Lycq%LPFB1 zb@Pb^M_+m*5$5X*4Q9VeoKn=XBhXs z7aydx(u}BlwP(MONGKF+)P+xYMF3n5peqv4Z!o8g2E_z>F(FOGg3sK^+zq|oyV4v| zpXHOr^@w^ka<})LzHrN(*KvDw?lu{Kf4apD7(Me*@B4i#PxPwKaf5u+cEYb_KI(fX z9BH}xIxf1-!z|xk`N{22?|SLkToi$-b(VO;`GSu|Z!kmr))Bhn9gzN)p{TE5I`yE2 znFDDR<+5jkT*|M?Asyb}RFckBL;^Yxk;^YuT$SddBo3B^U(qgaB9yjA6$T4@ z;s`+;A<(~_iI*#R4JTy)9>xx}3JcINXvU+|SI!rh9z}E>*TuNBkg@MH78EV9l>Ip6 zat1(@3ed|4=uYDq3pP{4!_#9&cpLMS6ihzH;k{$?EFI_TIv)H;$MJ-m?OvJiMTWX8 zcd}*0v7a>peV|>cf?cW>2lN`)rg)WJ?g4FB1^L|8MBq$6Zo2ToCZ-RI&ZOwiB)jyn%*fo+ePQ+MLSdh0eHe{(K=zn8Ky2*C*dP^$f#QufEC z?4OphKPYA2D`jt#vcE2~Uz5q4OeSO^gU!ncS(1T=d z%h2lvJQ|4&$3s0qyuW~_yn7%$jd*Q~dnlcqc^NN?vzKP%9Wq)~{W*R9f(-&hQ(QNPMjCdis!@yys1ec_%kZTL|TlC=S4p>6ANQ`&^1YHncLHMHZnvI`D6O0MHf=S1ybeu3>#^cIGeWQy=U`Ry=(GLQD zj=(QH5ZplE`7*E!nsIQE?ufyZQqLur@;?NdE`yc)RuHB9oWN5L1ph06C(FQPJ^v%Y zCJ5$`)0Mlz`u_ipkX|h7fWV|n#F6!=e?_P-5UOVPM+DyeETeotNSU%xBq_uk<@X8p zyo8nYyG+&NRPDIWp{HiwB6wQDnb^%{_XZ)2ZQjY32{tOnEzDL<+ved6A&d}0VZLKj zlaftrQt>QS$C8mq7o$|VK&6UumTx2ti&w{51KNFxh;^@HAp&Fz&0nBRZsyzZ3Qosb xEg@{|d_N(aD?^Z`R`%m(PyH-GwX0XzSs#`K9;S_*_M!3`<=f!4cK*{({}-by+rIz+ diff --git a/sources/COREIO.LCOM.~1~ b/sources/COREIO.LCOM.~1~ deleted file mode 100644 index b6fc52d9e37ca6d7905db633bdacef06358e4267..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 16349 zcmcgzdu&_RdFQ=UTv?SgN@iVKY2#BhX{BIddHE8h6agt?!?W0O|7o~xFu zT4j>mS1~h1bFrgxdSr^mWiXGH+RjdM>v{KQ6Md*f5lQ2gO57oWO(ZsW?s8M~UZ?9fAzX*Mz$ znVTs*E+#bQBk}o2c#@sHyy48a@ySbfl*@mMmRVCR~TU-;O@753ysY;tO$Tw^0WTb*W? zE^mC|{KcoP@ZF)~q%k+MuyJ-~E=q6=C+1@~_HPO|V;V~U4xvoRuHkNRjq};$$W)0< zg;}kRt6G|76&7ae{Boy7G@^>fS79HBDL)7DD zkpIY+!2WQ*`Wxf>Bkfc}3dNGG-3sckeX? zaNl!1FA76VbK7r?KHUt+mVtHu-asp_Yp48shnv@8CB5}Oy0*q&ju-XTzw4TwKX|^- zXz2R!cI&?idh1_{sC%g>YyQ53x9^vDvsh%aInkU54yqM#buo2wxEBFgJ5yxFY}ZBg zfxnT6_5gc!jx7*)6212jkBX*foY|#pu2yG}S#>iBS@2$iRn2AUc6F6tTye-jK|gC% z74Y8+63|l|yc|!*G+%0WINx}VQ^n?MIAkQo%9*@btuZ6amdnHy)%AryURHS#E5{io z6>EC-0Y;l8Z1(J+QpWX5s>J309xh*(*E~sAyO-QFUwh8v%XiY&&B0Y|y`h;0JNN0Q zt|dzsG~d?kS9r%$tq*FN`P#L=%eQ{1nRmW#t?8?KzbKgAE)&+o>Tx-v6`U;MWMJFt zW~pRn()b5W#5!IhQE-e>DYs~rLS~f?X&4SkMQ3}iFRIQ3LX`(}31cx=&Q(Fi1i6|6 zjwrJ$b;|~qjDRp|fMB*#wJU%$tC)32A_5lS1kuT>BR=1N0F3Fmuu1<|_>hF)KyzZbCs@Hi^X6$iLMsuQNp>Xu{_^z2p;q$3~O13d*w6YKe=l!yZRQaDLdxPa@HfJqf7`jP{BeLfB+-07qPx%Qre?~!2Fb%&TzavfMf^?3OIO4 z{_gtE4->MEef%By#&@r34@&4{(j0epCS0^v?3*{V<&-=3OBN5otxChHB-nm?`<*8m z>EKX1zbYsHNuv-Pl$~yj{IpTrA6IX~KWmhN0r~dxA?+_4OSgu{+KmgkZ~q!3~BP}#1Bxa^NW)99^?$t9sm zkdPsAia}M&L6zfMibNq}%eJ)yF+!X%Vt^{;)X?P3h^MvCJEN%stz(N10U9Qh? zfW>>Kgw%)p|4=#iC^P05{Un)H?$p6N#OMeb5-%q~SzhXvG78*f5qRimU^7Z{{kcBA zd2sE%wj{AXm%l%dzfiS=-XKWK;R%ViW(uU?^u;O|5I7!-C0Ncbkp^6|)^ZFyP2v?8 zx z>$Ix23)DG@F1BMob2!CI++YC+T93L^=|(oq2#SR_LSQoC!g0bV1Uy5}{* zbE+u}zTlaVcvKj?pjujBk-0ddAL0#F@T*=jk3jb$l#2iZyGc6|o8|nizFNuQWJx9p zP>Xwd0za)ss}@`XbdX56cOe7z8Pq&8D~_7%C2?am!YppxLy-`@;=M~5u^4k#GWu-B zFyauTa-q2%J%A-qMQ#kW3XGKWY8^@_C=NH!eKuGi-BnhB_puxR+!( z4^%2hKOF$(dxYy&C>RWy7q{oDwp|DJ`tbniMk&8A8}n%)od=p+z@OS1%yVMXR*1HJ zU$lx&gC!bPcP|z8CW`t`6*27G-!5v}o_}-ecB@p>k6tTCa=B*8LMtIC@LBY0O{;N# z(k_Y_wbr{t`*SqU;jJ%lB3auVObfb)%@6i3IH1>@0_sC2R77M%VGnXW7P3kzkq{QO z+~QIWG!|2QmY`S5m}M4KT$R_zZe+#KRfL>wYFwu&hg&f)r6XOybfu+f0IP{B8{s6E zIIx;jFKEbI6hQ$XBc(&nbGWO+eSs5%aJhvNyi|QOy*ImMZ2|h-K#DsFo)@g?W-u`J z*YE7Q^^Can#?GtSUsy%w?H{%4g}qUAjUP8#pTWKA>wAO}cQW6->idr~#K%sE3xc)= zJrBClkk;l#Ka@0Rdi)ki<=V7Ih4%Qf;^}~Y@1Co^KhwWnumifL-T9^+D3m5po;cpV z>U$Q2)-Q{?V4z>%SfRv6y$yeZK(n8CS3eB}%^vUE0Ia8m9d!0^l=g5`?E&i*X}Q(| za_X{&r77#1APA_;?)rknnj^d2{en4!2?~w<=Q|;ORzH7IQ{T729)!TFn~5< zgb`NQ*n#0-BVFhSEbpoTGZQsE7#a<8ROJ2-_zDRtBk+QKX29RYZHPs`|1;pg5rLp{ z3Hi&hnn51C;TY&I3cVq1gkk5H{e3KZhpt=(=AyYU>Pj&09Ban+FxhgZe|H}CoT=|H z6Ijqlaq0eS8!rJ-{+g+u)my(x?~V%;U)eou=1tr)nR%o&yHqVnJsM@pW~q|5tJxgH z9C&zXe!gZcRiMyAZGxj_Cie(>blGHHZlTWL?v{{DOZj1Q-IHog1bk%9b(nOds*>XB zkU4izNi_|qMT%z>?u;tf6g(Q_>JauFlriqgbU~xf0Sbr4zI`}HgsEMZPC?jne*>kI z^Ui0kYTr}3O7OZQ=$-p5&h$57y{Xc$DoN{2x?{7TE6ed!z-9wYi6J*eV6(x3lW)Vs z1OoC6S`b)(*Me&X6CGxpw8WGp*9^k=;zUj6Tr>E)%5ZyAn+_c(LD~E7qX(nM33}W| zGrWf$6ZAMn4{(4c>^HsyTqg}X;8=mp;4nscOhNE5G6io9(UiA_&>K(JM7%Y~>j!!L zAnLi%xVe81^&9w7Kl>3@B=4tDXOuYf!Lx$xmDc5ed7g8or&9rexvj_2S(BURE4%+K zuk59KhGTq7yl0NC?IeZaUC=ej#=g_|UVF3kUitP+d+RGgsy?%=|6ze+1KmhoSROZ6Cp17fIR3KbKE}ACaGOID`MmxfyD;(GY(Z)Q3pgRX`QiTR9JB=25u-DqflsR zIj>m_!${e_u2~INWN#&HhDLkLYAo+DtDzfv&1wUhsG6mpS&fyuSS&N3Z}imlI-H<4 z^s29bzdU9i(-_W!?s@xI>!hsk@B?#U=Gcd>D#CB9^M)0ZBPXlFmDHt7GYYgw5YS)} zCDY9J%X>7RZYs@VEHaSy?;R7o;^v_r6<-p?<=~-a08s{o!aEC+S&8PigWKz*eUyOV ztuvAWejtCp)jt1IXTIQ}R!Y`8F{=+L-dAX7f@Hp~Yn)(yU)SK<9l}2NtI#0w`pVV2 zG4i^0N%Ke;sO52i!{?wB0;8*m)JI@(hect4lDaR_02OsxH$W|~A=1|k16)&=0q<{2 z*kF+AoWNj9g1%rkfxP;}Re(H-;AVwmp%-yUT6VdJ`nVW6R2hXvVe+jY0!x?!-zAI^ z6cF`-m9hZIM=oI$V(h_X#LucT8Q8=k_{;_GgTSphZNR7Ti<0=I^Or~Xv&x^f5w5)< zJX3!`7&QC>xz9HqVM|4`ZZ9!ds>^%<^4ke#I4&kK#~y;=${q+&XzH^R#^F*q#y;)R zNoVj;oy}k+iku4Ykt2FmhnvLwk=$qCtcqpIxaiHnu`vylF#syKZd%&wcfM*hkGFwg zt^eez!&Ib?f6j?Os*Cb$3#3aIU#V9e1;YTd%&xfG;&ww%aQ9<=a_Dd;tjB7YYTSHpiQOCCTtVPJJP&b4r3xaa(TfSc0fQT5$V zse{R1?auB;$Czxt;kypUv~}lNShUJfqt>rq`GtE@g5WBoy=ZlTp?U`cqGaultAYmD zaAlE5R-TRg5~>IxB#V%QvXpd6U>~v$erZ*L&q2TlVo#QU+Op(MttR#WFf9X@UQ~Ju z82%VIq;=wmatYoX-1Dcl@8wF21j!BG=D`aJ8gQLn5!g2tmH|#V5p@HqiH`lSOHJ{_ zU4lNq{zqKDy5ZY;d0!?Gh%Pq{ZM}Sb)4KB=>vNlH`-chvLPan@X+5dD0jMAAl+wZ- z>HvrVBTNAd977cmTUJF#ai{1=YO?5Ltw(%2Hv{%7TjNeL0zCP$4*XS?`k*#w9Qh62 zdx71=olzY`j$?FZaC{lQA4TK>+Aoj2PtODR9~U4Z${u(X@8`w>e#HlVa$Pi9Q1C^m z0L5R{iJzOJ2TvEiEXsuHbWfZ4J3A98i(h#G*CM2+tT@ksPdbr+en&0`q5t|?u4;=z z5ebN1PJo<5FO)|K2Gy)+p4f?VI}o!HlyKQ8pgJWuFcrwv)p}?EkoM@sij#OOF)@}n z{Z}Y6KnWe?;@X*zV3PcPThDVSv>H+e*$MaW&{aDihs|)|=7jNfj!Ec?ESqiFP594v zt_>Y#ph0g0FY$3`pTn zH`1&7bm$>Gg$53W?ioCc65Hzv?MPurt~Ey*MtNul?oqR}4Cnb9gm}ISX)qw-HNq(d zIqh8PyW7I=wKtTO9PR9Ya$&xhj1>l%B3Yz zd=+LK6T_a_Y8`c}xAiZ|1y`Z%THsy=nQ9KR;wc&K8>QR0ZvdWjH7Q>z2*~j|(xsw5 z*AES7Ku{13GES;IS*jcA#M{Uc17quM0=YSwCnOSg{v$Hisl<}{=+$Al55z-v*cl}Z zh$y9Vb#PAEoGFt>)L@V1&H4hOu!?C?)*7JE!SkR=f;n_lA$S#napG5uOZ?vOjZMlb z9>`NsCLy;*#C2NoGNniLhW2^r0k7ZrmYhm|j?@47z*t~FRCS6g3%w7(5{2`{)eZ7n zzgU6fI-)eKz}o9~u04`39K5LXt8rAM6#l)~PQ$%)LGW*hLOb_5Yv$J+HVxI{$QMNl zOgok5XE^2bD>U+Vo^4}Ge~i2?354;_xjQZf^&`vA$`irbK}m{9b@;X~w%bI=l(9zp(z!-E|iCIVl9s&(``c8j-DFLqOFmb7%4J97ndO?j9uWbjLbaEPaK* z%$Tx%;?nv_aO(%cy$>o!oA=N_emm{=1p z1ukm#{MM<$x7Skn!q&^8;vKyC++d-&^$)MV_F}5Ab-O6rz95>0iWW8Po=6q9Zu3pR z3LfVh5WC@4Sd?%8FfMLi|z*BW2ng zeBu~Hb?`#h^OWX5+zDEkn*l(v7fJ!J%HZQxcE(8!fY$~Vo54*rSiWI4ImzJq#uLu@ z$%iK4%Mxiu#J7YY>f8*pC>se+#9ds6?(g_WWoiho8HWWO8j@1vMawCG?ZS)gPU~?S z^DvIvVur)8U6eNQ|M&m;plwSN$sL})FfTLyyrkT;fwt)l*}!njH!L_^$Av@-X8X2}I_)1(6D_F1SyedG zcWAIZ-fzY6{?*5vg@)QDc;{h`#mx!1&w>7t1zdrcC#?!=s_>q^pt!I9?wPaurW&7Dg`_ILDK8d-BVH7cRwW9K z=Y0ZMPuwVtQ=$=1%(OCae~>$dBt87KKrJwT7Dt@S)4|LV>B4~vwNnk_3|mx-1O%jc zVzx>ySLC%Z=L)QAg^!8S?uF8l%ZAd>dnqp+ zJ9q0WB(Fwk-<0Q@CHn=wClxGo4ZA3%mhmpGl@o;;<@*43` zifubPA&{pnM8PRR%&Db4BY~*n80Zv%ccuf<Shc8 zfHV>92?+yoO9qcb$ZTc7!)@eBP{4pM(P@s7cEhW^28BT}1Eur0Q;=xr+9jf}h#der zo%IA$UL$wN%@m3&@Ji380Z^kk94Vs0+uScVVicGq@1%&}3hl#Li@PnAoS{5XGh0E% zpex)M8LcUi4+~$Z`3(_MGK2FL8 zd^7={Vu!~i0hTR{cJjsWS=`>7|Hxn}B6;A?o?t4N%NwR_#F1&Mj2qbaG_5CUN�D z+H|6(ar)>=jBzuRd03c6Luimp25X_vtQ$4uv0+a#a*WbhAvN!&bYi z`lMI)$*y+&^{#)p!=Rk1RCD$EYQ|owz?!P_Wh@)7^kG}IVm|VSr;1HYJ;)w<=plTa z`NXB|jVCrPJo)&O=kaaj#gB3^%r0+SIp07nJM&SJ$RC`X7M~t=3m5q*hDQ=f(WE|I z5^`QtI<8sqD&;nZPfdy~&o>})Y6U%DjvD68A?T>%;<2ZuJ9Sx3>=pXX7{}SA_5+oG zX99{IbQ+Z{C~6!I@_ReF^*XNYuhJMSKU zv{R?R=mOE>J(H7ndL!hG)3QQ!!O(7rE|H>Bo9Ls+V6KsDE>kkAIeeR%MYc!AuB@^t zN?WRCYaBB}q{|`=v%1FkMDihz|knen<|2U)|)cQn@W!wDWXgyZD?M>EZ69Vsqan>;8QdkZ1fcHIlYq zhTv;ydZm5JnfQS`Yd|fedF4sH4U|jJw}CQlcmoHUcSu6*sLyoCH)(_Hkw@t>a0I&b z6h93j^Ko@2-etj*-=ageoTwPrnuq{)|i^FeAQY zr2du-GO4Uqt;KvDAIP8FxbV~l`v6+kDA#)6i$Kwc_VKvUqvz(&dv|k6zq<^!&-vg>#Q?pL~3+vAy=`XefSid*kxOa~CeH zoxFVE$xG+fE}zWU)tqIA9*j+5hM6hz;w3B-4l^S;8#ZR6k#Y9er8Q@rp|ww4yma}# zS++{!Li4#g?UNsG16wG~%`+Bt_ZkX?##!UhC$PhDZ@rPA$s@7xU+tj3(Ye@AJRY8z zX6M!)J^%5w%j}5@*#5*^xz>G#Np|tl+9x+IJb9UK8vVv2$*IDV=ci_781`($XCukq z5YExbApyHg$*uuKfDNs~ktFixrMClg#&d&F9lnhkf`p zK2Fbrt4Czv75TrDZ;1}A)FJ9|Bgp^cOJIMnSN-+T{h?N>AqE5nXk2R~;1h$^gSs5E zxv!-Hz6m32NWfKdrJPyIRe-xS7EQ|9#Yz@9YtOMbTLpTUnM|%$!!;WbLmrPAhEtr0 zsmf$Tm8KJnkV_#}x>RI|8Pyn1I;BWgw^&>?Mv}~|RC47ki-cL)uII5Rvlr`?#X9z) zt{{sO)Z6bM!g8l_WoypHU}msv?i8+qwo*11a+A1)y}Nuqf2#4f1g4#1t@QT=z}F9U zk1Cjdnct52Zt5~(_T_i)HU)6scP%dp1MB9t-x_{;Js?~9R{eW@&AhIi_U|2DzZxs) z&HvH075;L(s5k#z*Yy0s*9wh>t{-nT|Er)k|Fwv^SBkRc?@M@lxx|~rBAe@D>tn%w zwIZ%Arfv@RLL{3m*_k3UraLaG2mFmhvPWjD>z=n$-skF%@XcR+*=~n_8N(TW0Xp{d9xHUt8_@ia7ZdT-F1CY zbuJL9JfKS$^SN@a3Nj|h)f{j{nO&({HaKSlgi!+ovz4k{0i;>QtV5s?um~rJPTm;u z`T7K4OwWal`$xiuBn11KcQ>@t`p5?k+r$37h#eSR^*_I`ccS#sM_Rgn?~U^43LnWI z>jj|m*jRu=@R8E-=09s^M)jS~*a0ib_U_9UwF^XV_Nd0`j-$u!qIGr39tCBrk2Nh6 zj-DCaHS;K(8I^=6`k@ng+&>Z?v`3rA8=8J5*s_oA9kzq(V`q+i!47`t%u(9XzuCt| z`G_-tmOZSW8NPDI0?HW)wpz~EI_^-Ib+sYa+;M)&sw!9(VOu(h10v0ZwG{P+PEBMl@-cOUt-(pbN*8I#7o0{(~S>KZy`P z@>oi1d^?~?a4(rJG&VQ{19_k{kdUU~$E9N>J5Pm5wI$E7)Rqhew5wX_#d@yCE(j0w z6evxs=bKO>%A>V}=BoBW$YF+)LuISvE-5?a&2rWwrlU*hSNu^B{h^X6c<)!4c@=%Z&p%A5O#T8-`gn|)Z66c2RKM_WQOv4X)CFeVve znbK^oTD7YTM6gO&F$F@JD_NO3i-Hi9V(Pini6|NblY=CRb22MIIfqoAhiVW>Km>~B zP}#1Bxa^NW)99{@$t9smkdPsAia}M&L6zfMibNq}%eJ)uF+!X%Vt^{;)G!Fl#Zn!l zyp&#?n*;4Z$&PnoJmfKPhIakOh<7t^Bi1dG4QM-EV<88->Y(6v*3BpdiA{GehCR)K z$L9&h8CcvBE`fvoVY^(P;sA?xPYJ0H`TyZ^?qO!kF#1a}tK6=Gd5F;wG$dY5fwH{R zEoBtA%kKdX9S!V0rMdn@AKg5-dbA};?0fPbDwfa}1Zg?EAc0#W2zX7H4rajOilch< zC2*uzl8!|xZ_QfCF)%TSNZ{ZS%T&R`zdQ%+T&Ooca}juwX|p)Ap4#<);ffYBmA3z0 zsUTb*{Q18KnRF`)Zl5%Rx5|$^N?`F#yb} zv3c+uUogg&X{!Lz z&y!^XG2JoP0CSN|o%0&u8Pya9GI=HhVno9r{%UECMP}lR{)ib=!JxY7Is#=cXO~zc z-fbI2V$+~4ax+}RuYkD%gilI2WK(P%HB4|_erl_?Yq233n2@KxKcgI)cwkCdU5U)YKH zv=GOA>s+Fr-s{hEV$+t0wtZi;icW(i8kTo27WT%9`i~Sb?A+TbYTBNEbL&>KRMd}N zEl6^?YRW=0At>-!^lMJ4aevw>iW#-$dqn&5G|%C!r#O+U?DnSx-NVQSzZdM$Yd-Z^N% z61OuiUGe?LS>j_S#05b;gJK8eXh3UmD<4`JR6Bl)q+@N`!$MvBaq&#RzjxOa-=FI* z6zqVmX}7;=2MVPzl*f*@uK1osq4~3-E*R)j94nOgsJGx?5NP(Qcl9&S$n4Sf4ZvJ# z*gQwpji|elt8lxSvXK0T&@jt zv;-@IQPT@wV?a6Y2m@#%Mi^m*jcphXHqwEP!19h7Ff&opg`v?fM@8=Nn1Qtntc<|z z_1Qju2e%;>{lU+I14jgc&LreN$7%+7@U~+TT>0Qc0BIvEImgcLVahvn)1Vs5cQ-4fv{ye=qDo}iB_pq5aanEGe zk(%sMwIuaulr5U2O5Uz!a}aaj;icKxnzc}Y1`o9fo|&oKL+H_Agz*E&DbyL<-4c>% zDL;&?yHe|80Uz0KZ8jX~rlhGlWX^q3QcVMDk)|1i|Dp>10~ZGQHiSV3^^^N9UC`(= zfWo1XZy(MPVQSZ;7Z3*A-#`oHyz`kW+IN+%61*k}dgoq?GyP4NYpOJ;O43}D{?{z% z%5t0&Fw#I%V#xI&7-=xs<~AQmXH9O8FYW%fys}sF8IJKy@t!%lvXc~+c0t!98~aYEl7q znB(VxHc9Q$I}sy)An#8mnXqAFaV%)r3w9Q6Rbr7C;yC2vWIvMn83$p~A51i;pK++d ziaH=lN$ZRyqrz-sF>piK7==Ph%X#hS7?ftw?6ITad+e^H&CqC%9gXEZb~JQjuN`eb z6IHYHvZJwb2a9C}^o_2%ZVwamhHmv0@R!HzVGF}s&^d1p^PH3w9&cbS%pCjBRYmxX zwcoH}a^zKYxRSb*Nk)+s2?82SqGXc!es-7U(@mv$j70kK{=H*@SKK)CgW@ZqxEMUN z9za+@q43U}WLBd2*TL;o(mqPS@a9=b0pFAV-)e3A$eAyAsF{-WPLS%uiuV;7njo1M zbd3|tALtsKxdYe-e-#=;USGO$Cq{184rv|<1GT(#W8mJDcyDha^$}RyW>FZRq|S>p zKt-L_4N%K#i1hTk0N2!Iz}*`YHW;KjCotHOpfA`>Ag>;Q6d;cxxM@yrJrI|qWrt6w zhl`<2l~HIECTEJ30g}v-vl2!L3J7z-N|}S?BOfpdG4{YB0%p~z3~XW%wB~~M0pQk* z*5}jsMM?b9`O8E6S>?~#5ZB%ikEwq{7&QC>xsx{@VGBjGZZ9xcs*8L9a?}a$H!dbJ z!ybg;%I*tMEb4O`b zx5e#-u4wMZ{p8T$P%?kNllSkEeKdlZX|Fzq@9~)t^{krcOJki$et6|Y9M-5xQc>SmD zNeP0>koKb01%~P!42Y7oKdK5EV8fL~B3XGh@=K^9gpe#k63SB2DS>^+Iyj1Ba^BVifQloL@mpql8|3%k@5kKZBa1MGjy^{eZ?t=INt)_~}8{m|BH*EX%&-?2Ww zxw3z#5Fk_p1C-X2N)&+lu}Y~h+=C8)7%;*Vz`!w75y50tgcNs*j-)1wPS$$Fw{tUK zzp^#%WFNqFFYCZxWvK^hgT|52;Jp{vP23sPM&vj~XUfKx;rmfUE};F|$OrU1fd2^r zBBJcRH}HOLB;Z$k;MHrQ(Sm|6N(CtXvQGTn7(RHq@MTdZRHu8|%-`M_OIiHN3%C{` zJ!QoP2R`XU0{U(2l+b^5C0Dh@p@;-TFDD{Sq8G}e1cPc;G*9frxgCgE2}-!^6i}TK z9GD8^>S{eS07!fEV#P^3mY5hzoc=463ZR6Ja&hg9Nia!%zpdvv6q*gGgY1NRcj&0? zlf$OCaC72zJI5sSMOw|a>?ZtYJUNDRJ=Z}7jPQCN;9G5b2THcRV{qF$R1xxS5J~hB zOCBnKn^~s2PibZDKkvK^pXlK#g#UK~6iD`relCd+iORB}aR#Pq{E(Oh?%(>Foi*=<>Ud znBvNu(7`ukSTh|wlvcq5Y09M~QhXI=923Ky*=injtGD$p$_1C9?ONbo2AOIOvtnd( zxo?zTG_0g-tavz9??yxh;5D;NW=jz~`vN=;GkEp>O&YSf)gk2TWq%<|0zm4ZX zlLT{Ut3vQ91mnc77?=3J?i(4GRXlR1qD(?=4TUHf4&;#DO{Vh3_{yeAu zjlf8tPgJ#wD+|33z!HV?#nlb+TR&Zbt-#7#x34~wFC4t6^s7-+q!j+W*h<5_ zbYAdpi9$PfJ8R}w95xNr;>Z_8&Pywm=Vv(W^eZ&-x1VicOMikyE(wIu&$~M=2K6J0 z&&m_Q+CfZ2B>F^<*4Dv}BV<&!TRx}&cMh2uikMLJ#Nk8ajC0TummWdFiNk{(9VP-_ zfvR=%J9z2bT7-*uNC#2tC=cC0U01lk3~2dsxZ$ckl=-4+!J}l+qf9yD;Tn;xU_(Gv zgjd~NI-5k0M)i^f4-&V#V;wA(zCvJTOj$p1Y5gR)^#ft@a-ScH)E2)n!3cJO{6Dqc zXlx8|1lsd&2^8461=QuqMkygCR>Vtzi<&*Zb-M8Fl~lg4^_r-77jHh-Unp+s9AGfko zPA&kvHn7+XZmPlZ4YP4%5hImoobm$4A4KNzjL0h@z9kG%=VqWq*~oAr?&3Ohf5%5E zQ$u*oI4tPUkdz{yT229M7hY_4T94b9hjH8%GaQEPqO^(szyH?xML931fXfn3?(p=5d71I&MdhXqv`lZv28Lt4 zVZrG-DkNGk+p~SxY5%C2XigO#Q-!lVhXz}ty;dCUU46`1XrN_+cOK?gygnxP+1Gp2 zpfjppZDv*#90xVr)qFB?V2eUs6{@OGR)vZxoKl64sKQBAz!ivj(yFkc3h(O)ihFwR zo;kZ;SL5@lkW>XY<;7xf#ESy*s6@f>ypJKxi5sPH$}HlUm{tbv4|2zlq=&y2s0HTF z;)s)ZI+$4^T{v)|cB)~VVT)>!fPlPC%vQcKypda8kH2loxg zPR-1_X5d+7F_93#XP%-t=8+%>Pm<)+wije!VP5%A~fLQX3z64B~C3Z{VHSD64OUApn zR!$UZlvAgiJW(f!S}MC_7DgSj%4@_&DYotGgg~CQ5Cx}#W1v$6-kCN? zlly*J96I8}=AGnkT)FPc+BC`kjwC_MP)T*dP{J6(|aRe->c=tQi;yU zuNU$JdMKGIyt@-ZGoV&<@m;}P-HZVMkS3x%Az?sn$>5O)nVu|oxQ$#13K;Mu+RahY zZg{oVpfD(ApmZL03K9(+yF?Tgu>(M-y`EsoYvc~OnL=>|Ug`N30BSUcBWd@%&HYp( zMuA!KPKpSw&_0~CxZ6_68A=Q_vlXNWy26c-(V7wou<(_dUl%bYGdQdC#XO`P9kfl_ z(Z)N(3`uC@{a_~@d*G2D&L`AHe$61~H=%;wB{CTh*?d|CHp#MX$jI3Fnt<)VDVFfRBW{{dsk0LvCeJNaVxEN*Yke`GKfkv#Bc zPcRkCMtE@Rgq>I~m_xPioIt4}-h#u`!PTuZ~kT*`~DpVH??Ud*e zDcZG(9*PX+8p`G}C9|5t7phrgdt~g&GMk{ZrE0duF*8KEEYdKm%UvWwdyw47vmGh| zhv;NA`5Di|kX5!2%yMT{=f)?Q*hKpta&Qc!N;VufSr7{Cr@|&Y3rsw;Xd~&^Io%{f za_q!VcMqz8gTKevn)v>RMp6gw`rg$QJn*HQSvm#NWr&6N5YX<2xd4@-f9&vgk=rK(Xe5F4#6J|qrQXdE^`g9)$f?YB6 Ef62bU<^TWy diff --git a/sources/COREIO.~3~ b/sources/COREIO.~3~ deleted file mode 100644 index 67554a9a..00000000 --- a/sources/COREIO.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Jun-99 16:15:28" {DSK}medley3.5>sources>COREIO.;2 54856 changes to%: (FNS \CREATECOREDEVICE) previous date%: "19-Feb-93 16:06:40" {DSK}medley3.5>sources>COREIO.;1) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999 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 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.") (if (AND (type? STREAM STREAM) (OPENED STREAM) (SELECTQ ATTRIBUTE ((LENGTH SIZE EOL) 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1706 43043 (\CORE.CLOSEFILE 1716 . 2489) (\CORE.DELETEFILE 2491 . 4477) ( \CORE.DIRECTORYNAMEP 4479 . 4740) (\CORE.FINDPAGE 4742 . 7971) (\CORE.GENERATEFILES 7973 . 10560) ( \CORE.NEXTFILEFN 10562 . 11061) (\CORE.FILEINFOFN 11063 . 11292) (\CORE.GETFILEHANDLE 11294 . 13448) ( \CORE.GETFILEINFO 13450 . 14226) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14228 . 15765) (\CORE.GETFILENAME 15767 . 18056) (\CORE.GETINFOBLOCK 18058 . 20681) (\CORE.NAMESCAN 20683 . 22450) (\CORE.NAMESEGMENT 22452 . 22889) (\CORE.OPENFILE 22891 . 26010) (\COREFILE.SETPARAMETERS 26012 . 28193) ( \CORE.PACKFILENAME 28195 . 28590) (\CORE.RELEASEPAGES 28592 . 29193) (\CORE.SETFILEPTR 29195 . 30294) (\CORE.UPDATEOF 30296 . 31925) (\CORE.BACKFILEPTR 31927 . 34135) (\CORE.SETEOFPTR 34137 . 36006) ( \CORE.SETACCESSTIME 36008 . 36633) (\CORE.SETFILEINFO 36635 . 37826) (\CORE.GETNEXTBUFFER 37828 . 41784) (\CORE.UNPACKFILENAME 41786 . 43041)) (43044 46677 (COREDEVICE 43054 . 43225) ( \CREATECOREDEVICE 43227 . 46675)) (46678 48979 (\NODIRCOREFDEV 46688 . 47285) (\NODIRCORE.OPENFILE 47287 . 48977))))) STOP \ No newline at end of file diff --git a/sources/COREIO.~4~ b/sources/COREIO.~4~ deleted file mode 100644 index c5be7571..00000000 --- a/sources/COREIO.~4~ +++ /dev/null @@ -1 +0,0 @@ -(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/COURIER.~2~ b/sources/COURIER.~2~ deleted file mode 100644 index 36c02a09..00000000 --- a/sources/COURIER.~2~ +++ /dev/null @@ -1,751 +0,0 @@ -(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/DEXEC.LCOM.~11~ b/sources/DEXEC.LCOM.~11~ deleted file mode 100644 index 9e874d74d8a6d8a5d3da6cf2124c2200bf9a54b0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4063 zcmcgvUvJyi6_=bX*xG4G_D~ca5S(&ZK?#*YN|qxjgU2h9GU-qxLsE)W^hLFpSgj)& zl04KH_PBk4z3yorU>I8TVNd=_{RsP=OWKm{B<+x30(f=*o zc=aVg0!8Ybot#j74tguvl(SZ=DKr_cAl*&*L0M}lKS9ZsLhqszH5<(qm5z?bvzO_T zR`cI?NbUJCJu-dEjmmVoNdGjQpDm@FSX6X<4Rl@WG@6~d{%*kTLd_@?&z_M)8eqnx zsug5 zM{zJn@Dw?o;vFy!PpS!+Q zMOI6oXoW(mQxhAqCrr;4{vfP!YKSX9t&z~^e|NOfqNyx>~ zcb~|?Fr%IPiuaB-$tB-?^!BN}BS#^%B;Lqp^jHVr+}Uj+r6!COTcp{f{q?A^yFmqhp=&L+ z7a!BLI+eh_%>Up{vGB9_{wG_~G|~jJkw(0Dc((}XabH*(DNN?f zsOjm8{t)5-i^jE5P+kG3*}8c~s?K%dRgjReg$lnd6z&wW>-%M4QZ%-T-`|-UTU*5s z*-e=L&NUA3_02d{F8QvgRN ztlYZAg$psR_GG2OW%%{lHm`WIch+Tc`CUbY59qsP1HYbiU^oW{hKH}~AK=eI-{K|1 zIIw)U1fsfkW5Ki9_ zjw?3_$MEp=u$ezI``#cAt|-4D;_U6PeoB~L2TpPI0tJA#UkvL9gDibF>2SD-+~PcM2APt`9-r0EdZs4Je_~iIQbYy29a#q)hrKl1EZHE69st@y<$o zk|D`OjG~Y27wBuB@&SS%K_2?#uau9_-z;fMw$GOpWn>R%&Ml?Y7n|kXksLy*!y5Cu5pTsX)r#%;?GA|I%M1^TqBrqm$#&bl067j*fRCu7qAvA z(im(eVAhiq2_&g|dVEaL83-IUQlRl@3Gr?yP-{1ug*Vgkt(2n1*3OPXhexC7 zi)2B|*`L~^4n!D{)Ek;bMLL-$f1S)u7gAVkxFM}3;eH!j9MlfbVqvy+HPQrw1xME17>6nb3D{WLLk_v%)!ZRZ(ERqDKL0`h(@=SIoNkPFT z$8%z-qx#4dQCu;6&$A3TQpI#a4E%6NuD|DawjafhuvWw&cE*FAFhV~fK0v0xYS)YC zk>Ozv7K5R1-Oez!B2psDBD7K}Qv}KSVdMkXNDLfrFP%{|jQoC_O}-35I8xm8!)JbI zR?<~wjrD-ox#D49r2t`7F)hOtp#_7OKCa6^xVq~L6EhYC$4Kq@1C!LJeLt4c;8Z$} zheiBIy^Vxo`jTGe*^+@Ink|GWe8M!-f#-^zkos~5!o1+(pVygHQAxf{4$CkHwauoY zx}<9K@S()BY0E3_J`cx%c)v}L=d<`cuY%jQ&bEi zD=tIve$Vn^5j(z@c|fM{ggu6~4`Td$Fk>QyS! zPL?yVxu~q?O@YcvOCy2g6glm7sqZ~=JhO}}7$Z5CD4-ezafpA7kUhH?R0$O%F>vyP z;abA$2W3trQ3l$Im6Eec2z${@L#V{?TTvyvNuc@MOHX8EqckJ+~#? zU;pyG{k4SuAMeX8=YyX=l%xOrP?03$$Kg+(%E=(59siE^4%f-WKYip#ivPBqqw%wQ zDaU`>jy!)P(`HkaC~1A7HLB2pq0i>^9oSLURDcyJ)( z0dO8{H;{s3#)>V{XwcqjR^MKu0#j?%CfkdTY1JATt{+)Ivvsjpt6j%h+s@c%)ol9> zk4c?{T|yc+Lh`qyXGlj_H#mFA>LxkxiEEa1K;+UR95`3z1ngF8&QV`cf%zZY$>)9( z-T!n$nns#HcG8IF5AWsyJ?;xjBZWzw8LtQWvNwP@z@mPobd*;BYBsN*k*af9c^M>R zY@ysIx!j$6dVRmjjr00O{^vUrePbj4TXqxXzjcKJe4Wd)i#SzOJjdmW$mQwejn%8_}#ykmS?(jG-jry<=G7`T)1&@C@T}L^{ttPUE+y)Ifu-?!ZKqpow=pO(H* zwg`i24Gzhv80$s&uZv-Tl_@OU&}~<@?T+b)jv@3*R>J9c9jjxmH(|R{&ew_Y%JTo> z-Ea#mHuPi0o{rn3ce}og=IUMF!&5*PcFz{JBR2_KchS1o%*{yKE%M-s@|z=j1g@SQ zhTDcyT)uSy;Oib3vQ%ED!{H`$_Usrh^FcB_P3SW^NanL|$(YSgX7kZkaplan>Local>medley3.5>lispcore>sources>DEXEC.;10 5477 changes to%: (VARS DEXECCOMS) previous date%: "13-Aug-2020 12:31:18" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;9) (* ; " 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") (INITVARS (/LAST.CONNECTED.DIRECTORY LOGINHOST/DIR)) (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)) (RPAQ? /LAST.CONNECTED.DIRECTORY LOGINHOST/DIR) (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) (* ; "Edited 13-Aug-2020 12:31 by rmk:") (* ;; "RMK: August 2020, added - ala Unix") (AND LISPXHIST (UNDOSAVE (LIST '/CNDIR (DIRECTORYNAME T T)) LISPXHIST)) (CL:WHEN (EQ HOST/DIR '-) (SETQ HOST/DIR /LAST.CONNECTED.DIRECTORY)) (/SET '/LAST.CONNECTED.DIRECTORY (DIRECTORYNAME T T)) (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 (2246 4697 (/CNDIR 2256 . 2693) (COPYALLBYTES 2695 . 4211) (SEE 4213 . 4457) (SEE* 4459 . 4695))))) STOP \ No newline at end of file diff --git a/sources/DEXEC.~1~ b/sources/DEXEC.~1~ deleted file mode 100644 index 2a85259e..00000000 --- a/sources/DEXEC.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:41:00" {DSK}local>lde>lispcore>sources>DEXEC.;2 5019 changes to%: (VARS DEXECCOMS) previous date%: "18-Dec-86 18:32:14" {DSK}local>lde>lispcore>sources>DEXEC.;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 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) (* bvm%: "29-Jan-86 19:50") (RESETLST (PROG (INF OUTF PTR) (COND (FROMFILE (RESETSAVE NIL (LIST 'CLOSEF (SETQ INF (OPENSTREAM FROMFILE 'INPUT NIL 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 18-Dec-86 18:31 by Pavel") (SETQ LINE (NLAMBDA.ARGS LINE)) (LET ((**COMMENT**FLG NIL)) (COPYALLBYTES (CAR LINE) (OR (CADR LINE) T) (CADDR 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2112 4249 (/CNDIR 2122 . 2355) (COPYALLBYTES 2357 . 3687) (SEE 3689 . 3933) (SEE* 3935 . 4247))))) STOP \ No newline at end of file diff --git a/sources/DEXEC.~3~ b/sources/DEXEC.~3~ deleted file mode 100644 index 1139c421..00000000 --- a/sources/DEXEC.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 1-May-2018 10:22:21" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;3 4953 changes to%: (FNS SEE*) previous date%: "16-May-90 15:41:00" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990, 2018 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) (* bvm%: "29-Jan-86 19:50") (RESETLST (PROG (INF OUTF PTR) (COND (FROMFILE (RESETSAVE NIL (LIST 'CLOSEF (SETQ INF (OPENSTREAM FROMFILE 'INPUT NIL 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2117 4178 (/CNDIR 2127 . 2360) (COPYALLBYTES 2362 . 3692) (SEE 3694 . 3938) (SEE* 3940 . 4176))))) STOP \ No newline at end of file diff --git a/sources/DEXEC.~6~ b/sources/DEXEC.~6~ deleted file mode 100644 index 31b9bee6..00000000 --- a/sources/DEXEC.~6~ +++ /dev/null @@ -1 +0,0 @@ -(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/DEXEC.~9~ b/sources/DEXEC.~9~ deleted file mode 100644 index 3fbe4a93..00000000 --- a/sources/DEXEC.~9~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Aug-2020 12:31:18" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;9 5358 changes to%: (FNS /CNDIR) previous date%: "11-Aug-2020 20:35:21" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;6) (* ; " 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) (* ; "Edited 13-Aug-2020 12:31 by rmk:") (* ;; "RMK: August 2020, added - ala Unix") (AND LISPXHIST (UNDOSAVE (LIST '/CNDIR (DIRECTORYNAME T T)) LISPXHIST)) (CL:WHEN (EQ HOST/DIR '-) (SETQ HOST/DIR /LAST.CONNECTED.DIRECTORY)) (/SET '/LAST.CONNECTED.DIRECTORY (DIRECTORYNAME T T)) (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 (2127 4578 (/CNDIR 2137 . 2574) (COPYALLBYTES 2576 . 4092) (SEE 4094 . 4338) (SEE* 4340 . 4576))))) STOP \ No newline at end of file diff --git a/sources/DIRECTORY.LCOM.~1~ b/sources/DIRECTORY.LCOM.~1~ deleted file mode 100644 index 3563e76192d251e5bef1bee6aeef0ede3a8b49ec..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 10850 zcmbVSdu&_RdFQ=yUQXmvvZ5-q;~cZDOR15<%Qw|5<`qeqS0Z^CK1|DbD7L6Zv=zyf z?V?!{pv}6X+ps_CHEr583zjTx*AA;li9oVGi1v>G1BP{f7)8=z>p#U-?13=|(0_*5 z`+eWJFWCsX&9E-d`R;jq=bZ2H`@VBSx%|9Q&QH%9#r(8Uo;Ssjik@B6Pv%9?DA)7V zqEV{^#gS@W&(-z0;!Wf^y_OeRcyc&I17y*vp3jM3BtE@xc4Io75?W+78k>zKf+7@L z*?i_=dwsPfHaA32JeR92zVPsR`_jdg&8^i(E^S`fT3NmHNY1F{vvsq&H1i2VcLbPSdi9dHy!p{t5gMK^*Mzegkuy=wnx&Fn&ebNx#jVv(w>Pg` zVn)$C7}c=OXQ$I)+Oi0kO$WvB|A~*-^OM6oiw*5m~dmASyx=b=@eU5EgVy z!Voc0HY@mz3Y@>*DArHqt2NXkc0GT(j;bc`Th+lfy$lQ5hSNpJ%cSsChJ3!;GD=1r z8C4DCE+77#d9|=$sLEO(5O~v2)uru!)4yuy`{~tNxt+k%R4@*I&-(qA{0+QSFy^xN z&^x~`luUZ|EEX1z>y=8roWtRORocMv0uC?{$7141QK^VnT2w%p9LCDfK(3v5rIntn znvDv0y%U2g8Rijl#N8<-hs#EhdOHWDhr{8t9Hp$6@}g$U&Q3MTO{1Kfu2juBgmVg$ zN5yG8BiI$1iyLK&dA;1IOwXIuQf*4iW0RR)&DZjEhZx79l=wL2MM9X3I-khANV*K8 zYl>R2sGx!sR-udY#gnLLVNtP48t7)JV!w!p0+iG!pR7@{D31q8Q{LLQ->0m#ngL#a z^8ij~<-k+4-|ItzS2n4z)(Qmbft5S^&Cxebz1|$}UcuiXKA)%PJ@>@1uE|#X;#BXp z_V!e}bvHHW9hEeG@`111L+$NxPu(;^bF9~BPV_$7UK#D5Z*hly^8h!x+EJ9|= z**`L(6oz_3FLr#rwbAZB(oy>Q%?WP1K0Y!!WXQLFb#Qw};rRzU-)#C<_V-7G(okBG z^eyZ68-1fU)PA$Eq^|7W{*^`CdC)F=#4ZG^!uPCSyZ=}E4eI%mexZA`(Hv6;I{~9P zrZfWg^$YF68-CTO~^8E$ozQ3q^ zbx~?ge_>HouKkUnE_H51oBrkj-jdGs|MZ1o(ZpWkA!1sLB|;Oia1^RNCn7lRYMyjB z4>K7Tu-gzBp`~K{T1%u|k)J6;r&;K<1Q~`o$V!9+vC^muO+yh1SF6L6mqa=yPUh=Y zC6N#iWDE`QB}b6*j9Jk!HPkQ~Nr-a3nXlFhdRauZlrW1qrxvDZL^Q04jEKPCX3b)w z1S=UyMaA3_tZ0NZIugh7L?j9w*Bk6!k`8<5nk|~O{QL=#(rhZ0q1P7Cv|6vv6-E3e zJ|nOqB|Te!*{Uy9h)YZ^La@WwGpwjqhtm?F#~bst8GX*I)@K}JFgfY5431e%c>58* zx9T~lF=;IeMy*cE3FA;oC}?R?Z7Q&iTZS3ieo8Mk^0n!v4zHV|_nNEEs99=Xfi=kG zYjBb|D1W7fhAC0hYxROzs~;x=Sb-^V?Lx(4WMDE~O9IR3u{dPVa&UQ=+AJ5BFi1p@ z`6Ek%$(@rT7s8Cf?EO~X;g~Sn9Ft*+B;9?P6homyif`Y@;J`?DL~jj!WsT+ji@iHo zYu5tj)RCiO<}qdYxTV?Srd9fmdE8RXm;2_iCzi)L>R-z?-4C0`TB;Hi-@afTQ=yo6 zcGNF9?Yl>avV5#1Rd1rt-OSOz@@PkWT8{BjdwHUxo^kqI?WiSdx>x(>-}Lr~%O2l# z+IAn3rRr|4yvUtl%e^-tnSsM*t2c0E;-6j%EZuj!>R@C2(_1T15t6M(OQg`lm zCvr>gOtf)yN0gtv^T*6W?=Dj=exl?1vD~BwXp^{z83N0~UXi%3-+BM<&ErpzuNYqr zb?-Ni^Z9~1GsFNzo=5wM?JL;9q1{8^5$}$vEPu;EWx@=qG|Cr7!XM^gwgW9iS)S^f z4}y`YwZQVsi{{kvaYot@awPf0!v(JMTZj3p0;%U2X`uh4(`T zn~9O55*qPJ_#vI#vD=k{h2DO1;`L*S&%Z|KD3xYg!*)x85|MA;A`1!gc^} zJ#G{Ms`TQFUd78;N*Fn^opCr2s}!+Iv2@y^#W0oRAR30vspj*i;4NSX08z@Y$RZMn zigLC!2997@^&BrMhPAuSD;CGXnpFb^l2#mxC56G^j$xK1C7SYhzF5TT`N&N- z%F@1yXxcHgB8u}OARdjQIl0Cd+$YtsjgE6nOK8YwG=f8b?~D@51pVMwBo=_{hO@Sa z8hm5TID^P6Nv69|uFF~?Y#Dh(OEH=NAsaeI;XfO2AXRvo6glD~ubkinR!4hAZaI!8 z0Egw2ab#A1@~24*7i@2Q`s{kU<)Q+CFzuPM8?B&-!|DgM=>@$!4e<(xXTxC-As4~O z&BSm*+!ume)&!6_{Y?VzL`2Z?P7gWz*lKUBu3X;Sde)xik~q7yDmFGRi%VB7UfkS5 z02mwwwulK1PHF$V?tF$Zi|y3eJyS%4z=2`5$2r1jdBdXln>-%@eXmQN6uwU>`+UlX z-3YQ-a}^bx0fGa0+&=Y|fvrMDwF-fN-)ie6 z`9gGj4tBBD2Q|Ez1cASW1j%p$Z@DoL9jUdj4tU3*WXvr_J%QRxNv~%MGr&>}Xfw>j z$$U9qg`SY6L8-An&fp*w!5ZPnvK4)aL{tRl&bGuSksX+RdTaB_MV#rz`70YMm)n~g zK^O=TssWfu+*PdA_nf15L_7R*4$O*cHSYn^A=?}X-y(d(5F6_ZKi$Wi1w)vkdn>Y~ zwDyDDJJ|M1Q%^=3C>ALcT06LLiv30MPX z*wbOQsvuSiPQW(j-nBj15}sII)&y|3E}y)h()O?5XgXEeuaod zkiChCj{}sNRhv)j1f_nQ5XH)5NboF`6KtPRz&5Fu3XPDE@pNw#wH8s}x7FQGAh;X) zYQMmWbDEzoX9^SjjJmdce?~2|qM5<&-SYMB5WSG)i40CK6?dHwd_rS7i!>LEU&?WY zG0v@IA@(LzpQ3F?=55~H)BsseJcic_`g+RAsNV!R`)*K)*LKl7iJ~VXv}F=2B1?Swi$= zl^|ZSgu_XOodcC;30b@4)Vx-}NkQ2Gj^I=wAEBifSa%sYBr7j-&eu}bpBuc=r=Xi?Xd+EZ@l-HePcmkHTZ~r!DFWM15k={f|Bo`x(8!o&W~|ZE@6Gno^CpF4qe* zH%S<4wOjol&NbVcQRqxjC$a+&HeLZmbRb$~jg3UnC>hiY1_9e;9Z&?G?|-rEU)>I~ z`4mpahl0=dcRrn!Y$UR8&Um*w#UAVjnLls)GdQWK!Iw#R-;+mM`lR8igjWu|w> z!ulr$e&tLHt-4P_;?Mck2EBS_M7gbmt}}z~1L_kzL`i+3caR6x=XmcR-uIRibl*LI zcj$EoYEy&J-gw4pvGcjP3)jx=14sY0=GW(V;>TK$oY(t>#h(mz#ur-a9~oTjx4%fE z{Bm*q=wSC9mOt*-xsiarq+n9r%@-QMsJ$Yi0k|?!u9!6u2PVyzkXA`rs22K@7A%Yu zbng{LyhEg)7D42!qhS$($&aVWy?N8c_OYe~fmj?EG?UIP2}53D^hsepd}>w3<`n3Y zg<)9B$pi^{St4ZiflgWaClEErH%oz)nIvha*PK3OOyq>}oPe~UDJq(k4nWb#7)%Pa zw|~f|X3p!XGLpT$Io1ubA~(n0e&)v8&9PrJ$9}%Vl=UO;y#MZN=a>40-o7=zQc&M~ z%!%ryKyCkvv}!NwZ9cv2pDns3usN>tTYhtGWqkWB+4vi67RJ7@uD-qf7fy#m$Qyn| z4%;u#WZY`!_qV?wyM4!L`LujLGIFOC^m^u5_P=Z%F#YdB-X`{tcki<3gPjMgZr#A1 z7GL8AuOl;fFa8e5S-WB8<@=tNPrlZ!=%~#K*kvAKEx^;P zjCZbA?JnIc`dk=%$DPQ_1&<&j;RVj{^Ef;TrXHbm==HngG>DO}+k>L~u0#Fx;#0Kv z@e$=NbF|wuTIMKHrJhAE@_0{n=gO_9fYHT!wI}zMnj#Hd<`&yx=+$yd8TwO}JSP27 znHl;#Q;@KI|2gs>(By*IDCWv_k$~=#7HJ42qcTjyg^5VO$w1YOI>E36W7oF}2ewhM){dLSmjm@Ek?9h&~h6f++SxP({rVhcZNWx<(U8W;qHD z!7^F3DEPT)VG)D~Hpa{gu0fjTK2FyWhW?@)v*+&F&m`(09 zj2q5oZyh&qbTtL5cCuc8m3B@DHZ}qDjNFHar&4U$+=Kw-J1FFiW64fz87IDEIuu}B zLTQ{x%7NN3045{{oDiAP19m(eLp;q~B3dTN;5a=BAS_3OYfsj zY2?_bWR#{*Mt*Pqg^{DfhB?l(<%!nLrw%S&E%u_#W3BZu*sqmieQCCfy`l3L-X2lz z)?e%R{@LyUJc8;^JHEG@LRAJ|UM#-1^SAa@nY35yLu|eJ#S0_qhs-19;rF_qIcOAN z@K!{B`)feZJBQ4P^@j&LWB7Sw@LfC~8oYt$(3DJUYR6aI9ym$q zF&YurSk#K^7AT*qCb|Kf8x_a54-8p;B_d3a2>?c4Kzpmt2B713OD+&n+Wv zZ~GT{+bz%~x4JJ8rv**z+u~Q{6^cZz{r2`z>;1Q_-|ho@8mv{UlU%=zj?zlO$SZnl zjO{;Uq-E7QH=aj)LePQTyhcusOZbe$%BUk1EJ?^-$N~i1^05-p0NapgK-e_osZRjh zhz&SOf&1H-c$Q9r(ny?|58e@E&m3G5n_Hrc&sGF{L$JIV6mTTLrPWLHc}=B?YvLt@ z3^ZSzoU}~qfKtQjYDIta(Y;g=3Qf6`NfF`?O>k*j1@b_DQN{yg{-lN?Ba$%s!Ji!4 zEy=v+u!n%QPRfzUoD6e%y2&Oh@8Q1jCNyrM3ipcB z-urp#?cgtBXE=l_m%52w@@m)`G6eR(2OoE+T+~Z*Ih`(^YO)o7hD2*2+4ybk@Hv*X zLlwel@~eX|^_JwRNf8V(Dp%?YS5!^t4@G-$t`^gy*xP9Me?-m58$%Q=Eusre$BN>oaX^2HNQ{lugV zSBZ}A0-ULb@o^mkI^w|YEPr!Q+`O;=crX;i5|DqQi>TmaaMA-pz0f&?iU*OV!}#jY z1*jpDwgm2Qk}t?Aa;qT!Rgke6^gR}Wut|GkLNx;~XiluCPGtuuPrCR%Gz{cEhwn&i z)a~6b34qB&^0s;U!@HE~Chrvb?+E~`jUZu`_HB=p!@fDgz~h58XLzpdnVu=uCZ^HU z*+l9$?5-JRn?jm|NP*6~97n;v$-~E!JPG*JsLYw8BnreBSKRKzHNO7A(DSOURCES>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/DTDECLARE.~2~ b/sources/DTDECLARE.~2~ deleted file mode 100644 index 95fbc0ec..00000000 --- a/sources/DTDECLARE.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/FASLOAD.~1~ b/sources/FASLOAD.~1~ deleted file mode 100644 index d14371c1..00000000 --- a/sources/FASLOAD.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL") (IL:FILECREATED "25-Nov-92 12:35:33" "{Pele:mv:envos}Sources>FASLOAD.;6" 35074 IL:|changes| IL:|to:| (FASL-OPS FASL-DCODE) IL:|previous| IL:|date:| "18-Mar-91 08:30:33" "{Pele:mv:envos}Sources>FASLOAD.;4") ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992 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 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.") (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:SETQ IL:TEMP-DATE (IL:CONCAT (IL:GNC IL:SHORT-DATE-STRING) (IL:GNC IL:SHORT-DATE-STRING))) (IL:|if| (IL:EQUAL " " (IL:SUBSTRING IL:TEMP-DATE 2)) IL:|then| (IL:SETQ IL:TEMP-DATE (IL:CONCAT " " (IL:GNC IL:TEMP-DATE))) IL:|else| (IL:GNC IL:SHORT-DATE-STRING)) (IL:SETQ IL:DATE-RESULT (IL:CONCAT IL:TEMP-DATE "-" (IL:GNC IL:SHORT-DATE-STRING) (IL:GNC IL:SHORT-DATE-STRING) (IL:GNC IL:SHORT-DATE-STRING) "-")) (IL:SETQ IL:TEMP-DATE (IL:SUBSTRING IL:SHORT-DATE-STRING (IL:PLUS 3 (IL:STRPOS " " IL:SHORT-DATE-STRING )))) (IL:SETQ IL:DATE-RESULT (IL:CONCAT IL:DATE-RESULT (IL:GNC IL:TEMP-DATE) (IL:GNC IL:TEMP-DATE) " ")) (IL:GNC IL:TEMP-DATE) (IL:GNC IL:TEMP-DATE) (IL:|if| (IL:LESSP (IL:STRPOS ":" IL:TEMP-DATE) 3) IL:|then| (IL:CONCAT IL:DATE-RESULT "0" IL:TEMP-DATE) IL:|else| (IL:CONCAT IL:DATE-RESULT IL:TEMP-DATE))))) ) (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)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (31234 34707 (IL:FASL-FILEDATE 31247 . 32408) (CONVERT-FASL-DATE 32410 . 34705))))) IL:STOP \ No newline at end of file diff --git a/sources/FASLOAD.~2~ b/sources/FASLOAD.~2~ deleted file mode 100644 index a262e91f..00000000 --- a/sources/FASLOAD.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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.~10~ b/sources/FILEIO.~10~ deleted file mode 100644 index d50bf23a..00000000 --- a/sources/FILEIO.~10~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Aug-2020 11:43:08" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;10 181084 changes to%: (VARS FILEIOCOMS) (FNS \DO.PARAMS.AT.OPEN) previous date%: "13-Aug-2020 11:22:04" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;9) (* ; " 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) (INITVARS (STREAM-AFTER-OPEN-FNS NIL)) (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]) ) (RPAQ? STREAM-AFTER-OPEN-FNS NIL) (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 13-Aug-2020 11:40 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.") (* ;;  "RMK August 2020: Added hook for user STREAM-AFTER-OPEN-FNS, not global so can be rebound.") (DECLARE (USEDFREE STREAM-AFTER-OPEN-FNS)) (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))) (FOR FN IN STREAM-AFTER-OPEN-FNS DO (APPLY* FN STREAM ACCESS PARAMETERS]) (\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 (33103 36424 (STREAMPROP 33113 . 33547) (GETSTREAMPROP 33549 . 33948) (PUTSTREAMPROP 33950 . 36272) (STREAMP 36274 . 36422)) (36467 38986 (\DEFPRINT.BY.NAME 36477 . 37629) ( \STREAM.DEFPRINT 37631 . 38679) (\FDEV.DEFPRINT 38681 . 38984)) (39244 44285 (\GETACCESS 39254 . 39708 ) (\SETACCESS 39710 . 44283)) (67801 72574 (\INSTALL.EXTERNALFORMAT 67811 . 69009) ( \REMOVE.EXTERNALFORMAT 69011 . 69955) (\GET.EXTERNALFORMAT.FROM.NAME 69957 . 70364) (\EXTERNALFORMAT 70366 . 72572)) (72883 75889 (\CREATE.JIS.EXTERNALFORMAT 72893 . 73457) ( \CREATE.SHIFTJIS.EXTERNALFORMAT 73459 . 74577) (\CREATE.EUC.EXTERNALFORMAT 74579 . 75143) ( \CREATE.THROUGH.EXTERNALFORMAT 75145 . 75887)) (76104 82073 (\DEFINEDEVICE 76114 . 78430) ( \GETDEVICEFROMNAME 78432 . 78905) (\GETDEVICEFROMHOSTNAME 78907 . 79951) (\REMOVEDEVICE 79953 . 81076) (\REMOVEDEVICE.NAMES 81078 . 82071)) (82113 106848 (\CLOSEFILE 82123 . 82948) (\DELETEFILE 82950 . 83244) (\DEVICEEVENT 83246 . 85016) (\GENERATEFILES 85018 . 85496) (\GENERATENEXTFILE 85498 . 86149) ( \GENERATEFILEINFO 86151 . 86612) (\GETFILENAME 86614 . 87003) (\GENERIC.READCCODE 87005 . 87641) ( \GENERIC.OUTFILEP 87643 . 88113) (\OPENFILE 88115 . 90693) (\DO.PARAMS.AT.OPEN 90695 . 92685) ( \RENAMEFILE 92687 . 93111) (\REVALIDATEFILE 93113 . 95715) (\PAGED.REVALIDATEFILELST 95717 . 97275) ( \PAGED.REVALIDATEFILES 97277 . 98996) (\PAGED.REVALIDATEFILE 98998 . 101281) (\BUFFERED.REVALIDATEFILE 101283 . 103569) (\BUFFERED.REVALIDATEFILELST 103571 . 104755) (\PRINT-REVALIDATION-RESULT 104757 . 105172) (\TRUNCATEFILE 105174 . 105565) (\FILE-CONFLICT 105567 . 106846)) (106884 111547 ( \GENERATENOFILES 106894 . 108990) (\NULLFILEGENERATOR 108992 . 109236) (\NOFILESNEXTFILEFN 109238 . 111229) (\NOFILESINFOFN 111231 . 111545)) (111666 113574 (\FILE.NOT.OPEN 111676 . 112189) ( \FILE.WONT.OPEN 112191 . 112519) (\ILLEGAL.DEVICEOP 112521 . 112803) (\IS.NOT.RANDACCESSP 112805 . 113251) (\STREAM.NOT.OPEN 113253 . 113572)) (113709 116007 (\FDEVINSTANCE 113719 . 116005)) (117557 124931 (CNDIR 117567 . 118872) (DIRECTORYNAME 118874 . 123057) (DIRECTORYNAMEP 123059 . 123675) ( HOSTNAMEP 123677 . 124484) (\ADD.CONNECTED.DIR 124486 . 124929)) (124976 154719 (\BACKFILEPTR 124986 . 125174) (\BACKPEEKBIN 125176 . 125537) (\BACKBIN 125539 . 125890) (BIN 125892 . 126109) (\BIN 126111 . 126388) (\BINS 126390 . 126676) (BOUT 126678 . 127040) (\BOUT 127042 . 127357) (\BOUTS 127359 . 127670) (COPYBYTES 127672 . 131004) (COPYCHARS 131006 . 137566) (COPYFILE 137568 . 138365) ( \COPYOPENFILE 138367 . 141786) (\INFER.FILE.TYPE 141788 . 142742) (EOFP 142744 . 143041) (FORCEOUTPUT 143043 . 143290) (\FLUSH.OPEN.STREAMS 143292 . 143648) (CHARSET 143650 . 145314) (ACCESS-CHARSET 145316 . 145533) (GETEOFPTR 145535 . 145785) (GETFILEINFO 145787 . 148912) (\TYPE.FROM.FILETYPE 148914 . 149384) (\FILETYPE.FROM.TYPE 149386 . 149565) (GETFILEPTR 149567 . 149819) (SETFILEINFO 149821 . 153323) (SETFILEPTR 153325 . 154339) (BOUT16 154341 . 154526) (BIN16 154528 . 154717)) (154822 160320 (\GENERIC.BINS 154832 . 155112) (\GENERIC.BOUTS 155114 . 155379) (\GENERIC.RENAMEFILE 155381 . 157212) (\GENERIC.OPENP 157214 . 158529) (\GENERIC.READP 158531 . 159865) (\GENERIC.CHARSET 159867 . 160318)) (160321 160660 (\MAP-OPEN-STREAMS 160331 . 160658)) (162678 164758 (\EOF.ACTION 162688 . 162939) ( \EOSERROR 162941 . 163134) (\GETEOFPTR 163136 . 163318) (\INCFILEPTR 163320 . 163670) (\PEEKBIN 163672 . 163863) (\SETCLOSEDFILELENGTH 163865 . 164199) (\SETEOFPTR 164201 . 164389) (\SETFILEPTR 164391 . 164756)) (164759 165301 (\FIXPOUT 164769 . 165069) (\FIXPIN 165071 . 165299)) (168393 178257 ( \BUFFERED.BIN 168403 . 169255) (\BUFFERED.PEEKBIN 169257 . 170039) (\BUFFERED.BOUT 170041 . 170901) ( \BUFFERED.BINS 170903 . 174588) (\BUFFERED.BOUTS 174590 . 176391) (\BUFFERED.COPYBYTES 176393 . 178255 )) (178286 180638 (\NULLDEVICE 178296 . 180314) (\NULL.OPENFILE 180316 . 180636))))) STOP \ No newline at end of file diff --git a/sources/FILEIO.~1~ b/sources/FILEIO.~1~ deleted file mode 100644 index 80cd111b..00000000 --- a/sources/FILEIO.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Mar-99 12:25:05" {DSK}medley3.5>sources>FILEIO.;2 177046 changes to%: (FNS COPYCHARS GETFILEINFO SETFILEINFO \COPYOPENFILE) previous date%: "19-Jan-93 10:27:59" {DSK}medley3.5>sources>FILEIO.;1) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1999 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)) (*EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *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) (* rda%: "22-Aug-84 16:17") (OR (type? STREAM STREAM) (\ILLEGAL.ARG)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) (PUTSTREAMPROP [LAMBDA (STREAM PROP VALUE) (* rda%: "22-Aug-84 16:11") (OR (type? STREAM STREAM) (\ILLEGAL.ARG STREAM)) (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 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.") (\DTEST STREAM 'STREAM) (COND [NEWVALUE (COND ((FMEMB NEWVALUE '(:XCCS :DEFAULT) (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 (COND ((ffetch (STREAM NOTXCCS) of STREAM) (ffetch EXTERNALFORMAT.NAME of STREAM)) (T :DEFAULT]) ) (RPAQ? *SUPPORTED-EXTERNALFORMATS* '(:XCCS :DEFAULT)) (RPAQ? *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *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 5-Oct-92 13:45 by jds") (* ;; "Does generic parameters when a file/stream is open. Called by \OPENFILE and OPENSTREAM") (for X ATTR VAL 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 (\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]) (\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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (31992 34502 (STREAMPROP 32002 . 32436) (GETSTREAMPROP 32438 . 32684) (PUTSTREAMPROP 32686 . 34350) (STREAMP 34352 . 34500)) (34545 37064 (\DEFPRINT.BY.NAME 34555 . 35707) ( \STREAM.DEFPRINT 35709 . 36757) (\FDEV.DEFPRINT 36759 . 37062)) (37322 42363 (\GETACCESS 37332 . 37786 ) (\SETACCESS 37788 . 42361)) (65879 69740 (\INSTALL.EXTERNALFORMAT 65889 . 67087) ( \REMOVE.EXTERNALFORMAT 67089 . 68033) (\GET.EXTERNALFORMAT.FROM.NAME 68035 . 68442) (\EXTERNALFORMAT 68444 . 69738)) (69973 72979 (\CREATE.JIS.EXTERNALFORMAT 69983 . 70547) ( \CREATE.SHIFTJIS.EXTERNALFORMAT 70549 . 71667) (\CREATE.EUC.EXTERNALFORMAT 71669 . 72233) ( \CREATE.THROUGH.EXTERNALFORMAT 72235 . 72977)) (73194 79163 (\DEFINEDEVICE 73204 . 75520) ( \GETDEVICEFROMNAME 75522 . 75995) (\GETDEVICEFROMHOSTNAME 75997 . 77041) (\REMOVEDEVICE 77043 . 78166) (\REMOVEDEVICE.NAMES 78168 . 79161)) (79164 103915 (\CLOSEFILE 79174 . 79999) (\DELETEFILE 80001 . 80295) (\DEVICEEVENT 80297 . 82067) (\GENERATEFILES 82069 . 82547) (\GENERATENEXTFILE 82549 . 83200) ( \GENERATEFILEINFO 83202 . 83663) (\GETFILENAME 83665 . 84054) (\GENERIC.READCCODE 84056 . 84692) ( \GENERIC.OUTFILEP 84694 . 85164) (\OPENFILE 85166 . 87744) (\DO.PARAMS.AT.OPEN 87746 . 89752) ( \RENAMEFILE 89754 . 90178) (\REVALIDATEFILE 90180 . 92782) (\PAGED.REVALIDATEFILELST 92784 . 94342) ( \PAGED.REVALIDATEFILES 94344 . 96063) (\PAGED.REVALIDATEFILE 96065 . 98348) (\BUFFERED.REVALIDATEFILE 98350 . 100636) (\BUFFERED.REVALIDATEFILELST 100638 . 101822) (\PRINT-REVALIDATION-RESULT 101824 . 102239) (\TRUNCATEFILE 102241 . 102632) (\FILE-CONFLICT 102634 . 103913)) (103951 108614 ( \GENERATENOFILES 103961 . 106057) (\NULLFILEGENERATOR 106059 . 106303) (\NOFILESNEXTFILEFN 106305 . 108296) (\NOFILESINFOFN 108298 . 108612)) (108733 110641 (\FILE.NOT.OPEN 108743 . 109256) ( \FILE.WONT.OPEN 109258 . 109586) (\ILLEGAL.DEVICEOP 109588 . 109870) (\IS.NOT.RANDACCESSP 109872 . 110318) (\STREAM.NOT.OPEN 110320 . 110639)) (110776 113074 (\FDEVINSTANCE 110786 . 113072)) (113990 121364 (CNDIR 114000 . 115305) (DIRECTORYNAME 115307 . 119490) (DIRECTORYNAMEP 119492 . 120108) ( HOSTNAMEP 120110 . 120917) (\ADD.CONNECTED.DIR 120919 . 121362)) (121409 151152 (\BACKFILEPTR 121419 . 121607) (\BACKPEEKBIN 121609 . 121970) (\BACKBIN 121972 . 122323) (BIN 122325 . 122542) (\BIN 122544 . 122821) (\BINS 122823 . 123109) (BOUT 123111 . 123473) (\BOUT 123475 . 123790) (\BOUTS 123792 . 124103) (COPYBYTES 124105 . 127437) (COPYCHARS 127439 . 133999) (COPYFILE 134001 . 134798) ( \COPYOPENFILE 134800 . 138219) (\INFER.FILE.TYPE 138221 . 139175) (EOFP 139177 . 139474) (FORCEOUTPUT 139476 . 139723) (\FLUSH.OPEN.STREAMS 139725 . 140081) (CHARSET 140083 . 141747) (ACCESS-CHARSET 141749 . 141966) (GETEOFPTR 141968 . 142218) (GETFILEINFO 142220 . 145345) (\TYPE.FROM.FILETYPE 145347 . 145817) (\FILETYPE.FROM.TYPE 145819 . 145998) (GETFILEPTR 146000 . 146252) (SETFILEINFO 146254 . 149756) (SETFILEPTR 149758 . 150772) (BOUT16 150774 . 150959) (BIN16 150961 . 151150)) (151255 156753 (\GENERIC.BINS 151265 . 151545) (\GENERIC.BOUTS 151547 . 151812) (\GENERIC.RENAMEFILE 151814 . 153645) (\GENERIC.OPENP 153647 . 154962) (\GENERIC.READP 154964 . 156298) (\GENERIC.CHARSET 156300 . 156751)) (156754 157093 (\MAP-OPEN-STREAMS 156764 . 157091)) (159069 161149 (\EOF.ACTION 159079 . 159330) ( \EOSERROR 159332 . 159525) (\GETEOFPTR 159527 . 159709) (\INCFILEPTR 159711 . 160061) (\PEEKBIN 160063 . 160254) (\SETCLOSEDFILELENGTH 160256 . 160590) (\SETEOFPTR 160592 . 160780) (\SETFILEPTR 160782 . 161147)) (161150 161692 (\FIXPOUT 161160 . 161460) (\FIXPIN 161462 . 161690)) (164360 174224 ( \BUFFERED.BIN 164370 . 165222) (\BUFFERED.PEEKBIN 165224 . 166006) (\BUFFERED.BOUT 166008 . 166868) ( \BUFFERED.BINS 166870 . 170555) (\BUFFERED.BOUTS 170557 . 172358) (\BUFFERED.COPYBYTES 172360 . 174222 )) (174253 176605 (\NULLDEVICE 174263 . 176281) (\NULL.OPENFILE 176283 . 176603))))) STOP \ No newline at end of file diff --git a/sources/FILEIO.~4~ b/sources/FILEIO.~4~ deleted file mode 100644 index bb124b37..00000000 --- a/sources/FILEIO.~4~ +++ /dev/null @@ -1,1488 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 2-Aug-2020 17:07:18" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;4 159740 - - changes to%: (FNS \EXTERNALFORMAT) - - previous date%: " 2-Aug-2020 16:20:12" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;3) - - -(* ; " -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) (* rda%: "22-Aug-84 16:17") (OR (type? STREAM STREAM) (\ILLEGAL.ARG)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) - -(PUTSTREAMPROP [LAMBDA (STREAM PROP VALUE) (* rda%: "22-Aug-84 16:11") (OR (type? STREAM STREAM) (\ILLEGAL.ARG STREAM)) (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 2-Aug-2020 17:06 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*)) -:DEFAULT))) - (COND - [NEWVALUE (COND - ((FMEMB NEWVALUE '(:XCCS :DEFAULT) -(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 (COND - ((ffetch (STREAM NOTXCCS) of STREAM) -(ffetch EXTERNALFORMAT.NAME of STREAM)) - (T :DEFAULT]) -) - -(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 (22030 24540 (STREAMPROP 22040 . 22474) (GETSTREAMPROP 22476 . 22722) (PUTSTREAMPROP 22724 . 24388) (STREAMP 24390 . 24538)) (24583 27102 (\DEFPRINT.BY.NAME 24593 . 25745) (\STREAM.DEFPRINT 25747 . 26795) (\FDEV.DEFPRINT 26797 . 27100)) (27360 32401 (\GETACCESS 27370 . 27824) (\SETACCESS 27826 . 32399)) (50272 54209 (\INSTALL.EXTERNALFORMAT 50282 . 51480) (\REMOVE.EXTERNALFORMAT 51482 . 52426) (\GET.EXTERNALFORMAT.FROM.NAME 52428 . 52835) (\EXTERNALFORMAT 52837 . 54207)) (54510 57516 (\CREATE.JIS.EXTERNALFORMAT 54520 . 55084) (\CREATE.SHIFTJIS.EXTERNALFORMAT 55086 . 56204) (\CREATE.EUC.EXTERNALFORMAT 56206 . 56770) (\CREATE.THROUGH.EXTERNALFORMAT 56772 . 57514)) (57731 63700 (\DEFINEDEVICE 57741 . 60057) (\GETDEVICEFROMNAME 60059 . 60532) (\GETDEVICEFROMHOSTNAME 60534 . 61578) (\REMOVEDEVICE 61580 . 62703) (\REMOVEDEVICE.NAMES 62705 . 63698)) (63701 88178 (\CLOSEFILE 63711 . 64536) (\DELETEFILE 64538 . 64832) (\DEVICEEVENT 64834 . 66604) (\GENERATEFILES 66606 . 67084) (\GENERATENEXTFILE 67086 . 67737) (\GENERATEFILEINFO 67739 . 68200) (\GETFILENAME 68202 . 68591) (\GENERIC.READCCODE 68593 . 69229) (\GENERIC.OUTFILEP 69231 . 69701) (\OPENFILE 69703 . 72281) (\DO.PARAMS.AT.OPEN 72283 . 74015) (\RENAMEFILE 74017 . 74441) (\REVALIDATEFILE 74443 . 77045) (\PAGED.REVALIDATEFILELST 77047 . 78605) (\PAGED.REVALIDATEFILES 78607 . 80326) (\PAGED.REVALIDATEFILE 80328 . 82611) (\BUFFERED.REVALIDATEFILE 82613 . 84899) (\BUFFERED.REVALIDATEFILELST 84901 . 86085) (\PRINT-REVALIDATION-RESULT 86087 . 86502) (\TRUNCATEFILE 86504 . 86895) (\FILE-CONFLICT 86897 . 88176)) (88214 92877 (\GENERATENOFILES 88224 . 90320) (\NULLFILEGENERATOR 90322 . 90566) (\NOFILESNEXTFILEFN 90568 . 92559) (\NOFILESINFOFN 92561 . 92875)) (92996 94904 (\FILE.NOT.OPEN 93006 . 93519) (\FILE.WONT.OPEN 93521 . 93849) (\ILLEGAL.DEVICEOP 93851 . 94133) (\IS.NOT.RANDACCESSP 94135 . 94581) (\STREAM.NOT.OPEN 94583 . 94902)) (95039 97337 (\FDEVINSTANCE 95049 . 97335)) (98020 105394 (CNDIR 98030 . 99335) (DIRECTORYNAME 99337 . 103520) (DIRECTORYNAMEP 103522 . 104138) (HOSTNAMEP 104140 . 104947) (\ADD.CONNECTED.DIR 104949 . 105392)) (105439 135182 (\BACKFILEPTR 105449 . 105637) (\BACKPEEKBIN 105639 . 106000) (\BACKBIN 106002 . 106353) (BIN 106355 . 106572) (\BIN 106574 . 106851) (\BINS 106853 . 107139) (BOUT 107141 . 107503) (\BOUT 107505 . 107820) (\BOUTS 107822 . 108133) (COPYBYTES 108135 . 111467) (COPYCHARS 111469 . 118029) (COPYFILE 118031 . 118828) (\COPYOPENFILE 118830 . 122249) (\INFER.FILE.TYPE 122251 . 123205) (EOFP 123207 . 123504) (FORCEOUTPUT 123506 . 123753) (\FLUSH.OPEN.STREAMS 123755 . 124111) (CHARSET 124113 . 125777) (ACCESS-CHARSET 125779 . 125996) (GETEOFPTR 125998 . 126248) (GETFILEINFO 126250 . 129375) (\TYPE.FROM.FILETYPE 129377 . 129847) (\FILETYPE.FROM.TYPE 129849 . 130028) (GETFILEPTR 130030 . 130282) (SETFILEINFO 130284 . 133786) (SETFILEPTR 133788 . 134802) (BOUT16 134804 . 134989) (BIN16 134991 . 135180)) (135285 140783 (\GENERIC.BINS 135295 . 135575) (\GENERIC.BOUTS 135577 . 135842) (\GENERIC.RENAMEFILE 135844 . 137675) (\GENERIC.OPENP 137677 . 138992) (\GENERIC.READP 138994 . 140328) (\GENERIC.CHARSET 140330 . 140781)) (140784 141123 (\MAP-OPEN-STREAMS 140794 . 141121)) (142395 144475 (\EOF.ACTION 142405 . 142656) (\EOSERROR 142658 . 142851) (\GETEOFPTR 142853 . 143035) (\INCFILEPTR 143037 . 143387) (\PEEKBIN 143389 . 143580) (\SETCLOSEDFILELENGTH 143582 . 143916) (\SETEOFPTR 143918 . 144106) (\SETFILEPTR 144108 . 144473)) (144476 145018 (\FIXPOUT 144486 . 144786) (\FIXPIN 144788 . 145016)) (147050 156914 (\BUFFERED.BIN 147060 . 147912) (\BUFFERED.PEEKBIN 147914 . 148696) (\BUFFERED.BOUT 148698 . 149558) (\BUFFERED.BINS 149560 . 153245) (\BUFFERED.BOUTS 153247 . 155048) (\BUFFERED.COPYBYTES 155050 . 156912)) (156943 159295 (\NULLDEVICE 156953 . 158971) (\NULL.OPENFILE 158973 . 159293))))) -STOP diff --git a/sources/FILEIO.~5~ b/sources/FILEIO.~5~ deleted file mode 100644 index d37df290..00000000 --- a/sources/FILEIO.~5~ +++ /dev/null @@ -1,1487 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Aug-2020 00:04:07" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;5 159719 - - changes to%: (FNS \EXTERNALFORMAT) - - previous date%: " 2-Aug-2020 17:07:18" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;4) - - -(* ; " -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) (* rda%: "22-Aug-84 16:17") (OR (type? STREAM STREAM) (\ILLEGAL.ARG)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) - -(PUTSTREAMPROP [LAMBDA (STREAM PROP VALUE) (* rda%: "22-Aug-84 16:11") (OR (type? STREAM STREAM) (\ILLEGAL.ARG STREAM)) (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 3-Aug-2020 00:04 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))) - (COND - [NEWVALUE (COND - ((EQ NEWVALUE :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 (COND - ((ffetch (STREAM NOTXCCS) of STREAM) -(ffetch EXTERNALFORMAT.NAME of STREAM)) - (T :XCCS]) -) - -(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 (22030 24540 (STREAMPROP 22040 . 22474) (GETSTREAMPROP 22476 . 22722) (PUTSTREAMPROP 22724 . 24388) (STREAMP 24390 . 24538)) (24583 27102 (\DEFPRINT.BY.NAME 24593 . 25745) (\STREAM.DEFPRINT 25747 . 26795) (\FDEV.DEFPRINT 26797 . 27100)) (27360 32401 (\GETACCESS 27370 . 27824) (\SETACCESS 27826 . 32399)) (50272 54188 (\INSTALL.EXTERNALFORMAT 50282 . 51480) (\REMOVE.EXTERNALFORMAT 51482 . 52426) (\GET.EXTERNALFORMAT.FROM.NAME 52428 . 52835) (\EXTERNALFORMAT 52837 . 54186)) (54489 57495 (\CREATE.JIS.EXTERNALFORMAT 54499 . 55063) (\CREATE.SHIFTJIS.EXTERNALFORMAT 55065 . 56183) (\CREATE.EUC.EXTERNALFORMAT 56185 . 56749) (\CREATE.THROUGH.EXTERNALFORMAT 56751 . 57493)) (57710 63679 (\DEFINEDEVICE 57720 . 60036) (\GETDEVICEFROMNAME 60038 . 60511) (\GETDEVICEFROMHOSTNAME 60513 . 61557) (\REMOVEDEVICE 61559 . 62682) (\REMOVEDEVICE.NAMES 62684 . 63677)) (63680 88157 (\CLOSEFILE 63690 . 64515) (\DELETEFILE 64517 . 64811) (\DEVICEEVENT 64813 . 66583) (\GENERATEFILES 66585 . 67063) (\GENERATENEXTFILE 67065 . 67716) (\GENERATEFILEINFO 67718 . 68179) (\GETFILENAME 68181 . 68570) (\GENERIC.READCCODE 68572 . 69208) (\GENERIC.OUTFILEP 69210 . 69680) (\OPENFILE 69682 . 72260) (\DO.PARAMS.AT.OPEN 72262 . 73994) (\RENAMEFILE 73996 . 74420) (\REVALIDATEFILE 74422 . 77024) (\PAGED.REVALIDATEFILELST 77026 . 78584) (\PAGED.REVALIDATEFILES 78586 . 80305) (\PAGED.REVALIDATEFILE 80307 . 82590) (\BUFFERED.REVALIDATEFILE 82592 . 84878) (\BUFFERED.REVALIDATEFILELST 84880 . 86064) (\PRINT-REVALIDATION-RESULT 86066 . 86481) (\TRUNCATEFILE 86483 . 86874) (\FILE-CONFLICT 86876 . 88155)) (88193 92856 (\GENERATENOFILES 88203 . 90299) (\NULLFILEGENERATOR 90301 . 90545) (\NOFILESNEXTFILEFN 90547 . 92538) (\NOFILESINFOFN 92540 . 92854)) (92975 94883 (\FILE.NOT.OPEN 92985 . 93498) (\FILE.WONT.OPEN 93500 . 93828) (\ILLEGAL.DEVICEOP 93830 . 94112) (\IS.NOT.RANDACCESSP 94114 . 94560) (\STREAM.NOT.OPEN 94562 . 94881)) (95018 97316 (\FDEVINSTANCE 95028 . 97314)) (97999 105373 (CNDIR 98009 . 99314) (DIRECTORYNAME 99316 . 103499) (DIRECTORYNAMEP 103501 . 104117) (HOSTNAMEP 104119 . 104926) (\ADD.CONNECTED.DIR 104928 . 105371)) (105418 135161 (\BACKFILEPTR 105428 . 105616) (\BACKPEEKBIN 105618 . 105979) (\BACKBIN 105981 . 106332) (BIN 106334 . 106551) (\BIN 106553 . 106830) (\BINS 106832 . 107118) (BOUT 107120 . 107482) (\BOUT 107484 . 107799) (\BOUTS 107801 . 108112) (COPYBYTES 108114 . 111446) (COPYCHARS 111448 . 118008) (COPYFILE 118010 . 118807) (\COPYOPENFILE 118809 . 122228) (\INFER.FILE.TYPE 122230 . 123184) (EOFP 123186 . 123483) (FORCEOUTPUT 123485 . 123732) (\FLUSH.OPEN.STREAMS 123734 . 124090) (CHARSET 124092 . 125756) (ACCESS-CHARSET 125758 . 125975) (GETEOFPTR 125977 . 126227) (GETFILEINFO 126229 . 129354) (\TYPE.FROM.FILETYPE 129356 . 129826) (\FILETYPE.FROM.TYPE 129828 . 130007) (GETFILEPTR 130009 . 130261) (SETFILEINFO 130263 . 133765) (SETFILEPTR 133767 . 134781) (BOUT16 134783 . 134968) (BIN16 134970 . 135159)) (135264 140762 (\GENERIC.BINS 135274 . 135554) (\GENERIC.BOUTS 135556 . 135821) (\GENERIC.RENAMEFILE 135823 . 137654) (\GENERIC.OPENP 137656 . 138971) (\GENERIC.READP 138973 . 140307) (\GENERIC.CHARSET 140309 . 140760)) (140763 141102 (\MAP-OPEN-STREAMS 140773 . 141100)) (142374 144454 (\EOF.ACTION 142384 . 142635) (\EOSERROR 142637 . 142830) (\GETEOFPTR 142832 . 143014) (\INCFILEPTR 143016 . 143366) (\PEEKBIN 143368 . 143559) (\SETCLOSEDFILELENGTH 143561 . 143895) (\SETEOFPTR 143897 . 144085) (\SETFILEPTR 144087 . 144452)) (144455 144997 (\FIXPOUT 144465 . 144765) (\FIXPIN 144767 . 144995)) (147029 156893 (\BUFFERED.BIN 147039 . 147891) (\BUFFERED.PEEKBIN 147893 . 148675) (\BUFFERED.BOUT 148677 . 149537) (\BUFFERED.BINS 149539 . 153224) (\BUFFERED.BOUTS 153226 . 155027) (\BUFFERED.COPYBYTES 155029 . 156891)) (156922 159274 (\NULLDEVICE 156932 . 158950) (\NULL.OPENFILE 158952 . 159272))))) -STOP diff --git a/sources/FILEIO.~6~ b/sources/FILEIO.~6~ deleted file mode 100644 index 0de24fc8..00000000 --- a/sources/FILEIO.~6~ +++ /dev/null @@ -1,1488 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Aug-2020 00:04:28" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;6 159719 - - changes to%: (FNS \EXTERNALFORMAT) - - previous date%: " 2-Aug-2020 17:07:18" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;4) - - -(* ; " -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) (* rda%: "22-Aug-84 16:17") (OR (type? STREAM STREAM) (\ILLEGAL.ARG)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) - -(PUTSTREAMPROP [LAMBDA (STREAM PROP VALUE) (* rda%: "22-Aug-84 16:11") (OR (type? STREAM STREAM) (\ILLEGAL.ARG STREAM)) (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 3-Aug-2020 00:04 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))) - (COND - [NEWVALUE (COND - ((EQ NEWVALUE :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 (COND - ((ffetch (STREAM NOTXCCS) of STREAM) -(ffetch EXTERNALFORMAT.NAME of STREAM)) - (T :XCCS]) -) - -(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 (22030 24540 (STREAMPROP 22040 . 22474) (GETSTREAMPROP 22476 . 22722) (PUTSTREAMPROP 22724 . 24388) (STREAMP 24390 . 24538)) (24583 27102 (\DEFPRINT.BY.NAME 24593 . 25745) (\STREAM.DEFPRINT 25747 . 26795) (\FDEV.DEFPRINT 26797 . 27100)) (27360 32401 (\GETACCESS 27370 . 27824) (\SETACCESS 27826 . 32399)) (50272 54188 (\INSTALL.EXTERNALFORMAT 50282 . 51480) (\REMOVE.EXTERNALFORMAT 51482 . 52426) (\GET.EXTERNALFORMAT.FROM.NAME 52428 . 52835) (\EXTERNALFORMAT 52837 . 54186)) (54489 57495 (\CREATE.JIS.EXTERNALFORMAT 54499 . 55063) (\CREATE.SHIFTJIS.EXTERNALFORMAT 55065 . 56183) (\CREATE.EUC.EXTERNALFORMAT 56185 . 56749) (\CREATE.THROUGH.EXTERNALFORMAT 56751 . 57493)) (57710 63679 (\DEFINEDEVICE 57720 . 60036) (\GETDEVICEFROMNAME 60038 . 60511) (\GETDEVICEFROMHOSTNAME 60513 . 61557) (\REMOVEDEVICE 61559 . 62682) (\REMOVEDEVICE.NAMES 62684 . 63677)) (63680 88157 (\CLOSEFILE 63690 . 64515) (\DELETEFILE 64517 . 64811) (\DEVICEEVENT 64813 . 66583) (\GENERATEFILES 66585 . 67063) (\GENERATENEXTFILE 67065 . 67716) (\GENERATEFILEINFO 67718 . 68179) (\GETFILENAME 68181 . 68570) (\GENERIC.READCCODE 68572 . 69208) (\GENERIC.OUTFILEP 69210 . 69680) (\OPENFILE 69682 . 72260) (\DO.PARAMS.AT.OPEN 72262 . 73994) (\RENAMEFILE 73996 . 74420) (\REVALIDATEFILE 74422 . 77024) (\PAGED.REVALIDATEFILELST 77026 . 78584) (\PAGED.REVALIDATEFILES 78586 . 80305) (\PAGED.REVALIDATEFILE 80307 . 82590) (\BUFFERED.REVALIDATEFILE 82592 . 84878) (\BUFFERED.REVALIDATEFILELST 84880 . 86064) (\PRINT-REVALIDATION-RESULT 86066 . 86481) (\TRUNCATEFILE 86483 . 86874) (\FILE-CONFLICT 86876 . 88155)) (88193 92856 (\GENERATENOFILES 88203 . 90299) (\NULLFILEGENERATOR 90301 . 90545) (\NOFILESNEXTFILEFN 90547 . 92538) (\NOFILESINFOFN 92540 . 92854)) (92975 94883 (\FILE.NOT.OPEN 92985 . 93498) (\FILE.WONT.OPEN 93500 . 93828) (\ILLEGAL.DEVICEOP 93830 . 94112) (\IS.NOT.RANDACCESSP 94114 . 94560) (\STREAM.NOT.OPEN 94562 . 94881)) (95018 97316 (\FDEVINSTANCE 95028 . 97314)) (97999 105373 (CNDIR 98009 . 99314) (DIRECTORYNAME 99316 . 103499) (DIRECTORYNAMEP 103501 . 104117) (HOSTNAMEP 104119 . 104926) (\ADD.CONNECTED.DIR 104928 . 105371)) (105418 135161 (\BACKFILEPTR 105428 . 105616) (\BACKPEEKBIN 105618 . 105979) (\BACKBIN 105981 . 106332) (BIN 106334 . 106551) (\BIN 106553 . 106830) (\BINS 106832 . 107118) (BOUT 107120 . 107482) (\BOUT 107484 . 107799) (\BOUTS 107801 . 108112) (COPYBYTES 108114 . 111446) (COPYCHARS 111448 . 118008) (COPYFILE 118010 . 118807) (\COPYOPENFILE 118809 . 122228) (\INFER.FILE.TYPE 122230 . 123184) (EOFP 123186 . 123483) (FORCEOUTPUT 123485 . 123732) (\FLUSH.OPEN.STREAMS 123734 . 124090) (CHARSET 124092 . 125756) (ACCESS-CHARSET 125758 . 125975) (GETEOFPTR 125977 . 126227) (GETFILEINFO 126229 . 129354) (\TYPE.FROM.FILETYPE 129356 . 129826) (\FILETYPE.FROM.TYPE 129828 . 130007) (GETFILEPTR 130009 . 130261) (SETFILEINFO 130263 . 133765) (SETFILEPTR 133767 . 134781) (BOUT16 134783 . 134968) (BIN16 134970 . 135159)) (135264 140762 (\GENERIC.BINS 135274 . 135554) (\GENERIC.BOUTS 135556 . 135821) (\GENERIC.RENAMEFILE 135823 . 137654) (\GENERIC.OPENP 137656 . 138971) (\GENERIC.READP 138973 . 140307) (\GENERIC.CHARSET 140309 . 140760)) (140763 141102 (\MAP-OPEN-STREAMS 140773 . 141100)) (142374 144454 (\EOF.ACTION 142384 . 142635) (\EOSERROR 142637 . 142830) (\GETEOFPTR 142832 . 143014) (\INCFILEPTR 143016 . 143366) (\PEEKBIN 143368 . 143559) (\SETCLOSEDFILELENGTH 143561 . 143895) (\SETEOFPTR 143897 . 144085) (\SETFILEPTR 144087 . 144452)) (144455 144997 (\FIXPOUT 144465 . 144765) (\FIXPIN 144767 . 144995)) (147029 156893 (\BUFFERED.BIN 147039 . 147891) (\BUFFERED.PEEKBIN 147893 . 148675) (\BUFFERED.BOUT 148677 . 149537) (\BUFFERED.BINS 149539 . 153224) (\BUFFERED.BOUTS 153226 . 155027) (\BUFFERED.COPYBYTES 155029 . 156891)) (156922 159274 (\NULLDEVICE 156932 . 158950) (\NULL.OPENFILE 158952 . 159272))))) -STOP diff --git a/sources/FILEIO.~7~ b/sources/FILEIO.~7~ deleted file mode 100644 index 72d36e63..00000000 --- a/sources/FILEIO.~7~ +++ /dev/null @@ -1 +0,0 @@ -(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/FILEIO.~8~ b/sources/FILEIO.~8~ deleted file mode 100644 index 72d36e63..00000000 --- a/sources/FILEIO.~8~ +++ /dev/null @@ -1 +0,0 @@ -(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/FILEIO.~9~ b/sources/FILEIO.~9~ deleted file mode 100644 index c3c271ea..00000000 --- a/sources/FILEIO.~9~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Aug-2020 11:22:04" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;9 181029 changes to%: (VARS FILEIOCOMS) (FNS \DO.PARAMS.AT.OPEN) previous date%: " 5-Aug-2020 16:43:46" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;8) (* ; " 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) (INITVARS (STREAM-AFTER-OPEN-FN NIL)) (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]) ) (RPAQ? STREAM-AFTER-OPEN-FN NIL) (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 13-Aug-2020 11:21 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.") (* ;;  "RMK August 2020: Added hook for user STREAM-AFTER-OPEN-FN, not global so can be rebound.") (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))) (CL:WHEN STREAM-AFTER-OPEN-FN (APPLY* STREAM-AFTER-OPEN-FN STREAM ACCESS PARAMETERS]) (\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 (33101 36422 (STREAMPROP 33111 . 33545) (GETSTREAMPROP 33547 . 33946) (PUTSTREAMPROP 33948 . 36270) (STREAMP 36272 . 36420)) (36465 38984 (\DEFPRINT.BY.NAME 36475 . 37627) ( \STREAM.DEFPRINT 37629 . 38677) (\FDEV.DEFPRINT 38679 . 38982)) (39242 44283 (\GETACCESS 39252 . 39706 ) (\SETACCESS 39708 . 44281)) (67799 72572 (\INSTALL.EXTERNALFORMAT 67809 . 69007) ( \REMOVE.EXTERNALFORMAT 69009 . 69953) (\GET.EXTERNALFORMAT.FROM.NAME 69955 . 70362) (\EXTERNALFORMAT 70364 . 72570)) (72881 75887 (\CREATE.JIS.EXTERNALFORMAT 72891 . 73455) ( \CREATE.SHIFTJIS.EXTERNALFORMAT 73457 . 74575) (\CREATE.EUC.EXTERNALFORMAT 74577 . 75141) ( \CREATE.THROUGH.EXTERNALFORMAT 75143 . 75885)) (76102 82071 (\DEFINEDEVICE 76112 . 78428) ( \GETDEVICEFROMNAME 78430 . 78903) (\GETDEVICEFROMHOSTNAME 78905 . 79949) (\REMOVEDEVICE 79951 . 81074) (\REMOVEDEVICE.NAMES 81076 . 82069)) (82110 106793 (\CLOSEFILE 82120 . 82945) (\DELETEFILE 82947 . 83241) (\DEVICEEVENT 83243 . 85013) (\GENERATEFILES 85015 . 85493) (\GENERATENEXTFILE 85495 . 86146) ( \GENERATEFILEINFO 86148 . 86609) (\GETFILENAME 86611 . 87000) (\GENERIC.READCCODE 87002 . 87638) ( \GENERIC.OUTFILEP 87640 . 88110) (\OPENFILE 88112 . 90690) (\DO.PARAMS.AT.OPEN 90692 . 92630) ( \RENAMEFILE 92632 . 93056) (\REVALIDATEFILE 93058 . 95660) (\PAGED.REVALIDATEFILELST 95662 . 97220) ( \PAGED.REVALIDATEFILES 97222 . 98941) (\PAGED.REVALIDATEFILE 98943 . 101226) (\BUFFERED.REVALIDATEFILE 101228 . 103514) (\BUFFERED.REVALIDATEFILELST 103516 . 104700) (\PRINT-REVALIDATION-RESULT 104702 . 105117) (\TRUNCATEFILE 105119 . 105510) (\FILE-CONFLICT 105512 . 106791)) (106829 111492 ( \GENERATENOFILES 106839 . 108935) (\NULLFILEGENERATOR 108937 . 109181) (\NOFILESNEXTFILEFN 109183 . 111174) (\NOFILESINFOFN 111176 . 111490)) (111611 113519 (\FILE.NOT.OPEN 111621 . 112134) ( \FILE.WONT.OPEN 112136 . 112464) (\ILLEGAL.DEVICEOP 112466 . 112748) (\IS.NOT.RANDACCESSP 112750 . 113196) (\STREAM.NOT.OPEN 113198 . 113517)) (113654 115952 (\FDEVINSTANCE 113664 . 115950)) (117502 124876 (CNDIR 117512 . 118817) (DIRECTORYNAME 118819 . 123002) (DIRECTORYNAMEP 123004 . 123620) ( HOSTNAMEP 123622 . 124429) (\ADD.CONNECTED.DIR 124431 . 124874)) (124921 154664 (\BACKFILEPTR 124931 . 125119) (\BACKPEEKBIN 125121 . 125482) (\BACKBIN 125484 . 125835) (BIN 125837 . 126054) (\BIN 126056 . 126333) (\BINS 126335 . 126621) (BOUT 126623 . 126985) (\BOUT 126987 . 127302) (\BOUTS 127304 . 127615) (COPYBYTES 127617 . 130949) (COPYCHARS 130951 . 137511) (COPYFILE 137513 . 138310) ( \COPYOPENFILE 138312 . 141731) (\INFER.FILE.TYPE 141733 . 142687) (EOFP 142689 . 142986) (FORCEOUTPUT 142988 . 143235) (\FLUSH.OPEN.STREAMS 143237 . 143593) (CHARSET 143595 . 145259) (ACCESS-CHARSET 145261 . 145478) (GETEOFPTR 145480 . 145730) (GETFILEINFO 145732 . 148857) (\TYPE.FROM.FILETYPE 148859 . 149329) (\FILETYPE.FROM.TYPE 149331 . 149510) (GETFILEPTR 149512 . 149764) (SETFILEINFO 149766 . 153268) (SETFILEPTR 153270 . 154284) (BOUT16 154286 . 154471) (BIN16 154473 . 154662)) (154767 160265 (\GENERIC.BINS 154777 . 155057) (\GENERIC.BOUTS 155059 . 155324) (\GENERIC.RENAMEFILE 155326 . 157157) (\GENERIC.OPENP 157159 . 158474) (\GENERIC.READP 158476 . 159810) (\GENERIC.CHARSET 159812 . 160263)) (160266 160605 (\MAP-OPEN-STREAMS 160276 . 160603)) (162623 164703 (\EOF.ACTION 162633 . 162884) ( \EOSERROR 162886 . 163079) (\GETEOFPTR 163081 . 163263) (\INCFILEPTR 163265 . 163615) (\PEEKBIN 163617 . 163808) (\SETCLOSEDFILELENGTH 163810 . 164144) (\SETEOFPTR 164146 . 164334) (\SETFILEPTR 164336 . 164701)) (164704 165246 (\FIXPOUT 164714 . 165014) (\FIXPIN 165016 . 165244)) (168338 178202 ( \BUFFERED.BIN 168348 . 169200) (\BUFFERED.PEEKBIN 169202 . 169984) (\BUFFERED.BOUT 169986 . 170846) ( \BUFFERED.BINS 170848 . 174533) (\BUFFERED.BOUTS 174535 . 176336) (\BUFFERED.COPYBYTES 176338 . 178200 )) (178231 180583 (\NULLDEVICE 178241 . 180259) (\NULL.OPENFILE 180261 . 180581))))) STOP \ No newline at end of file diff --git a/sources/FONTPROFILE.~1~ b/sources/FONTPROFILE.~1~ deleted file mode 100644 index 0d47afa2..00000000 --- a/sources/FONTPROFILE.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Jul-91 18:38:04" |{PELE:MV:ENVOS}SOURCES>FONTPROFILE.;3| 25066 changes to%: (VARS FONTPROFILECOMS) previous date%: "16-May-90 18:00:27" |{PELE:MV:ENVOS}SOURCES>FONTPROFILE.;2|) (* ; " Copyright (c) 1986, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTPROFILECOMS) (RPAQQ FONTPROFILECOMS ( (* ;; "FONT") (ALISTS (FONTDEFS HUGE BIG MEDIUM STANDARD BIGGER)) (ADDVARS (CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu)) [VARS (FONTVARS '( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words")] (P (MOVD? 'NILL 'WINDOWTITLEFONT)) (FNS FONTSET FONTPROFILE) (INITVARS (FONTESCAPECHAR (CHARACTER 6)) (FONTFNS) (FONTWORDS)) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (FONTSET 'STANDARD] (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) (FNS FONTMAPARRAY) (INITVARS (\FONTMAPCACHE)) (P (SETSEPR '(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)))) (* ;; "FONT") (ADDTOVAR FONTDEFS [HUGE (FONTPROFILE (DEFAULTFONT 1 (MODERN 24) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 24 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 18 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 36 BRR) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 24) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 24 BRR) NIL (CLASSIC 10 BRR] [BIG (FONTPROFILE (DEFAULTFONT 1 (MODERN 18) NIL (TERMINAL 8)) (TEXTFONT 5 (CLASSIC 18) NIL (CLASSIC 10)) (BOLDFONT 2 (MODERN 18 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 12 MRR) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 24 BRR) NIL (MODERN 10 BRR)) (TEXTBOLDFONT 7 (CLASSIC 18 BRR) NIL (CLASSIC 10 BRR] [MEDIUM (FONTPROFILE (DEFAULTFONT 1 (MODERN 14) NIL (TERMINAL 8)) (BOLDFONT 2 (MODERN 14 BRR) NIL (MODERN 8 BRR)) (LITTLEFONT 3 (MODERN 10) NIL (MODERN 8 MIR)) (BIGFONT 4 (MODERN 18) NIL (MODERN 10 BRR)) (TEXTFONT 5 (CLASSIC 14) NIL (CLASSIC 10)) (TEXTBOLDFONT 7 (CLASSIC 14 BRR) NIL (CLASSIC 10 BRR] [STANDARD (FONTCHANGEFLG . ALL) (FILELINELENGTH . 102) (FONTPROFILE (DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 10 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 8) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 12 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 10)) (COMMENTFONT 6 (HELVETICA 10) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 10) NIL (CLASSIC 10] [BIGGER (FONTPROFILE (DEFAULTFONT 1 (GACHA 12) NIL (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 12) NIL (CLASSIC 10]) (ADDTOVAR CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu) (RPAQQ FONTVARS ( (* ;; "standard size fonts. Assumes only DEFAULTFONT set") (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD)) (* ; "default BOLD") (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC)) (LITTLEFONT DEFAULTFONT) (* ; " should usually be smaller") (TINYFONT LITTLEFONT) (* ; "and this one smaller still") (BIGFONT BOLDFONT) (* ; "should be bigger still") (TEXTFONT DEFAULTFONT) (* ; "default for text") (TEXTBOLDFONT BOLDFONT) (* ; "default for bold text") (* ;; "") (* ;; "Fonts for window system, processes") (* ;; "") (MENUFONT DEFAULTFONT T) (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD)) (* ; "if not supplied") (INTERRUPTMENUFONT DEFAULTFONT T) (* ; "used by control-B") (DEFAULTICONFONT MENUFONT) (* ; "for shrinking windows") (BACKTRACEFONT TINYFONT T) (* ; " for backtrace in debugger") (WINDOWTITLEFONT MENUFONT) ((WINDOWTITLEFONT WINDOWTITLEFONT) NIL) (* ; " used for titles of all windows") (* ;; "") (* ;; "Fonts for Exec") (* ;; "") (PROMPTFONT LITTLEFONT) (* ; "for printing out prompts") (INPUTFONT BOLDFONT) (* ; "for user typein in Exec") (PRINTOUTFONT DEFAULTFONT) (* ; " for intermediate typin in Exec") (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT)) (VALUEFONT DEFAULTFONT) (* ;  " for printing out values returned in Exec") (* ;; "") (* ;; "Fonts for prettyprinting") (* ;; "") (COMMENTFONT LITTLEFONT) (* ; "for comments ") (PRETTYCOMFONT BOLDFONT) (* ; " for words being defined") (CLISPFONT BOLDFONT) (* ; " for keywords & CLISP") (SYSTEMFONT DEFAULTFONT) (* ; " for %"system%" words(?)") (LAMBDAFONT BIGFONT) (* ; "for words being defined") (USERFONT BOLDFONT) (* ; " for %"user%" defined words"))) (MOVD? 'NILL 'WINDOWTITLEFONT) (DEFINEQ (FONTSET [LAMBDA (NAME CHANGE-WINDOWS?) (* ; "Edited 23-Jun-88 10:46 by jds") (COND [NAME (LET [(TEM (FASSOC NAME FONTDEFS)) (OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY] (OR TEM (ERROR NAME "not a defined font configuration")) (* ;; "Looks up NAME on FONTSLST and sets apropriate parameters. entries are added to fontslst by FONTNAME.") (for X in FONTVARS when (AND (CL:SYMBOLP (CAR X)) (NEQ (CAR X) '*) (NEQ (CAR X) (CADR X))) do (SETTOPVAL (CAR X))) [MAPC (CDR TEM) (FUNCTION (LAMBDA (X) (/SETTOPVAL (CAR X) (CDR X] [PROG (BASICCLASSES) (for X in FONTPROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (*) (* ;  "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS)))(* ;  "Indirect thru another's font spec") (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* ;  "Don't let DEFAULTFONT loop thru itself") (AND (NOT (MEMB 'DEFAULTFONT SEEN )) 'DEFAULTFONT)) (CAR FONTS)) FONTPROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* ;  "Now we have a font class datastructure") )) (AND NAME (/SETTOPVAL NAME FONTS)) (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.") )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] [for X in FONTVARS when (NEQ (CAR X) '*) do (COND ((LISTP (CAR X)) (EVAL (CAR X))) [(CADDR X) (SET (CAR X) (FONTCREATE (OR (GETTOPVAL (CAR X)) (EVAL (CADR X)) DEFAULTFONT) NIL NIL NIL 'DISPLAY] (T (OR (GETTOPVAL (CAR X)) (AND (CADR X) (SET (CAR X) (EVAL (CADR X] (CL:WHEN CHANGE-WINDOWS? (CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY)) (for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X)) do (DSPFONT DEFAULTFONT X))) (DSPFONT WINDOWTITLEFONT WindowTitleDisplayStream) (SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT))) (MAPC CACHEDMENUS 'SET) [for W in (OPENWINDOWS) do [COND [(OR (EQ (WINDOWPROP W 'RESHAPEFN) 'DONT) (WINDOWPROP W 'MAINWINDOW] (T (* ;;  "don't reshape if can't or if this window is attached to another.") (SHAPEW W (WINDOWREGION W] (COND ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN) (FUNCTION \TEDIT.PROCIDLEFN)) (WINDOWPROP W 'REPAINTFN)) (REDISPLAYW W]) (* ;; "Set the new font profile name, and return the old one, so he can restore later.") (PROG1 FONTNAME (SETQ FONTNAME NAME] (T (* ;  "He passed in NIL, so return font profile name in effect.") FONTNAME]) (FONTPROFILE [LAMBDA (PROFILE) (* lmm "10-Sep-86 12:33") [PROG (BASICCLASSES) (for X in PROFILE do (PROG (SEEN (NAME (CAR X)) (FONTS X)) LP [COND ((MEMB (CAR FONTS) SEEN) (ERROR "Circular font profile specification" X)) (T (push SEEN (CAR FONTS] [SETQ FONTS (CDR (COND ((OR (NULL (CADR FONTS)) (LISTP (CADR FONTS))) (* ; "This skips over the now-defunct NIL or list-of-escape sequence") (CDR FONTS)) (T FONTS] (COND ((OR (NLISTP FONTS) (LITATOM (CAR FONTS))) (* Indirect thru another's font spec) (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) ((NIL DEFAULTFONT) (* Don't let DEFAULTFONT loop thru itself) (AND (NOT (MEMB 'DEFAULTFONT SEEN)) 'DEFAULTFONT)) (CAR FONTS)) PROFILE)) (GO LP))) (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* Now we have a font class datastructure) )) (AND NAME (/SETATOMVAL NAME FONTS)) (* NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.) )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] T]) ) (RPAQ? FONTESCAPECHAR (CHARACTER 6)) (RPAQ? FONTFNS ) (RPAQ? FONTWORDS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FONTSET 'STANDARD) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS) ) (DEFINEQ (FONTMAPARRAY [LAMBDA (FONTCLASSES) (* lmm "28-Sep-86 14:23") (* ;; "Makes a font array from a font-mapping list of fontclasses. The array provides a fast map from font# to font classes/descriptors. This function caches the last array. If IMAGETYPES is given, then the FD's are pre-computed for the imagetypes it. Otherwise, the first use of the fontclass for that imagetype would cause the fontcreate to be done.") (PROG (FA (MAXFONT 0) (MINFONT 100)) [COND ((NULL \FONTMAPCACHE)) ((OR (NULL FONTCLASSES) (EQUAL FONTCLASSES (CAR \FONTMAPCACHE))) (RETURN (CDR \FONTMAPCACHE] [for F PRETTYFONT# in FONTCLASSES do (SETQ PRETTYFONT# (fetch (FONTCLASS PRETTYFONT#) of F)) (COND ((IGREATERP PRETTYFONT# MAXFONT) (SETQ MAXFONT PRETTYFONT#))) (COND ((ILESSP PRETTYFONT# 1) (ERROR "Invalid font number" PRETTYFONT# F)) ((ILESSP PRETTYFONT# MINFONT) (SETQ MINFONT PRETTYFONT#] (SETQ FA (ARRAY MAXFONT)) (for F in FONTCLASSES do (SETA FA (fetch (FONTCLASS PRETTYFONT#) of F) F)) (for I from 1 to MAXFONT unless (ELT FA I) do (SETA FA I (ELT FA MINFONT))) (SETQ \FONTMAPCACHE (CONS (COPY FONTCLASSES) FA)) (RETURN FA]) ) (RPAQ? \FONTMAPCACHE ) (SETSEPR '(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) (PUTPROPS FONTPROFILE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (13991 22695 (FONTSET 14001 . 20342) (FONTPROFILE 20344 . 22693)) (22931 24830 ( FONTMAPARRAY 22941 . 24828))))) STOP \ No newline at end of file diff --git a/sources/HARDCOPY.LCOM.~6~ b/sources/HARDCOPY.LCOM.~6~ deleted file mode 100644 index b632a4fea750b6cebeddadde9607e0760d688c94..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 48608 zcmeHwdvILWdEf2=1Sv{@c0q)pVTQVfBno5*7`u27pcQE^77OkIyL+MC1wl}hC=d$@ zk0rp6pe4mlEyZ>`o@v@hj^#(1v{n*3o;ocE5>rc-y-nPi0&bb{B(hC9(?pJ9r;YOm zIG#?Y6DREN`@VDTYZs(syOWn_YjN+n_nyahzW4W?bJ~ZJ!|7bIV>q2jcBFH|ma%Wl zOpKaGlSW%QS4`$J>B3l>u`i!Ahl=K4##cOO7LrD^>p){WRgl12#pICD7VYaW&z#~6TzRHsEG-&sM&tX23ZuXH;P{1^^A{dkm^xRUT6`$8 zG(A;*=ajGf$s8f8qWk#^TcQ?A+p$#vGc?a{UGxForLd%SPcDRKIMv zyWQE@*=CfcmeE=7aH2<|14p9Kwl_ECA9ILCW3;O$dbrn^o}F5Ja^`}uyo8~&A2ag> zLqj5AWeW$4_TgN?7|ZjV6*?zU$y_0c8NqZ6=ZvwXbK~bG<`zp!PnnCQqch8yxeLn& zjC1E_-aEH+@q*Dv14YGcvHp&ci;Eot1AxVmZv4Ny&G_+#&~u$CA2iZNmpn*hl4fpvtYg^9XA1|7VU*LG z)&wr2Mmh^rEfj%xS=`5LpkUC$Mz>*h#d>=V7=fP()CYoNkCa3CyPNI^;NR?YL*>4P zU^vhojT$Gj$AIR=1C6D*B~>v9h@jgR=%;^bHopo?itQ1?-T z$dh3zumebbsXh>>k8^K#QfDKP;12qmTDv=L&X!7pjSX}gu3LN1Osv%nrmx(|FQ;c) zTX}SIkx(6%FhKcdgzrcBF@rbA#jF206$(!Bv&~P&xoD&Pr#x8>5;WaiP45{gKKr^yXYwa%9&OTDWj)HH$@X@ z#0HFnl}ngKBigMWaG!c;m}BSX7MEwv=cdkLpzYmw*UWLpac9K3jkfn?#)`iPF0Y}K zPaaJJWxQ~Y8dA&zX-@%0*9TU>b4zrUy7IF;P#zkOly4{bH=PQC+EO7Qw^e zd2()PvDOf)CfFY3ZDtoEKY@95Mqa9WG59j5|M*9*BxRCcPF;CVBpj**kP}=eOhhn% zAj1H2pwr)HBkqLJZ(|qF>|t~d+RH%$jKF~!a0TS8hS1aRfm(OJ2Wqjt+hIyyufdo> zXwm~TsfH$NC&EmCEuDkuV%8kfw1VcW;bLMuU$FAyV?dk3#t<|t7TYK&qNLAIpNxSZ zQ_1wv6qWWs>J1fBxau|rEpV?aE@MU}IZRKZMghuK5|SRQK#i0+jFyxG#!08)F%q5N zx=zXX7?(j5O4o)UQ`0%K2#lw9V|bVAm!3i02z>PpNL1llFI@`!UgTVZV(bma)kSPF z6+D5de>4>e1yAB96nrd`m50oQ9*-D1CYo0}CR(oCH5+FVpV+;5D!ls6CxAkM^}wm7 z3SZ4%4OAF4DsjHwyxgMS-?R5csj-q~JQ*3y&6hISMtR)||E65w=>h$@U<9TEfmO7M*4V@lL``F-;D&MX zxlk~(`cs+G+~$Ai4zD$Ge=?};S^D|X$lA`)+13*;U%ELmy8o3+H-~^ey@$1!=>?R` zG3XydF#soe_^|QFIJ8+~AZozMGRHGT0!AvCA(gy8=HgJ87R7R_RCnkvRxy>#8$ckb z4wS2^<8Po2rmR8{4C4LubqsCjfcL(i_)`?jt_}a|i5hK_OBao&=3wibo`K#EJB%!w zGfU?o2hNEoY-6!!Ezi!JC*$Wp<5pc#I)^K!9Rx|qxY zAO1B&MO{1;3T-%{cXIRcd@6lqYLMq*^U85XowbbMQHiIIP(m*1 zE2V{&hDvF!^Om#;=YwIumMmJr0MbC%Zu5Nun@&%m3nK=4T^P~V<(*CgLab(8U_06L z&=8c=XpdkD&HUj$qrJUta^^ytQN-NOTsUN$1*sY^fnh_=&KQd`PZ=c{i9P=?BHMCH zZ3e6$0~d#k($eAs%gXdL=9b$I95BEO+lc6E*7Put#^DI8d=#HK2dhQb#p;A84$Jcmiw^{-PbCRj>$9+ucC* zV0>*m6N)YUU@F#h4u~xb^`uQxLVF?)_k%HYdg=V~0r(2QApBpN%S&h9lyy%tpHCLX zEO;p(D2V-$COd)an62o*sIeesxAp`;;*#qC6(x(ddw?`Js!PTV?FIbV%nhZ7;FVD}`;JI>p*_4uRU*iuV!4QAVKO@&) zE~RfgUrEbdip}Qro%|x3E3>6J{u>F3y$p0}9n}p}v&SZyW=Cg*gEejs;9n$IpDFzs zzY~_0%R8MuT)O!_pkRN$k$`a`YGD-Sv5Z*XYgIT3Rw57qh$gK35LlX035;kIz+t@t zws9A@6<;g;k#Jnp&-Ade%=@}!a_jE|A6}Vvna0?5S9s>_k@*$wGn2 zh8P|kBNN8JVV-JeM~QrTtZ3!Q^3RxsBHJ>P#Lh&wlA59B+YgT$P;K+$xg3yOR}SRz zHU(9!#{g$Pum#R)1{EWuOagU)D?mkP)qeaU8AmSB<0&|dSg6^^#fa*|y>91a;NHHv zU?5b0tYiG++2tQbJLQgo=}C=pKg1_SUJK=+VoP>Qq617Z1Ky8OR%6WM{(F;j`XiEN zPc`UZy{ ztXvM?F z>|iqgFs^M~x`TBk(w}q5i4Mh5A6DFk9S0zkS*X$?lj^>}a%i@db=yk3RQEjeYd8S8 zn6a4ARzy-HlwNC%zhbWL87c7#tPIJw;o!>uO#gc>Wl|W~&)2~30cbzq&c z+)dC$M1l*qmXXqL>pmXa1;VS=+fX)Z6+=NkQiOxTfNEarIWV_oaqTYEtOG+J zcVc_S%nlBjM!Pm~c%q;ui=697J~D1*z|?pajCMdEJ&cba8paI$YQh}K>l-OM0L=G# zAQ=-#?G8i&_~&S740mEE$_N=S9Q|5b+{#Z2iffygotvK3`aEglXvX#dI_O4@O42IX z9bC_5h&xW1_fIw4kTQ04tfI)3&;BM@^s%(s`KlX*Lk zk$if2X7K`i-os1hnR=*QvQULI$j~6N0LJeE6^h;=9!Ew?NOleoLVEi^*JId_!w{9{ zL_^k(WXc#uYzb{K)5ph5YxD&g?*lIv`_x4=jL?zh5KQ3u*>LccG!xwjk;~o}MuK6o zPQMpuhl78d?NY#*V?u-~!)f@O&@oJy-A{4=J2yaIVq&_>q@EvW^kJ$EaV9*b)>7TC zYM^+5uAEX_4OBd+7^od?$2?-YnMn<92}?2<#9n1Ss;1y>OhL$WL0~VDvK@aQB1HA9 zL2~WVmX!nQ6+3AlPI$`%n2aIusvdcFK4B!*eOP6$y%qjo&aISUcjnjl8RVq;4%Y z+q`xkb6k^u2l=-VUfn=IpvK?698V2#`3Uu%5RYF>>@8=wS=nqJgmZK7m#{9lVSdcBn1`ULrjKYDv?_X#ky}ff(A1a`2bP& z!!W#}He>Eov%p9LEQ*5D$($(`W>4X5&?*`oU`4$^{M(*qIOtrpA;1JJ&Or1P!UGZo z+^+~SM6<>KqDfkIw;BCli^@NX8#r(iQ|ydeT72)!d5Ydax+k+^uoDZKoD>us9O^Od zzqgQvRb7Qo>@g;l^8R}f^+@v@5<>>g{2ZpUAwHN;0sjQ1%~aPWu7}k15U!Ivea;V~ z6G#V)e%b2oN>;fHEVM65oDWEv1I26B8@4R3tb?gjz_LkdS7A{1!y4 zHgLHY#An2P@@|Qqy<56)zzAO79tdoYjMWc*QK(1dMog}l@vjn1eLP_yT_J8M|tIU342fg)j{9p0k6OwH4@<`~>N^J{9U4|{ zN%4NYI{1=#`Cl-5NIFb{uTrJDE89XrpdQ~+RE973$DG~dzq&R&WFId7#ltJRoOkI< z`M;|IM&F8gr7jZ=o!(JN1Wz|qF5Ns19d(q#mzQq-oVj*4Ly5F+)z&g0WNU$}I0 zyD&wbs!M|$O z-wih*%YtqINup!jaJ^`$-3?F-S&4Bd|HV#u4;d7AnuL3=8)~Zh1hPO~K`WN47@RJ| z!4P(1uhr2UB0U2-G9LqHQbUM>QMEiT^(b3@s`XNsn&@!O!c*}Hurcgb!*S1DvEkLx0G*OMt zoQE>LWL%g*!%uORpfN{TK-3s9vn^`GS5za+@IIKH@*Ueuh$Qy)H~P!S22t&vp&_ck zBjseyF2U`C#LQX%TPBzwY6Xap!2qck?LvD<=d^(|1A~Dd9cU!mo9LsU5)4VkF_Jn` z(Ux;WsiF9+sfE_znlj7Q_`F2LM98Xq8p6ks6fVg?Ar8tJV(IG_5(<6n{>j|oRl9r5 z=-zgdITrI2W;vvm_8Q4!a64!-#LidiRhUIxV=3wFv9JNvWvG`FG_IvvDnFyhEu@?r zFamp#N>=Yu2iNKs!f+|Y%|y8_b$1hW%H|wOG1r~pRz1COt6QSFWQ=x!-^)u5{HdfR)jv*2Tz+$HXsgH?F(99wDHNg9Mk_@xu0o1Y!6`}D}@-WSa@nOJOIy)NdT&5o%Sv6NJ`6gL=G>KHljb=V>R+D#vlDeEx8cbGXVmxgNCNl<3#Lo$1-Pe@)sT=H~N;%SY~DIlj`LF3s`ld`}d zc9mrI%X1({46IT&4>#3-*E6bkP87nk7Uzw^kg8b@*O!ZsD7ne2TEH@MJvR`jbXTKV z?e=^F_mhEyOLUn$Vr}D#NKTkrM2gBeNlxh?27iQN&Z62dJekUwd8pD3wWN|#7>mV=X zL2(#RJaT9}o1LV5csP3S7Ujfu3vmyV`9uB+?G4Cf5YBw01L9(w7@kpA7YfY9;YMN_ zDG+OWrMNJ1chf9vaxPO07rM?71Z%R8Gl&ww+3s)}Pv3>%@N96u{b~HfcMd{d97>a8 zqa%fIUnZIF7(`woG!x|Wlf}kgN>_(7=20r_HV$Hf63OHcd$agOm~a@rdq{XODkCQj zD}eJa7XbSch(Np(^t{;u{Z;J@W5BoSF~Ind21F%~FzeiFCd%d@X=$watyj(O=sb8Dn-n`8?#a|@eS>PCVu zq(vnCH*$%ok@k_W`i1clrIR7sBqtD@x+&_pRKg}m3Am%xR@0es1RccFj> z^zMlJBR@xluF}f0jN-;*ZB(5y8xeANMw{sE)BcfkfirGQymEg z(`yHnKu8uj)d8g06{B*&9rg?#nR(rMgNO1z?(zcgjH6&eH{WxP)rm zX$o-MunGb%80!_}LOz*14vvgPNXiprt0Dm z*R36zZJrLV?Pk2c{IE+qT)EC)Jvzds&FVcX?-x~zU*WP}%Y}j~U(JO=D=()}@5x#{rA|45H81x|}1`ltrNM6-CVUmbPEz1G4V z808*Jg!xY-xP1Z{#E7D2CS0k?=v`BQ!u@=YkDVkIU9{((og4oAfLJo*-b zbXB3q7~C;XJN?0$m{;9{qlSXf*+DE3>~Vrk=w0=vQHoiL!X~T%X^u)+1#96aHZ{Qg zZ4)P4N3MiP0IL=s0h~mBL01ux#ttI%*6Z_$Va15Ja^T+5K^4C$tlcDAxozOlw=zQ% z1Qme>_NpWsRCP*X8-5t@sOdm(u`PB@!TCgDup8ZOx82*(191EyTYHF8ZWk7po`O^4 zDcdVUd6)2f#1Q{z2bVm6w(vEx1FToW%%cPYZ*%L}dPr07weXu$=btpD#A)*$mD|e= zJ%x;Kb^x)iO@W14tWZngx1J-X5Kpr!GRV0<#J?5Ws?L+E`*HK+YK?)X0>IxQO-?X% zD0vL))I`cEKLVNC;L{Wd02TvdZz_y;8A*x^~sp+&<7Lo;{8nX(RGa8juz~7iuN9q*UrzetK90C9akgUP& z!{BueB}RL_AqY#1V*wjGT?0g7_OTZ(1wQ90LNq}|K<01Y`d=z(KFbVNIVbpfZCsLU zH^hwD{Jg$hc~G^q1I`5~V$94%#5{WC9=RJ`xW>Red8KIt*O`Uud@Gzi?Z_W)i65yY zL#mP8k>Iv?YOY+DWxp4^=rRGq1uz51!2m<575$209jVRQqu|=k4Y+e*e2@)#Vw#w8 zf_)V3YIQ03y#O(@d?d1*1dtVSVcPtCKpjy3lGgB8F;9sa!YPp*;vf@Y3St6`!n77i zp0Ik(Wnjp#$PI8$zIE29Fml0sR}oBYe`vH|BLW>o{VXfmHP3~sDTRQM|RsW}dLA&AOs3hHniXhb`VTueYMP41g;Ts%>6kP$@NNiaujb)f3T zDlbX9BY25`qW%?p*xoEK(O~mM8A`CRv>#9v; zsN!TLu`83`BT|zhH7P`DF6EqoQCmr@VHJ^AK+gd=2C$Dq0a_&H6{ZkfVR(eM!|=iA zNhBrH9tNJk z$zpg$76LF`s28NGjaOVk8=`;|%_-%Q@c3EjA!2gR2BnQTq>TI~=LW`*(%N7jcq}qn zx{9@`nw=vSJ*p9v-% zL{NKs0qK#5yrtnoDx&N#rBPZ4q}BSO(MLI&_TRd;L0%1=M5Az>B(;VF32Ol*$!Qy> zSyuBM59*ex$@U*tHSvx0)>=t54!XDsF$&=WZ_Qr_rBxQOb{60a0ev%8A@)j3jEP@R zr5;ZkF%JFBalF#!=0}k8dqdmUwHONK3$KlTWBwS6PPi3!Fnto4k!FygY~i8>1Vi{$ zc^H{JPz?V?CNU@_* zs9dzjpDsxQgNZS1k&{QaJEQS+!&?3(n7^T z0y+a-g0mrrPFLI(MIxqT~c462B=2iTB1Vg zHK`S4@l)xV}hF{x61#EFk+zC99946gH);vyhjBDsH zxG?j1a}syhl7W`Y1N6A@OHIW*iS#uS@a`c)gb#qc5AoQ@)yl3hcX+7cw`Smf{j)y zrzu^z(`uC-2AU(mChp?irsl`XH@`c-`AKQ!`Pp!Kb(aD|`UfwH{H^3l<;EYZzN4aa z>-I?S?otOAk{xtQJ zp1oup^!M}-dfLf7Jy@|0sh%E^o*v|$9^{@LvJU!sy2t9$J?(OO`VQ`CjCu;pdCY-* zYpUFUwtAX&Ic4umm0M8OhxVlgg^UkIf_pOyR)16T3zz=xe&_w4Nm)&J{|F}VZ>JJ# zT~z zSffw(pid7`pZ@lF=Y6;vs84b9>4#UXrqLfG+9~h&W+Zr@Dz}Ee z5eeRJjg%~T_>D;90rqoFoYWzp#}NWLXpJ$s>KIVHm21Yo7cTwH51lUmEO+l1y7xEV zL-%%Wep>hL(%*aoAZ!y_eBsg$mz|Fe@kht$qf1U{2bZ3p(qE?-6U$xR3YNRce$?Q!*pE0A z)gWdd;^_R27XV#0#2kUjy2k5~!VZbpP5q&phd;*c~EOql&G*%dJq zsG6|gPkRS2%TQqKa!7t13yyZtOO9^n2?Y+&GF^!+4q#!hzJwj2F8h%d!G?4{)E`|2 zm#Vrv?7D=)Bwhz7JNj{#ec1;yO_la3J0_nqGYE-ivE5T2AVj8(yNEIky+ysS)3}LV z@wbros+W``89@)BgZGObbl+bD-ON|i4JQxR+YRMZRo0Cj=}Tu6F~V4H6Xa|67eR;f z6-A+Kauc+}gsPX4L)0Y!(9?1)oHnM29Wqsd${pH3*hj#lYmjb>Gv8L4lB zS>XYsycJ|g#Gs0bVH2W^oka)Kqe>-_Ee%yMkx7qX@1&#l8ywQcnhMFfv$szo15lbE z^Ut*jkJ?Fz^g&lC@gOz`6|hJtB%2Le)WOpEH^>^h1FPZ4fy*9+S(Akp{~W*a^wFkY zPaW0E);@#Gu~6`6`1{PgPeABAF|w_0t;pLU>EcIG93Mq-&xk~xCgbV((yXLoNlG;C zP1?Q*eAO)2zIbe>M4olG?G8rg-gX1C^eOlVRSW1*vH}0{HhKrHm^d zBFo*DPI1PYYt8(QqsPk*K_Vl$v}M2hrd>&Nk>m58Kb}YA)~D2JKW_#*@E3vDP&DZX zO%OZ^Tv8Mq3k56*A)D=M$QA(`yNk(8mf(hXkL_EI%3)GZrZbu3QRJ$@U?p1=RVoaC z4DoI!1v^irW0QI2hPtE-pt96ZVr&vsaGPxOMd3wN(+ICrjTgveE{qq3FCvNjDQ)AX zk-(X4?A8zdMq6(n^2I`t3Og;}pig;cy*PeNKi&H_73C|=@O1r=q*x`L-M;8o;iW(qC zd|FMl4Q;RlRU7a}f5MR0H?E=Bw5vX0Guzp^74*7~A5fX|9-uBJy4EZE8qJk=sskwjya$ma(qx$j-!G4qcfni zssS;8Y3}H|8lxZwN*az24peHX3gL$$IJu$KVuxoExgtYJ;0_J3pJaH5nJP09njJ;M zj4yz}pMw{M%+l)aEkK|`Eh)t9UR5!;F3OE!n^71l3oL+29)GR=BMh--`&I!i(zY!< zFO;*sbL3mhp|4}BH;DysC7&8q#_Y;y`DVH9+QPLz=ht4<)2J$YFc;=Nx*-;E7RQ4wTn;;CIU-3@#$l;*u)_I8-;rd zY4?u+V4y;I0T~Rw=>+W%{1`jo=Ch|skq${p_jGIZklrU@h|dWDffzhZQTR1I_dt01 zoD?8ummEbvA`!Dg&HA=bmxF zB2%P_fFn#lZ>Q}py{Rs1u-LRui!kgy>#ZiyL9$HUJOue|$2+MlcrFQ6PP2B$RRS_S zwFUYXowA>UCY{Y-f3!|fU8+-dwOEPGo0QpWTTY^G=+VqDYV?U5sTwrQC=iyR9eS8$ z;8X6V-MxpwFYDsB;Fo4<5PSgaa_79wE!Pd!rEO+OQ8ag_lp$fj!uCdwWmm7 z5tx|c$6WyymI?_TAE#X-@&T^}@ovOK4Q%geW`xVq=HtvfDVD-T1>PK=gDD8~VRLI) zOVc0N76?6JmW|C9iYtf4%r`b)D6IU9`NnjhlHb@j#!PYNSYAt!=?0b~>w(v%L%=&Y zNxZ|~VhTOu(PkG|7kSkoXS7fLu)C{x(r19V$bfJMj#uCh;PRo7(zj~#*qht?DeA;y zWPyo8-va{{I5rHZ76BEZl?#Mqn_&xM1uDSYjb#j5q6R`Y02^uLtRr@0u!(nua^MjQ zv5RO$;Xx!m{+D;a6(28k$KjO={N~{5-gz?-xmOZ&SrZ_YtN0#MXU8iYj+l6Y7uq7YBBXho@%aGVa)pTiH};%xPo$kNyXBXmCspCD#hfbOE;(H zBWCm9Y6_Jwf!N=#x4nL9Z)K3V<=3`-jEae2D)3!KwB)tosNM?QfjAk2`pu0>piG_fEA{ti4t{5kO+)9;*$P z42!|v#8uno?^x~DzRedbI6l+cWMToiy-vAQBPVzm5 zj&Ks*w=tD(6~mT#w9^%$SF}qE39j2P9Z~OCu)u{v9TD0^x-{%OVNfj0p|{B$DkRU9 zxKc@XJpfVwlW;Z`rtmJv)>ZPBcY6*#fZd+!;+Ut%b2|o08xO_b*!+C_4Oux^8Qf_4 zgc9rF!HvMHgB$&W8(k?N#kI!cG9HC)m^pOa}1GSy&ZH6 z&fDrYC}E~XDV&^R>5Nqz9F)~UTPR4jEeOk_rh2oVO+iudVMHkBjFr_<=A*o<4TJh+I18)7WN`qr%>BsA!~0J>;oPS>u@@E9zx;Xz~yjsu;bq}U{f z6eR5l)o*tr7E1Whc*-(zr8&=%Ll@f>1~aAarAL<*U;;gNTp3wR9lV*+i4WTB#^TH$0xbiHv}aa0H)O=py0o0Z|_HTXeW%E zt}favvRbq&5k)y!+NXyaC8S0fcI4B8i-N@&X{!EHN1$iWP&sa+jvaw_sbG!g6G;Ss z=xf?_MGhQ+nt}zuQjAP9CF1c8R+p;NN&56bB)zn~6(z*M5**Ld1&lboSrTg1?nVMj zzv6^`U6zyrdd`oby8?k7ortwrV2@Lxv{`U?w1{I>+zJ(}LehL8&Geo#IJ+ctf22MT zB5l^(=!&$}r8n+czw-p>7&$v9(i?%u&)=CzD+TniG}y=L9$R(AvwWw95&^y!+1=K znwf)|c?yf`Hg>FUD=lnZ27|2MM52_{{QB$katr=Yz83!MUbzn(Wwn(a>1X;Oo_>fq zO(kM9PPE~ymHTkkic)mnDk&sy2zKWn8*F>bdNV=HVmLp8>q7O2Mfvl}Y06(*gy z_1{W+EVHaV@UiaNbt&+lB3fI@F-xsj#zw=uf{ux4u#EMc*B7qg4P4;AJFi*$WEbX@)MBt{bG4tpzP{zxcV0)2 zsy_axBX&ra?}fifGCz9V!P6c(5e1C4%A@4V>FDeL$obCjx0f<3?&(WM{Hr+XonY)l$jMFHC;0^h%shL4&St6A#m)ImImjz z#4kmL=(rF$35YYfM_>g0-FEVI3PHs=Ks3ne3uB!fAQCme8wN4O(`VXYkNOc&=>o61 zRw2ERS@}6njN?m;pXu+v%%P2jTo%b}qq(nVa@m-`h2cs0Lv%g%VWI z0+>Qa;Hjtv;7LIZ$~W>NBXE(FXbxpSsitdrfr1z!@%R~Jw09a5crdxh1|lvFxN$gx z!VesmU>)9Np1~c7*Z5FRJ8nm~K^q%rU%mlLRbS(b5m#~mR2K**_JKHd+nY%c_+K2= zW1aF%BnX&mEzH-P$qk+ki3zp&8!CO3S>B4QqTc)s(MY+hrL&@P3T_h?_M{1TGYF&t z^#WI;u1miwdM?sT7&Qb3q-;T{z(4`zZD8v}?Nu0q;S3hwGN#~wP~k6H8HQ*63=XgY z-xsuE#)S`2n2Y{5;4?#!%_`w#=64(&ly=<28|>m$i4k&*-ni<9UdQZ8ZSx7`O5L*J zN&dT^SQZ1qY5q}=YE5ARLO47V#tFpb$e_YNT9mWJOMtb0393~U!b9I8WnS0sHB~!V zPm{eqT?!{HLFQaS+5;3`qAfp{FP-c>S|q?5he8q7xfVomlnv-mnKyxAOFFYTq73hV z5%^X1-w0*Bxg?6!Cp^@maQ!yK;-wE)T;4?yvtov&muo( zMUhSp!Jb6uQ*WT4ho$0bWJPI`fW4zH2@rhlU#EUwg8@Q|@d-RatSLFG5n2SyYf4wt z4|I|tvQGS2j37gmZU~Ko_w2D#8e!UUwaoGe==N@Xeac>=Md~i)(9UoK=Z2tEhdQdp zB^MG?O>5gR=e{1R0`)R5OxuTuae&S{0s1Ch$SzQq{bRoc&>sySZ9dv^bT{*WqkE3F zHq!pubZ#rCLqkqa0%uCxW)k{r$O9hkNyv{EQvRuvso))E2I)C%F>|1fHUz7?az7TW z##i213YM^su5|m0>9y_H%;Us!sr@fwXWj3OxHh68^U>9uSJm-OJ(=;ylmkO1gPM;@ zr<@y3WX04MkVMY8H<)j2vSYo|pd^|qMX6fB4Bic;FcjZ72;~x4Myxa5Ws;^T{-uq( zSR>&dF3~T&lV0*YlW!3JjD)wvVM4WpEBF(_>3R55-_liyn=KE)E^GKwYIHpWYx4EQ zn>W9Eb$bO>v2M!sX*Jb#vo3pw$&+j73f z$fsw;mCp4f4VaWzx<(JcIBx)gxpsdLBX7V0(pj0Kkst=r`4(l77I&HR<$0e(`PZ_v zVpX9O3d7!lzqyD+y+LI1E+P{qk)JM!I{7UhdHj`!JiyevU1$cUv*inCTj^e^sn9Y6o&yaf zTD<98JIsZAbauJJ?bOiW2{=|gc5+X$?Bd}utK$*!f^3O5jOMH&8AGmtnn+*Y7DxWN zxzbh&KB{JURKix@YV}R`pN%vRCYX&6@voS)AVKKxJS);Qje8v1sm;r2$Fh^$Nk6~V zV1i|7g8<%4eXU`T&L?oFgO};Du(N@H>~`Y!434}xl*V4HG~+~m$^0a)!F&0dc7=6; zB|Z3C2r`=X+YJ8A;zBY5b)irV2rvK}5ZGf{ z0RnlT`839?mqfq_PiCR#jaXPNs~`k}p32hL@6j%M6Hx00)NVsD!wfgSDn`zK0-qj< zh96k;R@xYl;dbzQ%XFo~gdSE!BD+e8V>bqz*$XZV&k;C>x&rSNBIA2PD7W7TEah2H zn$6tkgj@0N+;zfSoioKHw9zSLha~5D?atK3UE)l__PUo7k#JoqjgxFs^J*9Uos`bJ>gQ2rmYqSA3Gqm}kn5m`CBw73kf3UZEVNe3+$@=8I<7^ShW zjD))ed&(pc51=9vKM*GnvHDI4BP>v`tp@msl+^&cUE37w`SUSz_bR_Cg1%iA>29DM zGBQgNACz@9tUSQg01p|#@y za@Z2_B?uMJmpu%pHe!^XY!@Ys6rY0b!yK9O9__ENL!*7{kL28TY3mY8M(6_p9$%3L ztc(QGg6&`|4FNPpYhB>KN@Mvjq1mvRO=l*-+Fr$}PTR=1XERSlGTsHo>nV}lie-nj z^38>7vIrjMA-C+SU~3Cxc|QSw1lVkC;!7Rw2-eGD4Xz$xRM(x_Xh4=($&E5F)r}aK z`iU-d83`397C1wSC-be(g#`&h20Q4U4o2}9XwZH=_t1N_35dvv z=Mg1vXcG|9((?@dM{NRvPkJ7~=ci3T7+KUemkAg}S{~zordezq>3fCUfO7n@s@LGO zL2nUaG4HRh^L|RMrF-8`>C}Q|Sjs6Z4}btZdg4U4KuP89pjAikuc>86ZZ}9ZqB`0I zaM3ohas4A<@bkdn?LK^ku&62lyV#eMU|iD1&JeUKU8oc+;4@>eEYYPCx>*7#cSxuu zq_+D|1r03?-h%p;`V65ZHYX4m#(0-!4?OvREN{teFcXHq2X7#PJoj*5dG4VHdG3Kp z?t3f%ci#ewfFG`s+aQNSLk?!Rf)px3N2>(h=2*yBaJj_(8E`BI5&r+OEvFr9X!vG$ zm+J!;hQ7_f{%JEX*R1={1d64z7|!P&(4JXdM?yN(Ef&JP6LtzOgrh8WTJ+{$ z_zG5wtj?Ee zISB6(;eL(sv+$(^gLyd!JZx;fl1Gx4g(xJ}XoLh-U)qjFH0XGoO;()+M&IZxFl^RQ zBj1aH(pBHlanCxGg32ilyp&NGFw24ZvWk zoF}4b*B%!D_~Qcyrq4e;;Mi~p{x%`a6ZQ|!((M<=?9@wPn)F3jUo`8B7Jac>U+mEr zt@>iGzNlVpW9Ub&WjB&V)^bQcYSS0{^uX1K8p%oQWSUW7D(3;E znz;io_7hqI;*M-N4|vBI3VC@Wk#smMf8Y(y#%KW;rli`dPHD;f#NHj(HWU$-mvPth zgwwIM^dVW8u1`pV(!xXG2E=AJS*X~(Z6t~kzW9+SsxYO7V=+pYg0VRMT|IV$fCyiF=}WYiV+|zY zw8UCSq%lPY@$A}dO!38QHKzD5h%rUS&FxAwmQ+P$6pBzvl5DQ*;DSPs+Sns3!izjq z=1sJOqp1pUNNJ(u+3H1sB+aW!-3p0T%HXlq^7if3f^V-D{E4m>^r`l@UohzV;2+GI zL0`YNTsG)`kJi{|#-R-yIwHEN5WMxD^ZG#_+_e7x_7Xx137fpE5CQ?x>Fp(iyu9%3 zC4_Hg38DG+5<nyY?Z+s-%x3mDha3ITI7Q}N7O>$-Rx0%;M&Rf#*W7% zxh0TY4`umsy)M3fKNc51U&)l_vBY@((d*y-`d1{aCHF^HgDTY}_s3XpYi=|=wn3l9 zGo#n#?Gln6ZhWkQ-&0L3gIH_)?XP1YvV3lZodjzuj122aYIG#-?bNB}t8uJ7z8+t{ z56g~AR?Cf-z$8@VSMNYhHt)njC!g8DZdgR#z%mwoA*QTztlf@5B%`?!u3>1|Zy^x} zmI~Gz(3%u=h3se*HHXv8*925@t<*F4X&s?E0|`eEC5y$$goSg|VB6b^TTnp9bLYp* zM;`GMVlh5FGujUt?=jkDo<6s9p4Ou&U-$*;H@RGoA-NsxKe$QrX#3p3f7 z#f#P%_2dE!T6T^UIww*%MJk!Wme9!|_*k7+(`ToioGIeq_6x?*ndRKfQ|jB{^Gj#P zsXL8hOXtSVP0THpmYy;fOL)m#UOH=3m1gEHEE~@ERGX?QH+6P~Zn>%9x$=xLJhMDK z>m5a-hQS%Uut;B&=1QgV%=rs?=8{h@&n#ZRd=4+2=bEW1>bZ=Prit7LzC)G?Iu3F) zwxw<8p1~?*4IhIJ;N%&nY6`kZ_fegg>l&x0Vm@zksB02fOqoC$Q6}hASw8f+pw4Pc z<`o(+rl~HeB3X{B&)n<80s}fkicf0RooDy89te_%kx{Mg2psxa&a5MJpjMo3G}w%q z=RnswB2l56YC|n!ptHsj8SM6P{}DdDJBee);u*^vqJv&(JxBYP(XNM~Qk~i#8Mkl* z8V)eT1{$apZ!i_m#GIa*UU+Kie94$zI(u$vdG7R_CSv$kh8{N5x8P_Qd?^*_>S-Ay zSLo1tWnLO20w~a$-RX%c&R~0r?nr=Sc7JU>C|1Z zY7RVi*c{JbwKmtyjd?54-KR%t3iad^yja|pSXzAV%=zWH#V3vBnWvWxqL~Y{CV!5o z`NHz~nW?i(Hx2~&@HW*4tb775AvA=0q&tTFON@3}%%-~t|E(}CkPfF;sXJ_%)`K&s z5Lv=0naKW!GqA6hAx-nv*ygH(n@C|24;g3Yrl*XVpT9Ww-YHP_vaxgqL6y11>Dd|X zq6=*P?_Kv4cadHYqaa334_(JN);Q$E0UEvUIL^H19iTet{VaNG5bm85z6yZOPAwbL zQ;QEQ8-QrJ{EVSjC$>3t%f}a%FP=HWM*&|vN8-nr1@cZWoqNVmvtcYPqCVnk7tWQZ zp6S#q#=TBng}S_pdR3t3M|SIAM7A6Ksg%egwl-`SGxKE6jd+RXYOYPCa%u>8&oNPJmBI3cvCSLNu!C&`TyR z%7juORZlA@-(o8Ypn$`@8iy#WkXY7`#axW^5ISqDJqh^aizH5P!kJ0Oa<*sF39~SU z5F(0)i3`y>4lG%P`g1r&IFe4`$P?FF(ZeWg#6k}HyKbT&PY-U}f#LC7LXJ;7$rVBC zErLaOD&b+&?hs8z&T&$d<+ z_1k`J(N}KkjJn*V=2UBDHC}RbAwB80*3TN-t66>{A$-xoH29A+`H>Oci+{J~7AzX= zjZtbL{O$4mO%j*~;RzHqa2be%1GaF)gJY(#KFPe-Xm2|Pt9r)RZycXFzx1?`SUL|C z4@Sw-B928Lz*%DWflfStW7zR?n0|0J!vGvD(E)7wfgc2)2L@t|^xI8815mu9{XlPW G$^1WeW~HG3 diff --git a/sources/HARDCOPY.~4~ b/sources/HARDCOPY.~4~ deleted file mode 100644 index 5ee750ea..00000000 --- a/sources/HARDCOPY.~4~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 16:36:33" {DSK}medley3.5>sources>HARDCOPY.;3 106922 changes to%: (FNS \EXPECTED.FILE.TYPE HARDCOPY.SOMEHOW HARDCOPYIMAGEW.TOFILE HARDCOPYIMAGEW.TOPRINTER MakeMenuOfPrinters GetNewPrinterFromUser PopUpWindowAndGetAtom GetPrinterName GetImageFile PRINTERTYPE PRINTFILETYPE PRINTERDEVICE TEXTTOIMAGEFILE COPY.TEXT.TO.IMAGE) previous date%: " 1-Jun-93 17:21:09" {DSK}medley3.5>sources>HARDCOPY.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1999 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 MakeMenuOfImageTypes GetNewPrinterFromUser PopUpWindowAndGetAtom 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 \EXPECTED.FILE.TYPE ]) (* ; "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]) (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])]) (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 \EXPECTED.FILE.TYPE) ) (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 MakeMenuOfImageTypes GetNewPrinterFromUser PopUpWindowAndGetAtom 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]) (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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6577 10761 (HARDCOPY.SOMEHOW 6587 . 7945) (HARDCOPYIMAGEW 7947 . 8099) ( HARDCOPYIMAGEW.TOFILE 8101 . 8409) (HARDCOPYIMAGEW.TOPRINTER 8411 . 9076) (HARDCOPYREGION.TOFILE 9078 . 9376) (HARDCOPYREGION.TOPRINTER 9378 . 10000) (COPY.WINDOW.TO.BITMAP 10002 . 10759)) (10833 18071 ( MakeMenuOfPrinters 10843 . 12068) (MakeMenuOfImageTypes 12070 . 12588) (GetNewPrinterFromUser 12590 . 13018) (PopUpWindowAndGetAtom 13020 . 14405) (NewPrinter 14407 . 15355) (GetPrinterName 15357 . 15637) (GetImageFile 15639 . 17926) (FetchDefaultPrinter 17928 . 18069)) (18106 18644 ( ExtensionForPrintFileType 18116 . 18309) (PRINTFILETYPE.FROM.EXTENSION 18311 . 18642)) (18699 35083 ( DEFAULTPRINTER 18709 . 18869) (CAN.PRINT.DIRECTLY 18871 . 19027) (CONVERT.FILE.TO.TYPE.FOR.PRINTER 19029 . 20073) (EMPRESS 20075 . 20388) (HARDCOPYW 20390 . 23350) (LISTFILES1 23352 . 23525) ( PRINTER.BITMAPFILE 23527 . 23774) (PRINTER.BITMAPSCALE 23776 . 24041) (PRINTER.SCRATCH.FILE 24043 . 24166) (PRINTERPROP 24168 . 24351) (PRINTERSTATUS 24353 . 24542) (PRINTERTYPE 24544 . 26853) ( PRINTERNAME 26855 . 27157) (PRINTFILEPROP 27159 . 27350) (PRINTFILETYPE 27352 . 29296) ( \EXPECTED.FILE.TYPE 29298 . 30080) (SEND.FILE.TO.PRINTER 30082 . 35081)) (35084 40066 (PRINTERDEVICE 35094 . 40064)) (40849 49443 (TEXTTOIMAGEFILE 40859 . 43049) (COPY.TEXT.TO.IMAGE 43051 . 49441)) ( 49444 50579 (\BLTSHADE.GENERICPRINTER 49454 . 50577)) (50707 69459 (MAKEHARDCOPYSTREAM 50717 . 51721) (UNMAKEHARDCOPYSTREAM 51723 . 52407) (HARDCOPYSTREAMTYPE 52409 . 52688) (\CHARWIDTH.HDCPYDISPLAY 52690 . 53121) (\DSPFONT.HDCPYDISPLAY 53123 . 54528) (\DSPRIGHTMARGIN.HDCPYDISPLAY 54530 . 55107) ( \DSPXPOSITION.HDCPYDISPLAY 55109 . 55370) (\DSPYPOSITION.HDCPYDISPLAY 55372 . 55633) ( \STRINGWIDTH.HDCPYDISPLAY 55635 . 56142) (\STRINGWIDTH.HCPYDISPLAYAUX 56144 . 58476) (\HDCPYBLTCHAR 58478 . 61013) (\HDCPYDISPLAY.FIX.XPOS 61015 . 61435) (\HDCPYDISPLAY.FIX.YPOS 61437 . 61857) ( \HDCPYDISPLAYINIT 61859 . 62636) (\HDCPYDSPPRINTCHAR 62638 . 64798) (\SLOWHDCPYBLTCHAR 64800 . 68303) (\CHANGECHARSET.HDCPYDISPLAY 68305 . 69457)) (70181 100478 (MAKEHARDCOPYMODESTREAM 70191 . 72100) ( UNMAKEHARDCOPYMODESTREAM 72102 . 73180) (\BLTSHADE.HCPYMODE 73182 . 73629) (\BITBLT.HCPYMODE 73631 . 74253) (\BRUSHCONVERT.HCPYMODE 74255 . 74492) (\CHANGECHARSET.HCPYMODE 74494 . 76261) ( \DASHINGCONVERT.HCPYMODE 76263 . 76526) (\CHARWIDTH.HCPYMODE 76528 . 76815) (\DRAWLINE.HCPYMODE 76817 . 77129) (\DRAWCURVE.HCPYMODE 77131 . 77560) (\DRAWCIRCLE.HCPYMODE 77562 . 77957) ( \DRAWELLIPSE.HCPYMODE 77959 . 78471) (\DSPFONT.HCPYMODE 78473 . 79629) (\DSPLEFTMARGIN.HCPYMODE 79631 . 80215) (\DSPLINEFEED.HCPYMODE 80217 . 80627) (\DSPRIGHTMARGIN.HCPYMODE 80629 . 81258) ( \DSPSPACEFACTOR.HCPYMODE 81260 . 81781) (\DSPXPOSITION.HCPYMODE 81783 . 82364) (\DSPYPOSITION.HCPYMODE 82366 . 82771) (\MOVETO.HCPYMODE 82773 . 82925) (\FONTCREATE.HCPYMODE.PRESS 82927 . 83939) ( \CREATECHARSET.HCPYMODE.PRESS 83941 . 84912) (\FONTCREATE.HCPYMODE.INTERPRESS 84914 . 85948) ( \CREATECHARSET.HCPYMODE.INTERPRESS 85950 . 86938) (\STRINGWIDTH.HCPYMODE 86940 . 87374) ( \HCPYMODEBLTCHAR 87376 . 90345) (\HCPYMODEDISPLAYINIT 90347 . 93278) (\HCPYMODEDSPPRINTCHAR 93280 . 95461) (\SLOWHCPYMODEBLTCHAR 95463 . 98977) (\SFFixY.HCPYMODE 98979 . 100476))))) STOP \ No newline at end of file diff --git a/sources/HARDCOPY.~6~ b/sources/HARDCOPY.~6~ deleted file mode 100644 index 5da0582f..00000000 --- a/sources/HARDCOPY.~6~ +++ /dev/null @@ -1 +0,0 @@ -(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/INSPECT.LCOM.~7~ b/sources/INSPECT.LCOM.~7~ deleted file mode 100644 index 50004d581a55bb67f9ea218c88b1d3ea0ded1c7f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 47632 zcmdsg4RBo7b>9B)PqF|mAWEhY{X9W71;PS|-NheiN8Y#C1$TkPF0{Mg5;SEBCG`3}Xr*>y5Wtypys1q@1Gj3AXnP%F6 zRWiwBCRV?5&b{y5_jW;2meOfU%ZvB!yZ65PbNR=4D%ITEV9gFta7gqXW z1JO}yVDt$6H_~nObe~y1e_^3MU$vH(tZu9ACsU=#pZeg;>io*;Ba3qv>T^qvOBJkRunIZ z9*M`gt&WqaSKYC$h^?gUIrRBBS!qOAg0^U5u-COA28oyYtTcu0rea$jQ-QVBe zZB^&iFjntuMve@Q9ErucZ*9tNZ-!P|G&(dm8nw>U=9ZqAU$xejF_WHScClosbr>s5 zl@3}LR_32vSiZQ*BSsbfkmKR;gSlrltHa%^!fAE#$c%KEQ7=+s30ZS5Fxaj*#u375pD}-4O^p9>BjK z|Asm`Lr>7{ZS+%lxcYo}^R`OwV&&nz?Hw!cs`PIRb_}%V)*q?{JA!))_f>l9p-TVW z_RdrL8-=dT+Y0+@U8nB(cwzs6Q(cWvc=Hbn_jEp;o4lQRJJp%n41fG`@cs4sPTgG@ zE_4>|e*JNJAjNkqPVS<+mv8^WZ&W9)Kiin73{-l#CB_&CJT^JSH%s50mWwGKXr=dE z^iTXne3*Fd>*xvTZ1@7cjPor?) zGlibQfj2%~=s9(uQLsX%to18_p26V}KoP+Cs9@6Iz@Q~?ZN(3dYN}A_FQ!u<+&O#J zijN+)rf156D~y`)kzs$yFrd#{XAn5$Es2f#OQHZqPo3Cd|GQ$N{&&SjfKT35O>d74 z0_VMT;{Nf(fU>?i1O5?44}%7I`iYLltW*iOd^A&50rN;`XbiXWE zKS+`l#Q;xg#sh3bm+5{X0nve&^Qh9#RIFe13o-%bYR}}#)HV3U;9%UEn)_&WY4yVV znYHDW>6PUR^DAqYj?L9C&Q}(yYc*>y9=lnUIA(xtBobi7N1|3~tXRn9lC#D1v<)f; zViF%7R;6?^G-N`BQ)g(vGFrqBV-_IBde&ow>Dm4ah*&ONwBlHMDoDKaQFLSOR%KzSy8KjTe&LDQniV~4Y5W2w zQ$yl;<*+_EFr=n306-H1b$F+Bd@OeaY>Ky4IF#PwEb&UhTfJ;quuI`7SujeIi)6tn zWm&RT)7oXhFd07Gb;&BmX_myD)yY~hXVowW9)qx0D+>wU38aB3|q(E@nyeELqq`<4N{J z8WWhZCrNT;sjyJ&Q+;8zfl3-yOnJq-4-O7^WElYN`zOHS!%5k z;lCZR-MLUO7Yc=fub+SO^>0mHy?Zhk3 z*RNi$bmqDJ#<9t2kV?7ht&JlM^DP^_=H03Gjjl;l4w{AaP@#Qq`!lLM&z!75ul}Wq za7FBY4D^y#hB%a_MN#5VB%#^mWZ^id?P2R^S~0AdQo2aMkF6hVRSMG7qAr-CEMkdu zm=feHY!6_zG(DEfPEUhT+x3HE6? zYK_eli{MB+KEQ~18y|KlfU~ZG=*)>&jP{UaM{MF+^b>PwbSZn}Nbi^palfyaF3%M6 zedEQ#lu&DamYSKGn(Z4072;Z~S14c^hepD1JPtBJmGik$y8Ngt1r!NWk5DQO_VhiW zouR-&q9YV6mg=FIz3pf2sCAv$!@C#>Z99%w5^@`d7*o%0hm#h{#-#Q(pTiJk;t zs&}lAPi0Ai>QkahUlJN2kh?^i0*#7yMOJz|XCI|fpfB;+v2;3xT`HxyDn#3+Jwerx zo4q0i#y~*fd&N+zSG3r6yaMc2SOpC&X5|Z&^zkylnQn#U=IyC8-H8x@t0*LDqKLSP z>DDE>Q|h8pl$F$=?v#d&YA(_0o2I_0X*0j`Neaa2=%uctKunOui zC|A?oUik(QR;oPEBrZ~l5~5Ks*tD7`#1h|N_YYd31#5?ocY;|NG_R6ivgj>xspod( z9mnn{v~R>a2KG*_A0Rb4Qm`h3@pVFJF5Ckxx(izLeIGA$9XNFlY0-aFxUci+$y1R^ zax+q`RfN7Wkv)^tx8Bj1FP~5fCUetDLO0;{s$L;7*%7;|@ZRud_>)0W9lOJu6Hq%( z?N^O>T7~_acb=*#oQVgKb|Z!j1v>?a|CfAt^dZ)p9s;Hh5dqJ`egp^nIY zmPIP5u7zcYdx6S$S4a5A3Nc>DPJYSO)g6Tal2CrG(0MuViAsW7@Gzz}cgr|>_>T-D za!-pc?=KwjbvfGksY2(^^Gi>4RuYvYw_?LWUU%DB=&51l@ee=iJx1j};rF+!$jeCj z^?O67-iw6`K^wpP!{4d~PxUtn4;T7_T!D7+e-<7V1z#;XPeQFPnB{PjEPlpsB*Kbh$7y4P?%x$IGBXBQ3?WOi{3{RUYa`R`` zrsh_jfF(VSjnl7-L%!bbbun126km&h0XIp?PyqD8i2h1u8o44{6jjL>f^ijqK*7e_^4w^m@cM|WeYPz4iupn&mFztE)Kz}VD2K(iRUsR z!#3=V_avXQ<>u$r63bl%fKI}V*bj`Mz?yOrw^ZIw+A~=K#exEno=OYjxD6V?( ziUzIi0T3x%a{$Aduk7|){Ghe8Gwd^_R3epjxoFo`zXx|s{AQ)yK&Hvf2;ZrijY+eE ztO znTWZHk6zjY0H!~SB;ps~G1gBuv~ z$S>gRT?~LpII{duo1HO50wi(<9B+cMWo=0{)l-b)3NQbw~;RVes0D`tW z1#mPy1r@@w3G;NUd`#qrwk7hgEH}}ACDWQDUQHK44=yMeWhAEPH3e-sfJF!zGbK`9 z-Pjl2>@W%!WxhbsripCF=^&Bl*|{%g+S}|&RXa5VLl?+?UbxSol`Irfa5QE?SGE5t zW@Xakq-E|TzHXLbDVTzMJ($pwfk0rFm~oy>MC9T*`Llk^jz_LOn#4~|N;V!y1QQ`U z#gs2OmSWPzq>d$o_4oN6)v8sdqGQ~kje{G;QfY2Mqz}<85(ESF71|$G3tGEkA5r)i zNvpTZ*64_uM|NCMe0Vu|I&J}EH~6qB*>WbES3STDExqge0e?48d%WGig*#m+u{jj% zh$3!$eZqMry%Bel!Au`)Vw_d-7v%qh`l2@11BHZ3rf=f7&~QAhy)BbQA=Ay zsK(G?t6ZKX@n|evDiI^Yt+M(+dq~?bj}Xm-_)+QC4jN$H5Lj|?CZC5D+-VF+%j)GjU_gE*Vj$tLs?B2Yg5y!w(2-P51p3b8fMzi=0fEtD0NLiEs zguVeNGS5*iu5F8!*R{teAzS<(K37S+$+k~hPA@Tc00hIeWimt1x~S;kY{eqv_jz`( zbHBJV7zjU(tq6RVem?s+{jUEw|G8f%{JtHHDsRRaj@1=@LIR^u(L5xF^x4t7p|ob3<#)b!Hia#U(=R@srjXg7GkUvX{X*Z=^RBY z#^FKDk;ffiM-Hiv?FiG;^6Yf_!H-c$r@xoOJT`J_db`JH$#B!tgL11!6krSlLA!Rn zzWmfGWZ|Xxr<82GwrriAx8|4D=2zyc-3P566(gk^syQFTzh-vCYM2k)NRm)AgkVR5 zi%%}*mWZQ#6iU|)*&?;EU(p-suyz)?}hi8M$ELW)_inu5h5EzE@M!on+~P_EP! zSRMk^aRZEU@Z(T2ivU0LfzWXMKD%6)vJRVX8+BhMz5(N1Y*;3?j4%S#KbSBOfkYgD zcO1dLx@WOf#4&aSxr|{H{Md|QF(|Iae4)L1kt~M!czQupgDf44C!PnuFImDUCY7^G zWgfi*-68%2?-4{+m_Wge-U0{)z5>|Ja|Ii_5{1%ILR3Kxm)M~3>~UJl5lb!WaEljG z(5A_+phS4?p$x)u*vGp7J_{odT{5A7AE9R(q(3BBdhj4@Wspb4=Ex?d=>x3su!l+6 zg2Yu?kZ8#e)+DyFX3<0^blkU3S^6?af)Mt16i2o}|K}Pu^A^o7`V5V1<8I>y5m!=? z=@1hKVk)r1$VwANlo2b{%B4j++N{(ab}+`U+M6r~)*Se?qOhQw_7IAW^xQ*b1$oaR zLKH?bAR-txTEU*frKATT@|{BEi4|qn=FeBgmd~G`TdKYdUewf$!;Jh-2*{!ksmUC( zfS1E?x(b#vzhte>*Aa}1V;*N$md{%_BeH5e#gU#k|H1sLI6pqWcBZCTk(vegn0kO? z8JL9y#)YFQ^|?zprBR!=mQSBUw-2paXBXz{)m7$cD(#*xvf5*{U0Cc;(Lv?!Q~Z@JB~X}r$}iQHH;=PmVy)i7)#7!wz`BR>-aS0FdQJu ze)z>i#6Gw686H(65wsVtC0R#Fp4)mp5xROO&*&FnIY};F;|E;-ya$_qE_<>5r)2O61z*nuGxTScD=l85vTNTsH*x*NiKox)ZzLey zhp3BBCqmiv_v027s1=o~c6Z|uH$=;q&P`r_aS|0C8l>#Ddw= z$)7?_pTj@_oHMMgJE4eLU*<3_*hn-$tAzl=B}k`6yoJvC7*U_ofJ6_LJrDwxb(;a5 zt)e@FU$?Wt6AY*?WHHOc1n(^);deOnlR1e50DX{Qr&{0f{c~Gi)^hkFZoZ^MWAbJrc+j;+ zE1|(T+5l8#!;5~ckRt%7u7S-SY!b*A0&d(+1H=$5I1poytRJxI;WDlcQ{a+BVCBan z5JAi!3Sk@Iz!?ogC4h`E@xR%PiJR1TZdc~TTEtk2FEyA3{35Nyl^^i+OR^wpjb7RH ztxQeadnXxkzHapQjS1xw%$`setoDc!Q{Ra`H!|6)DWk>J5##3DCNua{DD-oLdO<*@ zjz+I-CF~iqFg!7^@bG50zIge~#mjGA0+nT@;}BuehoFIg zFwPW9g`&2XLIt7iX5{pE8Dk{I$%|C=(<)t2ZcUA*{xU ztyZr^uuXHH@E&LLY6=L=_RRoV1i>quXo_)>QdB4xrpY|r+#6t#Lbx2A0Rij?Tyky^ zgb&RKBBi)ymExdoppG~I4~qd=G(7hZ^PP^gE`r`nREDN7l}+Jr5!p2*%*=SZZlwEl zKw4pt4hZw1B^gVi^z*huwv|>_fvwPu&m~JUACM+PldDFMo!PLxD3d~9%8A@A5fH1G z?X8XX;5Jxf>|!7-*24(vUgzSn_rVT4fT8dXu1rj~6(xm=-2^IFrjbF%HUvNr^9Lxg zT&MtIvYOq(ifWo9CMKW#Zq#pb10{mN$#1_S8!)dO*?rx$BLWA|VFpK(>=w@H0+@~6 zffm_p^81gsL-J($Ae27T(H*W;_VIF8_OXnh{xJPOupK^|%&;rk2i z5%cvbob{#3KG79<*!9pPyCGvZLD#h1z||H&z}oV*EX=@_D1=HtZ4&5F>+x949km)4?4kU^*r# ziuiz=srym*-Fy~+C<6JkX*&v%WPmM(ZkSM;c{##$Jp|1KOP(%E!%Q#uSejdgVPjEY z#wgcd>a?J2E-kCm{npuwOJ^Lvn@7pBU>-pW)W(0L79za?sm|8vi)(AkOa0dD@;{qymCJbkYkf1<+D+qes1dV+}_Wr{GX;vjGUhy zUl+0qXf2fZkP~!Aj0ho+Y=yJ}|1hvqc{3j^k~j0wB2x@pPIsLNFj-^b!=#8knpDnI zi|Livr5k1S*DPD$He&KtkDH5>gOjVC*#$PmL3Ch)fO9&^2>)gj2uvstWsiq8)xtC+ zg+N|a20A81kZH znuSn$4&2;sOd2rWt^?JuXvuaFc~XP~Ti42a`pn;t_muZ|>uRsPbI+H=SaTycYIuUE z3bcwF?;6F~dW2~25rp;1<2au!| zF48fb?+5e;@fV05Ts{k60ry{}QK3vM#ogo(RY3!#@+9S|P&N-=kai`L9m|j`!d3wR zWC^0m1YicVLr~4DVHhdpz*Eo;oenil2O8@?z!oVhfL#qg4@;4l2P2~8Z~iYAg~@CJ zLB&KG1U0%y17{P{H6AAPKF?;sbCxe>bT|^cOWR?IR)LiPQ4kSYN7R}XLkR>Fy5P`s z{tE&D)S_7Z2ibUt$w4DXoDgI5hl4Ln1~XYEEYD6xCPM3f273XiE3Edb5s_eoPAdH# z^MG3GsAkjbLqavYYCo1Wlz2`BMK^2)`5M0k%S1;zJ!wfCJAgK(0XDEChR%!vXAp)3 z;jIoqvemr(A@Ip9NA1@n%IhQIt>LC+}$b7|iu-yes2^q86rz zo7p&^32-(ke@~3Xt*dv8oy#!r zHEL3ty#84UP-v)Xs{F&rgjCQKPi7>q({0x#bJreIH@Cljs=YCF?)ugHb$8d)1*{v% zYu~Qsum6ii{uk7%t`%U%z`v~Oc|!fg(vs>5-HuE^PBtF6IeZCvz`RjJXwBh`FuKuZ z`cpZOf74S9#}08%WI>uyNVj-c5NgM#8r^4zCh)XH1eW&s^Fc%RXaNN$ecW zjN!vojsj15Az0?18q4MpS|bkApK1p2qQ0Ubt1wdrjWB?WlVd1+=dd_BCQ5MOFm??W zqk!9Rvc^zsbHr*gn8e1ACF=E>9OIH*-E+-mut?ZR3HHaHK-4y&8bS4Xvb;uo0t$9f zOp`+RF+k9A-{?t(RMKq9Gk9c%%zV{++;^0xjZ&(Z*TsC$yxqe zlMeJNchW0iSf4+4`OVY(j*Z`1|6^#KZOuJF#ta?>RX9oZ>d7<_X#}j2 zsM%z|MxrfmEr|EN0%ZmFTdM&x5}?atRp7)PwH8e2L5C^vhPiC1E`iA|Pl|bX63HvX zlMvf_v}n(2UUjg|zkY1^6YRTDq_$&=E!wH%q+)Qh2S7s3tFl$?Mw6Ik3G z3I>7;9I#T~vw%~7Op%JeSNwhA2VzoC&Ne+xLQ!nUG5aWv#DfkU#}NT0BD#VD2x=vP zjLrHn`Aw&b%vdR4i%08>>Z@TwK?Yq4*yAy6UD>BDem$dNbUxQe$Ou(X&c;!$iIcCA z)=J!EUr#7RON34b!dL!VVq>2x5i7@;)Z`Ze(Q%mZ{oE7pFb*kp1dXJPTuU$xvBOT< zq$uD|uK+B&m>(u>>bFsd+FHSl;^d;Ptd~pnJqpjIej?Fae)OVnIj06prutg7~F>rrvp9Wy?$psv;hUrq70kqr)245!O3#c(=<3v6aZdFJ5B4B=2yp!lQQFjF` zFuZZnPU5a04H|?*atxlv{)80(**omdgLyI&y&N3nJ?-e&H5J|*taYB)yf^X1%fVe5 zq&Chp5;a}-j%p~pk!mC+LaHS2x51B8gW-+tpy0{Y=krL+@ls+Dw*Oydpprv)&jd4D zwXHAa*I%3pJ+}V2&^Hqk!DKz0+uMFQ@LK}S&nJ@1DlZ4Vq~HC5`|7~6{#sA#TF*CB z%k{d{`JBE#nfZ#oe3WOI*irBN!&f_ky9@2Vy(q?eoyQE}&7rwMq`?yEfLX+nI+KGRQO^@*GeJujM)e_aI+CE#(hW`L zNs(Ly@fa3SZ^R}?X9DeU;7FDPF=ystlq?E$TR6LLW{#X8@Dyg7j zAyDNSSa^&qo-0xU!pb4Z7|_!c8^1Cy(2&Rq5$$zMsr*fV^D-Ke@&%hF zO{(86IY))ar>7_4Adq2619L`1Q#py#M=+!zbd8c#l`KS&D)2#|=Xe%p2}&I2DRGO* zg|+i@7v6>~O@;d!{Wu1-rbh&KY*mxUOC1p@gF-Z^VVq|C&g->S%w*Z z32~V!o>ET~?bFo-6|d=3@-&An7e=|JHB=xAZUja|?#eM1PaxeE*(zs(u)}Z^0Ec$% z1^{acfhHYF074t9QzY96RxQiQjL7rW6R& zl5GO6JPqMFuk4!LIGYeDti#^5_>tN%pf0GDr^LL4GgR|puMVOYQTBu@>HE39trf|)#s$^NR;l-756br z3oyt~$SO|C!WplShBPQfSJF^QBxMSg{ zkb)sZEO^-9AlRF?fRB_I$Lt3AWQkdT5E^e2idNvI0^5{Di-WVPHG%pl$DQKXDNG6G zL74O67zj@aSEQVZ7}2k3Y=6;)mdNq(G1#qg_Ea)uW7S|7_VH|-mL}C2Q^cWZBqG*H zMd%EO^ES$CEN_eA{GQac$M_^ErMp($N3kg~R8q~|##nLH81k04F|40RPzL@@!DBo| zkbda{eq5&uDAm#fScj(r2>PlWpi?aZ4w-P}lIVI6DiGZasev<`sL*$KR|lbbQ2c&% z{!D#tg{1>IqKuq@5Hs)*2MX**i2dB!r3>>%Ec8G}Maa)Kw{%Gd;)6H9>1roEoGM+6?^}#WMCIIB^I|MHI9=dGChcS-m0bDQSbF*^H9`X>-0@B9^L0LogM!(W; zLmjX|!5NZ`1W$e;R}FvVrHRe9$y(QmSq=yO!Q_Dx>whiOO-l}thU9!|YG%4bu`sg7 zysCn<(?_( zxL^NzHH!}$AQC*&5!*FMOy{0PPM8k!IN~M_JNfq1W?R12_1HHj7hn7E`fK?E-&+4` zgZ`WJo>>t;WBN}-UZ+e!$OPnSq32{cR`eV=t#HR7rXY(vsS+jGfMCZr1sI~~(57<( ziWmh>d#D*{C*A@-%>>dO!phl1qiJn{ZpdM!v6u89W+)_ikrBR|5f}J7x3V&K$<@sL ztj7_F=nMeZ1O5klup=!CO#Cu-D3l0q_TK8^Rk`9~$JnmSN2=lH8WYv*8^7AfZ$u~a z;Vbv^My=lqX1|x2{lwyH-^hp7|A6@YU&$_Z2^Uu4gp|?F+DcHs?jQigzy7p4I+r8d z6S8F-KF5JCNNmAJ6lnuML$R80cLF`-+yvH?kl$Yf0(9U21($pbpQHJh1rF;jyBzJn zQ7b1-K`DO1z1>se+9NBEX^$udLAFRVI%9_b2g1+P-iRd7q+;PzASx2Q7Hpzpd{&^q zYL+@+`U$}uvaoGDl(6N1$uqo~?vDp!?9VVFJj1_CX$TWooFQgRD_SNKQPavJc|ai# zd4R?w)Q2Hlt}$VV8HZp;pvRC{$X_6r&F$EvpgN(If+Rp3XK8tGO&Zj~YS9v|KPKGR*udxV_MT!5=;rsB9zi=hk+ z>TS(f^d7b=^P;K%Q__ar^ftgH+NHC0p1$3J04bD)_2}TaK(IiBSbU+ITK3y&{1PQK_^&6!31?uX>g$Q+r<6?At z>gwNSLgA}_1?TMX^&gns>iLW8)nfj(bRCD$H{X zf8k$D_^G&y>##=p01m4HoI7NfN`*0i6`>Pf1FrDsV4J>ieOz!Y2%gAT$n_So6L*Is zg|}KDw?j1x&d|m*(bt~nQ`k;AuKW=OZ+>kPlQgi|OI@d1tczz^e$;j0O_pV$OT8+3 zqe!(dEL7SSQOR{FzZk5!K?wFk7LY%`}w!S-aQ%K9Lsew-a`6tGgaK9 zGgVk-rV4y{327?0_VKH?Co*aUgQwbqN{jun`unNI!p}Bpzfx!q1tF;1A%Y6N)bJ^i zQ~m}^&YBB-Xw8DUAg9m4wF(^dK&N`u7Q!26Y$$NW6Qrs4+*uCUCYb!`vkvG2Fo@#< zp5yO~LK0Zwqeh;!B>M^Nv_SEff!z}9e?M=x@E+kOza%$TcgquT*ARuNZuD!r!~4`T z=KOqZ7Ld`P*44=m`3L7cvsmgKjn3-AzB}Blkj35S%O1jYkv)X>g=9PM4PMbGxlCc) zM36`f<}@)4^9{5&bt)91m%75?e_Ao9wPfCM$tf&yLYRqK!^hH`aDYTecVECk%`IzM zeLDN?HIg~UgYhvwMhYJ$ApRA)i70`3%iUKTWIkzA!VhGxM8%$NzG2FQj{?fbO*a_9_w(MhSEo|GKpCNrNNT#8Jd_~07b z{+J%doNl#T3W+x0*Mr8);1;&!1dl=|(?l6nj`?tGYD ztu0?bkpGkOb;Ktl=3jP*J~O3Gv(wOI-GyW|FOnvu=oo2Y&R>9$^X$bH93EIVp$m|L9&Af6u_+=4$r`Rq z;a)jp3g|+a3i&kvF*$+6S^?=6J-zCKyuCQn*->yFy>Gr8K#0Bf&fjqpa#b#BsDx-<1E$q zc)Hl9p7xQOo3c2=^v82)HfdB4Hf5J4U7H5<_27SisWc3{VzSOb4MJa-e0Mykl7>CU zk277rggoZ|CiF@`1kbNYDHF+!E@?-)?5`N*$Dhtz>1ArlfNCc8^2bR)r{Z!r(vH>){l7tJ~F z9^}{a&jk1#Uyz%b#AX?!jPL4ji;8Y-zH-vG`x|Son~-#_>%7eAgD>14*sysN>W}01 z9z;B`-|tOdPf@VK(I4c`X{rO7}FxSHbPYNFLS1bh_(1$l5(MJ!Bn$1tSoj^RI(7zEgi5sD(M=u@Iitzyt(j}ZGq zO=z)7tfm}@tCF4#`f9Vb6vN86+7czF^XR7_t}sDLT!YaSL`~6>v4>4hqwwg_R4FGL zoowVQNybKHVs&&awv;>zm5c)DhModU3Nd%0a7#rvlZk1v)9(Z&Goj;%`Ce$^GL}dRXXk zP4t~@);|S3TXNrWn4JJmMTIMAnzi z#?37PFI6YCl_o+$Go1%#*uf`@l&%kKb5RwPsToT7EJIO%g5*gri~<@N4#-0NAvu>? zsV$tT!FPIgiBvauQ{%>_k1bc{-92Xl*j=homQDf^oHoC(P)G8yGpNS9tAGP0%R^2m znA#eIc=Olm-~g5nq!JJoiX5m#M`AE!ihN-wJYC=%Jy^5)f+}45e2|p*w6ufR3qPKG zD}f|n#A#2no+9@2e-1{hLou;w#PP(_fX|oWbm8W0!Yd;$2WJtX_?L3GnEl;XLMOJK zO?*O4>j>@4ZQh)V;Nji0FHlc19g?uf?TeWPm1;M-p{*Bjb>MV%rwVBcE(Ay30)$y4#W;-<0 zK`YA1f)yeifwS-fOUb$lgCj-%GYaO8iC}E%puDHgL)9@3ZT|{_p%I3o6j0ga-w;YE z7-263|H)D?At=Q~EUc1}Byt=hlw5PcTexSbTJ)|H z#T#Etj@|9#DB{wdGn>q&JtYW*@m7Hl=`8@$hvgc>&}WV4$S%0Jw(;sXVUPzMnTu1A zWkOc%mg7ByAPGpur>9c{*OYPr)PyuMX11lKPr_5+zm(Fv;aA>vO@Q_83L&J&Ur~Rw z8T87{V+SFXtpT9#^jQb`oQrebjlTZXZ4uyF@(FcVfjN)|rev43=;SBREL%)hfhOY844*!4{-Z;xaOdnNG74j0g8Ysy5!;f=>r8&SDmWVk)C(Vdy7SFe3@F?apN91eT& za2P`x>bxeGFnIr}#LK%_LZ@h>kc7Q37ljL50}BVI3phzmcSMUIGbEy7qKN5{2Z&98 zC9S?H{v%okGGA{>J0pJEn;OV#KN-v-IAZf~@;w~)h(Q`2KV9|?nZvN$9{QK%ynEE)7C z7@7!9gi5?~MtQBir^FP2qk&2D1K(ymz~r4BArC7rBn4~nH(e9Pf`hBFbpUN31*TMv~j=SAp-*caFmpeNMT09A09GCvzuZ`2(*@ zgUKNkiLubst&S7Ii+F7z$jurJ4G|eIn0ttppCq>{Sk_*v(@kkP%N#OgP z&oyS4p?yM5-YW44;TH8bp>XfWO}_E3CUW1&)k9gxVY$WEPOksOofA^)=`ZMuEYFX& z9$^$}>n%v{Cyx?k7l%odU;$z`jhcd|=>V#G1HIX)2?|dk?5Z7Qw`{Q*E+_$iWDS}2 zs;#HKdAqskHbA78UV#xwVZ0e;M=+Maqbiid*JU#RIXyUzEDWxUO)`7r&|k5r&?AiP z4;a9!@yK&E6=5cza^;YAvR*l$oC;U&)fXyR<<_sOg6A6wMS{u)d*xoIb&I;*H;IEp zm+5vJcgZRf-*L|1jbt|GOrx}V>nbBXL zqUB-%0x*OW+@^3m6b*DC#0g&sNTs&~(g@ng?m=$0=xwS!z%GX9Dfj&VQT1}Pa$W*8 zk*Yu_hjE54Kz`{0FDfAwF(jEBDStdPR{7jp$S;s{VIqfQJ3E#^9ZEBdWEJ@K0^Q(S z+i+*gH4b=3bvaD+Y0MgL94i-d$B5uVFMz{o*>pNatRW7otsx8MUs*<{u3tf$(y904N&uc7}}85QJ{@JPAJeu=ZqcLhM)U}(5AR8S)z?& zQACeb7HEPqVz;1dZGbZg2X)vt4CR1EU<%7mhI{&!0z!?f1HJ)h_DEcCOhpF(zcYm_ zOuj4vxG}Gof(`;*gMpOJc_yz6?7?6Ir*~X==yAGWfsaK$zGc8mxR;X0{r+n5W)Y&~ zxo8m~3MmO5)(Ado9cpZg9c6$$*LmJgDC79y#{Yn@|ve9C$$O1|x zMZxE$Os)W>21T19fnH|)i?ylmnfg)?ULhP)u2$W&m--G z=M31N$XNsyO&|^#`wgRu8_Ub|-!ovf=Qsdh%^yA0}-QROC%&89b+os z-4`8d^k1>EJ312KWVIgJ(y?BW&nmLGwUK5F`C4M^d-#_L{?X#KD&xrY&xjB2Tt{rr zR5kYoyhK0O$akuYZ>D;szKC!?W8drxF2;2|!#$CY51$LXY1FUb<2#NhBw1EuO?o0> zORB-hsYs*Hz8NV*YF($=zdg11+GBWHh#Wv-H5{CP8P7TB;wLRpn4=gyqc|todY9!W zCb`%hJrLWbc7{y_@G$C)B7^rK$45fvMfEmOz&ZsjG&@cBb5L#~a5#8XZ~X+P^a-9R z#J$3|P0n(4)Ybb0GKm-QVSjXE=U8P`)&}#`lUq)RABAwmQLV;+9p{Wu2EB~}sSr1z z?NM^nwx5olI7KD6DbrL0PnJ_iRv`jN<9x28&p`njgA<-WRh=g#UgJ{p2rw+16z~kX zEC(M`qjSE}1fQOF(q0;`x(07y3sgA$H)DUz|Bt?4+3}m}r$89XkO*KiWv;XEzGtFL$s5YEg6K%7nSNwqCO-~sd*W@2(x1xDG}FE*|6 zvcOyR?=XHyIWzfGp=2L}KbIsz=TIUvo^{lQ>wrX?~w%J&WF zTM~2nniG*zKASm&VyQSrCy}8v#A(7zxIFkwTNyw=F322qxw;ILU%!`*RmA)Gxsor#_45 zypsl{W+uB*k!f)bsX4p^2lJ>?ns-HdJdY{LG*vJg&hlcd(06TqVMWqy(5G zo34@qbsT~k@C}~(KDV;nmn8Khd>?L8MIq?G+?f`1IkDTNLLnxnGSdyG`^J`Dxi>nl1I=^zsUaB7B%=T?lb01aV zP0K6taP1O5sw`A-lnsyhE{9LpOyOGza6ai;ZV@DWmnM2hA|bK|VY^Y)K-X6J_!PeA zOm6yC>jIX>MPJ$#Be98Y!upCvdw>25U5U_)^f-T1cbn6Yo=&S{o@D;u>af}?PQ(Ws zokQrx(R5uwy4QE4&&W1AGa(&Q6$ym;&)(|8WE6>%CY{C1T>+D?uSA_=@*F4f9qHL7 z&dL;it)8Q~LK5-v6zi-;FUbX+ft$I5tdjQ=^mJcZn^RwLP%y@k-^~Ej3e5C2GuDYR zsyZ1)bq+hfu(Es>LCNflUcE5))Dn0z%Ff_ZJ;=>LW1*z4C9BPMVgrP{oS}4w z94*Jk7u0MD#lCd@n3s}t+X#?%nZ1v8NVd*aaq1e?%m8VHSZ;Kz?^XC7wi{;M{7$_v ztQoY3k<)Bc$0_J2M}N6umfn}Qb+a#jZH_)ay&%!}a-P{Bl}^r6s44J3H-Yt-Q0k=HepLrO9`@GZ&W@ zo54pzuHTTUk;F04w>D<#YHR`5(A*+%UYjGsDeE46R7E(XDrhzU($4v7X_eX6m=sah zE~srmP9-V8()vowcS;@aJEcs&)Bgf`sh+=~Z(`M5YOLqzwXdoeaY>CZ+K1GpDjgSK zSI$f!7={iGkkuqP3#RTH_$Y5K8i!W7ZGYzeNq=f*4B+zY7`j#e zps2%Y1BGj2;_0eQB*=36HwaOISU8Zm9!%E zgpcA}&B}#kNtA%&4To`*0zVM+4&#V0ejw}}Mz}nFAn+Z=sdD^47(9%?f;RlpW2D24 M4Mf51IZ4j{2HeZm1poj5 diff --git a/sources/INSPECT.~3~ b/sources/INSPECT.~3~ deleted file mode 100644 index e436d2b8..00000000 --- a/sources/INSPECT.~3~ +++ /dev/null @@ -1,35 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 16:37:36" {DSK}medley3.5>sources>INSPECT.;2 115126 changes to%: (FNS DEFAULT.INSPECTW.PROPCOMMANDFN INSPECT INSPECT/DATATYPE) previous date%: "19-Sep-95 13:59:31" {DSK}medley3.5>sources>INSPECT.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1991, 1993, 1995, 1999 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 3-Feb-87 16:54 by jop") (* ;; "returns the character codes that are not OTHER.") (for CH from 0 to 255 when (NEQ (GETSYNTAX CH RT) 'OTHER) collect CH]) (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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7006 42734 (INSPECTW.CREATE 7016 . 11771) (INSPECTW.REPAINTFN 11773 . 17309) ( INSPECTW.REDISPLAY 17311 . 26183) (\INSPECTW.VALUE.MARGIN 26185 . 26588) (INSPECTW.REPLACE 26590 . 27298) (INSPECTW.SELECTITEM 27300 . 28290) (\INSPECTW.REDISPLAYPROP 28292 . 30722) (INSPECTW.FETCH 30724 . 31147) (INSPECTW.PROPERTIES 31149 . 31790) (DECODE.WINDOW.ARG 31792 . 33520) ( DEFAULT.INSPECTW.PROPCOMMANDFN 33522 . 35540) (DEFAULT.INSPECTW.VALUECOMMANDFN 35542 . 36800) ( DEFAULT.INSPECTW.TITLECOMMANDFN 36802 . 38492) (\SELITEM.FROM.PROPERTY 38494 . 38936) ( \INSPECT.COMPUTE.TITLE 38938 . 40064) (LEVELEDFORM 40066 . 40785) (MAKEWITHINREGION 40787 . 42732)) ( 42735 60036 (ITEMW.REPAINTFN 42745 . 43965) (\ITEM.WINDOW.BUTTON.HANDLER 43967 . 44382) ( \ITEM.WINDOW.SELECTION.HANDLER 44384 . 47051) (\INSPECTW.COMMAND.HANDLER 47053 . 51054) ( ITEM.WINDOW.SET.STACK.ARG 51056 . 53260) (REPLACESTKARG 53262 . 54361) (IN/ITEM? 54363 . 55245) ( \ITEMW.DESELECTITEM 55247 . 55511) (\ITEMW.SELECTITEM 55513 . 55775) (\ITEMW.CLEARSELECTION 55777 . 56132) (\ITEMW.FLIPITEM 56134 . 56607) (PRINTANDBOX 56609 . 59118) (PRINTATBOX 59120 . 59637) ( ITEMOFPROPERTYVALUE 59639 . 60034)) (60037 63642 (\ITEM.WINDOW.COPY.HANDLER 60047 . 61768) ( \ITEMW.FLIPCOPY 61770 . 62229) (BKSYSBUF.GENERAL 62231 . 63640)) (64034 86509 (INSPECT 64044 . 68307) (\APPLYINSPECTMACRO 68309 . 69291) (INSPECT/BITMAP 69293 . 70328) (INSPECT/DATATYPE 70330 . 73573) ( INSPECTABLEFIELDNAMES 73575 . 74096) (REMOVEDUPS 74098 . 74303) (INSPECT/ARRAY 74305 . 75342) ( INSPECT/TOP/LEVEL/LIST 75344 . 76303) (INSPECT/PROPLIST 76305 . 77280) (NONSYSPROPNAMES 77282 . 77578) (INSPECT/LISTP 77580 . 77902) (ALISTP 77904 . 78113) (PROPLISTP 78115 . 78755) (INSPECT/ALIST 78757 . 79112) (ASSOCGET 79114 . 79325) (/ASSOCPUT 79327 . 79592) (INSPECT/PLIST 79594 . 79957) ( INSPECT/TYPERECORD 79959 . 80199) (INSPECT/AS/RECORD 80201 . 81325) (SELECT.LIST.INSPECTOR 81327 . 83372) (STANDARDEDITE 83374 . 83657) (NTHTOPLEVELELT 83659 . 83975) (SETNTHTOPLEVELELT 83977 . 84737) (DEDITE 84739 . 84946) (FINDRECDECL 84948 . 85531) (FINDSYSRECDECL 85533 . 85934) ( MAKE-INSPECTOR-PROFILE 85936 . 86321) (CONFIRM-SET 86323 . 86507)) (87841 95930 (INSPECT/ATOM 87851 . 91831) (SELECT.ATOM.ASPECT 91833 . 92977) (INSPECT/AS/FUNCTION 92979 . 95265) (SELECT.FNS.EDITOR 95267 . 95928)) (95971 101370 (INSPECTCODE 95981 . 97127) (\TEDIT.INSPECTCODE 97129 . 99087) ( \INSPECT/CODE/RESHAPEFN 99089 . 100628) (\INSPECT/CODE/REPAINTFN 100630 . 101368)) (101408 102893 ( INSPECT/HARRAYP 101418 . 102045) (HARRAYKEYS 102047 . 102426) (INSPECTW.GETHASH 102428 . 102655) ( INSPECTW.PUTHASH 102657 . 102891)) (102942 105731 (RDTBL\NONOTHERCODES 102952 . 103293) (GETSYNTAXPROP 103295 . 103534) (SETSYNTAXPROP 103536 . 103781) (GETTTBLPROP 103783 . 104701) (SETTTBLPROP 104703 . 105729)) (106210 114593 (INSPECT/AS/BLOCKRECORD 106220 . 107103) (INSPECT/TYPELESS 107105 . 108351) ( LIST-ALL-BLOCKRECORDS 108353 . 108628) (INSPECT/HUNK 108630 . 111236) (\INSPECT.DATATYPE.RAW.FETCH 111238 . 111564) (\INSPECT.FETCH.8 111566 . 111715) (\INSPECT.FETCH.32 111717 . 111888) ( \INSPECT.FETCH.CHAR 111890 . 112053) (\INSPECT.FETCH.FATCHAR 112055 . 112217) (\INSPECT.FETCH.PTR 112219 . 112390) (\INSPECT.STORE.8 112392 . 112698) (\INSPECT.STORE.16 112700 . 113000) ( \INSPECT.STORE.32 113002 . 113437) (\INSPECT.STORE.CHAR 113439 . 113765) (\INSPECT.STORE.FATCHAR 113767 . 114089) (\INSPECT.STORE.PTR 114091 . 114438) (INSPECT/MAKE/CCODEP 114440 . 114591))))) STOP \ No newline at end of file diff --git a/sources/INSPECT.~7~ b/sources/INSPECT.~7~ deleted file mode 100644 index b4af5df8..00000000 --- a/sources/INSPECT.~7~ +++ /dev/null @@ -1,35 +0,0 @@ -(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/INTERPRESS.LCOM.~6~ b/sources/INTERPRESS.LCOM.~6~ deleted file mode 100644 index e238b82a4b2f6f24a589ff5b7949b9005c21fcc5..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 60938 zcmeIbd2n3EnJ0(>K#Dp517w+^X_|V5b%3-8qpEPS)pWf&fGVI+uY>|gfT9JFEJz?w z1lSP!4VGo4^l(AcW2c;cI?*7 z25HX5#_qP8`}=*F`K|&)N^M7M#ExvD^5x5y=a*l8cXnp7L-}HM-%!4g-Ip&8Io9ry zogTG^vsOpGIFTJM>;LMS_Bm$O!^drwOzD@dc%L^fk}#QOHxrCA!oW2dXf77i2^ zPaLZrI5ktL&ODLm>OD|BdFJ$q#if}8XBHn{Ix%zRfOM)fo-LQVeywj0Y8li`b$45_ zf&JaF{fT&ob$n^YZL4MGW2cwS+_T?WSUfv>a^W%SBpM%+7A!Pj4Lx41TIDCuz*)=R z@vg3}4y$tPEV>&WP;792EY@*zqy9$^(rSsv`+DMW>%{D_g~w*jSZ5b8n9f7?c-iu1 zBkhcp_gJTwWd9xa#fkh-K0EH#RzhuQR25@Y`QmV}*5BI9TC1CER^Mi72jq1_H5|*0ca`wT4*VY@ zcpi%rfeFlG*5XznTO6Lq$y}mu!HK-Dv7w=9E;WC-y)lx@Uwd}8Eosl?-+1GV%m1-@ z{UL}-r zWRZ?pwlkg|MylJgC69nCFcO@P$G2cU)R6SRwl?PSm*y|$+vB$sMz5`OjBP!VtZvDT z{9yi)j8?yGZ06g0XWQ(8ERq2GbZf2n8K<>)?XynnUlu;{bYcF&(dAb$KT>2wzOPB< z{{#T;HgluL9_x-<*}{a?9}i6mAes3+J#RUeF+D&Tc&{2PhaLh^wL5%J>cPr*aBlt? zVa2W_td*m+Um3{!HDU1^YVMCW0uW^))nAz}ZuPjCsd0NE?-cCNFqboy zFWLYJD;Dc#7KWHbNoI6QhWX4IG`m_)`2glg5b656ygw0IiC%XDV)?o)sTZdZ8V*!V=bPZSvq!hamhNd zSee<6<5bOsnJsq+vbQjTxRt@*m_^LuJ7M~pfWp*@rDXMp$}0J*U#{i1wnuPEG>^QY z5rx_U$&~sf!srFm$_nTe=?Se6u=HE45GI~So)3WppF_aE{xa*+Gk~ahk_3nO5EiWo zi}q(+pf9Qop;l}zb@l5h$aNL^itV%7ewUO)8$OIm%y)IF7OO9ER1?G_zSm{JRSK3|SGc&*O_{_qI8LK+8@YvZ|P%evBb#dXb4l4m_ zt*^hoKOXC~aMrB{9%r98Jp-T!&aa-UZmS5|q773LNy?hfU#i}6>4!i3A(vFBA{9+DEmxLKdGnQ%zPu=gt7r(R)p z75I9uV%_q}ot9K~IA0vI%b@jrlM|SLtuoKmFX;h1Y6gJX6$u1VCqUInoh2|48`Zea zUt=vkgZn{0++%zIsvy*pG|iV}lZ2L|6k+G|PHc}fx^;(PbpQa=z?Mvnlbw(ht_78baP%s8m&@iJ({PS84`y$i?;<=}J)@iPehj#Sx^b?$LwT7}OyLDb#OZkc%MK z^250a@C1X_1SqnSHDHy~b|IVDcPL*r@A`dth3pWE_xZ9?&cuW>hD;2~{Z`fHTTUR0 zth6N3q_%q{lM#rvWjf-=O#_=W`FK}lY5Il z_W_;z{@c=X*H+%=wAtwkFM&#Xww9lc*6fPYdiDHWHK%oXC(>$C09B-~U zQTyWY&Cb@;#p7Gh_6vy${&d|On*4%U`FOv9-?&Q-#X$nQ#G~PWMm^=RBb^dCJn(|}rq`OtPEH&gC%xWdr6I}6j!z*C_E6G9E^+W`nfyUc z2l$uur{>=R&)(9WY_hABtDmV>0PeDX>^CQUsP$v|jPOnkLpo)L6qA$Aq?DwvkKj}3}e$MXE8@7?o>Tw8<4 zQ^5&@b~(1Qsu1#u@H-y{*wX?L*hJngKwuLhg@jND^vxQ=ym;;K1jkMQKbDC^8Y1)T zqQd+#EvxU{CRq>W)Z>nA$*QF$O#aq#^A}!R{+=)WI(Rs<%iVq7V|F>9r8tqJ^fT>b zpnT}{Kbi#{^s}KKnw(i${Md)UOL~KJp+w8@Fd#(?ak%nw47C>^NEyOP1%{7-{u!jE zhJKS}SnGz+Az8gHqp06%?^UBy)1u1A4Amv8O)AU7gyvH(=fBmJdAsyK>Krx0c?B5X zy$?{)8RG$>VLIm0`muxo)L7i?l97?9qBnO!g2J1YaF zU3}o81DBiiVR1ll-PZ55f?EkkW30FCY=nTurT(mbNGHaJQ-zZYGsl)XERduf<1=TF zJ~7*20bO(mpb$>NSRlU+5CmyNm#eSC0p2*=(+53I`$cqteIH_n{!|uMmQt^ZULChK z58b+wB%VJIWrX2&FHYa48%i>&pEFI?FN(|CS#Lwc0E|MthBLY$)6E94f1WoDhll7P z`5O&!hZ>?(l+--1M@D!DjG@xJ0T~j_&2cAq+?jx0(?!>u+B(AKJ$}MQZ_Q-YWwSj7 z&g{I6n-j|ZowW96X8PWCYjIz5kc6!dJ=S_tYlK1yE0I+-sQaDGwf_XyYmLn>WEe>* znHzL39w5Q69yuF_f&T=>Db;P2pgNo=XU7la(^=r{zio(s#Sw{;Ox4NPK4{A-jyjgdPr;)a?XIo|j*6cNcQpIx|q9dudho3lyz9^8eEtSkRoiJzHV z`Cv-wzw!D)XS>xGK!A{fEV9?}t z$K2drbzkBVYrikpM$YqnnzRxq*CEr#TWXV`GkUbyWLFZF7iMTckEheK=Zk6j9%!4`o9M zVcm>415>PCf)`W?Oj_NdxH4q#NV0(9>&mTr1Y_^H0;e0$k_OTg?CJUM6_!e|SJM`kn3bJyzsFP&}KeZSCz5v*)(uDl&^N$zD9(ynMhGP2Y3&YSYKh zHGDgrX#0kpX!}gH`S|9VDLXq?$CKbnrLZ%A5plDDCWu;J?TOJXRtF~SF%DL;m zu8@a%=(eZMU7tcrbL9C7*UrB?nI9XS{eL#AMua_kbDJp9&t3n`nr_bP%(rxBeBhTz zKmv!g?ODgJf&(p<^p;Qau%KE3Rl)wuf;G7_ehO_Y^m#WY&{GX1CZC3>^4lOOC?w! zl2tih7UTt^7-|Y?bKo&GXk{H`L6+`+2GWW{OJNWkMrx9uq`J&|pmYc! zM0hIbPPi6@-1U~jhKj|z`+zcWau!9Ah9m@mV`70q0mm$jOPu1q0xv6avhY^X{HgT8bin}Zqthwp|3(FMP z3y>DOL}v_U10DdwX29$PBiD$5Id(x+HcY|?yOIGAQzbUoBjl4PP?o~o>yQCBSKTIz zSaV&j&@|-j28d3>8w4=vZV*gNcte1Pa-ke{Q$v~TA&8DZHi#hK>Vr5<69nM+%qGDk zsCuxaWJ3%&0dpuN)ANbR!5O0j`WZg%AA&`JC;fMYVTvts^)ny<{92H;JKEbD^G&PU zggjG}!R*%Pmf5z*%l1g)l~0dEmVcgaoLc@5u$}1B`g1IcL1H>lH&+-9M$Qx4FW~hH zU_^-nv53d$LfY1GaG^5uC^+4U_2}ZlS!?0(Q^#kPz}o_$mto==VrQ76uyTm>339oA zC>w;NiNW&g^jDkqp`pp~tk}x9B$%slidmUD?(|>Cw5y%k-Tr=W1%6MRO=`Ant&(WI zFcodC<&QT8v-khv+U%7VKBx3G_ zS`nTh;VkUwP!`ULP!5jEP!6_BCG5 zR|*Zff@C|3&jCo~5!kY=H*btc^C#jSOASshLVVHv8i9vbSWenXrG`?V)$(izMJhJ2GrS`Qx}dzH$z=&Hi*twJMFDkOBK~y>g_KI z==;!o#nw^KgKG$t8mt3x5ILbT*x=!uy03cbzPj;xZLm{fA_NP_W&dy;90-Y#nf8lv zwQf09Z($L`mJCh2h$Vt3X|S#kEU`nM4PZ8dU-i`C)*GX?sSURm_7%5R zV9gdcA}M~~zoE?ZZpMb%?2#02dufhDM{Z0zz!f7j4fP}d$m38MP;{Z3Uj_-F1UiNU z0ObyL5o{-UL<)N}xlKNi_WXgPBu2$6{4zcqp7Q^-*-t9GzcIJA{fOrGG#6HEk2HAW--ty6T@M)b#O>A!RDC+05AUHN*>b5*g`a{Tqhbnly5RgI0E6f*~)W8rp?*g_J28qIv?I~|_+vLVMlPMYeku9@l^%G~j|cb|O(yMVE?HSSkb7;* z#b_qER{R2Ouy8)Yoy0DeoixS>gzrq`V5KcX z0#kz>2?V?k4q|qJa{T>pM3|t2P<3010Yk{d;Cp(cbsQ|hIMEp{VlWw{9iwlZ8Zv|f zIk0G*yxbSmRKARZx0u`0oI}>ccn& zgC|u622VUpv=j?=e=cVSLRU2da!w^YZJcY`)ETR{sYT~mpXW?SZ!Zt@MUn(UGL(Z+ zg>yVf0)_&(Djj=l#sUB-cVg3LSM`$zutC2=8Unewv4iIaz}~t@IXiK?o;M7=+-Arxp_Ap-%WD zvS5ceIaG~`Un!j}EO>^fl0XwWVF-hD#2a+NVjV@;o&iJhxCg}%TGklOt56oGc1T~L zJ{NT2JN+%FV&2o2=>1S^0A_Pu&4vtsogzIHEGT@1csB@ zac2@W`8U&$J(e#_!R!utoU(-t@6CSj6{xv=V$5(jm(3O|7+HBGy?ps5kD34*YSmON zJW2MY7ONEtE;A{okbyo=7dWge#VNp=KtIy3O4sWR<2M@STj+Y{zWiBu@158~6FMV^ z?o!frWsxB}ow5zr^1Ry;c{29!Fs$Vot2tS|*OPCWl>H`b=JJ&sXn-6X^%~}L*S_I~{IS%Y1@flg!R5b%bI22O#M zvWF*2FjA$KjPLd-K{&Y}Ox3Lnk7?ko+L|8F`5At3HvAy(zN#!Q5J> z4R`XFa$qf9&R2dka^+jKT>eK2kL0T@SN=p{pSJ4tt1B1mflqyW zN%^+w9ao;y#oMjseAT-0>D*e^Cv$79`RetbpqW>|PK{o8Rb#G^m7#)8LOr}cSD^SD zJvjeVh=J$QDKKU*enBnbp*9GH4UYsj znA<8+9?kh0p;KVE1SmgW391ys!y}5p9``n{dz=Xv`R~O>0Kp(w9ptADCctv(0?gwNmi7%f<74H$K=4=`<|9%EX&9Xe zT^@L2yv2wd;1^mAKikvReRXnMYOLWXL$>(EhjGO7D+lf^gE?S-Gf`gzF zA7+JzY#2E03E*w%kimY`q@tZN4IBl@)h!y)9fQD3=JMb!h~m}CsRLcDCQbfz2`uP` znn?D`GRUS~XutK!>h3bc+L9;JFMqZ);J@14ndZS>Dev?PX4xwhuhM(v2 z0W0WcJ;jV&gXzIKg{z@QO(9E%YP{dmGG>ovy?vtQfleGwi5rr3ojn#J-7t|bTn*9y z1`sdI#nD@0jYxu`K>|bGhJkEOD&i7WdD)g*I5a{L98lmLGU4RM;HfI5TMz`r>wxsh zx4SjTj9Jbeo>He0C7QCIgC|VG;5t_5?UCHt=G@xW3sV)1>v#X+nm#2y3Gv!4B@`q6 zgaHj!Ua5)z>pm>y;!<=Dq@>qbg;fCLoI(oMs%g(eM{WI-Z1 z&ZmG}TBkM`XXL+NGChaHV@9XDWlD{3Ho8R*HL5xA&uJR|_XOU|A*nM}S^dRr(L4Ol z-?`@&cvJYz^aW0J;qHg#uAJXBx~b{8QOW-AlB4=ilE<1Z7C$<7<4T=7Vd9Ujq)t}fP~A2(o! zRVnrNwY%ppJpA3eYeoHuKHAOCoN_35ZOdgD?ehEU_;XXhFy__wNXeu^&OQ$7i)y}d zYxgUz`~15BlK1OLtZvl_kMZu|p$xzzfbazFL5u=pTGIoJ8IoaIJwSrl2T{)BjXdVa zZzN+>A3Z>`b;8jeA`!DQ5>QUz!KfV)IN5!>HGu{Lj}W&Ae^1*voeFUJ31BRh9|sMg zhi1k7%zYfky?@ZO7xH;L$ASL?l1ke49vwOY?gFO@X%~~mY2^DZ216R3O%a`{rh926nx_pBmkseSQp{xXWoY04f zbu_RzD8e6t#tLP{>jfS00M8_yh=X|xe^{?WjMEG<*n3)Jg|q4vlQ{wxSi?c|!WPZ1fO@BaxH&oiHfTB2F;C}!o`l}{ zI=!cbbfoEtp=%&w5w@7N|JiXZi2%)|PE<1IJi)PHIColb%ts#X0vkw!Ts71~tU_P0lFRdmIDlT$iq*-AA3&nuBc+h?IE`M*v+Q=5G@_XoPnrw&`c{RnA~ z_Q-AWdsoGYMt8soIs!N9=q@IlXrmJL!;3m?aEkmcTM`^{gLzP zFDu39_L^=HL8sun9o^|Zx8b=hTGT?9=s>M9_uc#OC)&e5asKJ9Rpz7jBZbqJ&zt$D zxz--J-Px+Em9wBda)%7U*{UF^>&h3Lt#Vf4B#p`>>1TCx=yKBCXs5GPK8|+jY-fA4 zTi3pFpR--6tR6vUob6H-I_T`EU@~?zIy)jeYM8aHQkAnq+LW>DEM1SvQdP}W@D;v| zkVDxSP3fKmfAn{gU(oI6q77(89sj|xJ6m;;HDv^1dcMOeE}c^h6DpalfGd)D&?V%x zRQ>709jixl1*;G0AxKdvbLE9!*Ppbvx2joH6;1DYp~Knf?3%x%bD5MeuOd|2Wl2GF z^Dbxi%CDKZ+AS^0ADMn>!Rv~!WsR%1$U8lwAV&LP;-** zS`lnR#?dQ!d*fN_I-T}XfRDqU(OydEwx`$Yg#;Gl#z7%@M77xqtQC?L_h1xtv21!E zsg+F6f44^z0H$?cJ|!n!CwnlF{zpt9_0nSVufjYfkmXKL0tyOri0m(P+;KQn26b=r z`6fzMRZ<|AeNcsBqA1aO1Ek+C$C%*uE{!U?KzbCrGI_?(AlB{2L4leuNm|j>k7G`0 zy81C!g5;?a3w%}X60WhI*gf>h>VwXtP=Z}P$f}$J-m(vPS|MYsG`LW~%dnl{EWni< zj-jNZBvmgl@1?!)dl7m}Uzx8C% z!Ahr{@$6F;w$g7kHwDK=ru_rIWr+?#4pQGC+7GdWH)<-dSg-ip}Oygp{rXx2)#jAu@ZhlDNXgcyv3+Y}zVfBE zrmyB-p8f573MbK z0TrM_9p20KT*Z86J`+Mfj@jeQm6a(_T`#6+Xt8__wefW=||N4ASfYpxF$+M@9owlm* zTyVn$!h>PSw+#{H_~Zh&DD=%oRn1gRx&TLE9Xtwg0`UL|t-FR*tKq>081NY1x<9Td zUph6nZCZ{L%00i!U&x={*`^{-l8}K`7O`cr!-x_J?!j~a(uy&dbE_^ZB@CU-fB)8YU5ElQ)N$HSYnup!Wa{%6;%}O<8n}r24GM!_Ihy+Aj$1@E85t z$USTV^1FiChnQ8kC<)4S!%7XBO_~S#b@hM{dmFJIBj<=@0SaM;N2S=+Y-Vm?Z!?oW z8^=;%^K&(IxGERQf`ZVwac z%*G#lzkOSiPcXG{SRL7A$*k<+q^@5*s8)<~w|<&qD|15E4!5G!g~+Tz0Iikkkt^rp zmANbbrc!<3$~S;RBCS_ew%3xwt<@vO;!#@rq(Gs3R!a`4##A?|aCOUtUEOr2w8L9= zet7Hrr60C8ZKf0Gw4FjHWc=w%*-K-W;ozE?_egT(Yg|hz2_EKZt3q+@O}9F&isv$} zbFVn9PTQQb70!08+r*vp%j>z&c^;+zqaJ~0iJ|6*vS*T<+GYU|uT#*Bt5gCsyH0^B z&?zd$#O@&hg4lH)ivu6I0z6`XxZlZHGHzg4>512*G^Gy45iSnuKoP)*WUobJEEI#x z#wSX{2FxQ`3{*PM9MB@s*bv4*SGk=tB1fu{>NBC8Tqo1G^?CN&>p7doRIBWn-{@1# zR(;$(&~6IFxFkRV+?JSmCV)OP^_PISwaL7=hsJs0IBs)f%G@4qyDCL zzfE0^gjh(XB5Eh%5H<;4$|ODT51A^PSXuynn$)YsdD}5}T$wisG;O|*!=Mgyyl6XK zIh;HoQ(Ybua#XXQbOP(ByJc*MeP_IO>f?C}uV!~y7{w5hUYJjcW=GFINj~Q4Lx6-I zAB|mwp%~RFlIZhQ;iLb2xjGgihTt3=Pa8{E99M{LU4Y%c$m0s)QwR<~`08v%m37Z2 z?B>7=bE+to%j3gIGSFnt1a*UE)(2#W+9+Mn5t{qGlTIJda;*8f?zSHorfxjpAG(}% z;ZE!3ba`MWX*kS#8R}%s#u?l!wpr?2)vt0j7*6ook!`r{;v<+{UPo~?RaoS#(PCIQ8r>!xfPPQF* z8ofC7@1@xb!#nw=;6CH2F`{2G?LJ6LN7BiWdDUi4DI-sEPr$J1s2Al2p$L6Ms^DC3 zp9*1V7>fb3NoYhy0#FHnv`S!usRUIcUaiJ**iX+Ie%hZ0!ZgqnL=X_xC}^eL9uHK_ zx)vNtnBzC#F+u0l*?)?ASJ~5*s zCFt8eYIH>PzRY*BQ(nELq2XO`W2cN3hIfsftI0*FK(1Ar6 zZBg$HlSAJTuU6x@<=+s-NZ6kT!t0l|NpPYBPkW+sF1LH0D@j=ZM~9|Fijub6U!U|hVCJ2VNgHg9J*R06+vnSAr80LM3yx3kQLIHwITQA*|y=<&*z3) zC1>*K+zVHSzBy~l)A2iM4+>d-?N4n*f8>Vb>*ehdyD2*~tR(L(f>TK&3lVH4W;k2S zj_1=_+-XtD>?e^#`B+8_(yr9Khr3MwA#wz&@(wRB+alQUFQf5X4&>nkg$NslovLhr;GxQJWWk@hGrXMFAou_V&066EA@7#+SvmbVJZ$A>0tOpd3W5i*;a3 zhb=DHwQRwo*eda8)1A@q=1nwTqz^)6>GqR*bX2rsz%HN0hb#Zv2)2JZKZq5q-C%A z{SFl`tHnl<7d`j2Bmjr8i~y#}wu)|b1>COyw$YH>ByTjS4b%!5z07PJ!g1bYK=%k} zJksS7El(x>nJx_8)==n%FQ$=!&LiupL~<5!2UpCPu0rCi7+F_*hhrdcKL%q!cN{-f zvF5>zAsQw`=I)aQQgP_>Ex&8*O-N9*Jpt3hH$=c5JWK&r)`>|u0xLExeNF#0A@Nh` z)ph`Ud`4l-ZOaH93wFqr4!9v<^x1&z zsR(D)TZRGl&ytVbf$6_4sy8W=btbT|mYl(XXE-H{hflz-6h%S#R6~&l@IHgc7h?9x zhm3Iq@SlS9_DDnt@AJ{NWImFIaXcsk0lYR-SczoXh?@k$bPzqr86fQ>`e&Cw^s22+ z6(qVZT0mp9uO$2+9F&p=GZaEjFjvy=ys&zET71>(;Y0j~wz#B4M__BHpq+tb4uEDp zEUumyUy`vC|41Esla-Zd(ONdr3Xb`5} z&=wTR5Fes-3P+(yphn_o!Er_pszsvG$sAhXdOPyf>da%us!;J%7a0P_+i-d;K=edW zAHZrN1PCzrA##-1ZA>x}I5cV6zp}(90E+C*On!(e9?E?rqCXA@mqcfOb-;g2vL?~N zq2%nskYR+W+mwoM`wA<@L08TWvl~>^8AB8t+r+SGF_*;f`G6Teu#zLhdygc zj})@2Ns|=Ei76>9I=4wl!eRD4Nnoq1M7Je{pmvZFAUK3yhgJaWI@S(E31=H?n3rc* zF$sIcJP4b_Se|KIv-bgYkl+DYp!@E-kJ;U5M^b~#Le2m)@Y|1P{6N6XA0^y|j2USJ zA-u2T6qK|ZoSdZCU!6pik_zH4@07z1QK;F!&!OytqWGw{p1_oQtmgkC5ou_yHjBtr zD8ZXa<3OW-u6X70k4m~f=F!Vw3dJMpRN}WP)qeeb?N{z^Pj(-Ebneo0F&d#fd#PnX+k4!MJ)j8zsV&Yb3motgP^wG)}lC&-ndQa)nrVlJM zH%zA-<&8DH+u0@L@U-RZkZAUCr{WyHwz6ZJbM%F+$+RLBwP7!!)aRY3qXIuVZ8}lZ zzXkoPh=SV4sI%P^-D(o8Ix!Y3>m2yc8Z)moRGZ=r|G8oM-WoIYWSGp(8hVF*UWQI@ z5be!hk_AVq+NhH9{K9V3uiqgRc=z<|^nNuH&Vg%RIoJ57Y{m%ZtBun3UTJ$&9R&?K z^ZuH%R~A#6_?#rCQS$z}Ot<9EKjozU*_@NQJPms<6?=5$}p zv7EavIh{Xq?tgQ7!0G$>%3aO@r|+lJ$(qyY^f~wc-A`qq9P9G*-L>WS;pKq5yw@3U z_L`Twr753z^~$@Q{a;s;c18C&`HYjSo9?a}Gegr2yDjNr*UuD;#C0dT^)sxwQq?V2 zSMGG;PVwhob9(Uic_;P5=~V69Km3UUug&QKu3A`me+Z6h0RNf~FrA?7(frgzqy zUDJ;^cVC!>72VMl=Vl=MkGy)$HT;hAu=5B39$!v4lg^=&Nv(fbe&}W@TiF$^U{+VK z+_ll0KV5HdGH=tn)qG9E0x&s!pyqTDs=KEgrd{{o)A$9w+{DMRGemKSyT8 zNxi`-{KZ4g0eSy3e!TxV!1RUb$}{Tc+}}S0nI3O_2*&=7(F*w}NMj)jNlPM<6Ao|6 zWrYSd1Z#|LF6(4>^ZWYJ-7p{Jr|Q;;LD;}}0*yf&y1`xy;;amGVgO+`>GCnaxET2D z2dg_YJb^O=w3A3nXoDt+J|t*j-Uq`U{`P{vkY7*>yd|?2r?vb-1}XU%hde`x!rvZz zUvTV<956jN@Ff$}xcq|nl3yyGSQyqdZs7#9PRvX|LLOBmB0xs3DB1VAbTW@vllu9oun<5 zPWDo5!FotjApnt1VwH4~kzvDRD5fHuRUbKOJwt4)r6F!%frIJ8I#TGRQXoHc3gTnQ z!U#ZIU|C{a-AJI_9!X#gm>2*r$2a|$cK-HZFt{oN_JiH(7sO+4S9f+_4@}GSE09+v z3+=IVZ(qDcKBu1{Gid%4mtUA!8#n5D$kqfZ*!{y)^3aVQbe^JI6!~POZCJU1154YO zF~5y6)$pZ>7zo!AUck`6k;|hfQy{rYiGrd~$+c-Y7)T?CD`;=SA5dAW6ZB9FVV3WL zBJ8&IQgbqe6FB)|>Ucvf#|Y>zropo35bgEktEuG0m(%veSCUZOL87G&+ZQP+bDv(q z-JCy}y8>ZZ{sQ8jcNbRPJ>2%q;jO8(q63DvChg^Il9jYgmVSA%Er+x9V6IZV1um$y zT*Q!vB>#iy(NvbT;(DoC_IUHT>pN*)114V( zl-y1NEa2fKMy>NU8%#;P2LxU4z5+zK4?zixL5~_N5O%}IO~i0JAOXQ;M?q=3awG^) z#fGu|_9BmSm!-eqeVCCE2ySj2Zd-|xMb8c;hg*l+6a(I-g)0#3WfiIU$wb?;+259P z0v2t_n~=FE9(Zkkx?;mK+|FNwC-Jn-OlB%6WTqr@#75Q9s0GSrV2?~;u>5NWfg=knA%Pt?vOZVPQmR+@dO%a}A}TJwja(1Ih=6R^1Sx^SgMem`X+*@+`4L=dynOf!JlX`Cr% zDi}G)ci%uBn6*xsBXTo_w0Sdt^n_- zj1UNVx(z5WKT;S~82a0(wD<6rW0j&p&_yC>OUZ4Nj7pigDM_4IH@1xdAy17Ngbe#b z`=ZmPF!Cr7@;)NZ?MbJ#;JqmDMbviM^2v)%tHR28!OC7QK638*lSPA+QEggR+guwJ zmN#&GD0AgNw;|+6SbM!Krecz0 z$M<0dSi!y$Z*|xUV&Qgi0>`~ri~zW0%7&Q#7YdT{$`M5vRhYMG{aE9bPn~P{ft_2s zWBcl@NtM}nL_5Fw&J7)eJ7>e|_YursgVd9&tlf{e7q40BmdR*W?$rOHZT)V$9Nn6; z*S1GHwcZU;&1{KkhL4i=YYbziFuca|I&SLP+Ye1#23ZuUWV0MMdFlktRpGbfyd@zrJ3RWGV+038Q0 zo-fg&l+lwgb_R6QszSIe_^QGH)pjMhyUu2HZ8!o@kIi}~Agz)5%3by!C>yz}))&2HLPY!x!ARfUE1}Sjr?l-;EI0iaB z?RSoDgQYX>`LdOHo$O&Emt775!Zaxji!1K)@yv+g^?s2lz1coLng zC?RtZK?X?#+EfW0h@1P~HF$+h6nf8b&?i(UDVL@y`Bxz304!cDIwpn zavsrh1Iz(`{z4jlit2hC-5qgdbxqH~4!ZWj2y|mEd%g){9InXbWc5hePWj^oQSR(s zQSHqQGbuU_UR^C70QwScK`l76K#Awdm?$!u#f&<|@EEq3_qq+P*1NJ>p;R2K-=KL0 zqH}GGQE-APl!6QJlnf8iotswPr#QwJ?cZm7=ZFrcxeXx;u6}aO42R8$`5qL^Vin>E0a>p$PXJ0a z<_Ta_edY;>45{VmGD; zL3xIY;axI<5R| zbJ`00-BNM3;&(c#PgCze2_2yxz&p|BlcNPCQM4NoJOR4GU9@QXdj^xEa`An2`nQ+e zFGi=g*9y~!GO;TXc?EwOUv;7@nGHHu(4G6d`F#1GK!d$QEcg*BqRrDKmTpkP%6kGI z8cF8z-gUF<6^KV_Dd=r?RT}@IHY)~u(1&s{oL!CQt~YJN7upIkFSR6CwEf7)O8!?*rykDr>q`fUE0>TTcMMi|ka z9Ui{)=FKI3$VjhaXh;&P$tWnaLO_vNF3H_b&(!mZX|GeV6*pYiDG*n^zn4t2X(ina`2R z3sFb~J~KCR?Sjm)rL+SY8an; zP?7P%GpS$dW<{>#vA?t)*KcugYM&oJd6GCJHA`^sSR6KLvlriRnL8n-C zHa0RukiBwedz-nwF4_m_ge>be0Hvq{Mfz8N_XDO79#5hDN-Mgc;-ilDb?tI}qYMnm zEf9v*1AgJkfV~n|5?ll`G>NEAeACv@Dq^YupO^~BDk!Gv1Z>Ftr8F+c7ZD3f?k+Hn zreGZ;HTQp7#mWMtV9nA zcM<(kBlq0(R^R`o%C&3H0&q#TvkTsk!gZNdSB!H5RZ-mLh z$rJ7qB&-2%4Zzz?h8Cuvne-@tnLmI|{6H=wKPr>jLS#~s$RGLuf}mx9c|565uZVfh z2k3R|F&(j+V?c-qW;2>Vad;xfH25Y&m|?10f{h>rj$2EPwaqxPz>B3)h}|yax1gu8 zSgbWHqb612swrW1ycvgl7vw1$!88#CI{9;gbrzz{{5SJ=isl z2r2O7Wk$6{68601F&OL07zp+frME8RGTpefJlujcD*R9612Igki|dPA=(!~RJPTut zoJ6GD3E+dDRAAj;a#dW7GT-86c&A)AIQ(H4x_&*jr6F>-f_S4pP?WofUmgK)HQZIb zj<5oVN+4N?`VJEi1gP1%UUoxmYx~c)wzq9F29DF)56>R19G;u49Ii@jhZmH`%2C)y zZkDDB0=)7^fc7I$O&)%9=ZQyaD$wflV~Rmte&3i^(pOy2Zf&mp*v^ycN{8w0Po0bG z`sZ`FWjk`m?AGblxht#ha#}Yv!FaV*1~J__rovIbAs>%fe>-Mfsx17|>sLRE*e#dm zFHi4O1DLCSb@{uutIYaW)4QD3mAloK>hEi}kNjYv>8F45-P=K6t0d@c_0HL4%3S{L zZDZCC<-do=tYWqCC-9s>=Xa?lrlU2~dzTZ1vi3brw6dw`b25r=IZ<6D3V?}dZ`=iY z&Aw|;#r+3x0|Vc8qTfY)x&c`B4J`j`%;{7!HDU>8hmXry``UX=Vv9-Kdic03wRByP z2HT)%RKwlvJmBodUFjI?1K(eGx`Cs80Hb|i`R}$VSdq{0y6p{qae4mI8@_x6UYB7) zS#hkZpMpVUdvk|#Kpp!!aK-_e*B)?^PRhwto1KoJk0m*T@4roxX8Ac*InmU*-WQa92 zdhdhj4pFNduYKSoO~Z^XNNdzyC`?RV4_HDF;imZ>^0K<0jC|sI6(^?(o($Bj6^BQN zDHbDNtMI-Yj=Z&inqhqn9jt*s2b$o0l%o0S?nCOi2_7|+7zj=%u zk@b8zDy$wU-Cj&9tWn{42zqjUUz)2~cj!jzri@)>&t;{z>tvlj{U8{z?!900)( zE@CF7+PWiCr9u#bx>S)%%>?fw*bP&ZEjPG+KnTR(^#k0A`uYJ- zfa{aAm_vYD@ZJLCkpd3eZfKTaUA~fo$6#G3LE3O;5W#;?*h+XxGr0e5TO6ftv$db} zOJE_B`L%{O`YSG@Aq>|H|o%b44d^Gl@G)0s)3q z8AKLViLE9PHHqyevBM;Gn#3-X*liLxu2nr9CULh(behDyCV?=;s_hV<$*axgl^_WNI*`;eh~SwQseVXk9HYN&^(9XUpNe41KIwuycKX}M&Wo+F|qr-qNl z$ct)7WQFXnKr2eYfbALW08x}jfB=}9cvsaeP@(4DHPDefKu$3D1w^dg^Z{!#nl3M$ zA$Um~T^{&7Xs)xfV;`d6Cg8)g$Lj2OxC4g`7K7=#CEeE}`9*mc?3agf2dGGdom5YU z^i!X_n`FVBUP(LZjea_+pHziY`bmA2;a314`D|DW>qmjY8!1w+skvJa-IDkCL*P$WK7HL%POC%z&~n(qu@}*dy1(%|sy( zia>=l7Q&i#xEc*1e6%41^_6^Grfv-EXCQtyL(`C4y+yFR{1K*hGQIk!wvla~O0Q1n zbkmXSidAif9Ow0{Isq=v<&=t3Ki5*9%cov{X(aXf%Lp@8c0*il0Y3>Bnz{VNm*z$; z9$6lsw0n7lf4+>6m*@9n7z6Wp78rTy$ntv_0P{JN%)dPKJIcmg`c=!JZJ|P5SDqQK zUvM)q*q;=VCZ3dU=l_({3hW^Y-x0!x*pf{YM8`RL8fbOX2n-f<{VJA(~Y`LUFvb;$pm!!qI+1T$gtvQr-PWKv|-76fi7(RvwV;=Nmxk|JQu2@NC-EUwfAycG3 zMC5Wjf_JA=9()}Y)uSer?shKYqRj+VFk-N&WR4Z{0sy5{n!HW1thpCD-$`BWGb~X} z-C&nx(6S_MF4jm*g%$ZYmST&&+N8`Tl$fPKyWdG1OU4z4@7-K}Z8zdA-B!sfANrlM zJCAVfIyM(7qt{j{+wc%7qAP3v!0k>OZv23Idc%*lDf5azYtilL)Rps=dXs{jSEW=Z z1c~m9M)Pes3a~yxtN-W5e)RCjb|ikkh$f4|-#leHwt7Zb2>}-6886QYQwTOFN``_n z$?z3O`O@>gbjFtse>1ytWarC}ryV`_5C3P*X+tlkw_iDbkF)(pBikFNqbu*FtO=4) zJs%G4&Sab_O6}SpUurw|4?l*b8OT_LNfIEDR4Pt&E9oc3(l@W;Aba#{2|WU24wWm8 zGg|i$6CqGNZcNT1qfYfw{b?W4qGjavM(&8xuA740&JX&pZ zV*g>U4(!3<0v+MuV@nGtw%oS%khlGlS1votSr6 zvzs2p0FqWRh*1NV5^sq5DK@zQu9sn+b zZTr+`fWzQBb?1qe;Q8LkNFbZbPE1Utu^E9CAS`l+ge*2SUa}v2Fq92SpKqX}BL$v@yjeGXv%8nu|K}u7qbW2AX5u0(RJ0kBd&74~N z=#2H7voj0UqmNgsG=|0s$we6m<-DNc@y{%sVTCY{$C7cDJF`U`*t8DpeDEM{k5!+6 zC`T!BcZU$luLU3Ad=Fm(ZoZgI$M)fW>I<`m`l@iNBi7^IoV<303r z0`jIw-&~@*(kYjIS)GU{bhy|h`={d|ZjHelXU99(M^wTNGAZed zoj3fwkd*TV8@s?yWCcWpi%`P2?8 z?$GT@fqN0_u4AG&hIbfA%yNFN{6@T#aQg@z3EMy{o-}|bBi3M&PA#xJ;w$5c0K`%V z)XI#Y88UN<+C1F&WVBF4<@3GZ_RHG^(4JoFUY;xTG3H+QTKRL31W}U_v}kPcm?}@W zB>>0HOG2CmK)Ab=BaIMl@?Pf_4*8#Aefo(Al}TQ*Bjl6Lp9F(ulIB-T`%!Mv+}DY; z$#b)GjKtuy$w4B`m?MP~AA*uhez+b$w5Y${P%CsVmc9u}KzEPT(n;U~nxfQ5kC4A| zpBYB$VJ^+otNrWC_U>=;GI{V|rb2fd`=o3>$(c^djgG?4YR^NmSHAnlf-H3S!WHkW zTq?pxSJLJa%hib?12VdxJQ6${8F*tZ4(XUD{R|4?wHq@;prEy1Pq*8!t!M{T`#a^u3y?7 z+9{2K0^xcI>z9Idu7|zjj@DOQ3eC znN0+0^tZ+8QNPf1c~aA-muAkuQgq?OVuftuM~_t>pAl*}G+%0(J^Bo{p~1(7RF`)c zp<=JVUg*e+KqDaWgV~0{p=6)$TKwO@7hY%kbJfmr#=})jIHOsZ8IF(H6X91P;v5GZ zoToexZ(9O=gYXmIf>f#dt~3yLn-0Q_$7YP#>2Y|5Dk9F1jhaMM^c?`+JrWH;DYSrm z>g8wxQso|%PSg8M_KR3(4nc^a?C@KTYDXy^?!kR0KE&QOqNO*x&Q0Opp6eA;yR}Xq zfUiMhmB|bFgvGKpzVls!(yv)99lVc{1VD-0f#^JW^BFHwR9xT5g)?Vo5ThB_=M;Im zkO}N^Kf2$7(BcHHO(WU^NLE0>!|C|c%+gHt3G3|4nX_jEV=@fx0_YeNoUs;;oto*g zd~L|(YGCH9V@u%v7VzcL%!$Rv7Eb;XFe{HzAcD_MESfx%r+0Rd$2OgLD!TD&z^ zId}!Z8Let%eV8 zg00R8+)QElT46CFDpzoX^#F5F8V?~5K(3LCpbi9D4zU0e5MZFKP|&chi2oQ>;qOLjb& z1$KC1=FC$M6rNZ*dE&qj=)*GyD8%u@u1xyjToxAiw0Y--F>STrTIo!wjEI+cNU4+z zXc%UA`7|B(0Q^=7s0(&xEC-T`(i6xu(h%n3_=62hk)Y1MA@Q(-^eY4xjfN5;zj5@^q@q9Ae3L2lIdJnqzpX0SeZfi@&3L6J^hB9URPkt zagm6Euu&*`;@4pt0zqg5jxAL1?+M@;Ao`i56F{>lWQ=IN#o) zu1~<1fSP?$LvC4V*84613?4a$56MgbgP4t_aD&iYXjpA*D6-`KGNC24SeQmCd54_~ zRS^DEcqF$fA*uKs|5F0+4~wSfhSFqH*aLZkJC#h?yce7ikSv=w8c%u^yj}6Ks_4Ob z@iMJ*JV~^Lc%rav=^y0msC-;3+o7@(y?v5xcOzo}dU5E%R6#q2oL+=JY(cgv6Gu)D zEEkZgG7_u>4%Nt189mIv&O@fk=tTx~amZ8|eawKbGBQ<0KQdtb)PhWvF@OvxYx;E? zgLs76tT(RS#@JD)|6oMK;pEFsSBhB>T*I!XC#JrVY!09w7Jz)k!Y!&aN70MIc;!{W zkUcG9RxBwU?TW(`AN+@Vr;=O8?(&ihKJ$v04$lzHJYV5jWu<@JORW&?&r2^23-9<$MV ziW>ay4NKt4C_q^HOvT=*(7`mXtG}`6;q6NvS~@?ZaWOemVZStP^{|oft_J0HiiDI@ z3{^Zg@vC$}H&O6rD-4&TwT{(7mS1!-zCYoTZ}(YhHXr?}#=%XX$y7=V4R^#zhaHe^ z9c4nV;v2t$35Z&o`mg#dGmQFo2=BeoXSAu<@SVRW;Q_#`YU2-Kxv^oTZ_ybXI~xxI z4!Ijv3a$Fa@BEz!j{+!l!w-RlH-7gPoq?(P#-o5$HJRqJ)rHWq1d!0;(|AO`7o5ED z>sW#qwZ4LZx30i@jSANJ9zs-a)ZyuZ@uK%K)HR%L8^80fLHN6Yx0o*aCT|2updU7V z=kH8-6fjRVbG+^vz)E=IiZ=$B77Jk^H~bLvz{ckV|hNtE;c%EhKjDRAATg_9S*5H{lX_Z%b@v#CmR#=F1GXgB1Z0$x8EX+yP7B$H}YUTDphX|F7Cyae3LammL z&L^iBxE!KSS}c@lkI(;+D+FzW%X+}!LYM&ejy^;UAC%{~{Dl`3-hqS1Unr09NsoMr zXV|0i?*RYyC#)9!fcx)-6Z}9gC>Z{)526o#oPbz_@73QPmQr8iMj-iL4CgOB-stO% zf;j&17nSfY+)Yq{^rSBaas#gux^`aX@#HwV^c34&Ih~wha3RQs={Wx)qaWle{zx?l(}|K&3q1Co9B+}?p-T*Fl2wIo8@&!O z3vt-A$Ivjn3!fav8gm|=vaI#s1-AAu?uLW~?&ugMTtdJ_@q0`zmLGkBOa|gOSTMt| z7k-7{YhVTr1_mPmtAepWxCK*tw1Pmv;4>fvLWj^B3=n;0C%_0`YA`Jr5kz(v5=IFc z8)HTWxIH-NLFNV+18`vJFdYEA3>=SW zX#lf;!g$30(Evf5{~&*Ys~+FWAAXJT;*sBAZUzT1Ks>ThOb`A@5q1P~gg^3vg)vk3 z!@gsx@PhThwH1FbUHHp_m@nNi%oeIl9;IbOl=m|43|p4?j(1B7@MDO0i=E45V3ZGDv=GDY#k!ym94iyY%FqjjTRM)FA(G%dadcp&FNRACO<+e3AOmj!BS@<<@-epzawMPI2Ib{jZXKkh8LS7>q7&%m zKEi`k!M%irRiywmG$3!eZBVJC0g{8*%FG~SqKHakAM0%HjqYylj&AyKb1d8*m<{O< zfgCwfC1Du(QUkXN((;zu1!*b6ErWSe-%5+zBFK>u;oM_djfHy%RjZHXH8%}9sw!1; z>~)kF0{u4wx(RI4;zKvUBR;1~>4Bb;9yz5$NG#At-`tHL+HF&@JC zRpFZ!Kf?K?;F~=ya0m0dW{8rtrL%NUVnD%U)MYm$GLs73-Pv(yX5sM}>t1VeW@+(b zR(f&i^dfu~pcwBUwg$k-Cc(MK6lQ;r(?3Wh)}SDKY_ArebS(d%Abi2@F=&3opZ)&@ Dh;Wn* diff --git a/sources/INTERPRESS.~3~ b/sources/INTERPRESS.~3~ deleted file mode 100644 index a56a3d88..00000000 --- a/sources/INTERPRESS.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 16:33:05" {DSK}medley3.5>sources>INTERPRESS.;2 223462 changes to%: (FNS OPENIPSTREAM) previous date%: "19-Jan-93 10:38:47" {DSK}medley3.5>sources>INTERPRESS.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1999 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)) [ADDVARS [PRINTERTYPES ((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))) (ADDTOVAR PRINTERTYPES ((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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (12218 16759 (APPENDBYTE.IP 12228 . 12364) (APPENDIDENTIFIER.IP 12366 . 12757) ( APPENDINT.IP 12759 . 13210) (APPENDINTEGER.IP 13212 . 13637) (APPENDLARGEVECTOR.IP 13639 . 14439) ( APPENDNUMBER.IP 14441 . 14797) (APPENDOP.IP 14799 . 15238) (APPENDRATIONAL.IP 15240 . 15596) ( APPENDSEQUENCEDESCRIPTOR.IP 15598 . 16582) (BYTESININT.IP 16584 . 16757)) (16795 54267 (ARCTO.IP 16805 . 18011) (BEGINMASTER.IP 18013 . 18167) (BEGINPAGE.IP 18169 . 18405) (BEGINPREAMBLE.IP 18407 . 18658) (CLIPRECTANGLE.IP 18660 . 19027) (CONCAT.IP 19029 . 19175) (CONCATT.IP 19177 . 19325) (ENDMASTER.IP 19327 . 19650) (ENDPAGE.IP 19652 . 19909) (ENDPREAMBLE.IP 19911 . 20735) (FGET.IP 20737 . 20921) ( FILLRECTANGLE.IP 20923 . 23134) (FILLTRAJECTORY.IP 23136 . 23633) (FILLNGON.IP 23635 . 26032) (FSET.IP 26034 . 26218) (GETFRAMEVAR.IP 26220 . 26538) (INITIALIZEMASTER.IP 26540 . 26997) (INITIALIZECOLOR.IP 26999 . 28167) (ISET.IP 28169 . 28421) (GETCP.IP 28423 . 28613) (LINETO.IP 28615 . 29125) ( MASKSTROKE.IP 29127 . 29281) (MOVETO.IP 29283 . 29501) (ROTATE.IP 29503 . 29686) (SCALE.IP 29688 . 29872) (SCALE2.IP 29874 . 30092) (SETCOLOR.IP 30094 . 32240) (SETRGB.IP 32242 . 33160) (SETCOLORLV.IP 33162 . 37662) (SETCOLOR16.IP 37664 . 40610) (SETFONT.IP 40612 . 41308) (SETSPACE.IP 41310 . 41503) ( SETXREL.IP 41505 . 42832) (SETX.IP 42834 . 44479) (SETXY.IP 44481 . 45983) (SETXYREL.IP 45985 . 47574) (SETY.IP 47576 . 49165) (SETYREL.IP 49167 . 50361) (SHOW.IP 50363 . 53415) (TRAJECTORY.IP 53417 . 53815) (TRANS.IP 53817 . 54037) (TRANSLATE.IP 54039 . 54265)) (54298 60326 (\CHANGE-VISIBLE-REGION.IP 54308 . 57969) (\PAPERSIZE.IP 57971 . 58792) (HEADINGOP.IP 58794 . 60324)) (60327 165874 ( DEFINEFONT.IP 60337 . 61203) (FONTNAME.IP 61205 . 62135) (INTERPRESS.BITMAPSCALE 62137 . 62699) ( INTERPRESS.OUTCHARFN 62701 . 68873) (INTERPRESSFILEP 68875 . 70036) (MAKEINTERPRESS 70038 . 70222) ( NEWLINE.IP 70224 . 70956) (NEWPAGE.IP 70958 . 75924) (NEWPAGE?.IP 75926 . 76405) (OPENIPSTREAM 76407 . 84121) (SETUPFONTS.IP 84123 . 85115) (SHOWBITMAP.IP 85117 . 89779) (\BITMAPSIZE.IP 89781 . 90558) ( SHOWBITMAP1.IP 90560 . 94842) (SHOWSHADE.IP 94844 . 95641) (\BITBLT.IP 95643 . 99847) ( \SCALEDBITBLT.IP 99849 . 103494) (\BLTSHADE.IP 103496 . 104833) (\CHARWIDTH.IP 104835 . 105285) ( \CLOSEIPSTREAM 105287 . 105614) (\DRAWARC.IP 105616 . 106063) (\DRAWCURVE.IP 106065 . 108361) ( \DRAWPOINT.IP 108363 . 109400) (\DSPCOLOR.IP 109402 . 110353) (ENSURE.RGB 110355 . 111019) (\IPCURVE2 111021 . 125530) (\CLIPCURVELINE.IP 125532 . 130230) (\DRAWLINE.IP 130232 . 133814) (\CLIPLINE 133816 . 138516) (\DSPBOTTOMMARGIN.IP 138518 . 138934) (\DSPFONT.IP 138936 . 144520) (\DSPLEFTMARGIN.IP 144522 . 144982) (\DSPLINEFEED.IP 144984 . 145651) (\DSPRIGHTMARGIN.IP 145653 . 146450) ( \DSPSPACEFACTOR.IP 146452 . 147537) (\DSPTOPMARGIN.IP 147539 . 147975) (\DSPXPOSITION.IP 147977 . 148964) (\DSPROTATE.IP 148966 . 149144) (\PUSHSTATE.IP 149146 . 149908) (\POPSTATE.IP 149910 . 150415) (\DEFAULTSTATE.IP 150417 . 150650) (\DSPTRANSLATE.IP 150652 . 150833) (\DSPSCALE2.IP 150835 . 151010) (\DSPYPOSITION.IP 151012 . 151313) (FILLCIRCLE.IP 151315 . 152398) (\FILLPOLYGON.IP 152400 . 153625) (\DRAWPOLYGON.IP 153627 . 159898) (\FIXLINELENGTH.IP 159900 . 161114) (\MOVETO.IP 161116 . 161480) ( \SETBRUSH.IP 161482 . 163492) (\STRINGWIDTH.IP 163494 . 163897) (\DSPCLIPPINGREGION.IP 163899 . 165075 ) (\DSPOPERATION.IP 165077 . 165872)) (166066 166821 (IP-TOS 166076 . 166336) (POP-IP-STACK 166338 . 166633) (PUSH-IP-STACK 166635 . 166819)) (166882 179446 (\CREATECHARSET.IP 166892 . 178683) ( \CHANGECHARSET.IP 178685 . 179444)) (179447 184052 (\INTERPRESSINIT 179457 . 184050)) (184053 184611 ( SCALEREGION 184063 . 184609)) (209359 211665 (INTERPRESSBITMAP 209369 . 211663)) (213092 219748 (NSMAP 213102 . 213684) (\COERCEASCIITONSFONT 213686 . 217540) (\CREATEINTERPRESSFONT 217542 . 219407) ( \SEARCHINTERPRESSFONTS 219409 . 219746))))) STOP \ No newline at end of file diff --git a/sources/INTERPRESS.~6~ b/sources/INTERPRESS.~6~ deleted file mode 100644 index 4799b26a..00000000 --- a/sources/INTERPRESS.~6~ +++ /dev/null @@ -1 +0,0 @@ -(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.LCOM.~10~ b/sources/IOCHAR.LCOM.~10~ deleted file mode 100644 index 252556ff5b53931850b5ccb1bf6f9ca08c7a4434..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 22579 zcmcJ13v}GodFRZ?FKncaWFdrb%taQCq*!7edK#C`e;)G8XlAag8G~gMCbCB$Y5tao zA0%YctxZD6V_(K#pv{sK0)#Z2WHgd`@N-giPYCRG%bp4%)$E?M33SsvCmluUw%f&M zf8V|T*NlZpo30ON?(@5^@BZ%hefRs{=3uBVk_ff+MPi}0NTQFk?E^}nU)dXCjgdqu zG#HB{2O8P-!H^P6DgIblvR_GtnA_D-*-QiiD3uBYS)<$4rkr@N&ExX8n8&@lqhq(X zr;#-`9-cb#(6~C9VN;W=kyZYyV6y*r_v}A5di2=c*^!6Tk;%JbQ-?>?yN`@!)X_)0 z?VWe485Il~qn;mU$Z*OFok>luI`2f7G-R{oDUvHGZ z(V$pmudBn|%MOo?Og=bzj2)l4V>fH=OC%W$W`N^Y3$(C@j*dP&K6T=l=rf8ny4`Jw zsfRHg?jGj$?8bkc-rsPRJ22+K0cGDlCg&Yfn`F(+@`t(=2nTqA?N1QXu%L_uWwb?h ze7_PK2=l>UXpos9R0=35Rw;i2JQzwcA`uXO#h+F-OeyV=R4C4psX+{$DDF=LQW1`p z4+LVnMXP$C71?`Z+^@v$Q3jK2I2qZS=!+?PS>^D+Ab5FD2}TZ}OfVFPDT5)*Sdb@D z0X{Iqn&V1f5R*HMP7NxFWDIQF(t@()KxGeNEUxs2{E?K{3nj!VO=^RoB;P+6z?g=$ zYRcfCGDHL;iAd@?*=BnI>?~1>?H?Ej4I0r(5E(#+`8~nkVa@yY^Hhi>Ln#HxM#Lyg zEtZrF#ZpGWy`hw)Ad=0A5n~D6qr`kMt^_epa+burHV=y_8o(4LQkWsVpVU@qSIgs= z(b85#3m7u(R*Y(p4=`f^%ZA-zSuCRr=GW4fvIWyOOr^eKuo$7#{(*KqUecG6uB^F| zeSJa9p5kW1TF6780VPFv)WRykD~V)ENu;nrhU3bCc4PrR6Ya^!L13h(2ki~VBZ<;< zFH*IhwkJb-EteQ<88cnKhoB|7tCih#7i$cH z#Q}wrhmVg>O&)6`wxazklIc$$ABD?++!IjJJUklA*RZ_EMM) z^ZhAVRtvOY14I(E2L}gYgOR=A6dRWCAdArsmZ4yZD1&G+m`wc+wqiJhtRziuVs8lD z;{&Nk9CL}iO*Lc(kuJtl+2|iVJaXdLC_@!?X!ODHNucN0C~$KS37;7q&5llH7>)v* z7~?9NochczHteTzR6*ixhCOg}>Il}#1>j}9J#6F{n|gqC-08iur<*lLgFqmbm^wbX z8>GjPH>p0tMjm)z^ziXx?AY;<$;^m4H95-Ajiblf+K!J+p+BD)KR(8ej~^LjNPQR? zY~;l8sUsuD$8pl3{)3~(8BVyPAi`8S{m{t=rdac#hmW*~WuaBpcOJ+bL<<3&qf9WA zF@jzZ4NYcfI9^u=CT2J|@t7s&B|EAVcTJcGo$Q0Y%4fziAb!H{%>xP%@{3s*kCZ_ zkAX~IY%i!EXki1a!=y=#3^1>mfJWxG*lZQmpIWax_n-~`e2V`@`t5i6G8wP0m}dpw zA8&fy_GTM5REGX0|_M_g8bDhg)FhIh_+Np{G_J}c%gce~oV{OqS_Via}r(!W<-%JK_}>RS4eOndVXaYd$#E1KOd^iCO6 z0yyf>xehQB2R@CB98~~v{t*D6=h`&OFpLrWbNJ|Q!8R4u4{iAW$w#M%Wvo18FxEAE zw1qo))ym9$#7IubNY45D*PP>ooa4mu3khS66K|&L3cMCfR|lr61)Fgvn9iAdh1cx_ zKZ5CMi0QhBBeXfkVRa1)x(&{y^$6=dNUxGuLx}igzR|6uC03tWj=s|%^>9FKx z)>Z&ZE+c`8q1m5eGpti8=GLRlYGqw`sM@#5|HQQI+Zr-8N@Ti}y=)>A(80i_sKlnv zlyD5N=^7ZiTv9^gDWartRl2H>;8g@ri3{iZqboC>2u(&rn~Wjud@9}#9(y$2KVM(y z&o11Tdq;w)KOn%gur(4co*r|C9T&q9M`Y}l!YvXwW4FY>MILNRXh)bEcW;-8H_YwD zb}fZ8@7ny-WhCqT)N7CyB<6Ua10@uQKG# ze{jvok4lV-F24{pFfRILeIb@z7|!KBgjp|@GHd*nI4xGUS7TOBM~{_R0csW~^j-sn zCP!MK5c-qBsT%M0m`pBtx68u2o(__qgpEV;st4S24ZC<;*Cq;nu~xN`$tHPn{@G0V;g=A#25z4zwa|x()mFvSK2$=R1ovw!&`ZxqK(FPi@|M+G)Cx5V| zRJ=Nuy`baPd6T7b(Tv2fY$=a`k4n!$@X-aGUCyt?P8Ss^&BY1|NpqKobwvn5+-1cO z>~ar#o%yYb*Ev?4t9W$Ueuqz487n%G@QOmx;7f|=51?$^sk8XMQ>^Su_*$AESX|Md z^m0j_3AO&Yjbh3-(3BrqCw^YH9hmTo&>N15Y*7Z&b&w@_-H$5%uDYTs%IlYBwnh`h z{KJBUsiWv_0?D)J{_1d;Z{rQIXCl15e-ZoRF%g)rURT4LGMp{HSm4`v(|k?3Mik`E zXXCscNROglk|C6>pI%yl^`OD&#{WS53=XQN}8ggBHh;!K{|7RfH2i}goF#9l8TAV@A=$o-T~ zW_M>NOAx9hnH!S@yNPB)AyH3>K@HX85Wcm7y=$*dH^7pNgM)irtlPul{aVcq6YZ>v z>GA4o-(u)`VlJhD)|^o4ok*jJZC_`z*?nRN;t!_Sm#wa;h*Zq23p?!>!qI*?(1_z) zG`ny<_djjT;6#i|Cj*04$-p|n6J+QzdLd22X8Q-I-EVF}yJ7>+-KMUNWyZw}SKsdN zO@!q_eoyr0t7AYvo2`(0?{!=Cj*a~lbG7k_m|TyVu*`GXflV&5(PB=@KP0ILHSXcEfPIUrF&eINsP%Vq>_wtdl^P-^+%Fg%&86tzB9_bn`JI zW$U{6*Uc73lQ5uL=M^%sTUZv_BZ*+>fDn#KN4E_y+(L1W1pKy#mK z4-5VL`%>)un!XG_4Zm)iz`l^{Wh}r!u~;uh<(bh`2uCtfm|hrCSF?+jm5B;=`l2Xb z@Hr|D*=U~KUL3zP9(iNn_Vku)9n8DA3T{`IzH?yMle0TOJ49cb4im;CEcRH}hWK?j z5{rfQDzSEKE=(ouH0wN-uNBFc*UQJ^UoYQStX4x`cCr0rY3V9mEwF@zV_@CsWvw(R zxX{D>h~0IAU4o!ovsTNRDeJSD>Y7cwDidDLy9yDxb`del#@bzpVC@q6+SNp~-7^Bk z<=z@dt50yJSU*UiUxD^2j(z!qGyft&x;5uQJR9p58+LAIB$46rWM8Bv0;#sZ`j;J+$~H1vd=OI{t$@OO-L`>?Rqq1XwF} zdX0)`n#@PCg*KS`?t$GL_hxOl``V8?+w1Xq2^bS^e*_MF6mMUDYY5ghXZNEG1#*uI zbP~o(3%}E8M0Tx#5+vUzSox)Wf|VcL_quH$yY!|4+#bj-941-YW2&+eiLGE^971Lv zEqjn|C+RS%#0g`UDvjVjI>!ML7Be19q6RvdDlis^Zgq7C?q+^$)_aw~V3Mqom2UEZtI7x6;_eTa8nGKaeXz?1WL9M{W6T0Mh>*F@trZt3q$oi1Ru^(Tx2>tt{ z9Q1NQV)`MQoHH4F)VGH0e_ogU*EGArT%}3>Ov?NhvzK()|AIyKACRaoMf^h!R1ysv zHeKit)`TBbT+*fb3ne+aR9{o*4=-gG@1Iznb^B*-+FNxxaWZ>oT_HTNJack!X zO-3YJe5p^=D8wNFe3Ha~gECV?D;as+W~m{ArbZF>FQSv#Q&6hhO4gVKQD@)OgmwY(}&oY@5(Us9_%8{-VbzJMRlx|MfjxQA%Dc-MSQ zG5<$UM4CWgvASYA-_3hgX2t`0N6tq0ZmNnORBhzJ4EIshyLk}Za299UVHY)<*(00T zgR(n$EW^W8wvWfq%=2Tpt$a6nxx2vk;Ac-E_vCoZ^V6$6p(i;DFP`EozJ#sSfqNM# zPkDRF6cBGGAk%U-Lx<>wjQ|MfW**qK)>2|f3o3zGQswo6ni@m)D?LeqgjJw+qeD8> zyWMN+V}SLNMsSMg1a(!ZtclJJi^yK0HbH*TRV0Z1dJw0D9_$8AXgXAfSpbKSo(dn4 zGR28?boSzwPruJ+heswqejHb+Y=j*UgGgRb3Wt3B(Zk(ICa*NCkt{y3u}mtu33@v(;C3s6B0=KeCi^J4Drf&8!^8STRF zW{q|wLdT53c9cRij@;1RwNO|A2HQyuTrZGhu21~j2K}V^Q=5E$LL2%IePdxEs2sBC zXxSps5)dgd`cn3y1uchk8Tx`4*2^CXn-_GHyv8n43aC14Itu{H;OV%)$`~NyVjzF} zMD8|#4oQ(MwFUNvUC9(^bvyUZE?{XYMQz7^)h41H8 zSC_wpJOq}X7|ZPm_+Yi}PhkH)+Mk#|e=dq+I{&eVG`yVrMpO?8u9(|6@n|GEU(C-Y zVoQde2G!Bk%V5-CfQTlA1%xW^?AAl3f_eo%fS?MZzzP8+}SDIg}8$+-|SQ8a>zK zifc1*4#1onhz&{(g6IvG67C;Lg_4*zHz3lOZCtKdV=%_7u@>MDvjUjRjK~`X=_y8b zspdP;-4q{yUzP5xb^T>zxNygHyMf5Ml;~nS7KGCg)~{PA<8y73cAJnsCo;Mf1XGR` ziLA`r9FAt>stV})Td`QqFs85*^8oiZaU?J=SRSS#x_uT2G#M^N^CH-(%(aWUg5EJ( zCpusgY_WdBT*D?rY+wuZbLxm_{jAjQo#=zgmMqs*=hTMIfjus=mkZOO83Tb$f* zyy<>w`r@uB^9xbm%R-5u<*1>W*v9}W68FDRXR~b#W}Xzw+c(!O)C@oEVFf*A{1#NSr(8 z=kF6`W`5oed-Ttua=l+Srhg~R;!fQEC6<=tEJ|Y2tB-_cc3e}unTj`8Va8F@3N?)aAtlaq{RD{7h5Hcrncl;?I)y?{*!{(YOK3DLC{Q-QbP`Q!L7ilY$;Ps4- zT_>&JbS`TcIerary5?HbFm2qYo?M=JOs(iAmHA(X%Rs8G5YF$d9Y4MUY zbYtTOW^T!S;##os=l%jvbe7i=zMKs7FJ^e{@)LlS`{T>s9CNCfM0`mo=i#{ANCLy@ zQq*>y45KEBn;B25C(DyRXHBZEaQ4j&i1M=gHoi>{Y}W%!3t$x0p<5!+ewYxNpz$}# z2`?moWBD+Ej6C6TpQcm7Q*uh=ci@=#rmmg*TP-lX`e`F14L#GVziZ%KO(7xRuBs3> z(wv1jrCox-pauX~MF4miooSsi$_AFfDo@{aExiEetiser8R)BkZVS=|W z&m_Y~K9KF{waLg*oavSXFjwvKKYeg{+? z6RkSPK@YhW*LdaymS|!juBo&Txg?NH0dRr#E%ZF(DPtP2Jt$}eT3}i!&;p;zfffj) zCrO~iL0|$c%pCwP;T+lRwqh%hF2mMN_ARt$6aKP5cQdt&dd*=22y=VCBR91yGneI87Y{XM}LE zEG{@x+6gbL<-~EMO#Rt!;YjlTrGL>6930%B{@#S}e1eH$;_{_Ld<7;E+*@WN)$8Cf z%$+Ow)-h)=_GTDY3Bsr8?LeZ>rz95V=MTPC2u34`rPoLbJe7{;7X7QpQ;=Qun-Gm2zIaewDQu zSgRwx0MVBcdsBRSLMtM!RfL4#6EI17KcqPQD-&?B`7w!MDKx(hG3*{znvgXrw5ys1 z=}+1WZZW?oAyr*|_M-Plh*%_l!evr^76X4URG=P$Wo#8v2vPh(zok9`c=SF3H`eH* z{Gvv0zzuHgQ})MF^x1)?(ute+R=`-RxP))T{=f}x#XsU~bNJ>qiAj-?P`3J)&T7|I zk&8jCyDBI~ldD_yW}L;uD43tr>M!@ejZu75Q4&QqJZ6v)W#K8qqTp zlO$>ci7^X_?-2>mVMJ$F@pR#FQLDyMYuL*~HMg3Ht>pK_R8MT>%;d&5AD!H&E?nd_ zUN+aro%d;_&hwgskdGiXWTPuDM%5cv@=asT3*4Fe8TN4e zjX7y(+Gx_X7{pA`7~8I5erv%P`X{|?2K|`%m6CaW+HsS*=N)ocQ}vu+V{)B+1ri$jEVxgO#106t;iOm$k*a(=AFy*npNA$xO!vp^aNT5@fY#;q2iNBT7V-as_T8AwSSu0%KZXG z+KTy4811U*cOm(x3i-v|#Ou|A%dc2_e+uP4A^VGJF>^A&5$j0k6+ILRKzh3!kjJ+> z?CAz9A>Z~ja-~!Eh!Uh(3sU*P310VBE|QNTinbZG&6a2G;tXxibVSk+4lUC+7Z3BD zz-_TPK}5*H)wkF2=8Cz`j**2yt;byKRQDuSW*M(KtM1`dE3?mVTZeRQ{y)f`HBrH)<(X5w2_+!~K0>@Qy_&J7TS=*J zb=bwwp5m?c>DA97j*;)m*CK0|$aoqV*`?{#Px59*x_NqapRKtU8Z)jeb|)k80es^u z#iBOpIoFF@pAXH0Ss7pG(Mc$5r9I@AL>JNmdwb}VH5?LpfU(xHBySSkJMOp>jsrOO z941q1yc5cENgQ&3HQoVB$w!go#aB+sjax}; zRq`+?>k+Kf))H8u@)Bs?kdeD_A`Q{;0Wqlu_676nJ}Ebq5f>+q^bVpE296XirX4Z1 zKfl2NBkrfx-&=dHG${=M4Q*c~2zVB5K5&}A2T(sduezekGd)p!HiT~zRM%Svs61r~ z)*T|}zYD6Xe|hHr^i!D?Dic;WzrFBk?#B`Aql>B%TOKRUx?w?ZD@j zUqJTBNVRKI8OaTang%EGE~yH1!C%E`zyG4V8kxJQ=I|{JKBB3*oV(1OJAvZ4Kfj@Z5I=ty+RJCxPm#e`>Lz$Vf#=oc#m}MzdbsJXqexfdvW7s6=c846SP(4~JvVd@^bgrj2hcPYLVaZsoDk+1`x_JHbeV%6fs z`~f*g)TCUFrfBqobOfUP{0?+CAoIL52}CI@<2wYUZEA&6r(KO2Abx|o-ifYYHlIY} zL~fv%@0IPyUVZS_M2mVE5wt$|vEEBe2m0~BYef5lAE@iZ98$`hn2o(M`(>)`MRg3G zGQ|WCxulGLStpm0@y`l!pH?@~pp(?I$7OdgyHx)G=-JUr5$UJOhe1rMd>6%&h--xf z0|XF{%ksBUK6M5wM8vjGoH`@RU;V!nr+JfOzxuzZGgp76-r!VuF+VECC8zl6o1!1G z-K&2>^{5>#=w6*EZRhH@%GxnUy-A~pbqXjiv5@iiw+%KQIY3{%d?`#%?L%Q3(I4%Ic=e*eEv z+-&>(ixfB8e*YDUn{B`Ub&8v9zmE;@#Ps`*sW&>UdXypB>oA~yx@px9_6LCq>wexs z+Cla5Z&mw1_FUL;(0(E67`9)EIqoNy|ahMQ!m%Tv_6#SbmO??!jG22`zsi*DBk3YCIh);Lb)L%Ts76QTVFN zJTsmiD1Z!YoL^#8+;e7P+IE(Qe_!-)EFCOlPfqY)zE<5#AIz;h#k-!!=C-SjTtmO` zuo5TN1>SeIU&y1U)Qa?;1>W^M51&;x$5-H{r8?4gFYxHMBbmvKf3|X_pssri^7}a? z?_S`s{0_d&B!sT26+Ce|^CcdW@~v;-h)f*`|f)T1PKCGPOU1zfC)-R|IP~<&x>nCzM zyv{S~h8!g3GrY%fiuc%!2^Fowi(?_Z3#YgkWx5^BPuu>Hhx3t4R`by3dthee?c4>+ zsf#zu>spE%qepr?E7r>>r|uHva&Z*A``T=SOfY{Fk>Yzmqo3~)L~`|%)X)3IiW*Uw zZxAX94rx#dmSvTQJu$s>xKd>$ocC($}AIcBw6*vyV>DKszu2 zUlx68rSVqr0kOiC;Vr7WEt60|rD}{0_-A%dWo4I`P*e7K478b044Q^me4b| z)sJK32fRIdWL16%@ANv6@^#*DmiJ&(Jz_qHae5|JzB9pl-a?Z4iBoEuPJ)!_W?5<- zN*T?gf9m=L!IQFRPJZq!`EjQmccFYIkOp_5R1|faO6qP{fR?l8ZBbm$m|jha!qgo} zbb3|c?ZWN>JEFxu+2e(=266fD2fQipjV|AhOKd!`0ddyMagz~L(<w*z))t~F4(e5^I@(oO(17DgCJ>G*6dz#F*I}G-(8YR zA0(Q&Fk6@8!VyS6F7&5RNb|Cm>48RMQs^oBG=_Asatht}?9r^zjVnMay>9ZyHhR+*U0o%v;H-<}XPW0E>%^q%L0HbQTo9dE2k9)bKnIpy zOZD`M0!lK;1B~qG##I4SlP=QNQr4$DyfEqqBKJgM5hc+s3}Rj^IJBGgB>bN7xCv~~ z6ytsE_l83KFh%2gDUR23;M)_#n;kUeB?LW~@ZZLz1uV;O^1&r1tj(r+gs7_|+J)sV ztq%q=%EO5iiXz8TJa|qjv9~=59U3o%(C5^85Uh^DIlh>$F5%ltKuYuA=Z{@TD zm-fPgt&0ueaUU&4Zu{bW2pXMyQpZh-JC_sThVL7~Qf2oF8>D6{t!$>ZC-91k%hkv_ z;A-037@xv>G>_nkmDGvRV={E_Xl7Cmr^Zek)sp*;j?4Vy$ng_LwcrU+yM=XtVVWDG zBaO6ByQUGRg)5`-KigvZdpD7{_p*jy8R05#6ES?f@V;=5Fz_!t+a=w z;kY|Am^r_;0nheLeaUoYYaT;3o$BEFXRzf1O`A9fdTMh?s;A_xqj}Q zj44k!aGOeLSH!KZee#{lIE*V6)Qx1N4d*D7Yp%8`{b2{s3Q@zzm;8#@!Eda->SwMw0~F#0~EH#|9v3;?K^0jFnq8Uldy67WGW3IJ%}tP_NP zh-uoPv!Vo?aNv|bbOcld+5rNZz4#`s9l!vOI4@8MK^KA^oR96SmqKvIX%`PkdBAM# ztQ%?W9uGoY6hdR|3=b{hKEsU=y(tCjTRWpi%WyQbGYIU49_)L=BB}4IE&;vtOcgHofbqE5!$t$QhUrER z6N8;5fzri>$Pv!I5iqc^n%RA`)yiy@e|Ae?c2jV6eFz>FN@k*XrZABk&lb<9x8)Au z{Tl~e9o&_>SFJ$O!5l}@I!gL%E~u_Y($l#;NZLS2b2+!V5lIWV79?$=q!nlnHx!?o zv{&bDLfU4eP1;?L<3eI~{iHpCd&GqUllCLN$&E+eI%Io$0pHAASr}5XE3our7hXm5 z9W?xm@5pNLTVxwPvKm=|)#JcKK&_9wz0fz;Bvhq*eK>$@aJt}csYhj(z9=#m4sD=1 zO(AuAP~8)Fd*SV$$SuD>tcw}eo>T){&==sP?BgMGZV5vP$t+mL2pHdu$9J#+&?4=sC_Q;!F)x++UD;dVSi6AnB7$JHS=v4T! z3x{lqUyN0V=Cjp!Fv^VL<9m38W0RG>7{};_x-^Mq0EycBVC1EsKc9viFkfkD16*;? zCh@8r{2o4}n>*0Wb-qks`SiFmpl(>Yx{Q;@52iVzWS5;j{}LrGm(0M_L&wLDjDK#l z&AfOt+Vilcraq+{%WV?-r_u9znkDU&LQi4&AZKyfg zt}z-EtAvZ2UgDoXA8(mS4_iC}Si+gW2k{sw()D%2BYkF~PIh3A{>r0WZbz z+L|fU;mO8-=?CyCuYCdUqaMJsI1J0zR?WxdFyq>Ch*xbf2*bBnD@u;sQX*+?yk~Us z#3OADK%0 S#aC1Go-94(i*=zF;Qk-;A93#h diff --git a/sources/IOCHAR.LCOM.~5~ b/sources/IOCHAR.LCOM.~5~ deleted file mode 100644 index 09f8eac7b8bf53227014a8aa63c773eba9fa7c7f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 22453 zcmch93v}GodFRYXeqfL~l4T)`V=lrtBgGc;&|@ULME`lnGozWgvNQ(EC`=@eK+^mz zIg(65Ha)e;gFN= zWGdVnkM{M{v%S4xC6rPE@pZ)kr7z4p?uH5%0SKa1DjZ_88$J_>RH9V4E1&Y=Aolg!;@3@WCu^FgX8zaCr%8i_naKgsKbx= znp*BrN2gAmn3x>CXKLc~Pq&pXb5ZCz)npLKRh~ddP*RQx_Ymie7lEv zeI4!=VDW3NsHdSK7zy&E;&!_|tRv*FaK)L+!-6~%W^NWbnn?6Fur4GAM7wxjN{Pl% z;4uptm~E%cVRQ7%?@&f|pRk>9I5W!r6SjiWmW;+L=zo_sj4^_j^@dV`IKXtp4+HwK z2G+xxO_(%D5A&G?7-Zo_o2{(s(_55hAF|*l)cia zmhT_{7o)MIlWR-SD(?)nJZEWChI7R2ED|)Plc|0xb&O4RfUZwva@9OFcr&xQlQIhKK z2_H-zO$5TdtgX!`7N@Y)%lcBi(d1zO0nmif)00#ZVbE?nGxrtQhKi#}amKOFUSk*j z(fh2>J}Vh@ZRLVkzufI=`^qz)riD?|9n1e#bt@~+E2?|>E3)j3A)<=RI;wDa+`vxh zRf6C(K&~0Y#K(t&BZHI5^u)=);M6elZY;A*!0)I&W2#rt#bNM;%c3T9f^8I2SlA8|$;mm^U}bmW%8Es}A@Z;6A7yf~I!aRqDR zX>T?84fFVLTuWJ+Z*zKTHHvk5YBx$GOKa9y8VJGT_cIGANYb#-im{FV0NS|6wh3)) zddxOwWgsJ$x5Yd}K&Az2u%2=GHkMh@HZcCDAUylckVyvN9oa&JcLNdL+Zy5RlQecU z3&OCFUbRVjNkMwg&DdTlAuSMJDXoE_5sXb(8aR$YekAd@ljx6EUcMCXUY&hl9RXH9 znT!(wCgTgoH(mUgjm{}AQ!KDW1*mzqe{Fd!h1uI z`lebI0Pj(H4|^KGbSfcq9i560w9t%fHsbOgW^@CTR(7k0oZ6@!1Xet z1r#zd1_rSI^k$NiKf1A0y?P~kN#|P^O_IvRGLna7OKAjjR4NBSN0)SRxwsiQT~?$v z7cVHJ&0QhV6)7ljR~19C%RTIK=65PS=SXqB?9mzfot?_+NYROcA1I^^zNiR%z{*CQ zI*I=q#Y(=!UrP%Fi7Of_y;@Rdvf9A>HnHSeX~~Dm#m{TDV`Bl4dfic$Ey`rN7P=&_ z{Yly1R+Ux8c-_kE&RDXTe^`((AqsSpD4qlQYXcF!hwqL*9p!c1OE@227Kw$b@@l>> z!`aFU1-_T>Tc}P~i-z3!OoG>e)1&EEWD0F-`GE{~QQQ6e0NU0Rf52;a^~&5fIVP`z zVo+C@S)0b;fa<7Ivz5xlQL%Dzug_FPHJ0s#uBrDGbWf7r&_mlTX%M&G&^ie0mlA2w zW}Y~02n%*%gl6l>YHsnfc(|_*212u!g^%EL1sBWQQx!4+2({vs~?XhMCGT134u;GYn`MOq7m2Cm~6FlF`8ZO&s~U(WRgNC zUxrMc-4o3&y%O(^4vMp0Kth0Ax|I7lNoG$=3riAL>th})R&Nh1H8Ko@s;9)`JgDcP zd}|HcH{YE$FiY4V;4^O4=4FX)t!J~z?W~*W_33-xVAy(MEy;%Lvn(iKC(3AHo62oA zd#9L!_=6?x%vM#GMa$;PBToCJNUU2U1vHU7 zoQfD&ki8SMjDL*A9o>R)#Q~nbOaqdPKcZZftk#jrbqg3WRUe(VzPxo68SvfV?T;-d^6zK-B|@ zZY9MNpj_i*2m<%CS|>xiyPXXT2y0F*f79VO4=C~8a34R~8w@itnyy=a-D*Mdv_K{6 z1KrlcsI)1X426#gRo6NO*6;B$+P7yq%U+b5SCDI2Z&}OR9k9UXn$vFiLB(^g{a)Ss90rV@7|7L?~?l7RY$c`FbD(WzG`Tl=eSesAGFD@ z!3q`PTmC?HUq(vz%3MlhB^Z8Rv{@NLoB4_#gR6-tCzOkBrTGv8gupHfXb8G z17{ul6b483!vE8EG@x-+FKxaF!PD;7A$UNYC1TP8+uH;~7QMA&i_hqYp~(#-M>q({ zc5k@1FUpe#gK_03oVVAb^%AB^wEYo$=%Z-+`bR^Mwz;|=?S`~)C*g#&&^t*L@=x`Y z@Z=+clwUj|Ncqttui1LC%Wo*)(mmP56QnbHO_Nk|Vk@&Sgo%lxu1!+M|68|ovkXsbmnZ(+jk+RPM?7bFQ} zZg&)f1rk$wVU25~2J@gtNdYCtn;*B?wr`@mLuZFpjq~`jMR`9W^_iCnlBW;Z>4CA8IZt4A*Wt>?lV`F+<%P)D%IxjoxsL^$V}X@t1KruBMU-X( zEBU_|aR!nr`JatAgHHzqHbYwrUGp~z4mosF?#?Y+^S5^Csy(#7T}CEbe6dUPC?rm< zEq*G7KgVUI#;s)LHJhb}Oq!NKBCrG`vu9y2Cqj=0zD$`j$)%X;Sc*lKsnfPE1^fORWx&2TTla`V=O>SF%)VNmP?fTgOk zy}X0_S7%3qIwBXMyo0*p2VLuVD8oCc>peUKG@QlRCipkaVGhY*4x#OS9?$Rywe8|@ z4D;MbZYS>mmK_Ct2tS7kxhF=epPO0pho9gqvUHZS#4?Unb88Ee`jpSV&XDl6fMr@_ zGi-r2*!tjrbYrr)i<7LG5;jXFxo)*+<_P(r^diY5tctM*2syoaBy;R@DW@p`~yrwa;+=b%NG98uWOZ;K7x^4()q>)i@%h` z=#0c!0Q(3%o)Fw4jze@gn7@52cN^Hpw*m>1eY`i4dpM9-$^Y3%ZafRl5f3a~jfb90 zW*4t!znnzBs|lzPh0rsUet=hATlos=kXSi4k~@Bi4*Z?cXHw4D`ZUMKNgiP zg)`rZ=_zsY=eLbL8jUR!^K;4gvSES1C~~(m*y|CcFTy;a8J()ECYlF6F1=i*Xqas! z1nGhANN*!Z9HeEKejtCHz%3+U2R%g2cQF4RkKc)lzR#Zp}TS!K<^&9KQ{fIiF)ATl!}edjvW;6_+?OB&nZW;`BJdTArtgq=BmaNKSaiq%*~ z8tS(@uy$D5=<4jvkyu7<4-D?(xxW#s?u=k9S}-Br(=TX|`9QnyX3zzxD48? zoFtF2DPnB}p;fI`Rdw#te7!z-K_D)yB;(EXXP^qz6uL5|GIYMsm3vu$&CQ6PmvsGc zgA;g@n=JFnDlp#=lL+mQKgo1GoG84$5|`+;h2X3reF3@gjE_B8026*Xpx!F=q4gaZ zb!6yRhy`SeK<>&|aAkIPPy*qV%jtcE4BxksuP^X@xsUP6vEcH`1zGzw`4e2q;syh% zWV(*muE3ssfmhPqe$7}BcJ5jZK*BLeSdO^+Sh>_ zJY5(|?@jM1P5DBXjMD8+s59=^ADj_-bS{EQ7ATVBiS ziup!SI(y3)UHI<7NYp6*F5jJol9>OmFVS5X3+S$iZrd&h?6E^6+o#EQwr z>o=v5>KiL@GF!c1_r#@$xKq8Xr44=?OTHQ2V{4uy2Z^aL@1o{j2qkM4ikCGD$BnhK z7jYF<3z@DgO;{cn%#JWo{JiYbb+7EDg-(gJU;EW^!}R_2A66=hyY4S$pSKoOl{vfSd#ucw?~yBL z<9qc4(-N3PRrr=@tQ*$fJ{W8D729n1S4e{YI(5xk86p0O=UfO%XiKajh`>mzI-eSo`*vwIVm=YfT^ zckv4MW{b1WM(`uKPwsKv2&UXr7~@SVvwe}1AIS0a-eeyaXWJwItX0zjIBW(NanFG( zr@g$9H!UwqurQUoOu#Tic~kDiNccRK8z#F1yPmjq6LIaXoLRf0GZF|Q(o${(cwZZA zKK-b*L3tX8CWAU3Y@@qjOTHD>SV^A33M}<4%`jT6d=s3|!hh(34YfymnvBEkgD$2i zL~hMIWM0_MvdjyHV}<91jcH|_nxU<+VGn#}rL5Cq@=1+#wwor0;GBS9m=my1!N6qL zn&j^qKWmc=3!Jj8)h#(&8`!i~+ky-Ifq||rup81U*IOAaBn?m<3dd85cS9|?2J~9b z`r2mU#?<<5tfk%3`)+{TOc4Yhj#jhDeSNK_2fx*~WoUV7P`decn zyad+r*wrh^#44z3&&qAgksU; z@~fn=J&^k`7*hau_%Rl&2c!nP_k!%TvNOFZgQqUW7|W&(C6w# zt7rFV3g8&^i}ISP@=7Rcdsb)P#r6E|)qElM4oa7!+_}7zu6`AI7!`W6a(gY+*%e+krJU5F8}GuRkgnbiB0fUtuIN1SRMM;yvca1;^F26`UQ zM3-_jo=Qa%y6GY=BO74>HHv%4Mlbu z__b_;2FCL%x&Np(6`w-(Jmn;aY5`)z z0^)}R0&p0?IZ%AO@R;aTZRs`OW1^c!&BRyphvKR?zIuLq+Z&ILZ&Md9^J*WPujkJD zwN@8-^>OGK5Wm^j>I*UTrq%qu5$7fD%>5PG$5&sBk8k_i)%@!ta)!qVwEe9t0;+u7 zG4+NbVoB8U;`d|f*5Zq>KyNHQQBe2hcBziyH{)vAyU?xFk9|qqb5^}=^~n(@O--9k zx(1V&EgEw>P|WWv7*qe0kIe#)*N6@D95CUhE43y!8cn{DP&4mb#h<@Fo@ZU!OwO?#ux+Ygd znNpm+89zP6AL8#|@g-i9QBNV923N&ddFz)^6SO@ivCX4r3nTgdNK|z!YGlBQFVY@< zJM)~ZJfv16R%umjXAW$3QsKzsibjg|XrG&xwzf5I47 zO}`5bLRBclXBV$ikFWf|iv3x%|AfRB-QwnAfFjCCc@!85WjDRo4#vXwI_&A)*h0SN z8x$3!9uh6cvJ{~5y<@!g&0I7eLl$E*8k?=m-pv`to^6h%p=4Q>Z$1&>`@tQ>;RKLR zVT+t3KiMqnYB-Gmm}?(Svz8LwL`oG;~gD+(L@iPuSh-OpbP?P zhhp)eb?_r5QxQ@egmcUfpQgBz6P(Tu{mZucP7cR4!AeQTaI5`RNb+a zS$_;KAP{D)y5BrT?Wt0bZa>8_T~giME3^N*o7${Wn~1vOt;LsfKaJuXT~?L&%1Cj} z9mnCouS*?_u6z&f;Loo-kLokgD);tvAh#x~cRNvcMO9!^{VGA{{jb+|BX>{bJf0Qc zJwWBv+*R(}4=$ejeTZe~vDPJRE!{pi*DbZ?)wkG}k{#6*12+>pOosp4STlQPRh2zr z@6V{QB3A5cg^1%=#-0K1&Igdr*wtilt}Wv@mcJ`vSC1CwK7j`LJCIh2bGK3YW~6(I zb32iK2Fd>7-1dm$+gT_0B$~gk!9y73E`s;lfEX^$y_<2&{!HEKRO7|DWvv)J|1*kT zQ@1(Qu3~;rjE=UiV0610D9+_*xWjU|=P7+R(ir1uN)viO>0eQr&;v>k6>Gmq`JKoE zI^|DB9AIh>stzZ1Em6!LlaoYGs^u7pX5UL95aZ|X0J=e0=c7d+ND-O8LqOW2mN|9U zRpg{jKn1J$1O_K?J;i*x97kgH!Cw$8!ZIpgeehEqODqTQ_~2E7{lSmaa`^!V?h8xq8R53>JFMTMe)ihYtV+p zQ1?pE$Ed40#cL7Dn^U~zr@T4EYc9%LrdUUL%M@_{Fh#q1qZ1F)Xi?t(pJJMFMc)5Q zF}9rZ`|nU+bL{v36XngZ-@iX)VtCy6g{Plr!tZK zs?p*CFla60WT*N*2B@E6oyDoGKW%R6CmOiw|Tc6{R3+j%Xx(W zRvvhK3_~sQo_q_!57ir2pM^E_6t6t_D?FVnsHeU*R(wLeiIRhuo(lVZ^#X4_pG`M@ zQFQ#Z#pe~>1e#cqvw;QV|M#r7~V)_6?xR_tj(M(p0 zH0FoktK?1G4fms)yX2i7<&D{+JdqWfWwcWdh<3RI8s4+9+5i*E?;=qA5MXrkLjp*y zj*7Z@*GN$VD(em4MsMobfu68Pw3f{;N<0f#_f~#@cfJXqC!?NBHBrZXDwi?jRC7RW z5Xe3{MiXtu0(@2A)JXHKjcScXJ^9;ZBi>_y zbnUIinHEUs=PIHCszrT5N9%7F|!`=?hFi=*^7$ zz*=cDwq7gsw&V6c-l6pM@gSq?OC#17hDs~B^;4rKhmTL-{qw}hQ_P3AEy3u$(Rfrz zHVJQ-4{Hq5rl}8cpD9McHk9LCP4|Vv-S7(I-3M>#3nP*v)Fa2w8VYmYl&Q2zjxfMtcO&!Aj&!aeNs9?)xS@pb6rQ2R#eblQ1p&@Io|# zVv3p*_JQ6WF&MDe$R=z8U&7lI*slF}nx^F_Y+1Z>r`c(yBU$ZSE`$euZ=|KY?h_73 z%~4w6qBry{tlsUeXU$k-SAAk)JTv%6J*!Wh9-fk^`-U^)dO9_7dQvOynjDq&eS_1d zC$;2h(Yt{)gJ4|svBB}vgOdcUYj|i zL#L;vk?0#fH9dTCXm}E7eqwq;rjip6>xH4=6EfKVTUB$N>Ssn*vv3hYG$6x%<>MZf zq(Beykb7Z&l?U^8s%2RjT7;)>ol0~uARVESRgqUH_g<%xT{2v?xJbeokZu%^PsxFR z$-SvThz^oln3yH-VkCMvngTHZCtNGh^J#&Y2i~UgPJ9#~pze5QN#GI8uDqb`2&~N3 zDcNNdza7jj4{a?VjtW7*h1}u@anlkuWg4TVFWK-O!x@bgupg-+3sk#$9+I&;or3wl z_vh-~x8Wr2RJSi`-n2_ma&Fd0XIL6{5wo{)CK$aG4!i9nO?N{$)D_V5?eVYv-6Cgi z_N#U8T;_H2wNbV1ZPHuo^7rv-UbmR8&h?!94^mW6#6}Iuw4o%xJp_sG0YHiiK_qb@ zPEG2BJ|dgI`-dj*{$0*J$E(M;%)gT{^(hCgB&qCeaW!fmf9EQMaoM7}ja;;m{JvzI zSBk|=*XD1IXO{-ln^(VyTMS$~6vi%(yqx>JqzUZe__k5*RLlQ#F)?l*e|s_JNXG1M zW|!i;rW?+;%8}jLKWqdsuz^sDye`Zu;%oateW_343k~31TDga=nsf;UhZh)LSDYhG z-O~boqF2ECU{(;P7t#<6NN+)xn0ikz8bqpu5Ite~b>KQHWlp$u90(0Q5+8kNWV&zg z;nDGjrodIf?flH;^5IQT6Bt7SLy)9Mx{>t4N7%&LDTO$#Cg!IUh^>jWA?5LVk!qzB z25Vw1lmd5aV$DcF@-#6Y5)jEv3}2&hVHOwy2`X^o>|$9w7`qMLG}*Kn989)_>?~yfVrgDEQXm zTR)RWevwEQD?AVtF*4Yfm)$3KGJ=fn_RODOmwmPj5Jt>JRcn z55!oC$?rQMOChJdJ<5?ImLi-cs*xW?60!W+*Fv-}L+Fp}aR}+tNtSo>=1X@dNA$S2 zLjKB!sdU(a;{BZX(`b32Ljec4cqEAM?5FT@s*fE5XQD1f0+*34`6lyTdUZR{7d@QB zw=oVgoMW0*FH|Ia*2onK^ zyfoI@3ar9}roRa#Bn09Z4=N>($BLGYB1Ryhqxe|RAn#$u2Ck35wQQEr1`B8j$XK^wdSp+95plCFAfg195>z(b zNj)Hg>7f~reMaa@1FHb7B=Ptw360BzmuAPBv>?2uzUXlre=o_k0SJrIauQw|rmz_f zC-C}RcJLt{gt}CSKJ>kaAe40Rpc+>rkZh=1M@-kp5bY&(HL|b)6nRF+Dml zK2=X-MWIRR7K2mh#2V|9Ud27qZ8%<8=v^> z0h8fsUwq532PY>^k~;vOeq%632dCJ?gRJ>3-(7gj0^c0(#9)yje!fs?hV{+=?!Re6+;Pcth=@B*!laitIVN|fe)A*>?;PfayvWNZ; z4No(CTyGLUm`Wes!zc3|oM5h@hfg+$ZJ}M(PoC8>6$GV=3}B0;(1nT5P1@0Vxyk4u zqDu*dBs9Z_>;v)oS$$7m3dT@RC{>SEZLpt2J|Xk1c#9Kzv6HyF=9nz354$^j8*^@`evNk0nRnx)_G+tS}_%#_5|k zkaQNz)7soWJUBT8En`Y75A?+-Ee@=AD8S9cwg@?V*+7YlrE6j-!G?)p(cz_6FPeZv zJCltPAF*=L%_pTXz+Sm4#`YxRN6^z_=F?A`bdZGq0xtj$JwdD6WPIsw39H1k0_3gPqXns zoQUDioCdw)tWo0=6XPe)c^oGLU#7&6RH*$3yqcIe516F*C}vV@A|$rB`WG$m1Ygb$ zivPyNXk@Paki9AS7W#D%@A7L>(t3kIC{op#9 z#JZLru1QFZu|zaur*w6OFeQz0oqXS@D^$1;DNi~9RLGK#CRua@(v&xwwk`?RMU^&a zQ@&1@^}(dq@1n&^e#kI5iiXUxoMW8|kAVWa?<4(9Fe81_tg;Q}i?&>!TxS=-Iu*-^ za;pe13N@>O1c6bu&WwUMs32*O;@~`{OA+eJKeaHZ*eDG?N*GvnUm7DOqs95xSf==3 zE+%0Riq@30Rp}3N)!#cjetMYgXUB#oCqBo56O*SVCIyG7$0zgP8NnYf{qfPCX8O}Y de_H8J8~yR)4<5l(;4j`R<72wm68ePd{{`sLYo-7I diff --git a/sources/IOCHAR.LCOM.~8~ b/sources/IOCHAR.LCOM.~8~ deleted file mode 100644 index 4a2ea64439cc412f731038f421c1cc446b764706..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 22466 zcmch93v`^-edo+beqfL~l4T)`V=lrtBgGQ)(9?K{zIn(qqnWv~W(<~5m`EOhr1>m4 zl1xH2Ikm}yJobeR2HGq+AwWozla5AG5BN2yx+es7yJb%WkqX2@w3~K)jy3oBzpwxO{U7(<&lL=HM-ri??no@u6iIY*wzpRa^eBfztUi)R zh5BNVWN$s&+ZR%TDa9XKm+V)PA?9&6RJe#h0Hso)AggD-rug6^OWGj2EYbWk%sZ#|o)R@9GX z*yuQ`sE-R$476CU(idRer&X0D9|5^(##)*Z6Ax2;A8T%Iu4kFSX>_jMn(p<1=)snb z`sFtWV&OALH$?*>t!t_O=_f<`OE|~vT&o#R#x@NEy}YG+3>GR@!v$hJR>x#VaD|b=$UF_y#JR|4~=wb%%4T_=1R@Me&k^ zM_+e5rUp^1q|}egUg=WHcMyS#k?7LNwWUavcL%Rbtj^vQzYyk?Z~WNy1^g_eYYM!2 zekZRP*`2OVI}5xryO^%bE%TcF>FPr6m)z;Jxjf!>HgGtUq8-&8Io8WOo>q3}ol0My z(%;0pyOW_5>ufPnQvJQ5ro_>>Kh($C+l^$gAKSbvnd*xq4uc4Y#+BaQgc1*dfjgPG zu81~N98HMbj&=4LtMHFrXNA^T$*5~97sUMKZdW^3p7|tAjH2#X{SY>S7g?4h0Ehc@030z0MtR}TEI+vd^j*NIH^oeob(S)4Kwe?G|MoI5&XaK(cge= z%BoIn{paMPv&1r19x@nf10UVUoxE~&_I_d{r(`7O!ULPmaYD{8gq805-;)vrSmgV{n$0;VgWpappgq1p&4j*VWUp zNn$6naHm-2pvk?)T5ra!w zMP6*n?wEqP@pQJCc*8tCY}Zmq^KH&gZAP-rPn|}JgtQhN(!dCwjt*vF1<4u~UNM&O zAHW;;*f!yfO}E+RPzE+~d0Wj*gwC{L4%P#gZ)2LZ+eVN7DHzXwGh~v%ct^Gn~fbSITPuG@`KyqycdZ_9KbMoy32<^75rv z&+6<0>lm>5$wZ78FcDigzUkygCB{Wpo{t(B7k#6y5X&wOUttXE2zHGWH+7OUN- zF{`(w!^*4xH47B_Hb`TWBdt*A0i3Oq(j6v~OWtj>@UFLo^e2nd^@4jgu#4BdF;Vc# zQ6<(J=6yj(eN!#-1ACOd!=46!P9=n{qe~Hj7MhXGMkw!LMm11rV@G>?Lwx}#8bZ4e zgpC3QT`x0AKp_)tpaJ_&ZYDYT!y8N0t5>p@blkdVvQ#dbkr3!UDDa* z;%4l0S&`aYte}uKcZFD2grLM-RSd;0_pr~I->LYVBgOf$M`!GJb}6ePMJE!zuaGwQ zq9XbOC>wR^EdFm4EBg|@mL>=mS2QTST9Ri%t$%)-nDVVOfVSju{ z1Qx2wtNFeRXDcrh_+Gwmp*meH3UcQ&ab5?cN6|0K5X#o_0~zk3vitb~l&vX#pV#o} zmAP%QOF{VnuSV&s0S<$o4|l)aweqCrNMUp`Dg6m|HJs zZKQLZv}iYXoYsV;ccO(B>&|Lv?O?G`G6@5r#mhoRuvM7PQhiDy2|F>ANQrF$BPgJxj6LCI3EE`e-Uf|#xXNw|k7cWTTO(t|*|EsrCp2cS zEhJ`RamiG(hXkADI*9w8P0Y5$O>6vtq_g5u1004rHhg5a)0hZ zbR?4yLisXe^6Z{ScIlN^Ph?Q+^#THdjk-ib7t z*yeJZ&E6%3ApT&AyRuc)Ws$P^^03o>DID#Q1C2OdiDnls=Kj0Q1y01cbTTl30e0rV zTEP>E!>O>*3$k|tmiCWPyQ5psuGqlyx2bC*nNcyr)cROhF60kHf4(*X^t0Itx%XbP zRqZTCw`zLEqOx>#SmrtHm!mL+o*q$elndJveIxeAwgUAx;^@!)vCY*1ZGikLp}s!e z$H3JC@g60`XUnt3s_60(WjHc`6UpHH@ zJWWu^{6M$$z;_bpX^tdH6BVm~bTFt;4!D#CHRcSS)l{ zi8W)BU@B?HSm$Z|T9KZ3y?iYG_419yYP77@QSz9ym97?8!oo4|(sZ&$niTl>8X?f# zH`pbZ$u(=VteLVUo2jba&MPzFmAtzUk!u$bvuv#0+Yzi?LSMV;h_(v`VSwCM4XyJW zcZ&6cHu+Upp+bDiAIR>@2^(7-b(G-X&N8!f394CA8IgfvK*Wt>?6KAqR<%RIr%Ixi-xsUjrWB!$A{XN;G zMWkl^EBU`1arzT0`JawB15XD;Z-%xOy60~c2sw09?#?Y+^S5^Esy(#7T}C8Ze6d^9 zD8x^$Eq)@3KgVUJhE_82n$1!}22IN#?q5PDvu9y2$AgdizeJHUiKVFOSc-<1sjtKEa<>qY*)y4cDz@XR% z0!vk8d-*}$u{t{%&^vM=!Vgka{Ge(*4`z55RlSD?(G6#Dwi*6SvzbG(nL{YMpT{yh zOl7-y49z?@lH17-qL&8?{1AQ)6>?9ERzEkh))9Jwv+&Yc&f?41S}kp@OzKmzZh7v8di9<`482-PC~!uLmJ5^k6%1LbHWh%mNTXdMXZ())_#orL~jQ zn|^>3gX15aW<$elkWHN)Y8srJ9DD>vPz@ClvtkAcwv>Vvgiz@4X1JsPmF#5TY!Q2F zzFYjXX~M{)kxo_qs;HLUa$=bo^+L_yN$6sC6ZK*@7Sax>kAVLxALxjvE^+ z{!)n1fy7w=d;}kl3-pL#6I~AEZy(Fu2Ke}u{{awh(~)83m0D@VcZS2uVbfK7^OT?B93j{`yyOY6Q4=c$q^MGe`uCkhF9{9NQbe*GN zwv{lX2fib{j9_uFmSOsV{dETS`B+@(3Hc)_aYzg~=7X|5Fre{;;IQ@jFInVdw#j2< zQmD)r+2Yr&?3La+Sr?uBTzQ#Mn+AEu=jh<@dL)FbwRYNIUhD|SPU2WMi;*OsgLzoy z7u=ZN=O0to1V0v}N9VOO`CIgmV7SL54?~u8f`?YR49pg z^8hrA*@jtVjls>Z$y$Iv%nD#KGa`NGI@jPtSa(Yr%i(4`7F7CZA=-tVIo~vHw+Y2+ zEF%r|+Z~uYOl@R!_U3RjBbNsT_wn4{h*@`rF&C{E5by05yvTguU3fF-fK(*VsN9SO zDEOk(Ln^w06KiH`MF(tReYb3#-@P3X8`f9-tU4%KzaULlC;FhWWlJ~SgMh*jMkr+t z53VUAf;KUw>l$rYmmoSu*DS2s;il@K&;ordln7cdmuiBcu_H+ne5}@H+ZN0`A*QE$ z{-79>#2A|*=2kFT)oN8$*DlT1>yrlr;=oD*Z>~QBRj8)WoiUZ6^M&r*%YtlfM*O^_ z>yI0pz?+<8nMYRs`G%NNY}%O!s{z>h+bO=%qr3skQ>kV*pmf-@Y8v%3S52(MgD?<-{ZzLk7^f$z(GgjbFQmRByw+^@=?z)}_` z7*HkCb-Z>3_UsG1lFs&P#)`0W*CO%6!oonfn7@VBWS5ZYjUsjSmN7c;-Gi2>Q2t%MI}If<|6ilLS`2u^8H+^OLh(DYH@P1r=pup>V{!7D z;;a&hbLYas{i4k5FM8lw{CQL^>TAaI@26SZkE5K#^0J&oNo;2AkR$8oFoT{sSxj`;$8?PYZQu?H44X# zwXzrYDy$YV9a);RJTRCkO2STF!+_bWOF%SY7s;n(qO6(mlzL`;@@K6{Rb|fZ`Ccnn^F49~ zZG5jDU|Im9s0!T@iT1$y+XrK<{41rCbVNUps6* zeXF%Yc^Zf$0y+-1)7h{k-Ue%|Bu>`~EcvZ1Fj}p+2_&@O4;`=}_h@gkvAKQF#WaP; zt(k|+3;S87c>y?9dS2L=R_N3WZ4HJ!@R^lDr^m!e4LUnblS3dUC>Z7h>{9@kytXFs zUBk0>30OeN_BOXfwsyd@mfMO0{egk*Zomy`mFumHR+0wD4u)bW#k(PwTmyQpXMJvq zaARt9H|El6>2)_yZlN0lAKa}L6McPcrsa_!k)jRmT4!r39TR`@i) z8z0=Bx3g20BTw}Q_uAXurWI?WlcWzCI-M&@31dnkh&L&SgjWJGN9e2T8BV{oAoW(( z%H+DhSQ7yce3;roLUlz5r+4D?DWx%xaAgwfkU8)tzXh@4|8M>!Kaj3(tNPnx;(7_J z<*}<*67f}7=Qvc#MykqjEt5M}^Nl0UVC;=B{Ji4g$XkI#cbAe_T39&#Y9SbnB$i(# zjqQQlj{r=5oRL2pi16y=g#al^FtQtYbvDQ0A7s>&;&tnFEyeHX{`yI1pt+&f5Jj&SGlQo8z8=wVdZi8J{7t(Rlz!mq^& z>gIiM;l`DoWg$zu1l*9J2MtNPBTR;`ykR144C}|Q6pZ#HQS&kCBoFJm86L&?6@mwKyYeqd#{9UX=S-u9w^DDXks5Td$Li9YvB#CN4V#Gq?2SfsN z7|}UUe7x|Os8wyLHQ-~Snn%sVR`Z8qsyDWJetg>-kB)Cs7ccW_ADge|&il1e7kTw@ z=ot{d+34yEQT3+P{Js(ACGO1q70Sm}UyO}!``gw0>mzc6$BDH4tt>87`Ff)24Mp4~ zQOk?pi>h0TFTw)7vG_zm-J9E`I*Q+jsb%j%w^BdyMRm_v^|sX~N1QY?Z8Yf`3}Uuu zjO{=%zq4Qr{S!Vmi+;@hO36Goc*8VAKEBDtZ(p1cU%xG6lzY7gQ zRp^S(E?%b|U-`bZ_h(W5W3s=f7BeRU98pfnqv)YfcGG+902aR2VNdVI67oG?r&~el zAyI-XOF=5%H^yt<%ti81MA0^*w%N+;-JGHA*_KEeN|t5%=Hp?$ALuAHCy0C!I~Kl- zTJ9>F|I7$k*lHc-V!wJQu{y_i#4!|l^1zE z+RH;N#@ysFUD`UNYx4h2_G}*&+_y4&mhVGJXj6|6ugt7v?CC}_Y8xGPF|;RnqkU%W zGl*m42l6$@Iv_HhLPmCZX6+N)FyBDRbd?t2xLnJltha6K%})n@v+isYsC?k-_N))GQPro}Sn7R{SFB_vWmi4VxH4rnM8Y(CBt!j0Kbv7Wfl zPUHm%k}x<+b~8=H*#7he2R6tjx7=5ApLD780}X9oBM5i~Hyv(Q&iz2~+#f(JLyxsiXQ#uw6Y`ockCGl)H%D?|@>cIQMSGG5b?>t5b~?=a#i()cns#eofux zRJ)7$LD4$OzJk{6s=qjwqvj6F=ANhU-3X(NrzuR`Lzn&)g{gb!5=6z?=PAAuaZsoD z$*=>U_Mqx;V%6fs{4qI5)TCUFrfBqiBm&WX{tk3EAoF}Q2}CI@<97&3d(<+gPP+;< zK>P-EixXYJY(9a;iCk|n-znRXz54ZE5-sXwM9}*6PxM}5I?#__ze==!{X?}}%ps-B zi`h6VvtOd>K2*oxDN{@UkxR<>S9EeI8UKtR_bGKd4LV6ZdrWo*vrF}lfu0?`6p`a7)f=2D zFXo5Exa1UHdqea?wtMZ5s2;V$1>I}2rR`k%_PTb?uWRQEqMgsFJ7~~!i&qX=qc$v> zx>u4uMpexrUJFy)9OAVOikm~c=AyV|h;{$+}rZNLA0ikoe}{|$^A1Ap1(#aom0>>KL$Ji8&sy1C<2QM=>q4Wy-q&_n6cMDrP!Mh4mGH0qiJtp z#`bqIdSNu(g4kbiYkm+Z(k)j+eiX6SOY*ys^0HAsjM(oP`A-+ryV5QsJ*Bm$G7TkL zS#>M-KR$-07I|;J6*myo8&{u&LG%=_JoziUo-C-RzB*QXLcNKCgBYO-6MyvrZ#$n& zH-15NfFkdh-!hiF!{QGXL*O+m{8F=j_nuI2O!18DAUboe#Z9qJe-eY zvf5>1ehBVL-pt+bK)Sh09_vxu7(LSCS+QP5IrV@jmy4s|JsYzPGQs>VBE=7ZMh`zE zh~(-hsfTxu6g8qU-ym+(rkV#)6Gn+vvgJkD&jRMXjUV7$Z^G@#s3ud*uH#6R%WLG6 zb3knnoqcqS2HJuN_=@OLBaOF`_lgy^3~xz2XqkjEDphTCz(0EjRnBfwsMaXdo4;Ka z;=LA14p350Y6%_lJN*zNKjh8XlWX!(uhZv5$~XA#3%moP>JalmjMFi;`rR?!@g|bg zkDXPUbP{AtyJV?ylrow}|I{suf+uCsoP4<|`EkD;XMub_kOpUgR1|ghmDJt32rK8% zTcWt0F|(Ewg{eD|=**hJn}y#4UNXxSO|K8m8pQh|hr_s~=Y_7{$B*K$)+65im^mJJ z<8-US<7qE7D?A=3Y8I*VoNR@!6mtLey4eYG+T|4OsUb6!^bD^1bX7+DdxlTmO$j* zNGzfxnuSBmhXsdq)11WB&lIEkHWcIC&G&^uJ#Y-;=?8C4hH#l9m=w=nN(p)~;r{~8 zejhss>j}q!xU_7VM~J#hqT~-Q>5vx;WR%A}Iv9$)IflohG!H^|Xx)O@8CE_z1a!Rp;^eAEHA?OgToiSf+fBlWC4b$WP8hVC2AjO*dl$mvNfxqEU{ z<|hZIPfu#W)1r0*YXQT!>Z60>rw1pATKDkKq!x@1PM#P+5G5Il zqf$&c{m|*DX#|qPr>2Kb4h>Ht%uh^D$Pm6tp(h51Psm^c%++;!M%T1(7D7BAZ~n^n zJuE?YJ;+J!g$Y(3$ls}!W##Q6yngFaB8z_M3zbksj-lLpT}pPz@Ydoi$>e#kt#w0S z@SEC%C?j`}*|RtvjYJMdQeX!32`5YRf?9OU1BX+27rqPNS9iR#B>EA^uDqb`@UP6) zDcNNtza7Xf4{a^rDi!Vl7jlaugr+69W!j^rJK5sjCUw((q>7AC?euv_Uf<~w;Q!uV zsC(arpSVlizNk6WE=9<{StI>nX>)-pZK(dMO-s+ew=4hH$7Wpy=D)yG{>*i}CYTetUy4L0I1qfr6BlAs zq)zA~vIrc2C;|uI<=k_;dVI_LI~h}-a^O^w(%u%QqxSK4u0j}>EvnndOB>GbOT>7k znA~)2{^nSAX+XVs^&2?Iz{x{l?DELVx!+Hi#4e6+8|6;5{LdESyg4Gi}rMbM3)7xJ;0by5gdwVGK6g}`jhtQ{dwhZmtX3Zb!P z)=D9uTQh4x2;R45hA+~%AR3yP7Xgd{O&~xCZtPu5iwAAD!=WaNwgACoS@`x!%F@k@ zCaAo-MjCl}6oIMgnIQLU{Je6d}fJ{`y2;e-@C7)&9OFH2|GIBV9&tn{B z*vB-gKB!3evXLto!o#b+5We9Qgyut6Q<*ES1p4syX8@g|m&h?Vwi~eImVwG1#7eJQ zTZvVe)bwYe)CtjXw1>ygL@<(w;2xTMHM&W*Wnzu{Yo*syD?p?d9p?82Kh9i7j&huI z;BtwAWFunSJ)ss$O5!qxQ4n|HECrElPK+2!=w2n(72`?}^CV|U%&V*99)!z6g1Jh& zx;~B>Ep0`#KukwhWWj^Hml+GV{t~Wbv5Yd9K+Bzsbql6n?x`>?-K@J4QPP)^u57xJ z`kf4>-_C&SGj6{$unO=>0`I>P(70T9Y<8?!yNB1Dj2y@I_mW&2fUqb{C*h^_6gI=* zI3B>u3O-y3p(+)k4t+8r03}_#smAFDBpdS9G1K*Xi1L!V8rj`!)N zpQ5q1`Kwdo%XAT>Vgybns$x(!^DQ_?mD@-fTask0|=BH~ent0d%mdwR_ zVfJ7yvA4|*qT6CT74`n%6N9JmtttZ3Ap+7VHa#+oJ6?TA`1J5_c6eNTnogJpY<%L= z2TZ`#zWkP94^B>;BzFKl0mopr3{J6$2U*KqzPs?A#}y3%fmmWwtzDi}%^8R#vhLKh}JH)%)fH8DnS z5nW0!D5)7nWD?8^Tdg;lf-%$^Ox2@QJM1SBkIQ%)o+F8PK*n2HJ&aeB56QTj)gO*i z94~39KH^73pvePDA>`nbfcTUeR)?~iyr@a3^j9X9V#5dQ$C9mYoeV>ERu~d>Xe2rYq=;(6OvMbiY@|zVh3?`=V-!^iOeOQ z9<%+ldGKLDd`^&LCVghoe2Wf(w1@7-63Nn2BNM09jC^l~4?#}TCYXBU4e^COj@a5>B z_-~wyM&{ZN*_)EjvH$r-ed08BGluy8aojZCyPyW7crT>3t_ocL9TvmO8dNLM53Zw0 ztSkA!nuOFCOGGnPN>^v7r=(G?lkXdKg$frg%acw36|&^JNfsS}H08~PtxLjn7fTzo zAz!D;`un8UucBR<{D5Y#6%CnX*~dB;9s>vV+(-JG03&_Ttg;Q}i#A;!UuPG=Iu+B1 zbgKw35;d!W1c8yZ&WwUMs32*O;y@nLr3m%qpIR7HY?KBcCJZdAFO3lsXtDn_$P{1C z#UKnu(Tb9`D*a)u`g@1RPY<*G?AY++#AjGwV)E3)q(GQ@d^HcA5&ZGeA0Pc`p+Bwk er;Yx!(;s}@wG;1PD)1N2mhoj>ED3!@_5T9t18)id diff --git a/sources/IOCHAR.LCOM.~9~ b/sources/IOCHAR.LCOM.~9~ deleted file mode 100644 index 2a0c8310d79bca9ad9d4b6872fbe9e3d1bdddf8f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 22437 zcmcJ133Qv+btV96vt+U$MbR{^$j=n5kcvoS;R4bcmp>K?00BITplnfQj8Fn?lK4d` zTAVnOo=VE%EVD_nWV_8cCywnnjZXrCWRJBXW#`1PXFBzq(hga9deSC#C!KRrFifYN zj%Chw-}^T}wA@TPIyUjv`?mYOckg}oe~rOVPb3j)?uo=g&5=Y8XWROeK(DeV#Ofo7 zflz-elI*Kz+xkOFa6s|LN|OCbGQ`}jrt(H25J0JcP>|KT-OY)~$D2Jaw~x6!UHGrf zThAKn4^19EGNz8C+2jPPXXXDonC$(X-TRJ>96k0xX84FYJn=wm^3bsQz~Pa!I`V|K zrR@QA?AVb*lSfA$I5v6W=%JBg4@7t%tn|0s-`WHUoz2RTqiDwEVs2lT%iZPm)U)~k zkN44Vs7q-yGls_Ef+7P+)^kEtS@H=GJkC7r&HT`D+0mAkmU@;RK926yThl!t+tJnP ztN*8s@}D&*R^HL+Yxl52qr(%AjT~dgC-3cIjXjAZqg4qsu_H%E9v_=LaZGd+dG*ZO z93Or{j=<&Wa(TKu?f=ZF^QKAEXWfB z0p2&r8skc!pQ8>s)vqLyG4O6v6Uv$cl|6{DxY8T)M+U?OC?ZyFQtJ;T`M&-D#x$f= zQ~LXrK_VDQLoKN$RN*0^^c9|*BzXh1=-5itr= zi$x_vu>qstp3s1$Ad=0A5n~BGsKmNsTnS>HDE02Ey-Ow+5Pvk z`XE>w_&0Ir_}Jvcv3g=F+Rq}H{`BzvICkhBkq{Aohr~}ZfHCskP=d*LGdLj`YK~(s zh1n3_Hz3Pufo5!gNP_lYe_yOWvL`&ih9o@5Vzh&0C^$frK{Odm4*WK@VmO4XBu#H( zPYB)PeFKp=<`R3GYRC>EU5ux^-am3^_{6ahhAQmf$YWy@fXvYm))VPR!e>TCG9wdd z2K>h{F{ZMK$NRJ_JLVbb_Kl0xzpVuYa^M~^i(A0M4We?BvIe3Ts@J3PXW z`ZzM!@QLG-hlh`k;dn#+$3~7b9BW5GgsF7op_7kJvc`jtA8r!MLaVIrJdinn76Ldt znP4bm1f3!pnn=@dye^!HjYGlVCt_odjUG=9KR!0`*fBOh`%ei5B{j@usO11p0H(?t zeXPDOIe-(hFE~(-QXM!aMLaI!?Kn$CJRsw3tUe^-AsKhE`aN-~??)=?Bfd`rn%$rj zLQXmT(CScjvj_DlmHx`aVr=-3{aCd1t&?FaWjPztCgJAc8v{lUth=>!aAf%CG0fI6 zF+Fa;G)+#DdE47qE5R0ZF2)1e(bB>O1Pl{k(dHc(>zIO;2cIw#_z&&CxfzQ5mf}WIN<=rj;FsYkkh2V<6KL+XL$Rn^+%fHEB{Keavenppm&vHd|Tcr`9UZJ!ZqdZpD8){q{P$(`j#a zA;$38&w1 zJgEjzt*F$G%Pw}SYc>*rOOfcp;gy9*rDr3rNGwm^7rzkZ6>t97_67XRrKo_?4Z$tfAhIrqq_bDWTKoLG7xVa##j%~VaESA*$lz;xAMGwuY_IkT_u znjPRrFkKZfT|04vHs?63Zel^V!C6*@v+$wDng4Vagj#j;y1IR?aSrZmmJ1p!pz@}=JB^0X&HlM&G-V~{(~$9utJr{leI zwfWx6{KMIIB$)aG0!;IpBjLiCQD@k3B^+@?M(@nuDS8dwwrjv z++J+gVo39@&QI+|vd&MPMv8>ARvps72yUNG(+^D`(-g&zMl$QFVUZrNt->3tZnM>) z3~bcsX)`wwy4Qv|C&1sUOHFfu2lJV?!;7l?YZ|_=SyxWNJu4|0fAbIRs28>~0 zy(*LS5`y)fpR&DN#9Cm!VqOEF5sg(K4Txi~ADwvIN&Lqvu3V1wE>AyF!hluh6ER}I zL~QQBs*@j;7#Cf7A!=Y;^v&9QEHgip&3*{8UM*(U_?>ZDtPZcnte#e%m01C57AW-I z1cfF?TA>j7lfkJP@A^z8m%Q6<;ayKF$xp(@A$ipU?zxFwJg%D)1;1D%_`g%E>`VAsoFG_S z(V+BNQJx94{@L|n%Gc49A6z4TUbpQZ_lwXQjyI z6NTL4f`zH0=xzeZGwA-xP?&G!b+Kn6yta1%`{PR@Fju*ziZ`S=TY53ixABI#s#KLI z$equ|c`cA0MZYXVC|kpKrFkQj-NAREY<1xkUd^kPX4cC#c`XEk+WgeYacmBVj=Icg z<#MrAtVr(hnxd%2_8!QZdR@WybkZAgXs0C%=GF^Z8|f@LEjr8{r!`^eooJ!ey0co_ zd@L49CZQm-dRS;LwhHsQz1SJBmmv`nt`_uknn7QikxDX%)dnQ=6KP!3_k@cjXp?<= zJtW?dO1mvQo~iV%i;Neh$0Ng^)R?^{pO}utB~wlB7HpRF5%)cpm~M@my!!D-Tx5Py zs1T@hhgL~yAsTaCi^@_9mm-tcGm`r0=cx}KOzX`nSHlzJ!9XkuH|*lhN0F$D1kQ{0`YtSXC?&8`VM?U%#RUOCW+ z<6<;3e<}MvY>nVVj7uj2gI3YN+Q1WJ=rVdiR-%BRDUgndcE7a&?TQUNd$+nWnjRA~ zTzQY9dps-`^82DcUmFGb*=+gjd#~Fnx3BLlo2`zI$K-lcg=L=84s41+8G2?^-J~t; zGx6A)yy8!6Sud|Z&P(wauXruHV?35wymT=VUH(Bl`er;j_b0Y|^zaIX^-HaMe(VuC z;;!^M9?qV(HA3zgqMMUYe?RYM*bPJRUS)vC!STk95*x$aZk+_e{7yDBB(y-eY%S9I zp_`8xDOPlw8vNBP@ zPG1z|^WBcJgEpFHw-?7RjYr-XxILXkTL<%Qu7cauuJ0Te_T=pL(GJnqrqzTo35!1K z+7Q1EMPjkg9wpX-&4sC?oo1b<(zPP_@>cm+{9EN4i?!3T3-*zvrM-Byz!DaYfpw>o z?W9S;EgtSi?5^AF5(MR%?X;|!vNn^htlGdU(&43?D<6?-7ZI~;tljkp)-Iv1T~$Qe zJ;P939;$-0dX_uI`auf)DzsN|?8_gV`BxCqtvQ$DnOLvbu(LZNi8Pld`}`v%OU<2P zt+U7MhO%uGjxMfJJQH0I+gDcGt01QehkS(BhjE+%P=r_z&(ZR>q*Sn`Fom zV6E8ZH7cTMG9SqnnqlsH5O#Cin>FL^YacFZZ^i3HU`)LI5jgZwynXAfAz0g--H$dD z$UQF5Nf<9J{7$D4*|qwLkbJLT<(KvfRzAJ=bz5I%@l6G|-Itj^M6$NWRAnU+TfxFO zgv>r#_8{F((qUAN6UHu88o_^bjsqktW;~cg4RkV9U@Q<_Qt1%f!Ti{)4=Me@Bw172 zE#iC|6ZYCxrhqwclHjcFjr1`x8!G+K;x$%-T7iovbjk77$8EL^s|fv&^&yR8KfY=a z`u9pX=;ge`^n*4zXEJuWdllLLk}mtNYIcRWN|XMXl=-h@uIjS?WsB_JCsALD_y--R zBpNnsy3ir42|q5os!R2ki*j_SzAE1vUd${!GQKq9_D^rwQ*kD7GIMZEK0LlOeNSlS zV}9qjf9W}YZ)Ra0sTu!L?ypCk{=`!5r=!lmGXc??gX{7=vzr7$9=tt!@7i^_yLxn$ z08--?Ba$h+)FW!-?bjJ$5M)Q~|_qlo(#(8KIG3!UK(-je1!NoQ!}EzlV% z@_QUfFIDhi?^q_hiJKY z`&?Ba_lHnK8bDy7vTPgg;=bkSv4Gx@3lZK$Rq=zW^*os7-Bk4f9z-{sh3OX9Ma^b* z%Vu_?><%7F^Dvd|;W0Gx{AhMF??NxT@_aXbcIUHCja5BAwc-ms#aVda6ld{8Y^_$@ z%Sd_3>nl+}ylsF?%h?Paq60PpAfTIhVB1uda^)){7d!DWVh9Ri%<9+FC6ldy(1%`9)WeAo}Y;oECbp1301SP_1SG971|3 z+;K`2C)V25iCaGXKA#;Lp7{82T&1#McI?E#=Ha79ho69#NmIG*aABa9iy`;1W6gBE zxM2v1v!xY%lM8f*}n(!!+vD6 z>xNzZ=5{4Q$BeeoB=*wbQFMlX(Ue;0aCc8*6pz5&c%mXZgXW{}YV}Oh+ zf!sag*}DOj-}J{#uzYVc`?x>8l>3X(>_i4Q8S^h(iv`aoGV|9mUrM0fwK#;PeDGNc zKf)_+EPWYy2rQi)&F&6#!)o1|!2Unoo0z+FF^Xe4_pyjHyqx@IR1XQRm|Z`9Iue~L zgeiZuxf;rBpe~IL-ajlRb<_;1nTMf{)KW|wEf($u<2#QhQ>xR6l836 zeLH)-#Xdjfjb5l0Lq(oFrP4mxEl9bQZgM0(nlZ9i+_Ez9q)`{0{QR0SBTj?d{&~7y zy%h-|Qdu394CclDhonFp>tZpITV~e6GUylFm}~Hlt1E&Z^V071`pMj#dPp$blahyV za&~7M({}K(Kb&4`e?er*^?U)R(Q8lQk07)ecNU9EZm+sBUg@w$!pqY={s0+ojAi#n<}&Y9maXYU!55;vvDco&A4xBgnIFtv@{@Q)!Y_;)J<33GFd=Ta-CmP5 zd^hEaYcp{Uz?>V1^-B(d=na<=?jIZoB{6SqK%_C-xLmWwV2oL1Ex;dU1u&Tzkv9y| zQ;h6VjrXCu1H2D@Rl2j*t(TGE!X4M`1|sWHqKolZ5Kc!}zYd{{&o)okZ9@7SPwQ3? zOgUC0vOIl9IGUELDxmLg#bPd6#$(I!@+ zq|w%r1ktf#2R9l593)nAg)1*E`Qff`(&e$}cw|;TH!Z)Ub0yAiP3TeUx@l%7D@yyM-A1)J_b;cxc_90&9*+6eo8EF&uo`i6A7(0Mev5$ zUzN+1mEBvkivX{@JrcK>^1R6orXlZE=X=to#CtB^lYLc?%}$A*mvtrKrW=A)t~t&7 zO#f_CRCZ{i{7Izh^U(~iuYiX|O+GNKNP|yyBJE}8^Ei8+@vC=F(38I z68`Mf@xan_T|g4y6^p5ce3~~bL#{4TTH2J9%|x5gAdIr=yP7KsK$(lQT$Sfy&nc1fR)|r?#cG z=Ck+z?62g%)HdWy{O-!Tsk%I`F;cf8B2sbLzm;z*oaJ?=Cr;X6&gV6}wvgK?Qm5}6 zCvSkQXo(8t-sN>EXac$a9_3YHz@yGsB+BLr-;uq^{wP6SDo%{W$*T*~N+iymb8`=i zGSk24h28n*QMstE8`HmoW^o7Z`4WqZauy}Asg)-})7x(<-blq8D==fSaOtA#r2L%~ zK$dp6&z9QLMQcEnq8wP20Yfk~%xi1$!&56)t16wNW&Uopg1KWsx@EgK`DMv`*-sLle0XO`qbZLMt91T1M^b=*|g_Jnc z)eLO>cGz~|F8UzMy~4am+3gsjNNdC3v?^^d^~*F|Yiem8NEaf_gTqHlb3@kVP)N?0NzC0u(C$TY2#8 zl;hW7>lS~*=Ay0S_zMkiwn)Iam@$kH+50~NQf|6*Gz!)z4ZIJqLyDz zVEcqKyr$xcf3_ypn^|1ADh<)tuz~42v!A#bWc=Ab2ZUVU)r1Qt1HB7rUcGb{aPUZc z>06^tHJykrQcKQoTy6k?v2X8WvQ&9}-KwDE0v zfN24YqB3-6B-#rVzX2L~effGD{^b+EpIjIKM4oEdPZNZDiXc3<9T@&CU3>VqT3~AB z(?&=dVy0Gp$H1wod_urfMLuq%IrDK!y9$NA3cyuCz;z9s**TYT5;xxX&= zWX7RLBB0}52RRN{;_Xnmi{j*SV##l7g=NBun?OPf{?P3!axG5n%nK1z6X;x;4S;!I zB#~(z0FITO2ZjVIbZXWV4Tjw?j21(u+r&u?Iy+5GOCTpG7+MsJ5CAZ^f5WFy;=6`t z9TKpBlpXCZiEJH!X)U)6-X24yZ+)q9)kdd*;e>xvF4=$dTz6@1tFTq;j`BC<(rW2- zJvZf&d&!4)tJOqbZ@X!pL3cDv_5$PeAQTlN2xZO!)wurl38@=~EAYmLx992Xl;!9; z;=_B5&j_?)?Q~uEVMC`&XL-VyClQV}c@PQH6V4nVZ107ZSUcyTT zY0`=yx*~+DU8tZ4XbdFm)xr0ZX&{_eQ&J%W*7{Myw-d>KXw z+#F^im22R$%bm-)oukfR?9DKY`NFH{?LeZZTS+X;%^i3xAB;v4i?5Ny_DJ?e046^i zD4q*Mc-7)ufCMGj7IyNgOcr0a)FEZ-9N8bY@H(=XLSoxWzmVr@$Ev0qGy!m&>P2{U z<(dizYg?D6--Yi+-EuCUeFv$F5$;@ENL9TCIgBbh;h^!b)pL4P4e&#jq)BRjx2jUg zqPMQ1twIS~Yjwmo82VCTONy^QXhp=uhB)QB1rUdfym3}M4c z6DNL|c3Dy3e-cejIB&+B#K{XnAAt$ zjowGV#VUQ2-?ZorxWTPG%D&hDIsR)(6>eAEux9e)PH_#s6YzvP)UtoX>E-C2-5@4K z-dkoWf90%nZ5AmhC%FMRz88*&`AVzz6~3ERn+q>M0WO@)XYWd@y9&P#4k^o3!W{HjREv|5`~uKjqk>?tX`y#?;-{ z4>}OOMxm=y_CGUebro`oQTq`&ID3ncpH@*|mq|ZWp%vL=6#05wO}}#uf39EU)z44a zALrD={}=|TCgNN@4mA{PY#RkH5o(mw9zsJpwNmW*L~Ho1^z$-vw^|-wrdhR}jH|a7&WxjV5PuPWj})Fl(mY%tQC;r? zt^L!~R`!=D(p<=W!f01by$jh!Rmd}K3$IlVEWKjw{VA0HgzPV>#mvb7N30>SR`gJa z;i+wQKpx-bu&3&vElQBiD@f(~$9c_L*+?#mDB5P!Hd~s$pEI;Q-5No*JxQdWqMgy&ME~%uNo{rL9A%I`AThmk>^A6VA#bsa&!_3Yo(7ogXl_FV6P97q3IIf1IAj*cHnp> zy7%6DAFl3k-p3!L%Mpad#mPWFK8pn$vJU92rJw1wLnO1(YHx#wf~6nrkQlA;Hprw! zaTwyP@m5HkMRCYfMR5o>rG02cKa0wcuWZTZgkG3zt!2FMQoE@P^y#89uo+t89;5A| z&l1Uxu9TD;_kz}{h`ysN4LZSU7{+V8(Ctwx5ZidlROgU?th zu4S)r=MJEF_78C^VGj7#=e>lJNBpTX<&EGk8s+qCJHkhX~+KDePO%0uQ2lo6v%BySSifhP2oEb?k~)2 zM)+9-2MaSB!j5lcoWMyGe_x{q@82y%@Ap74RG4`;?U??ly3VP_3NwpZGHU);B)_h% zcd9*w+^}dJWiO(2yXr5@WU0A5vbh&1d_Tfy;~5H5_t2$(Lt*M3x`d-*<##B)8F5gj z_~Ebvp!TThaAMWsh1`BQNYtcUj;3hz{d5GP{oHnRHz4!8Gzmm0EaTe+rLAh2Q>R^t z8X$g~y4H!VU^bsZ<3z5nkn5D~$X`c`5B3Ft3TuARMA|{+(r;CEgY3nyU+H3Xei79(EM2c-`Vd{gJHkR__ zr)>WqqZh_ft%&^%x8?_tA`ONGq^Gs^R3@Td zF-lxO58Crt`GrCu*Cr$`i2F~AKuxwr{EFJ*kGM3%U9J2eBIUy^MiDK4KD$%4b$%=r z%i}ghAIo{Pl*oTgW}X{M_2of^HqNgwD(*QqK4rVW!@nnbIGPIPGbhJ+FjuW^q)*nC z&-3=Pnd~;zk*(_$K2GA~y3Bhn^a^?Olvp=iv+L#`rQErBp}ifq5SNP9#0C z{!f?B<<&J`g8Y6F$zAh2mfOy^nuO3*wTvguq`%B#Qoik;KRG@RshYQ*9nT);p0n!O zQ|dbIKQoS|=6PSP4GysCrse0L5IxN+4*wb-{pQspUmY(zrQS}#VT@3P@nQJ_Z$Fnw z?fio307dSbT|1uL?scA1*JU9wpW{BqDekiy6DnGVAH{rX7fx|8%2W%QpR)ZU59cE3 zjOHWHcf*j%Teu6hQ5SEN7p4?9MvwG(My!`nPTeKSW#cILz|GkPnP6@Uk>a~SqnGa% zM6$J%)XRHD3mQ?GZxAxKd>$t4u(%YVL zcBxIGv!};tpskpIuZTYFr14hpKC!}<;Vr0LmPsh1QdLF={L|a1a%Po6HAbPn+&!`o z@3T;HfRcJxOYqHZ_Tw1&A#ceXUXkCTJH1Y%e1q3r;69AXC+33~$2Y$G-Er=F3rXrH zPN~g02~wsTWvMkNWi*fescYv2Ps*ZM`N6g1#~pUuQt}-@8r)J+QPgcHs=IC;TF&mb zMR7f2Y9%QOQ+FiMsTGB{2)hUDcNPy}j~B)o#O2c)@MpkRvV0$|k@3g{L~t|54LhN( zRk+<9#cGAy4MEL9)eWCAYh9Q=k!xr+5UpYPHT;|1F4%U9^I_&LP9S$Qq{wcPhGos} zB(t=c3lHm}T#VR~3lnuwF5N7aJVrvAm$i%!8j(rCSMqTR>0+f6I&cqY*66_XoRwY& zS(%X_N7I4(#-d!(Bg|Y}E?RTj;U9#!)GAp!%;VNie%eWXrg=`XHcYx6bis2X)&5U*y?lot{7V8Z_ut|7dv3)&MdD&aG4 zsz->rilStxF0Ky-GRnh^6N)0oV>o!wDY2&|2^|`5bkoKG#pSBU{k9KpoW&>cBFqzb58w_GOAgKe!F0)t;wCqx;!zs#QD zb){frPXsS8!D0bX5bqah9dpCrw5A)+S@_kB?<|OZ1Tsr6svG@F)3r)w5y{sBnZ<+a z^6+hg8+txFKT2p?gj=RQYMPTR_H7b3?RzUp3Dxe!4@$?VZUO%9{gt}yI_$*V>V|pE zpmsSz_RVT(4@<#ycKR;P1klUFq0UaHX&nxS+B}M0pZLl@%yahEpj!LR6<#}A6H#lg zljvHTdx%%@+WAyfw(szNl1Bx(lT;&3Yf2K_N|g9k5G1D+__F6?RHRnOBeDn#fG7e3 z;Faw2ylP_Y>^o^wo^s&6l+vz?dt3X&JJ)a+m(8o|$x0i}H6-wfoS58HP413ZW?@LZ zWBD7nV!@qAe*DVltJxnUOk$TN){k+gy5`U4;}iCY>+?}ZB5Hptvk>Fey|BMkjMi!Y zun+`bL)r^b9^v6FUx^Z*&S>dwx(CzjVs4xmz`mXs$CncBHsFb#0RS~K;C3ueLjaIo zf^Jy#ngANO(FEbzVVZX6tSAB}95|&<4FOewc7T9JFTP4^0WiQP%?ngQ(1oA}=VJ@& zq!66oTEtUM9xz)A>p+^@=Rv5QLTIdowNVJ@)`GW)SR<@&EsUNG!_m;fJP2SEpo;({ z;AOCKJh|dV+Z`~d$)c@5Fj*G1y`r+@Gt%sFw|2DpyzQ+%?0dr^sqd?H0loB46fXCG z@wnN;MgzBo=|&F|gPkUU(!~bJ70tdLFtEOo*}G>dm6;0v%%;H1hTzQF5PT?<^myT1 zempytDV$U9&K|@IG!D8txIg=lT85+pS&pPNl=RtbP+g0pr?b0}w2qQyvu<@glIF8b zNZLS2%g`QfD?Bw}ugq>i+D4>J*j-QJLSkm^ggt?K#QFUb_QTy1>kq$m(DwE`zFN6H zKd5AuVd=@tzl!KPX!x1#!z+bvlWq9$N@N*UkNx8TwKnqhe9vryP?d7E;Q+G1>4Lwd z9+g@AqR5;-xQ^;Hgw$<8b$8(H`L};6xBNV@E@oJJ)C_Dv-(VNBkB7{;MGPe*vtaSt zU4o-RQ`ViCKWJ0@Vyr?mpQ*%?O=c9Izr!yZo2>ZFHb&pI6(`XQAW?gv3tVcv z+l3r3UvX&zTyfAQ@vht;_-*xWZbvuQbf*JLXU3cXb=~5PC7e8dFwHq7v*hgdFH+)C z(F{x;IX-rH>~kZ{be3zEiso!IGz13rgRvVLLWu`49}Nu;g?UWeH*N=amvuW}XcS6s zxNb0=+ngRNyyA7vZW2imK$mQ*5x!Z{7nLL?y&W-D-8)owR<&g7N&3rRUB=UQ&Ek^? zc%#O;lwg!&8)~kutBeMKP!8`jy~J-oAFqi?A6GoXSHzjX2k{&z(yb5A8HtwX=Zv%x zM#dv_<@5&K0LOc0rcj4R6aS^3pew)m4Z4qdg3jWyE8jacpLfHIYs(=Xlf@tm?_RAa zxl&7sq_O_Nk%uEHHWW$mCJH_%}IGkLPx9HsOzl{&?w6EB$GsKkf9V agZ|*L+)nsNmg6tJTf*bHSQ2`E?f(KB?os&w diff --git a/sources/IOCHAR.~1~ b/sources/IOCHAR.~1~ deleted file mode 100644 index af538445..00000000 --- a/sources/IOCHAR.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "29-Apr-91 23:05:06" |{PELE:MV:ENVOS}SOURCES>IOCHAR.;4| 77270 changes to%: (FNS MAKEBITTABLE) previous date%: "16-May-90 18:36:56" |{PELE:MV:ENVOS}SOURCES>IOCHAR.;3|) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 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) (* rmk%: "11-Apr-85 15:35") (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM") (WITH-RESOURCE (\PNAMESTRING) (BIND (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N from 0 as C in X do (AND (IGREATERP N \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR PBASE N C) finally (RETURN (\MKATOM PBASE 0 N \FATPNAMESTRINGP))))) ) (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) (* Pavel "12-Oct-86 15:13") (* ;; "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 (QUOTE INPUT))) CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE BIGENDBYTE STARTSEG ENDSEG) (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) (* Pavel "12-Oct-86 15:20") (PROG ((OFD (\GETOFD (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 OFD))) (* ; "This is a non-page-oriented file. Use FILEPOS instead.") (GO TRYFILEPOS))) (* ; "calculate start addr and set file ptr.") (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 OFD)) (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 OFD)) (* ; "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 OFD 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 OFD))) LASTCHAR) (add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR))) (OR (EQ INC 1) (\INCFILEPTR OFD (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 OFD 2) (* ; "back up to read previous char") (COND ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD))) (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 OFD (SUB1 INC))) (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 CURPATINDEX)) (GO MATCHLP) FOUNDIT (* ; "set fileptr, adjust for beginning skips and return proper value.") (\INCFILEPTR OFD (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 OFD)) FAILED (* ; "return the fileptr to its initial position.") (\SETFILEPTR OFD ORGFILEPTR) (RETURN NIL)))) TRYFILEPOS (RETURN (FILEPOS PATTERN OFD 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 4-May-89 18:22 by bvm") (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 (* ; "default to this century") (add YEAR 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 30-May-89 12:28 by bvm") (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 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3452 7246 (CHCON 3462 . 4312) (UNPACK 4314 . 5208) (DCHCON 5210 . 6477) (DUNPACK 6479 . 7244)) (7247 16568 (UALPHORDER 7257 . 7353) (ALPHORDER 7355 . 9158) (CONCAT 9160 . 9805) ( CONCATCODES 9807 . 9993) (PACKC 9995 . 10404) (PACK 10406 . 10985) (PACK* 10987 . 12709) (\PACK.ITEM 12711 . 13166) (STRPOS 13168 . 16566)) (17911 20302 (STRPOSL 17921 . 19547) (MAKEBITTABLE 19549 . 20300)) (20464 20941 (CASEARRAY 20474 . 20664) (UPPERCASEARRAY 20666 . 20939)) (21263 34330 (FILEPOS 21273 . 26286) (FFILEPOS 26288 . 31765) (\SETUP.FFILEPOS 31767 . 34328)) (35118 75928 (DATE 35128 . 35214) (DATEFORMAT 35216 . 35308) (GDATE 35310 . 35421) (IDATE 35423 . 46741) (\IDATESCANTOKEN 46743 . 48022) (\IDATE-PARSE-MONTH 48024 . 51720) (\OUTDATE 51722 . 64386) (\OUTDATE-STRING 64388 . 65003) (\RPLRIGHT 65005 . 65243) (\UNPACKDATE 65245 . 71036) (\PACKDATE 71038 . 74358) (\DTSCAN 74360 . 74502 ) (\ISDST? 74504 . 75011) (\CHECKDSTCHANGE 75013 . 75926))))) STOP \ No newline at end of file diff --git a/sources/IOCHAR.~2~ b/sources/IOCHAR.~2~ deleted file mode 100644 index 97887274..00000000 --- a/sources/IOCHAR.~2~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Apr-2018 10:06:13" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;2 77480 changes to%: (FNS IDATE) previous date%: "29-Apr-91 23:05:06" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;1) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018 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) (* rmk%: "11-Apr-85 15:35") (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM") (WITH-RESOURCE (\PNAMESTRING) (BIND (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N from 0 as C in X do (AND (IGREATERP N \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR PBASE N C) finally (RETURN (\MKATOM PBASE 0 N \FATPNAMESTRINGP))))) ) (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) (* Pavel "12-Oct-86 15:13") (* ;; "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 (QUOTE INPUT))) CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE BIGENDBYTE STARTSEG ENDSEG) (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) (* Pavel "12-Oct-86 15:20") (PROG ((OFD (\GETOFD (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 OFD))) (* ; "This is a non-page-oriented file. Use FILEPOS instead.") (GO TRYFILEPOS))) (* ; "calculate start addr and set file ptr.") (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 OFD)) (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 OFD)) (* ; "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 OFD 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 OFD))) LASTCHAR) (add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR))) (OR (EQ INC 1) (\INCFILEPTR OFD (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 OFD 2) (* ; "back up to read previous char") (COND ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD))) (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 OFD (SUB1 INC))) (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 CURPATINDEX)) (GO MATCHLP) FOUNDIT (* ; "set fileptr, adjust for beginning skips and return proper value.") (\INCFILEPTR OFD (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 OFD)) FAILED (* ; "return the fileptr to its initial position.") (\SETFILEPTR OFD ORGFILEPTR) (RETURN NIL)))) TRYFILEPOS (RETURN (FILEPOS PATTERN OFD 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 30-May-89 12:28 by bvm") (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 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3488 7282 (CHCON 3498 . 4348) (UNPACK 4350 . 5244) (DCHCON 5246 . 6513) (DUNPACK 6515 . 7280)) (7283 16604 (UALPHORDER 7293 . 7389) (ALPHORDER 7391 . 9194) (CONCAT 9196 . 9841) ( CONCATCODES 9843 . 10029) (PACKC 10031 . 10440) (PACK 10442 . 11021) (PACK* 11023 . 12745) (\PACK.ITEM 12747 . 13202) (STRPOS 13204 . 16602)) (16606 16895 (XCL:PACK 16606 . 16895)) (16897 17147 (XCL:PACK* 16897 . 17147)) (17763 20154 (STRPOSL 17773 . 19399) (MAKEBITTABLE 19401 . 20152)) (20316 20793 ( CASEARRAY 20326 . 20516) (UPPERCASEARRAY 20518 . 20791)) (21115 34182 (FILEPOS 21125 . 26138) ( FFILEPOS 26140 . 31617) (\SETUP.FFILEPOS 31619 . 34180)) (34970 76133 (DATE 34980 . 35066) (DATEFORMAT 35068 . 35160) (GDATE 35162 . 35273) (IDATE 35275 . 46946) (\IDATESCANTOKEN 46948 . 48227) ( \IDATE-PARSE-MONTH 48229 . 51925) (\OUTDATE 51927 . 64591) (\OUTDATE-STRING 64593 . 65208) (\RPLRIGHT 65210 . 65448) (\UNPACKDATE 65450 . 71241) (\PACKDATE 71243 . 74563) (\DTSCAN 74565 . 74707) (\ISDST? 74709 . 75216) (\CHECKDSTCHANGE 75218 . 76131))))) STOP \ No newline at end of file diff --git a/sources/IOCHAR.~3~ b/sources/IOCHAR.~3~ deleted file mode 100644 index 0216c587..00000000 --- a/sources/IOCHAR.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-May-2018 00:02:26" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;3 77569 changes to%: (FNS \OUTDATE) previous date%: "17-Apr-2018 10:06:13" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;2) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018 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) (* rmk%: "11-Apr-85 15:35") (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM") (WITH-RESOURCE (\PNAMESTRING) (BIND (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N from 0 as C in X do (AND (IGREATERP N \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR PBASE N C) finally (RETURN (\MKATOM PBASE 0 N \FATPNAMESTRINGP))))) ) (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) (* Pavel "12-Oct-86 15:13") (* ;; "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 (QUOTE INPUT))) CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE BIGENDBYTE STARTSEG ENDSEG) (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) (* Pavel "12-Oct-86 15:20") (PROG ((OFD (\GETOFD (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 OFD))) (* ; "This is a non-page-oriented file. Use FILEPOS instead.") (GO TRYFILEPOS))) (* ; "calculate start addr and set file ptr.") (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 OFD)) (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 OFD)) (* ; "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 OFD 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 OFD))) LASTCHAR) (add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR))) (OR (EQ INC 1) (\INCFILEPTR OFD (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 OFD 2) (* ; "back up to read previous char") (COND ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD))) (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 OFD (SUB1 INC))) (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 CURPATINDEX)) (GO MATCHLP) FOUNDIT (* ; "set fileptr, adjust for beginning skips and return proper value.") (\INCFILEPTR OFD (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 OFD)) FAILED (* ; "return the fileptr to its initial position.") (\SETFILEPTR OFD ORGFILEPTR) (RETURN NIL)))) TRYFILEPOS (RETURN (FILEPOS PATTERN OFD 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3493 7287 (CHCON 3503 . 4353) (UNPACK 4355 . 5249) (DCHCON 5251 . 6518) (DUNPACK 6520 . 7285)) (7288 16609 (UALPHORDER 7298 . 7394) (ALPHORDER 7396 . 9199) (CONCAT 9201 . 9846) ( CONCATCODES 9848 . 10034) (PACKC 10036 . 10445) (PACK 10447 . 11026) (PACK* 11028 . 12750) (\PACK.ITEM 12752 . 13207) (STRPOS 13209 . 16607)) (17768 20159 (STRPOSL 17778 . 19404) (MAKEBITTABLE 19406 . 20157)) (20321 20798 (CASEARRAY 20331 . 20521) (UPPERCASEARRAY 20523 . 20796)) (21120 34187 (FILEPOS 21130 . 26143) (FFILEPOS 26145 . 31622) (\SETUP.FFILEPOS 31624 . 34185)) (34975 76222 (DATE 34985 . 35071) (DATEFORMAT 35073 . 35165) (GDATE 35167 . 35278) (IDATE 35280 . 46951) (\IDATESCANTOKEN 46953 . 48232) (\IDATE-PARSE-MONTH 48234 . 51930) (\OUTDATE 51932 . 64680) (\OUTDATE-STRING 64682 . 65297) (\RPLRIGHT 65299 . 65537) (\UNPACKDATE 65539 . 71330) (\PACKDATE 71332 . 74652) (\DTSCAN 74654 . 74796 ) (\ISDST? 74798 . 75305) (\CHECKDSTCHANGE 75307 . 76220))))) STOP \ No newline at end of file diff --git a/sources/IOCHAR.~4~ b/sources/IOCHAR.~4~ deleted file mode 100644 index 2ba4df7a..00000000 --- a/sources/IOCHAR.~4~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Nov-2018 12:12:53" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;4 79862 changes to%: (FNS PACKC) previous date%: " 3-May-2018 00:02:26" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;3) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018 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) (* Pavel "12-Oct-86 15:13") (* ;; "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 (QUOTE INPUT))) CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE BIGENDBYTE STARTSEG ENDSEG) (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) (* Pavel "12-Oct-86 15:20") (PROG ((OFD (\GETOFD (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 OFD))) (* ; "This is a non-page-oriented file. Use FILEPOS instead.") (GO TRYFILEPOS))) (* ; "calculate start addr and set file ptr.") (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 OFD)) (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 OFD)) (* ; "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 OFD 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 OFD))) LASTCHAR) (add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR))) (OR (EQ INC 1) (\INCFILEPTR OFD (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 OFD 2) (* ; "back up to read previous char") (COND ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN OFD))) (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 OFD (SUB1 INC))) (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 CURPATINDEX)) (GO MATCHLP) FOUNDIT (* ; "set fileptr, adjust for beginning skips and return proper value.") (\INCFILEPTR OFD (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 OFD)) FAILED (* ; "return the fileptr to its initial position.") (\SETFILEPTR OFD ORGFILEPTR) (RETURN NIL)))) TRYFILEPOS (RETURN (FILEPOS PATTERN OFD 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3490 7284 (CHCON 3500 . 4350) (UNPACK 4352 . 5246) (DCHCON 5248 . 6515) (DUNPACK 6517 . 7282)) (7285 18800 (UALPHORDER 7295 . 7391) (ALPHORDER 7393 . 9196) (CONCAT 9198 . 9843) ( CONCATCODES 9845 . 10031) (PACKC 10033 . 12636) (PACK 12638 . 13217) (PACK* 13219 . 14941) (\PACK.ITEM 14943 . 15398) (STRPOS 15400 . 18798)) (18802 19091 (XCL:PACK 18802 . 19091)) (19093 19343 (XCL:PACK* 19093 . 19343)) (20061 22452 (STRPOSL 20071 . 21697) (MAKEBITTABLE 21699 . 22450)) (22614 23091 ( CASEARRAY 22624 . 22814) (UPPERCASEARRAY 22816 . 23089)) (23413 36480 (FILEPOS 23423 . 28436) ( FFILEPOS 28438 . 33915) (\SETUP.FFILEPOS 33917 . 36478)) (37268 78515 (DATE 37278 . 37364) (DATEFORMAT 37366 . 37458) (GDATE 37460 . 37571) (IDATE 37573 . 49244) (\IDATESCANTOKEN 49246 . 50525) ( \IDATE-PARSE-MONTH 50527 . 54223) (\OUTDATE 54225 . 66973) (\OUTDATE-STRING 66975 . 67590) (\RPLRIGHT 67592 . 67830) (\UNPACKDATE 67832 . 73623) (\PACKDATE 73625 . 76945) (\DTSCAN 76947 . 77089) (\ISDST? 77091 . 77598) (\CHECKDSTCHANGE 77600 . 78513))))) STOP \ No newline at end of file diff --git a/sources/IOCHAR.~5~ b/sources/IOCHAR.~5~ deleted file mode 100644 index 08456e13..00000000 --- a/sources/IOCHAR.~5~ +++ /dev/null @@ -1 +0,0 @@ -(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/LLCHAR.LCOM.~1~ b/sources/LLCHAR.LCOM.~1~ deleted file mode 100644 index 599bccbe1a3c9378a8a40903dc924db6b4adfc97..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 23177 zcmd6P3vgW5dER0H(j;vl3lO4FN}^98kp^f1!ane{}V)Tj@-nlN2JNfisMAqTS?UAg6x>j9ivW3X~r>|vI*d6XEbhFd#0HfFgw%f zw2u1y=W+Mm#gdjY@k}|x#l7dA=YRh9|DV$li4N=OXxFfwjCSeiVT0|+XyJsmC(7FO z^k{S>sb@3oY{y7ci;QZaWL0rU%SM^Er?atxItZiIXf(pweZ5`riJ7j!0p{%;@&$%^ zdfQn?`;pnB$EMB69GjhC?d(gDY~pu5XHL%_J2E>r`T6h$owbLJREB0tBj(!KG&)O7=FG{bnK#g-J@GhI@9yqy zXSs<54Ax#LrOEUU1qRxy=j-)}`3A6-A+K-9k8!^IrA#y#9ZKyVil+A)+28pbK_YC7 zL_eQ3_Kk$2S!=3+FSCAsATY>|Oij!@J~_`8W_J#;j^T8+k!43mqI>sgNqW%Jd%F2c zCp$Jb`Q-HM6Z3qIsNC-LcV#D!bq)3~Z{JX$f5;1nHGcFd_`i%LjbyaFdzk_%kdV3ma)KYuwirCe%%e zKjJOJ#{HB~d~(uc^H0w&Ode&^^AcrpKpA#q!ZaOd!X_S{n4W1zuNl^nGWJJ) zi*@YXXN*Q!qZm(NlPnd5T@uC8dXkNzt)pShcH!jEP*zW6KvT{x8bu$S=!FnzY)^EQ z2wqeI%Iv%SE5O3`OfH0u95b^EbJH`Av#k9MJw~G8q&5--@;63|^k~?~9AX{OgBfFF zly!_mL1~e!+BQ_*lQcqFazEkDm@zXMo|>4`7G{rzCgvycbtEc@l8pg{F+uegTRoOZ zYbiNtRK@;hN44}Q$YTt%w0+C~UZ{}L!XpMov47b&O4y2zMrKq`=?_IQjbV#=P~NC_ zXS_e+mpMCoj4e#g zFW{XQKR$`#=_73R*yJ2~nwuwdS(u$=lV3bGIWs@~>q7Wjyb(=!WG*61h| z6F|RIY|Tb3Q;{LCAKvEcN>gl?Kr5Pw)tFu?b;js58%5vrFhCQ;NBhQ7IY>Fde7(K+1TsEI zMe?VnsCnfPJorgdHT=zNj(GB09Lrs4=2Pvz;uQ0`ma? zy0ZH+#Byjiz?O$~ZElYA6ZRN55HTJBLj}?~0%c~z$S_i@Mh|5m z9l2ZvrZ(Djh@r?pV@Hy8_!;PBIJt-Un30SyFC!%3aOhzm=nV7vNs)kdF|sei1!yO$ zd!xzaY6#|+54-ZgwbyeqAAY#@Qqa76iwpnC+WCh3*EZCh%4=&cX`89&u)7>Szfm(k zTxQ9_?z1{3-oVpUq|IqC!)32u-nrg*k?8UUb*$jWZuzJ#r{Hs~&oHxFh$i46O#55ew?b{X`_0| zZScHQ4h5&Sw{9wjWTQN9bRz$QdOm27|7Q5_qx|<+IrIphO-gTdZ7m)d_ms`1PvvN8 zIX>51;fL-X{+ucEx$+4l$qDlb$f!oC0xK-;VFy7}uA|uOx?ql@L@8Siiv4|^zd!q) z%lUr2K4>=ZozDR?Un&R9kMlQ2trPFNUoa!9pCB~y2V0Kh7z)!zrW2+m}ONgqhbS|Wp~q4>@)--o>Q7Kmz89qwv}5^_P+osF(AxwbQZWa$)(q`YXw==JmDHI=x+p<=4*j z#PqeP)pMPClK!;E6S3u^A1>>$mBO-fGg1Qbfb(F$0+$*5L)qRf+X#U0-OZp zK(AHe*pUj%IfQ$AVO$Am#sdB8z-@_YrT|V%5{UP&>p0?Vs5@N-M|?>D@UROQ2-GT# zmLDbjIe)MD;Z$y#uc*1s6%*immjnCvrannk%Eg}oO+n!DqlLQpf@l{L)ja0l+RKkp zi=eq><%Y-X39h{sG<#M&qVNVVa}f9?@e%M+@DR%!biN1t4*SyE3znZuM)zpRZf#@_ zj8d<^f1Se4yxzVVg*|9&S9!XH&aV_C)`v!S`tApVxWji$rW4ww-Og2e(aT06qoE`V zun{eyA7os#Wgys+(KM(cL}WqB?_|Raq_x}fhU}&SzbNRU8oN7L!~5IZu8q;x4m@yp zOIgc>mLDf*M>%*wH0ORJ3fgkH-gk2vYW|-s%{_NT&VM{{@<8{q=9a^o%q_QGHnoWP z@s;JP=HOS%o=9P3`AXva_Vr!3TttSKWBTfM&bodU=L4-S-X$O2iRVN~>9b{{<(0h0 zX#aN5Xo(q~NVt*D!Gl*>`PEoqc43vz;m;B# z@XFLzja`t=yNW-a=1mU;wNRLIg|lwM>@k|wPM&qWV*nt7^z@yw9Ik>1on@mbb?ekL zre@r8z6tB6tER&I_c7|si9!;x3H4*+Tsw9Y0+O}PwNg% zk29K23txdX{km}BW|8)6FXWbe>`rr&V_)jFqf&Hr@n0rOhw&6yUHl~e46nY6-{k6B z1jy`aNiQ30QQ_3$Cu>Z^b;H>9DxpRdO-upZ#ByClbon4hPuHtS+C0~{Y%_Cx9eb~@ zV$WWXc(A)X-cdGo8y&Y6Lxcyr1s?1Mx|=<}SX;ag`?yy6RQlYgfYnwG!`CqiTY1)K zO0T^LWZ8|4*@tEq!DC@P5N0 zhC?eI<%(>dE7Lf-mZXLBLld{P>cdhiGwkcL z&$q8vm};yy(6g?eUaZ;HPcMX9703eEluFlu0SQyvTml1ffB<0e85Y2{%e4idlv70( z01|aEKQuG>#Xmsc!52T2TaF_Tzv#OQ;+3ir3fiFQ>+$2&0urfpz<_=S0{922r|yM8 z!^hi8Xw1hGTL@@bB0a;^akvTgSVhe5vw!zN&v1T++C!5U8ivA9r|(>;8da(VT#@j1 zO6>yb;N8#+8n|`Je=Ppa4ZkVqX4nvrVwl@H%%;8y)l*qNgNWYDz~Y(C!Pk8B@GLn_ z;4_?GAW!ThywP)$=F{ZA%grv#vuCpHP<`4*=O!l>xMzTuPQc^%7`;Bto|>GSWRvqp zCXP+!U_wo z&ph&swv&gG0EQep497BiCQ=2MnJ11OMiT)VIBIi~N2ZTXm~3t$H~mF|Oodyi4POV7 zbd+2swL$U~Xg3@4&3iX!q16{-p8N%~{t_M+hZ8XCwdm=f#+4pz=^>~Ci=CzxUwg;g z5;w>Ho2jiVKNp7{e=&SokNhaU@;v=6Uq}>IE@_43!|vk6Sbp`SUc5i`MkJT}(b$i! z#1e3doGholR#<&8`9i{Uuf7;LUigu|{N3US7g^EVk|v8;+BIrPpa!lkdqJstxWx!> z&mh}PfuGT?WORQtxf>+|m6G(H(HIr=t0Jx|qo7X}aK)Rd^g7gQLMGX76e1%NC5;=* z*r|epImk*<2Y3B^iyQVU2Yaz&0*8j*w>+z}c z4?oJw*@11`l-p4Et#To@_C_pc-oJLH9OFh^3oHSA)pDh_(CJWadiAC9fmYtl3;g%l z1FhP*O)+x|)c;uX{hNi^$k_vVT51H~ys%>}x)oNAHvlk2A{ zZHLd>@8pVJ`>PiQac1NoA&3`pregnkAz`dHX_Kv=uh!Gk{heh_KQisS2 z>yZ;70}Tj4d`BQDA{8!=%k6T*X$U>{h`XFA+&qFJ8$#Ct5DnT^wnjr#7mWWQ|&w_9=s z(JfjsUvDIO5L38L3*MW{NC(R5pOiD4uX2<-;wtY22;3Rr=ge>fdk$~po+>@)C_a&S z&s9}$y?!rwSjc&(dB_vH_&`;S+cnXydBk8JvA!4raDzUloDRyP2>nPE5s4$O03I=H zx)pnc!>{6~QLP{!9jyk)>nOZyvPvI0FhvRPH&Cfz_x6y~HPT^(vz)FsC2uhhG84$X zupX7IEhX0)7~CKmjX^7g%QV_0@F|N@i&?HiF?_WAN!WVgnH6luD;TC=yt1WmqY^6( zSU7?gzmsCXLPaaViGffS50$JKMb)kjc=R1(5&ExeX@KXnAqVmCcCN7cdd{q0EzNNr zcfQ9w&aq9r{fkY+_?lbX!Q6)W(!DXA6H0NXa$x;LJ^b~7)~N&A&NUopi|In(Kg7G? zKZQ7NCf!-O^lFv!xk7Vz^MUQ9Ha-drFToSx`FPbb!-AY349~X|qs*m1zRMV}bANPXRJzb%La35%WpJt74roFWmHklv zD@y=h;-*~<3?|;_hq6i1U_E{d&gmuZ+-<&kfl1`M6QOx;wOSIZ##N?e{x(j%zDQB-llO z7lybpD=h6uRphc`aGltKK`ONp20>GWA($=fKA9IKu+0ZfU~M%FU{H;<)tJ0=Gz-lG zDRB^iBm2^6$}5xW1YZK7jgB5t1stUXpRge`=}#iJBaIXx*T#y`9 z5Yw7HiH09;u5;Drp~p(hytk~qr4()9XjYpS6H&3!->bly250Lj(;XDr@5%Ck7QW^0 zZ+Ic!oZY0`(G8)a!pc==(R(iPBkBr2uQ4*Kuewx$@}@9iao9*)Y&!~VftFSa|)ZYjnvjmVdV&72WD#F@Yd_I(u z=GKSC9Vw`{hv)hF3Otbm@V*;_^tQ@nDel#B`L&l7h}XWUz*igy<#@0+wD!%A1ZnYp zf_&*y4k$|0els{NbktfO9c8x#yE}G9k8`l=aRNJl&C@R&hL9KTQUy>BV2X{a0y~7g zJ@CR;0~OkDt-5`VXnVl%hVdNx029l$bL)3SV*W4TH{dkC31QYiPD8F1a34#li=yeL zxqed#fWv*l1K_c>*J4%xJa&WY5fv8&)Gr&+f&KM@GgoDxGSWAz$~dE}=G!PU9Tg{%B8w7M%5txjfNyrJ`ME;wWzkm9nl;ClU4 zB^PUp#g=kP%ilT$l0A{oZjLwIOx!}OE^+Hc?YKhNa?EJqSn1IFFxEpxle6f0{mpTY z(eiTK@Z3nIZ=}9o%sMJaEH8P}shfqBwBc#4{{#ho5&euCZ8ws}wk1kh+J-o|=SI=V<8AC{h4PwW@`XMq22eR_W zS7guZfj9W&lA1?D>pxf1$Wkg&m6f+`G>P_jbJSaR% z!gYBfM$M#Xxms(pFF6V!)35LppERZT#9v8&H6LF)9jCX8Iud>mDy{pD9;Zn0%keb* zIo0fG33FVB7`rt!zM~xGsdV(~DTgVyE*v9;00H3yr4ArO4Q0=0xm^w*bVb7>R7wP) zIbuI=G?9Zh9M_Rp1k@XEMf%+~t`8uE4*7T1GqM6HM}emWhV>Nr%8(5KG&Qy(s}Lwl zK4ha!b-$f=|D3TMo@1JDkpE`*@1y+pSUEht!?=egPOfNU2Va)4BZ+mLb$z2bxUE(O zp;+*)vYf$gN(@18JZCV`QAU75Ij|A`&l&C9hi&Y}RKz+vc$Q&@SSDo|%E$2sa>g!e zLJx=uJwOv`IlM9KAzi4KWUbwK+)F0Ey}-}apLNNCeo%;`o{#()_J%%)5qp-Qo#1@X zpsZv;uPs~9F1{qCBXFq*&)x;RjSfN7Uqzq2{T0Ha(fC20jPm@E$yPJZkj|$lrZ1D~ zhIpmQM|p)Q3@%cL)$L4t}9(?_G}F5u(mED+Vy&z6HZ*v z%^L|$HYXC442w*qD`RFuN}y@d+^C*5c+MnKoDjDHCkwm@X*&q=+eA1{SW%2boH7uW zd~bCDA{KUxQ=$U;zQQ2Rx@~$se~0@)eYay6wn7!Fo_?tkN=KUPTLi`CpBsI|fvH~= zedIAK``k#XtVf@3yB+BB2NwDiRtWo#ez>~$qyq;OzH~ZDfiE#?9R1Kj4MeFNr~ztrq6RFm>b-*ktcnB{tlQqciuuB8z^+#|C`^{V@t`{((2+r zOnJaN7XLnR8a4`ignE1_eL9(<$7E`0_1u4r7j9lm6>eSu!rVMq{2Q_qYx8jmEGj4~ zGPBu{d?O%QR2BP1*o;Zp(q^iw9drl@jOBQTUa1tf8p@gN?59Q4m7R1)aVWyw{HL3p zsn*cCge$|5b6t$fB=v_Zdb;4)G3<`hM?$I9jv8`*E^9*7n=b1b>3SG%bul(2JaLCz zxzhiVc=OTwUwo4bi{h)i!z+cWnx!=s6Z}&tr&rMNj00^j@hi>(m@19}IdQ0K+)*q% zg6?{t&lfhi@Q=rWiU-uu5u$_-{kHMw{XR#JcN%l?lvvEy`C#w44klkUno84pBHg^T zu`s@!jFdykGjU@Zko7tISt2E~=}ZcC3kvXOiB4a5$n<;*+9&=X)zfHs0ST~6Fra|k zn9x6-bQ(9tcH}O;Htlf?^Ya*WzZ9cBWwVECG`s2Q2-xfmJBIsh7P>@nKVnph7&wmm zDW}Hn8u7!dwR|#uWC!4^RCI(6&T@l>`D~_)eJ~%K>Z)fsm=9L7D&m9rAYvVZ`H-BY zNXTaswDyj@>jSvn>Ig264BJ=X#Yqus6<#Ent9jUaw&l6Y8RNK#s>mk{HPA6%Bu`kX zU`N0ks0NPT*T1d^i7Om(h{j?bPH1xFOaVZ#`yOV5;yATNCk5Jo;W(nQq3Ol)a~nM8 z8sTy3Aua!0JzP4r?1r#7;#}#1ON&1ftpyPtwRi{b;E`JFp|s0U3QBRlU#|z2!-dOj zKkKxC^Zk1L5paAP3QIVYWQk^I{SMI#;HeFfTLgco zD&bp%aEp4EHEar*K=BF|+IJt^+p)K{t(7@Y^1QecsCDmxabru!)`Tfq`qd6=VEGHj zQ{*&(4SK_9`+;j~vT*Zq@%!m_rK^{7uhqB9dOj%*g0!fUARHGk@4s*QJaIkcQd)KfVid=2u@G)57vp}pN2(C#ve5)X8+pr%5u@b~!6%!r;OFV@ z(xq53ZcZfD-cHbxU&E4*Cz=}?jn;3%Q`B|?rnKvK>B-oBZ7XRD#ebUuUe=dd>-Y+T z?sJ=iZvMC()<6Jusoc!~)C2iQ+)d$*z?2?mfZvaJy8}mjwk#DpE|InBtO&O1=$hh^ zszBl?Mc!4By)!S^w&Dq1iiOK#IbI+(QU=7m3|%rB%xr2VUjsOhGr-S7_;)xW1JejG zMs5d^6J2$@o57uSr=vAU$GPKo&fDZ&3yOp)$%6=D|1GE0|=@|3osebitfJ4#`h-8t})68P}h0nDz+H ze(rw<-BYXQZw1{HMD&uUM=^AGB%t=y+F+iFOjLAhj(H#mg(%5?2_@u+zsUm=XBhqzV)o~aCOb3y7bu7JUQ)cqA^ z+Yo*SNBlX+4{t1M4v52CzIhn3$fnoIErP1_@8!XNq3_D_(vYJzG-d6EqaI3}@6esY z-#=ToCtTeyq!pT@o21iID%F(U0=3IoDAlgGT*dNLOMTkGb*3xH*saB_dV-6rMB(No zF1G$N<$XD(Qd!!GU&mxRr6R|tb5Dwbu-sBF>xtC0vNf;&u(dekm{tvlRf9?k%i|%W z)A777EBY6(d5Abg2i9v`r28pC5aI{=oE1s%Q>@y~B>XlXuBZ+#F3Ed{8$;K<> z08Y1cg$x~;*oqDEwBSy%0s9L%;Se1~z!&7Q-nq>~J9+-?~bZ>+V9x_6-9>C6)$Dp;|mr6oScnEyuwV)oq z_Iv!)Lx?l>vR=4(p}4YDP0QmLyvF>oLM0O##D0Xh^8yg~dbkA99pXL;{tHbhWZCN0 z;$+FuT{dc}fvVzoS2|4Xp*cgQ{OO0PiJepN9CZ7=b2R_ka5YNQvGZ^nms7-4VTXJk z)qWr5$I03DVVsJz?og`&Upw+CdVfh3Iu=qrWyK?{(}8r52?9t>jAaF2Sj0i05h^9E zatO(18>8P2g+B;tkq-pAMm)GFBCj>qyLAZvTfun#S~&DaJl;Uhy+q}J!{RO<3S`Vj2am_3MTJYyWPP72EGd?$L$+bpF-%o zLkru*gH>l9R4d1wj#f$l?(e$YEpX~WG23-&YIl1Wzb{N){00Si@i$0Xn;SV74Z`h< zkRT3=HJ@ujIPV?KVLAUPC+OylFs{|g7Z2ko*~xtIVY)G47fO&KWbUUDol5$6ozEjh zAYUAyf_h%iWj0XBE-Go|C3lzfm?f z74sPVl<6rRreMo1Dr3d{82=RhBBhKbz{^6IL816LDybJOdoTrR*+FHkROTt(LzCEu zrg9dZ$}E0lehPPw;olfiaFQGfaMb3E7G%OCs2ttl?vtF+Dw1V-C@u6+o{F;#rQ1a5 zqh)b=RK;kKD@2!jwOMI5f_}=6_nAzqRWmvoT9YU*E{cMCPthJP@X>Jru0V)OwS2giAW8wAu3-%dkrymf@^JVT zZ69!sUz9r)S&)Dav2SA7@+1-kWh<}v&U^?vb-*J8Hz{}mj{PGSwFj&(0JRt=9y&3o z7nl4_%zSzQht`ih&5q5|No^du#`Sei&x7Hj*&RFZ4K_MDn3xf5*;CUCQ*35-rt7yS z=Vo#G{jvGU1svL|eHEd_bQFOIW<|{RG32sKeU^^On42uT;3#p3^0VkVHhGHJ4D&oI zm4SfG-Y9qYA*8a<<#dT#i+AbCAe0(Tbl1qqI9B{0acnAlTlOdjKV@Z0T_G7~-(kuc zwC(45o`%YF$zN7p?pL|&Z)lh-b9sp%zg!u+Rb88|kHpOgFatgre>b(^mTg&nAg9% zdti5WZyRfGJ2Z3n$fTLiv6*Ss#u|S;oQeONe>F0fpPhTKFn+`wpMEegb7KZsv*EL;1M}6Nyk%8}53**MS)ZJGCRTSf;z1d9j9fx8K*s z+CoM$P1_-ma#&^(izWGt3{$e9Crp!Np2mdp%-7dx9GVw^c6D{NvE2APz-zO&`!H?) z?w*0RPq53LHug{26l?77?;q@8hbG3SAJ5OR`I()&S^H2b!$vwogzE(V)4`6+=AWFL zd18(Oj6Q8%UuSH5x)Wo)-MhWM-F|@bPeQO4+Z|48d-pPda$q&X+Bqy*B4LCw*-o3>pd6Xtfiu z?V*mzxVlWnA$0w)TFl(B%Cyj@~zsB14ju_bp zYqWR6bI~dqJNbq?SV~W@ES@Hxjdc@M>599a43R@AYlNg{^F=d(AA@#^F$f8Wgi=#=PN>j&QDmYqg4Qad8yfg zMr~8EA*dhdu-#>&I%ihmFgk$>_y+;nW0Ui2<}sEW2PMzW9RidDj+#_b3Q>Wg8k)|c z8U8@h4?U<1#c>I;B1o*kbW`awO1GH^=BA4Q0uT@F2TSc>8_TmxPct17C+eW%q z+p~3%`)7T;T?h5j zQ#z#8ZAsTog6O?Q3eZGceB+@I0d|^{%&TM)aq!Na#AcmFDiZG0hKIESszm_SnKeW+ z=Bu1Gi9iCB&bPv}6`s|?Va}G=O=O>tf3%ie?W|q5Q8raC%vWy9%qYNYpguJT`6z7? zXjI}0^J&flm33i5fUluy5{4FLjYGpwcF<%a5o3sjbx4)0F|0>29W0cD@BsokGb3pd zIdmEjK3Xcw4~~mF8+|$nm+;QH0>VX7IyG6;DoEYV12&o_EOL3r&7Rt)a$D>Wm^IEI zf;|SLA;sFE?xm#c5)ut(N%}~eoh3VkJq8Ixf=A#`p>&o|nI1OMj4ZM2fi%n)u9rcn zjrPOb9Uf?GPq21B1HTL<_Anna5@F_LL?j#!-3$z!hAl~k1gwkUku+DJ9jxxHCYP%r zFtvQpH5FKWGdF$f*6K?E^Yfcr_*c@-HB5bDUERqkZS^H>BQ+g#mqO>(Yv!%h=I?zb zdNNR0em-EYihM4(E$HV^WR7L?~zjQ%N&}d-s;-CaA?d^GMm1TBhYdj)?DES z?rwgaE^$~nfX|wtE4dVblB2l;V@;);*GdOyxR^!>$YDI7t*UrGPl!H~IauAGncD^ktgR5l-~&C{GQ_h51-THYWH^cG4kGa zu>qh}g4N##ya>r;$4MVp$=V|80XCI%;pZ}74U#7Sl&ERA)7Pi4DACi=s9XSr2Omp< zg;Px8|IFM8zf>bI~t$8R(~-ek$Pz=x_T;_SS~DoSAQ+>^(lSzlumc&qf@JAyQBK* zMEPuoo}fQ%v3PX(@U3M%x>8tn9!64N9(abArO@joR96t`C4#nNlFmdSPNH(4*J^Q` zNCoE{!@a$5u7oyYJ^gFYZK-Oe5Kcl8g!gajIN`0UJ5_>2d`TeipbHcT(kf<4j}rZy zyW6}qk(=Z@YOZrd1v=m7$o{Q~&rz4s!ry{S!Qk?tMY>Z3F)k{)dCbApS01Gi0dv#J zb&uH{SbZa4cCUCu<8@HxAm~fdBk-m0A+|Z_yzlWl6uq|>B0rIc?9mck+VCDYrCxvk z8iSpAy?r$ryD`{q@^lHCUl~ZO4}=?uj^TJ)4>hqrkk&rTG;&b%JLO+ z@M~swxUjN(Ieu>2+9_NvV#7;Oz5MMnuAjvCLgmHJ%8U16Inh#lpk%bXHsvweUJV#6 zQNt4sHF6j{xRsq>j}}&r;*l6(br83IC_9m+t^XV2uHvs7t?x&nUR3|FZ6)I_bK`39 zZllHAxJ*yB7%i*cg6`R}dRpilXqMvEfU(tD#M~soI65`99gv{&Hml9pju~24miY{% z!(^Yz0@0(!^Ms>QR(E z-?Jgo{d;kO*8NSxgHbQ)g_USwdF`q{@pa=~ zXy3*9RC_n)}2cHzBvxi-$nylfu)lw4w)Jn7Jm&pNv$sK1~D!AYn*A_fypsO@U-w9 zSm4)%3O5$$%=SWW+1KtcH#p9vZW}s9%8S2}C?3RBxV-o|{2400kKaW39YSQLT+~Yj zTU0c)__-Q@xUL&pUMJG1;)w~6o7k>v0aM=3$^>D zJ}7cEwd_M0#yj9=od~4jF}WaNeUAS>?8-n*iA#Yy~dJJNA-jdYA;Y0+nO*E0) zGDKdqZlu`YfX_C?AQTGkzn2YqyKN5!1|4^O_CW)%YzYe1KRAF33TUMw+>q^a-1hf7 zZlT*Gu>HL>&H}05*INyAKeQ+BOzY@cf;Q3*OWZc94_mF^qOZ>mZ(px))mU#&_nLWn zv1i*ny-;pdDC@zYRHp73kT|u$(la0z=m9Ri#CmY-a&J8_%Bdsk0TFdFKP)r(#6Ljj z!4p4>TTUZTznHrd>Xo_@3EHsf>-OW;LK2yEpn!e{0r&^1LHEL;;p^=sGUn?EVga@+ zm7eD2IKl*btS097*`NDhXE>k3>>=QVg`p_a89P^|MwMxSP$c4=(z<{-_<2|c4ct5B zKbCywj^6}qGaLw5F~ofxq){yMRhXX2`x!(&Xc`{RWDc?B!v|+5aDtfO+&o2M^N2>z z=FO)mewUk>pJUHt+F<&$WoPr_^E@)ZTgMS`e2i|NW>4j3^DIAiX#7Y%2N$ZE2`!rz z=^8{-ZDv$P-;;tF6-iNipn9+U*z5YrUPFP%3GJh!T2TAX5w6q1jqAuzA{+>jWp0W{ zyT#Ss>ySErJ63!UP|~PZSZN0hcH(%L4Kav^<{!_`vYlo4MRaVQSAUW=RxXx!-0mL7&Vu-IX0vDNp?O)+!qf0)|J@^dlR z@fSj;^zaX3E6>yK^7(jS<)T(tKImS!5S=QY&=>AWz7@{pemMHW%h5Q3A}318ZxqVM z6EDO~clmhuXyJ$Y@^=@GxyXy=o-}#P(yvil0yl7T*$YnH!#zesdj{DqO8jIy6Oo4^ ziCt(JsI;W^WTVv7ubQ~6jD|kdzzuKe((5pX$F(5EM)Q~%9U;Ed}xgfBZ$Y7W#R3?n?+Tnv#D<;k9>cno4QA}WL5G#&|m_ca)y zDmZg77w5s50)jL8cM+P2T9Fxf)v~blPl$Spn+pMMvi>KoT8~bgd*o5x&h~BLuH3r1 zZ2)Y)6XhENCK}1xsNIW7}ljIfBheJq{MUf@s5ly&z zuFbAGtmgNeZ3?8hoZ_TF0iHf?H36g4pIa&{>$~HY{Wb`0x8*dlTeM}q-*99C z6p3BDud2uGhG7&V1f~$Ya-;~Ok|^!5XaqNYC&xg9icvxm zgP<%KDn&7xszV)!=sVUT@?Y81fXHb>4(j9GT%r7C&a5vNXSs|!*KHo<)F$qJc>@W) z<`#D#x30c;cU0$$vanMHuzsX2{&HXI#J(+O8}@CD>O$c^%%|Z$g%}?u!&$nFYL%vP zh33%4ecOs#`6_U{giJ)_<8{jo3vh-oJg*imb51opyrC4I$fdZ+G1kP}Wxpm8s3ZfE zTAF8ryU6PpPC+zy$(OLpPS~oj%g~W{9j0jQQJ`AKSwW>CzyzY>W8*@ybc)g)FR)!H ze4xmrV?l^VSxYep$qwp#C^DRtA#}J9s-;UgT&lJMmXIW6Kg|Ei79f|nYgdDUNjCan zY?3xuOW#6rdMP@0o2On-62u+jM-2qJCo*%3EEUM4m+^6=*mycx*-mOUO9<4ooyZCjbzEyLpdk_smMcQ$ z4_R8WH!^DLH%Lq8jEvMjfIxDyuR*79{lf^(U(~ID{b-4t`uOU}&1YPHnK%{WA+%U@ zi8I#1-|#=hi9oZ~;EW<)t1qlva5jD5x)_T}eS^q+jR5~>DOOm1SYKUiO`M9y$Zn0t z!Jj;`5+0bqlN}?>5}_| zTmqwIvj7Al~~gdY&~hZ1H$?}QQFtSkNm@RFHALOHt2S8L+Yro za>d#7fs5jZx}wj^j;AsK1r?DhEPo}ry13KuoJPouB5e4xG-|e$-%Y@_ej^bp7ymk5 zSiZRMU*avxh(VK8*Hf`G9P|NkT16j~j)FcaHjK1B$cVA0pO8&a^n$2|Maeis(6slAr43BO`%l!p>`34P=CHNBjP@L|!COj(N8eWrcJ+J8Ck|U>z zqrTv1kVm<&gXbs(ah+ErcBybd`EC>CiGZ#@%#S&v1R3oAH#kGNX$ zpl9*3g=ioc;+6(7kNc_burLi|z@5ip;4xT-1pO$PA;WN`B!itqki}Kak^t6Za;wZy z=qlyb;2;n#vzcS61UJD->Auu}l&(ZM@c%WWtwj=>7&N%9?(F&?tb0xZ zD8Tq#4QN5wpj6OSU)Q22$WT=pwGP11RwG}oA%)dkU$38z#jgjy?|Lp44_=j-@Pn>1 zw+;)ovH}fW1k|c91$#@iaArb@fx35~7(%*|-=*ARbx9`~8+M*sn;LhNpxz#z=jto? zL=C`)ZZOijs+MJ8ua=uyeMO;o^<{;=g@Is>CwqgdF9#(`7w#d<7r)@Zq9pCN1Czo= zt@Y5+c3ZT&qo?&4N4p*)v;*0^{KDY~c@ZvE2;~T-+_-A6W7yk`D10?iVg1(X+Xr=A zIgK929oBQ416(Xy-?gVADgWol8%Ua8g)(cPpdmL4c#NgkN!j#M+`g$Kz!5&-3GnFZ z8&N9(9=*=(h)Re8=9i7>ApUwGnX4*L8QGgvZCp@R?Dq;C9k4NFU9gdehy$joCxXq# zHY&^N5nWYZaC7cb;R^o?tL}2es*}|hZ|QuR^A24HqPXO2xK@8f>BZV=v89yMrf!}D z%N~nsH^!Q7#BU;37r%L2JE{n_6g65nRXXfGto5+b&ZV| z$T&JkDld9d$s2{0l;LTv{|qI5k^PJrTdyaKElX6iv;~PQs#C(Bt)+#JHve`ag&C6~ zKpe%1@zNxeI!A&BvM2#0)2bFhQp`%Vs~`dLG^$AuK1Ir^3ET?>Y$H!E0?ulXgE^|D zi3yAE?TsSdqQ52kIDXjX0pA zD$o6^@S=%jnr}8o6~RTxf4IbdL2g%~mJ@NYu#gsoQg6#><$e)a5~0guQ5q&y%avM( zebLbfoqm~@_@t=BC-z$E>r=7SQ!%=`prhaisnWV{>oLj{zYGWv>q1d72#^qtQ|SOw)G+ppmfO_;!d5gq!lXnJniKZ(MiT{iLopqN zMIgPgR+Qgu;r0MZ=um%WU85?HY7}@`U`S6=tPIr7O&U zA#zLr2l#KA|31opkCZ}V+l{*ja0*2m+xfPP?FsDbjO&}tfi1Nv2*rl)ElCJ=QDF#@ z<2i$giP8cUDu9jrf6i#*F>GTOKoR?F=T(O7Vw+TDC@;tE%Nh4t0Np15x{m;AIk-OL zAzP@Ibgeyj+)FOMy}{4TpEbpTesGARpO4}h_JKaA5qp)Po#A}2psZp+udQ0puD&Fv zBXOx1&prjBjSfZBU&Wuj{T0Te)%Y74X%+b+m#t=*g}>1p`2xP8&^r{of$i95DPf0DyiUF`V=osQ=C?`3`VEfajhOz zf|Of2GG)AkQ8K^FxRWAb)M6SBxl6UpveLsLe>tF{5BQNYE+|A(nP#=AY6N7EbJ7gR0ZsP zML}G2+w6RPkMM(fZl^FDg=$ta{ahoIUTLx)5e%DuZt@W?O#MU2N4{odhmEw#TJm|- z?I54uvB;;eLeziwR(bJB2Ms8C>2S1yUZT#1YxT=SKs%kSwYq_#>H?snM`>-5m?O$K ze9IyYWT_ma0d96u0z9zlvx5PwngkWBIo`gC`@(y`uU8}NbWv?AtTlQeY{dI(3f*3I z01h=TS^g>5(=AL#UQcvE1S9$N`^xbkOlwjZi|V73)o63xqqf-|T#;v@+1qd;&iiZi zj(a(#dHwp>RJph#iJ$H9#m}b}w??6Xk52;sH@>S!mlDyX^5Wl3cpy6#e;hvr9|bW& zJ+_oOl}OTMBDqvP``=@Q8yAv=8<#;aH})_56?uxaJp(0N6qy@Octp> zZ1K~1$BE%|oG}tAt#gKjCz4jBTi0d}Gq% zSmviuntmxtbIM_l)EIWd)!t+CH|!Mdw|VH2#Qn%oDQ4g_?x&g>duYTDx7Lcu_)#5z zccmi3^ky@6XqeCD%Gek4A*ilqmW%n|HLE7Rm=7w}v6v6VS&D^xHbrZn*t<4?>#fe< z^31S(7hb$6V(r3gpcu_oInS$*--kxgY_O zBwlf@Ou@Cqcf@GHgoiEJ!6*1~E%8vi*U<`2ao%662bCj)%Y8rVZ3E~1wfZIg>PvB# ziplczJ|DClBgHk#g-Az&`m%I}t9Q%Rji z%39PLA{;*K=dT=xDTOaUo!eL)Q7TZ`wzHA80%@p1P0P*%jgsUo79mdLq8y4ZR}s`D zqX`Z;>Y1_omfwZ^Y{K@Rr@u=VqluU~9$$SoPWyiY`#&0QZfG=GUq%FJ>vg!;*gdX{ zZC5vw6|wLilAzc6Vrw1WVZeQMW5CTXx4}#3LC8p+au41>lb3$5xuPjSL5Td=vgUBJ z;H}!l4f(Tbgq_BGR3~lk=(D}+#izzA#@0wlzdj_DYEFivjFJ^pih#O9{y_)I(W8_= ze6OKXW{DZxLp6z52$j)m6aRO3bp}BrRPJ&AkixlY;#~}d#dmt;24y;Te9mQ__(+E3 z>{N;hk=*_Rvr(?HDHmBgb<7tHb4>f-;5fhHC|lAcA;44}TbIs}X=WoHwD$Z-`#UUt@= zNab;v)FP&5$x{i^iN_N0rSs-E3Qqo3rv*Pog1P=&!=y)u`?LQi;GQU-yBTm(#?eb* zA(&wN13d^|z(%Zfz`SnBPF7Tur8;tIvDqL}W}{@uG7P2luqK_L>_QGRfJNpoNv zzV(fRP*64_SRN7Vr$3ip2@uAyY%lJ1^oCijU3c_Di}N0acIZ#f)a?mX4-9IB=Ew#a zA(a+5)xtmxIUA)d7L&VJzGB%_+qofiIT5|NxLJ>1Pa@YAFWk78DBQTT@L#D&%mGSe zYsY>Oz;sCKj)QYok}|g3tuN{EJv4xX3 zNB69aBlT3rk^D#+SZN18CARHC!fy-s@+nE_D5;?=JDWo;)DB)>Q+@1YP2X5>%ueBK z)sc_%+A*AQVp>KbesAoo2-xvIAh!uHguG2D?YTO z1RZ&ukYG40i>ZZ3mEW1b4Ayj?-~(53tmDI2jh|o~Ea}=G#)4SKmsPBfzlixQ&1t>j zB@5{A0y&b>5-F8ey?C8Ma3W{bDFn1?73jRbRv$VM{OD+~lJ%yTgpHCb@f^9B?M(Oy zVIVXFg?fU}`&lVe+=EoIT_o0EP$f|v{iJ-6?|9XE zRGbWIlx=d%PBQP3vk9TZgk?QIoGp*SYTc1cz)W};a^;PH9=rNm{1u5H7wjdyaO3>K z%4P+Y$FX<~__0H!6B@*M1bL(b7d24gBWpSu9g+2L&RW*vf z+>}C9;*JEFQIBwNVLdy*<(4$Sm2q1UJ&}uIih~wRXyXbOUxtBAj_*pG`TK|9>*CcE zD-LY-5&XB2YE;!@m*F-kr*=^hha8UTAQAJ!8*UrI zE0op;*Q(Ih20yy@=X9ZWNUA|rGSYgLkluQN0#bmnj6e(vJ2*5X1d|8eM}h_8-ZAY*ZFxr z1tVUW#s|;Ddx2{GFCi1?4oodIH`i&u9|b|b6DWvm9O8ZA;(&Hqh!BqssSk5h1~ljs zMDkdqc*2Xj(#^6UaeP|P62rW761JRz;)}?>%YuE%iUADk%TwP7OhvK%g2q$IWH?hn zm*X7B>a-OAA#F&h_>2WZ`~9eF$Qo&SZ%lrS?RIY&Fvwj*K5jpt`jrL#F~{4CuzjVl z>IDfk%JBh6t9}3<`?}pH;~LwsbNUikMt%XT@(*ygnVp zcO2Uu%1=L$XZN!G`PrGTve3*deGzkha%LL5KyTaQ2XB@PBCe00Ui#^ypMLtm*JuZk SVZcuhYoxE!;zMMlvi?8DgPGR= diff --git a/sources/LLCHAR.~1~ b/sources/LLCHAR.~1~ deleted file mode 100644 index 2ee78c26..00000000 --- a/sources/LLCHAR.~1~ +++ /dev/null @@ -1,865 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "12-Jan-94 10:12:34" |{PELE:MV:ENVOS}SOURCES>LLCHAR.;4| 73449 - - changes to%: (FNS STREQUAL STRING.EQUAL) - - previous date%: "13-Sep-90 16:47:15" |{PELE:MV:ENVOS}SOURCES>LLCHAR.;3|) - - -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1994 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 10-Feb-87 19:12 by bvm:") (COND ((LITATOM X) (WITH-RESOURCE (\PNAMESTRING) (for C CHANGEFLG (BASE _ (ffetch (STRINGP BASE) of \PNAMESTRING)) inatom X as I from 0 do (\PNAMESTRINGPUTCHAR 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 \FATPNAMESTRINGP)) (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 10-Feb-87 19:12 by bvm:") (COND ((LITATOM X) (WITH-RESOURCE (\PNAMESTRING) (for C CHANGEFLG (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))))))) (\PNAMESTRINGPUTCHAR BASE I C) finally (RETURN (COND ((OR CHANGEFLG (NEQ (CL:SYMBOL-PACKAGE X) *INTERLISP-PACKAGE*)) (\MKATOM BASE 0 I \FATPNAMESTRINGP)) (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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (4079 41678 (ALLOCSTRING 4089 . 5161) (MKATOM 5163 . 5509) (SUBATOM 5511 . 6483) ( -CHARACTER 6485 . 7097) (\PARSE.NUMBER 7099 . 13661) (\INVALID.DOTTED.SYMBOL 13663 . 14094) ( -\INVALID.INTEGER 14096 . 14871) (\MKINTEGER 14873 . 17440) (MKSTRING 17442 . 18514) ( -\PRINDATUM.TO.STRING 18516 . 21113) (BKSYSBUF 21115 . 21850) (NCHARS 21852 . 22686) (NTHCHARCODE 22688 - . 23720) (RPLCHARCODE 23722 . 24277) (\RPLCHARCODE 24279 . 25231) (NTHCHAR 25233 . 25372) (RPLSTRING -25374 . 27068) (SUBSTRING 27070 . 28451) (GNC 28453 . 28559) (GNCCODE 28561 . 28976) (GLC 28978 . -29084) (GLCCODE 29086 . 29527) (STREQUAL 29529 . 31643) (STRING.EQUAL 31645 . 35703) (STRINGP 35705 . -35796) (CHCON1 35798 . 36270) (U-CASE 36272 . 37318) (L-CASE 37320 . 38741) (U-CASEP 38743 . 39061) ( -\SMASHABLESTRING 39063 . 39391) (\MAKEWRITABLESTRING 39393 . 39741) (\SMASHSTRING 39743 . 41582) ( -\FATTENSTRING 41584 . 41676)) (41863 45378 (\GETBASESTRING 41873 . 42376) (\PUTBASESTRING 42378 . -44182) (\PUTBASESTRINGFAT 44184 . 44723) (GetBcplString 44725 . 45162) (SetBcplString 45164 . 45376)) -(70973 72652 (%%COPY-ONED-ARRAY 70983 . 72115) (%%COPY-STRING-TO-ARRAY 72117 . 72650))))) -STOP diff --git a/sources/LLCHAR.~2~ b/sources/LLCHAR.~2~ deleted file mode 100644 index 7b7b404b..00000000 --- a/sources/LLCHAR.~2~ +++ /dev/null @@ -1,217 +0,0 @@ -(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/LLDATATYPE.~11~ b/sources/LLDATATYPE.~11~ deleted file mode 100644 index a64923bb..00000000 --- a/sources/LLDATATYPE.~11~ +++ /dev/null @@ -1,1184 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 2-Feb-95 16:27:02" {DSK}sources>LLDATATYPE.;11 96272 changes to%: (VARS LLDATATYPECOMS) previous date%: "19-Oct-94 09:29:30" {DSK}sources>LLDATATYPE.;10) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 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 (DATUM) (* ; "Edited 18-Dec-86 16:15 by jop") - (LET ((N (NTYPX DATUM))) - (COND - ((EQ N \ARRAYP) - (\ARRAYTYPENAME DATUM)) - ((%%STRINGP DATUM) (* ; - "Common lisp strings report as STRINGP's.") - 'STRINGP) - (T (\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6661 37662 (NTYPX 6671 . 7148) (\TYPEMASK.UFN 7150 . 7674) (\TYPEP.UFN 7676 . 7845) ( \ALLOCMDSPAGE 7847 . 9249) (\ALLOCPAGEBLOCK 9251 . 9957) (\ALLOCVIRTUALPAGEBLOCK 9959 . 12574) ( \MAPMDS 12576 . 13692) (\CHECKFORSTORAGEFULL 13694 . 18840) (\DOSTORAGEFULLINTERRUPT 18842 . 19136) ( \SET.STORAGE.STATE 19138 . 20011) (\SETTYPEMASK 20013 . 20960) (\ADVANCE.STORAGE.STATE 20962 . 21470) (\NEW2PAGE 21472 . 21658) (\MAKEMDSENTRY 21660 . 22106) (\INITMDSPAGE 22108 . 23900) (\ASSIGNDATATYPE1 23902 . 33530) (\RESOLVE.TYPENUMBER 33532 . 33997) (\TYPENUMBERFROMNAME 33999 . 34539) (CREATECELL 34541 . 34674) (\CREATECELL 34676 . 37660)) (37761 38187 (\MAIKO.SET.STORAGE.STATE 37771 . 38185)) ( 38648 60367 (FETCHFIELD 38658 . 41849) (REPLACEFIELD 41851 . 47477) (BOXCOUNT 47479 . 47980) ( CONSCOUNT 47982 . 48116) (\DTEST 48118 . 48251) (\TYPECHECK 48253 . 48390) (\DTEST.UFN 48392 . 51647) (\INSTANCEP.UFN 51649 . 52877) (\INSTANCE-P 52879 . 53142) (\TYPECHECK.UFN 53144 . 53707) ( GETDESCRIPTORS 53709 . 54227) (GETSUPERTYPE 54229 . 54743) (GETFIELDSPECS 54745 . 55382) (NCREATE 55384 . 55556) (NCREATE2 55558 . 56273) (REPLACEFIELDVAL 56275 . 56539) (PUTBASEPTRX 56541 . 57020) ( /REPLACEFIELD 57022 . 57287) (TYPENAME 57289 . 57788) (TYPENAMEP 57790 . 58014) (\TYPENAMEFROMNUMBER 58016 . 58246) (\BLOCKDATAP 58248 . 58568) (USERDATATYPES 58570 . 58702) (DATATYPEP 58704 . 59853) ( DATATYPES 59855 . 60365)) (62729 77880 (STORAGE 62739 . 67160) (STORAGE.LEFT 67162 . 70703) ( \STORAGE.TYPE 70705 . 74765) (\STLINP 74767 . 74953) (\STMDSTYPE 74955 . 76154) (\STMDS.APPROX 76156 . 76424) (\STORAGE.HUNKTYPE 76426 . 77878)) (85782 94481 (CREATEMDSTYPETABLE 85792 . 87581) ( INITDATATYPES 87583 . 92428) (INITDATATYPENAMES 92430 . 94479))))) STOP \ No newline at end of file diff --git a/sources/LLDISPLAY.LCOM.~2~ b/sources/LLDISPLAY.LCOM.~2~ deleted file mode 100644 index 699b5386..00000000 --- a/sources/LLDISPLAY.LCOM.~2~ +++ /dev/null @@ -1,231 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Jan-98 15:41:01" ("compiled on " {DSK}sources>LLDISPLAY.;4) "30-Mar-95 20:33:04" "COMPILE-FILEd" in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48") (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) (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 (QUOTE BITMAPBIT) (QUOTE \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? (QUOTE BITBLT) (QUOTE BKBITBLT)))) (* ; "macro for this file so that BITBLT can be broken by users") (EXPORT (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (P (PUTPROP (QUOTE BITBLT) (QUOTE MACRO) (QUOTE (= . 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? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) ( MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW))) (INITVARS (PROMPTWINDOW T) (\WINDOWWORLD NIL) (\MAINSCREEN NIL))) (COMS (* ; "Stub for window package") (INITVARS (\TOPWDS) (\SCREENBITMAPS)) (P (MOVD? (QUOTE NILL) (QUOTE \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 (QUOTE 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))))) (/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE ((BITMAP 0 POINTER) ( BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 (BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6) ) (/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE ((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)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (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)) (QUOTE ((\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))) ) (QUOTE 68)) \FBITMAPBIT :D8 (I 5 RASTERWIDTH I 4 HEIGHTMINUS1 I 3 OPERATION I 2 Y I 1 X I 0 BASE) 1@ABCdgð“¿j°dgð’¿k‹gð’llDE (46 \FBITMAPBIT.UFN) (31 READ 21 ERASE 9 INVERT) () \FBITMAPBIT.UFN :D8 (P 3 BITMASK P 2 WORDBASE I 5 RASTERWIDTH I 4 HEIGHTMINUS1 I 3 OPERATION I 2 Y I 1 X I 0 BASE) ¢@DBÙEÚAââââØÐ`AlåHÉHl -IØÐÈBKJÈå\jð³#LµkJÈ_¿JCdjð²¿OKæ°D ²æj°äkð²*O`Alå¾]ÉMl -NØÐÈå‹Clð’OƒOKäÍ¿(137 \GETBASEFIXP 95 \FZEROP 45 \GETBASEFIXP) (130 ARRAYP 122 ARRAYP 111 NOTBITMASKARRAY 38 ARRAYP 30 ARRAYP 17 BITMASKARRAY) () \NEWPAGE.DISPLAY :D8 (I 0 STREAM) @ (5 DSPRESET) NIL () INITBITMASKS :D8 (P 2 MASK P 1 I) ½lgjd lgjd ljn€IHó²9lgjd lgjd ljnðIHó²+h`IJ ¿`IJnÿÿæ ¿JâºIkÔY° `IJ ¿`IJnÿÿæ ¿JââââºIkÔY°«(174 SETA 157 SETA 135 SETA 118 SETA 85 ARRAY 66 ARRAY 32 ARRAY 13 ARRAY) (163 NOT4BITMASKARRAY 150 4BITMASKARRAY 124 NOTBITMASKARRAY 111 BITMASKARRAY 90 NOT4BITMASKARRAY 78 SMALLPOSP 71 4BITMASKARRAY 59 SMALLPOSP 37 NOTBITMASKARRAY 25 SMALLPOSP 18 BITMASKARRAY 6 SMALLPOSP) () optimize-\FBITMAPBIT :D8 (L (2 $$CTX 1 $$ENV 0 $$WHOLE)) Œ @¡ -H¹HZ»J\½L^_¿N__¿O_¿oIKMOµ!gOoOOogð²ÚO dgð“¿j°Õdgð“¿k°Égð“l°¾l°º(99 EVAL) (128 READ 117 ERASE 105 INVERT 89 QUOTE 57 SELECTQ) ( 75 (NIL) 64 ((INVERT 0) (ERASE 1) (READ 2) 3) 44 (OPCODES MISC7 1)) (PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-\FBITMAPBIT) ( GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) (INITBITMASKS) \CreateCursorBitMap :D8 NIL $l dkÍ¿dlÍ¿dlÍ¿d`¿dkÍ¿NIL (25 \EM.CURSORBITMAP) () (RPAQ CursorBitMap (\CreateCursorBitMap)) BITBLT :D8 (L (11 CLIPPINGREGION 10 TEXTURE 9 OPERATION 8 SOURCETYPE 7 HEIGHT 6 WIDTH 5 DESTINATIONBOTTOM 4 DESTINATIONLEFT 3 DESTINATION 2 SOURCEBOTTOM 1 SOURCELEFT 0 SOURCE) F 19 \SOFTCURSORP F 20 \SOFTCURSORUPP F 21 \SCREENBITMAPS) ¢ D£jb¿E£jb -¿Ggð²NCdò¿GCDEFGGG gh HÉ.ɹGHDEFGGGlIð@@dò]¿A£jb¿B£jb¿@¹AºB»Fµ3@Èb ¿Gµ@Èb¿±É@ÈBÙ½dMñ²ì¿M°è@ÈAÙ¼dLñ²É¿L°Ågh É0X¢±…A¦HÉ -b¿B§HÉ -b¿HɹAHÉØbHÈ"¾dNñ¡¿NºBHÉØbHÈ$_¿dOñ¢¿O»FµNHÈ#JÙb ¿Gµ%HÈ%KÙb¿G¥HÉ6b¿Fjñ´ Gjñ³4hHÈ%KÙ_¿dOñ²Ö¿O°ÑHÈ#JÙ_¿dOñ²­¿O°¨Cdâ±É¿@ ¢±¤h__¿W&²;W(´h@gh -`ð_²`È_¿`jÍ¿¿@gh _`ð³hO -W*—O ¿IABCDEFGGGGGJK O´‚±X¿`OÍ¿±DIABCDEFGGGGGJK gh _@Cð’±ê@ ¢±àC ¢±Ï@dC -¢±Ä¿h__ _"¿W&²;W(´h@gh -`ð_"²`È_ ¿`jÍ¿¿@gh _`ð³hO -W*—O ¿IABFG -_jdFGgg -¿O"Ÿ¿`O Í¿OjdODEFGGGGG @ ¿OÉ.É_$¿IABODEFGGGGGJKlO$h(881 TOTOPW 874 BKBITBLT 838 \SOFTCURSORUPCURRENT 829 BKBITBLT 806 BITMAPCREATE 794 \TOTOPWDS 783 DSPDESTINATION 765 \GETSTREAM 752 \SOFTCURSORDOWN 718 DSPDESTINATION 713 \GETSTREAM 679 WOVERLAPP 667 WINDOWP 657 WINDOWP 642 \GETSTREAM 630 \BITBLT.BITMAP 591 \SOFTCURSORUPCURRENT 578 \BITBLT.BITMAP 552 \TOTOPWDS 541 DSPDESTINATION 523 \GETSTREAM 510 \SOFTCURSORDOWN 476 DSPDESTINATION 471 \GETSTREAM 440 WINDOWP 214 \GETSTREAM 61 \GETSTREAM 49 \BLTSHADE.BITMAP) (896 IMAGEOPS 889 STREAM 844 \EM.DISPINTERRUPT 823 REPLACE 818 INPUT 772 \TOPWDS 759 OUTPUT 743 \EM.DISPINTERRUPT 733 \EM.DISPINTERRUPT 723 \CURSORDESTINATION 707 OUTPUT 636 OUTPUT 597 \EM.DISPINTERRUPT 530 \TOPWDS 517 OUTPUT 501 \EM.DISPINTERRUPT 491 \EM.DISPINTERRUPT 481 \CURSORDESTINATION 465 OUTPUT 429 BITMAP 404 \DISPLAYDATA 380 \DISPLAYDATA 345 \DISPLAYDATA 328 \DISPLAYDATA 305 \DISPLAYDATA 294 \DISPLAYDATA 277 \DISPLAYDATA 266 \DISPLAYDATA 256 \DISPLAYDATA 226 \DISPLAYDATA 219 STREAM 208 OUTPUT 189 BITMAP 169 BITMAP 155 BITMAP 140 BITMAP 110 BITMAP 77 IMAGEOPS 70 STREAM 55 OUTPUT 28 BITMAP 18 TEXTURE) () BLTSHADE :D8 (L (7 CLIPPINGREGION 6 OPERATION 5 HEIGHT 4 WIDTH 3 DESTINATIONBOTTOM 2 DESTINATIONLEFT 1 DESTINATION 0 TEXTURE)) [Adò¿@ABµjCµjDEFG gh HÉ.ɹ@HBµjCµjDEFd¥H -GlI(82 DSPOPERATION 42 \GETSTREAM 30 \BLTSHADE.BITMAP) (58 IMAGEOPS 51 STREAM 36 OUTPUT 6 BITMAP) () \BITBLTSUB :D8 (P 5 X P 4 DESTADDR P 3 SOURCEADDR P 2 GRAY P 1 SBMR P 0 DBMR I 12 WindowYOffset I 11 WindowXOffset I 10 Texture I 9 Operation I 8 SourceType I 7 HEIGHT I 6 DTY I 5 DLX I 4 DestinationBitMap I 3 STY I 2 SLX I 1 SourceBitMap I 0 PILOTBBT) Ð Ð DÈX@jÍ -@HàààànÿÿåÍDÉHFÚÐ\@EÍGdgð¢±H¿@kÏ -0¿@G”EGÙ€ElåÍ¿@jÍ¿G3 ¢±È`ÉZGnÿÿåbjð¦Gnÿÿð™JGÍ¿j±„JGãââââ^dáNààààdáäääÍ¿JGãlå_dáOààààdáäääÍ¿JGââââlå_dáOààààdáäääÍ¿JGlå_dáOààààdáäääÍ¿@lÏÿ@G”FGÔ€Flå_ÏC¿OÐ_¿@OÒÍ¿@O±6@GbÈdlñ’¿l]kÙÏÿ@GšFGÔM -‚FMÜ]ÏC¿GÉMÐ_¿@OÒÍ¿@O±ägðšo @jÏ -0¿@AÈYàààànÿÿåÍ¿AÉICÚл@BÍ¿ADð¦@kÏ -°|CFñžCFGØñ²k@kÏ -°iFCGØñ–@kÏ -°[CFð²EBñ²REB@ÈØýñ²C@kÏ -¿KIGkÙÚ]лLMм@jIààààÙ]nÿÿåÍ¿@MnÿÿåÍ¿CFð¥@kÏ - ¿@KÒÍ¿@KÓÍ¿@LÒÍ¿@LÓÍ@Gdgð“¿k°gð’lŒGgð’l€jÏ -Q¿@GgðGgðð‘j€kÏ -@@jv(414 RAID 356 IMOD) (705 ERASE 697 INVERT 679 INVERT 667 PAINT 656 ERASE 643 PILOTBBT 632 PILOTBBT 621 PILOTBBT 610 PILOTBBT 586 PILOTBBT 565 PILOTBBT 532 PILOTBBT 466 PILOTBBT 453 BITMAP 433 BITMAP 427 PILOTBBT 402 MERGE 392 PILOTBBT 380 PILOTBBT 323 BITMAP 310 PILOTBBT 298 PILOTBBT 128 BITMAP 123 \SYSBBTEXTURE 106 PILOTBBT 85 PILOTBBT 67 TEXTURE 56 PILOTBBT 43 BITMAP 26 PILOTBBT 17 PILOTBBT 8 BITMAP) ( 409 "Hard bitblt case") \GETPILOTBBTSCRATCHBM :D8 (I 1 HEIGHT I 0 WIDTH) ?`ò'@`Èñ³A`Èñ¥`@A -(55 BITMAPCREATE) (60 \PILOTBBTSCRATCHBM 47 \PILOTBBTSCRATCHBM 38 BITMAP 33 \PILOTBBTSCRATCHBM 22 BITMAP 17 \PILOTBBTSCRATCHBM 9 BITMAP 4 \PILOTBBTSCRATCHBM) () BITMAPCOPY :D8 (P 0 NEWBITMAP I 0 BITMAP) 7@bjd@ @È@È Xjdhdggj H(51 BKBITBLT 29 BITMAPCREATE 18 BITMAPWIDTH) (44 REPLACE 39 INPUT 8 BITMAP) () BITMAPCREATE :D8 (P 0 RW I 2 BITSPERPIXEL I 1 HEIGHT I 0 WIDTH)  j@ñ¥@nÿÿñ–@ ¿jAñ¥Anÿÿñ–A ¿B b@BÚlØââââXl dHÍ¿d@Í¿dAÍ¿dBÍ¿HAÚXdoñ²¿@AÚBÚo -‰kØâhh ¹dI¿(118 \ALLOCBLOCK 107 ERROR 42 \INSUREBITSPERPIXEL 35 \ILLEGAL.ARG 18 \ILLEGAL.ARG) NIL ( 102 "bits in BITMAP -- too big" 88 131066) BITMAPBIT :D8 (P 15 SOFTCURSORUP P 14 DISPINTERRUPT P 13 DD P 12 TY P 11 TX P 6 bitmapbase P 5 oldword P 4 HEIGHT P 3 OLDVALUE P 2 WORDX P 1 BITX P 0 NBITS I 3 NEWVALUE I 2 Y I 1 X I 0 BITMAP F 16 \SOFTCURSORP F 17 \SOFTCURSORUPP F 18 \SCREENBITMAPS) ì° -@â±+@ÈXjAñ’± A@Èýñ¢±üjBñ’±õB@È\ýñ¢±åHkð²[Cdjð²¿@ÉABkLkÙ@Èh8³@ÉABlLkÙ@Èh8@ÉABlLkÙ@Èh8@É@ÈBÙkÙ@ÈÚÐ^C²jCñ¯C@È ñ–C ¿Hdkð²c¿AââââZNJÐÈ]`Alå_¿_ÉOl -OØÐÈYCµ MIåjð² jjðNJÐMImÿæåÍ¿°èNJÐMIäÍ¿°Ýklð²mAlçYdââââZNJÐÈ]d`Alå_¿_ÉOl -OØÐÈå[C²NJÐMKæCllAlåÙÚ -äÍ¿KllAlåÙÚ -Hdlð²K¿AlçYdââââZAkåjð²NJÐÈ]nÿå»C›NJÐMKæCáäÍ¿KãNJÐÈ]lÿå»C²1NJÐMKæCäÍ¿°$lð²!AlÚYdââââZNA -[C—NAC KoH -0 @gh bÉ0_AO -_BO -_O¢±þºd¢±þµ W ²0W"´h@ -`ð_²`È_¿`jÍ¿¿@`ð³h@ -W$–@ ¿OÉOOCû_¿Ož¿`OÍO(733 \SOFTCURSORUPCURRENT 705 \TOTOPWDS 695 DSPDESTINATION 678 \SOFTCURSORDOWN 644 DSPDESTINATION 613 \DSPCLIPTRANSFORMY 603 \DSPCLIPTRANSFORMX 579 \GETSTREAM 563 ERROR 550 \PUTBASE24 539 \GETBASE24 435 LRSH 415 LLSH 382 \GETBASEFIXP 275 \GETBASEFIXP 220 \ILLEGAL.ARG 212 MAXIMUMCOLOR) (739 \EM.DISPINTERRUPT 713 \DISPLAYDATA 685 \TOPWDS 669 \EM.DISPINTERRUPT 659 \EM.DISPINTERRUPT 649 \CURSORDESTINATION 593 \DISPLAYDATA 586 STREAM 573 OUTPUT 375 ARRAYP 366 ARRAYP 352 4BITMASKARRAY 268 ARRAYP 259 ARRAYP 245 BITMASKARRAY 205 BITMAP 186 BITMAP 174 BITMAP 166 BITMAP 154 BITMAP 139 BITMAP 127 BITMAP 112 BITMAP 98 BITMAP 84 BITMAP 57 BITMAP 35 BITMAP 18 BITMAP 8 BITMAP) ( 557 "unknown bits per pixel size.") BLTCHAR :D8 (I 1 DISPLAYSTREAM I 0 CHARCODE) 2@d—¿j@ñ¡@…@ Adgh É0 (47 \BLTCHAR 30 \GETSTREAM 17 \ILLEGAL.ARG) (42 \DISPLAYDATA 35 STREAM 24 OUTPUT) () \BLTCHAR :D8 (P 0 A13769 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM) (25 IMAGEOPS 18 STREAM 5 OUTPUT) () \MEDW.BLTCHAR :D8 (L (2 DISPLAYDATA 1 DISPLAYSTREAM 0 CHARCODE) F 7 \SOFTCURSORP F 8 \SOFTCURSORUPP F 9 \SCREENBITMAPS) p@lÿå\¿BdÉ>@ãð¨@ã -¿BÉ—@A -BÉ[BÉ0LÐÈØYBÉñŸKBÉñ™l A -°ÃBKBÉLÐÈØ¿BɸKHØ»IHØYBÈ#Xñ‘H¹KBÈ"Xñ‘K€HºIJñ´‚±“BÉ*XÈ jð’±h]¾W²-W´hA -`ð^²`Ƚ`jÍ¿¿A`ð³hA -W–A ¿HJÍ¿HIJÙÍ¿HBÉLÐÈJØKÙÍ¿Hjv¿N¿`MÍih(255 \SOFTCURSORUPCURRENT 216 \TOTOPWDS 206 DSPDESTINATION 189 \SOFTCURSORDOWN 158 DSPDESTINATION 68 \DSPPRINTCR/LF 35 \SLOWBLTCHAR 23 \CHANGECHARSET.DISPLAY) (261 \EM.DISPINTERRUPT 196 \TOPWDS 180 \EM.DISPINTERRUPT 172 \EM.DISPINTERRUPT 163 \CURSORDESTINATION 132 PILOTBBT) () \CHANGECHARSET.DISPLAY :D8 (P 4 \INTERRUPTABLE P 2 BM P 1 CSINFO P 0 PBT I 1 CHARSET I 0 DISPLAYDATA) Š@É*@É ÉAàÐɵ A@É h "@IÉ¿@IÉ¿@IÉ0¿@A>¿IɺHJÈàààànÿÿåÍ¿@È'IÈ -ð—@È@IÈ ð©@I -¿°#JÉJÈ@ÉBÚлHKÒÍ¿HKÓÍh(98 \SFFixY 24 \CREATECHARSET) (130 PILOTBBT 119 PILOTBBT) () \INDICATESTRINGA0001 :D8 (NAME SI::*UNWIND-PROTECT* I 0 SI::*CLEANUP-FORMS* F 0 SI::*RESETFORMS* F 1 CHARCODE) Hgd gi -¿Pcgl hhPcgQãoQlÿå (69 CONCAT 39 RADIX 22 SETTOPVAL 10 GETTOPVAL) (53 %# 32 RADIX 16 PRXFLT 4 PRXFLT) ( 60 ",") \INDICATESTRING :D8 (P 2 RESETSTATE P 1 SI::*RESETFORMS* P 0 LISPXHIST I 0 CHARCODE F 3 LISPXHIST) _@dlÿñ² ¿S!g ¿$lñœ@låb¿g„ol @ñœ@l@äb¿g„o@ (92 CONCAT 87 CHARACTER 31 SI::RESETUNWIND 26 \MVLIST 21 \INDICATESTRINGA0001) (75 ^ 52 %# 16 SI::RESETUNWIND) ( 81 "" 58 "") \SLOWBLTCHAR :D8 (P 16 CSINFO P 15 HEIGHTMOVED P 14 YPOS P 13 SOFTCURSORUP P 12 DISPINTERRUPT P 11 SOURCEBIT P 10 WIDTH P 9 DESTBIT P 8 PILOTBBT P 7 CURX P 6 RIGHT P 5 LEFT P 4 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 17 \SOFTCURSORP F 18 \SOFTCURSORUPP F 19 \SCREENBITMAPS) N@@lÿåYAÉ0ZdÉ È Xdj𢱀 JÉ_JÉIÐÈØ\JÉñ²l A -¿JÉ_JÉIÐÈؼJL¿OJÉØ_¿JÈ"dOñ¢¿O½JÈ#LJÉØ»dKñ‘¿K¾JÉ*_¿NMñ¢±OÈ jð’±M_¿NMÙ_¿JÉIÐÈMØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W"²0W$´hA -`ð_²`È_¿`jÍ¿¿A`ð³hA -W&–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿OŸ¿`OÍ¿±·0JÉ_¿JÉIÐÈ_¿JÉ É@ãàÐɵ @ãJÉ h _ ¿HdlZð²;¿AOOØ -¿O ÉjJÉIÐÈAJÉO È -ÙkØOO È -O È ØO °Hnð²8AOOÙ -¿O ÉjJÉIÐÈAJÉO È ÙJÉO È -O È ØO ‰o h(586 ERROR 575 BKBITBLT 533 \DSPYPOSITION.DISPLAY 514 BKBITBLT 471 \DSPYPOSITION.DISPLAY 449 \CREATECHARSET 390 \SOFTCURSORUPCURRENT 355 \TOTOPWDS 345 DSPDESTINATION 328 \SOFTCURSORDOWN 294 DSPDESTINATION 275 SHOULDNT 55 \DSPPRINTCR/LF) (396 \EM.DISPINTERRUPT 335 \TOPWDS 319 \EM.DISPINTERRUPT 309 \EM.DISPINTERRUPT 299 \CURSORDESTINATION 111 \DISPLAYDATA 83 \DISPLAYDATA) ( 581 "Not implemented to rotate by other than 0, 90 or 270") TEXTUREP :D8 (I 0 OBJECT) @d3 ³ô@Èkð´@NIL (18 BITMAP 10 BITMAP) () INVERT.TEXTURE :D8 (I 1 SCRATCHBM I 0 TEXTURE) @d3 ˜nÿÿånÿÿæA -(19 INVERT.TEXTURE.BITMAP) NIL () INVERT.TEXTURE.BITMAP :D8 (P 0 NEWBM I 1 SCRATCHBM I 0 BM) “@Èkð¦@ ¿Aò)AÈkð²@ÈAÈñ–A ¿AŽl@È -HÉ@ÉHÉ@ÈÐIdKð‘HJÈnÿÿæÍ¿JkкIkÐY°è(79 BITMAPCREATE 61 \ILLEGAL.ARG 16 \ILLEGAL.ARG) (112 BITMAP 104 BITMAP 96 BITMAP 88 BITMAP 72 BITMAP 51 BITMAP 43 BITMAP 31 BITMAP 23 BITMAP 5 BITMAP) () BITMAPWIDTH :D8 (I 0 BITMAP) &@Ó@È@Û@g -@ (35 \ILLEGAL.ARG 28 GETWINDOWPROP) (23 WIDTH 16 WINDOW 5 BITMAP) () READBITMAP :D8 (P 6 BITSPERPIXEL P 5 W P 4 BM P 3 BASE P 2 STRM P 1 HEIGHT P 0 WIDTH I 0 FILE) ù@ @ gðªo ¿@ @ @g -CJ dgð§dgð’¿k†¿@ ^HÚlØââââ½HIN \É»Ijð³qJ gð²RIdjñ²\J ¿J l"ð²=Mdjñ²0KjJ l@ÙààààJ l@ÙäÇ¿KkJ l@ÙààààJ l@ÙäÇ¿KkлkÙ°Ï¿J l"ð¬¿o hkÙ°£¿J ¿J l)ð²ãL(237 SKIPSEPRS 224 ERROR 146 SKIPSEPRS 126 SKIPSEPRS 106 BITMAPCREATE 87 RATOM 61 SKIPSEPRS 52 GETSTREAM 41 RATOM 35 RATOM 28 ERROR 11 READC 5 SKIPSEPRS) (131 %" 112 BITMAP 75 %) 67 %" 47 INPUT 16 %() ( 219 "BAD FORMAT OF BITMAP IN FILE" 23 "BAD FORMAT OF BITMAP IN FILE") \INSUREBITSPERPIXEL :D8 (I 0 NBITS) #@d¡kdkð³üdlð³ödlð³ðdlð³ê (32 \ILLEGAL.ARG) NIL () MAXIMUMCOLOR :D8 (L (0 BITSPERPIXEL)) k@çkÙNIL NIL () OPPOSITECOLOR :D8 (I 1 BITSPERPIXEL I 0 COLOR) -A @Ù(5 MAXIMUMCOLOR) NIL () MAXIMUMSHADE :D8 (I 0 BITSPERPIXEL) @dkð“nÿÿ (13 MAXIMUMCOLOR) NIL () OPPOSITESHADE :D8 (I 1 BITSPERPIXEL I 0 SHADE) -A @Ù(5 MAXIMUMSHADE) NIL () \MEDW.BITBLT :D8 (P 9 A13796 P 8 A13793 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A13790 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS)  - @ ³C ªo ¿@òZ@²WCi -Cgh É0HÉ2ÉHºHÉ2@ABCDEFGGGGGABlJ±–Cô‚±¯C´‚±¨@i -!@gh É0AIÉصABIÉصBKÉ2ÉJ_¿KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO±Þ@ -hC -ð¢±Â@i -!@gh É0AIÉصABIÉصB@`ð³h@ -W–@ ¿KÉ2ÉL KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO‰o i(524 SHOULDNT 418 \TOTOPWDS 408 DSPDESTINATION 345 \GETSTREAM 330 WFROMDS 318 DSPDESTINATION 311 DSPDESTINATION 162 \GETSTREAM 147 WFROMDS 55 \GETSTREAM 43 WFROMDS 24 SHOULDNT 13 IMAGESTREAMP 5 IMAGESTREAMP) (494 \DISPLAYDATA 477 \DISPLAYDATA 451 \DISPLAYDATA 443 WINDOW 432 SCREEN 425 WINDOW 398 \TOPWDS 383 \DISPLAYDATA 367 \DISPLAYDATA 357 \DISPLAYDATA 350 STREAM 339 OUTPUT 284 \DISPLAYDATA 267 \DISPLAYDATA 241 \DISPLAYDATA 233 WINDOW 222 SCREEN 215 WINDOW 200 \DISPLAYDATA 184 \DISPLAYDATA 174 \DISPLAYDATA 167 STREAM 156 OUTPUT 127 BITMAP 92 WINDOW 83 SCREEN 76 WINDOW 67 \DISPLAYDATA 60 STREAM 49 OUTPUT 31 BITMAP) ( 519 "Invalid argument to \XW.BIBLT" 19 "Neither SOURCE nor DESTINATION is an imagestream.") FINISH-READING-BITMAP :D8 (L (0 STREAM) F 29 *READ-SUPPRESS*) (@ ñ Hd²µoH -¿°íYºI[¼K]µLk¾M_¿J3 šL3 –N3 ’O›oH -¿JNÖlØââââ!W:²,LO$ÖlÖj_¿_¿OOó¥O&°¶@ ¿OkÔ_¿°æJLN _&É_(¿@g -_"¿Lj_ ¿_¿OO ó²»O"ʇ_jð’±¼Oµ‚±©O$j_¿_¿OOó¢±6O" l@ÕO" l@ÕO" l@ÕO" l@ÕjO*ó³-O*ló³&jO,ó³ O,ló³jO.ó³O.lóªjO0ó¥O0lóšo ¿O(jO*ààààO,äÇ¿O(kO.ààààO0äÇO(kÐ_(¿OkÔ_¿±ÿf ¢±ÿTO$j_¿_¿OO󢱇O" l@ÕO" l@ÕO" l@ÕO" l@ÕjO2ó³-O2ló³&jO4ó³ O4ló³jO6ó³O6lóªjO8ó¥O8lóšo ¿O(jO2ààààO4äÇ¿O(kO6ààààO8äÇO(kÐ_(¿OkÔ_¿±ÿvO kÔ_ ¿±þ‘(494 CL:ERROR 386 \FZEROP 335 CL:ERROR 270 READCCODE 260 READCCODE 250 READCCODE 240 READCCODE 169 \GETSTREAM 146 BITMAPCREATE 128 CL:READ-CHAR 78 CL:ERROR 29 ASSERT-FAIL 5 READ) (194 STREAM 164 INPUT 153 BITMAP) ( 489 "Illegal character in bitmap contents specification." 330 "Illegal character in bitmap contents specification." 72 "Bad bitmap dimension specification: ~S" 23 "BUG: FINISH-READING-BITMAP called with non-list on stream: ~S") (RPAQQ MINIMUMCOLOR 0) (RPAQQ MINIMUMSHADE 0) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT)) optimize-BITMAPBIT :D8 (L (2 $$CTX 1 $$ENV 0 $$WHOLE)) @ (6 BITMAPBIT.EXPANDER) NIL () (PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST)))) optimize-BITMAPP :D8 (L (2 $$CTX 1 $$ENV 0 $$WHOLE)) @oHhNIL NIL ( 10 (OPENLAMBDA (X) (AND (type? BITMAP X) X))) (PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-BITMAPP) (GET ( QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST)))) BITMAPBIT.EXPANDER :D8 (P 3 NEWVALUE P 2 Y P 1 X P 0 BM I 0 ARGS) -@@@@ lð•@»oHIJKh(17 LENGTH) NIL ( 32 (OPCODES MISC4 6)) \BITBLT.DISPLAY :D8 (L (11 CLIPPINGREGION 10 TEXTURE 9 OPERATION 8 SOURCETYPE 7 HEIGHT 6 WIDTH 5 DESTINATIONBOTTOM 4 DESTINATIONLEFT 3 DESTINATION 2 SOURCEBOTTOM 1 SOURCELEFT 0 SOURCEBITMAP) F 48 \SCREENBITMAPS F 49 \SOFTCURSORP F 50 \SOFTCURSORUPP) 0 ðð@dò[¿A£jb¿B£jb¿AºB»Fµ3@Èb ¿Gµ@Èb¿±Í@ÈBÙ½dMñ²ì¿M°è@ÈAÙ¼dLñ²É¿L°Ågh É0X¢±‰@¹A¦HÉ -b¿B§HÉ -b¿HÉb¿AHÉØbHÈ"¾dNñ¡¿NºBHÉØbHÈ$_¿dOñ¢¿O»FµNHÈ#JÙb ¿Gµ%HÈ%KÙb¿G¥HÉ6b¿Fjñ´ Gjñ³4hHÈ%KÙ_¿dOñ²Ö¿O°ÑHÈ#JÙ_¿dOñ²­¿O°¨Cdâ±É¿I ¢±¤h__¿Wb²;Wd´h@gh -`ð_²`È_¿`jÍ¿¿@gh _`ð³hO -W`—O ¿@ABCDEFGGGGGJK O´‚±”¿`OÍ¿±€@ABCDEFGGGGGJK gh _IdCð’± ³I¢±&Id ¢±¿C ¢±òIdC -¢±ç¿I ÉÉ.C ÉÉ.ð¢±Âh__ _"¿Wb²;Wd´hIgh -`ð_"²`È_ ¿`jÍ¿¿Igh _`ð³hO -W`—O ¿@ABFG -_jdFGgg -¿O"Ÿ¿`O Í¿OjdODEFGGGGG I ¿I²hI -hO -ð¢±ö°)OÉ0_JÉ_L¿O`ð³hO -W`—O ¿DOJÉØb¿EOJÉØb -¿OJÈ"_B¿OJÈ$_F¿OJÈ#_H¿OJÈ%_D¿G²nOBGOJÉØ_(¿dO(ñ¢¿O(_B¿OFGOJÉØ_*¿dO*ñ¢¿O*_F¿OHO(GØ_$¿dO$ñ’¿O$_H¿ODO*GØ_&¿dO&ñ’¿O&_D¿OLÈ_N¿@È_PONð³2OPkð²@jON ON °ONkð¢±Ë@ON -b¿DdOBñ¢¿OB_B¿EdOFñ¢¿OF_F¿FDFØdOHñ’¿OH_H¿GžEGØdODñ’¿OD_D¿DAÙ_>¿EBÙ_@¿JOBO>Ù_,¿dO,ñ¢¿O,djñ¡¿j_B¿KOFO@Ù_.¿dO.ñ¢¿O.djñ¡¿j_F¿@ÈOHO>Ù_0¿dO0ñ’¿O0JFØ_2¿dO2ñ’¿O2_H¿@ÈODO@Ù_4¿dO4ñ’¿O4KGØ_6¿dO6ñ’¿O6_D¿OHOBñ¢±ïODOFñ¢±æG¦OJÉb¿ON _R¿Gdgð²~¿Gd²¿ONkð™G bG£OR°JGd3 —ORåORæ°<òG`µld - -°ONkð©GON -†G b¿ONdkð³)¿GON -°gð²ONdkðœ¿G b¿ONkð³ONOBÚ_B¿ONOHÚ_H¿ONO>Ú_>¿h_8_:¿Wb²1Wd´hO -`ð_:²`È_8¿`jÍ¿¿O`ð³hO -W`—O ¿`/ODOFÙ_T¿OHOBÙ_V¿OLÈODO@ØÙ_X¿OBO>Ø_Z¿@ÈODÙ_\¿OB_^¿`OVÍ¿`OTÍ ¿Ggð²"`@O^O\OLOZOXOVOTGG ° `@O^O\OLOZOXOTGGG O:Ÿ¿`O8Í¿°.OÉ.É_<¿@ABODEFGGGGGJKlO<h(1859 \SOFTCURSORUPCURRENT 1850 \BITBLTSUB 1818 \BITBLT.MERGE 1683 \TOTOPWDS 1672 DSPDESTINATION 1653 \SOFTCURSORDOWN 1619 DSPDESTINATION 1564 INSURE.B&W.TEXTURE 1540 COLORTEXTUREFROMCOLOR# 1520 \ILLEGAL.ARG 1512 COLORNUMBERP 1496 INVERT.TEXTURE.BITMAP 1486 BITMAPCREATE 1438 INSURE.B&W.TEXTURE 1404 MAXIMUMSHADE 1171 UNCOLORIZEBITMAP 1166 COLORMAP 1148 COLORIZEBITMAP 1141 MAXIMUMCOLOR 915 \TOTOPWDS 904 DSPDESTINATION 857 DSPDESTINATION 849 DSPDESTINATION 838 TOTOPW 831 BKBITBLT 795 \SOFTCURSORUPCURRENT 786 BKBITBLT 763 BITMAPCREATE 751 \TOTOPWDS 740 DSPDESTINATION 722 \GETSTREAM 709 \SOFTCURSORDOWN 675 DSPDESTINATION 670 \GETSTREAM 627 \INSUREWINDOW 612 \INSUREWINDOW 601 WOVERLAPP 589 WINDOWP 578 WFROMDS 564 WINDOWP 549 \GETSTREAM 537 \BITBLT.BITMAP 498 \SOFTCURSORUPCURRENT 485 \BITBLT.BITMAP 459 \TOTOPWDS 448 DSPDESTINATION 430 \GETSTREAM 417 \SOFTCURSORDOWN 383 DSPDESTINATION 378 \GETSTREAM 347 WINDOWP 117 \GETSTREAM) (1887 IMAGEOPS 1880 STREAM 1865 \EM.DISPINTERRUPT 1825 \SYSPILOTBBT 1793 \SYSPILOTBBT 1785 MERGE 1773 PILOTBBT 1768 \SYSPILOTBBT 1758 PILOTBBT 1753 \SYSPILOTBBT 1735 BITMAP 1710 BITMAP 1661 \TOPWDS 1644 \EM.DISPINTERRUPT 1634 \EM.DISPINTERRUPT 1624 \CURSORDESTINATION 1547 TEXTURE 1491 \BBSCRATCHTEXTURE 1476 \BBSCRATCHTEXTURE 1467 BITMAP 1415 MERGE 1111 BITMAP 1038 \DISPLAYDATA 1008 \DISPLAYDATA 987 \DISPLAYDATA 975 \DISPLAYDATA 963 \DISPLAYDATA 951 \DISPLAYDATA 938 \DISPLAYDATA 924 \DISPLAYDATA 893 \TOPWDS 881 \DISPLAYDATA 872 STREAM 801 \EM.DISPINTERRUPT 780 REPLACE 775 INPUT 729 \TOPWDS 716 OUTPUT 700 \EM.DISPINTERRUPT 690 \EM.DISPINTERRUPT 680 \CURSORDESTINATION 664 OUTPUT 634 STREAM 619 STREAM 543 OUTPUT 504 \EM.DISPINTERRUPT 437 \TOPWDS 424 OUTPUT 408 \EM.DISPINTERRUPT 398 \EM.DISPINTERRUPT 388 \CURSORDESTINATION 372 OUTPUT 336 BITMAP 311 \DISPLAYDATA 287 \DISPLAYDATA 252 \DISPLAYDATA 235 \DISPLAYDATA 212 \DISPLAYDATA 201 \DISPLAYDATA 184 \DISPLAYDATA 173 \DISPLAYDATA 161 \DISPLAYDATA 129 \DISPLAYDATA 122 STREAM 111 OUTPUT 92 BITMAP 72 BITMAP 58 BITMAP 43 BITMAP 15 BITMAP) () \BITBLT.BITMAP :D8 (L (13 CLIPPEDSOURCEBOTTOM 12 CLIPPEDSOURCELEFT 11 CLIPPINGREGION 10 TEXTURE 9 OPERATION 8 SOURCETYPE 7 HEIGHT 6 WIDTH 5 DESTINATIONBOTTOM 4 DESTINATIONLEFT 3 DESTBITMAP 2 SOURCEBOTTOM 1 SOURCELEFT 0 SOURCEBITMAP) P 18 \INTERRUPTABLE) ð0CÈ[CÈ\j]d^@È_CÈZG²QMG_¿dOñ¢¿O½NG_¿dOñ¢¿O¾JGGØ_¿dOñ’¿OºKGGØ_¿dOñ’¿O»DdMñ¡¿M½EdNñ¡¿N¾F™DFØdJñ‘¿JºGšEGØdKñ‘¿K»DAÙXEBÙYGdjñ¡¿jMHÙ_¿dOñ¢¿O½Gdjñ¡¿jNIÙ_¿dOñ¢¿O¾@ÈJHÙ_¿dOñ’¿OGFØ_¿dOñ’¿Oº@ÈKIÙ_ ¿dO ñ’¿O GGØ_"¿dO"ñ’¿O"[JMñ´dNñ¡hGgð²WGµnÿÿ°K3 ›Gnÿÿånÿÿæ°¿@nÿÿÍ'A@ -h(53 \SFFixFont 33 \SFFixClippingRegion) (14 PILOTBBT) () \SFFixClippingRegion :D8 (P 1 BM P 0 CLIPREG I 0 DISPLAYDATA) •@É -@ÉB@HHØ@ÉØIȺdJñ‘¿J»jKñ¡K€jÍ#@H@ÉØdjñ¡¿jdnÿÿñ“¿nÿÿÍ"@HHØ@ÉØIȼdLñ‘¿L½jMñ¡M€jÍ%@H@ÉØdjñ¡¿jdnÿÿñ“¿nÿÿÍ$hNIL (124 \DISPLAYDATA 91 \DISPLAYDATA 54 \DISPLAYDATA 22 \DISPLAYDATA) () \SFFixFont :D8 (I 1 DISPLAYDATA I 0 DISPLAYSTREAM) 5AÉ*AÉ AÉÈAJkðhðµ IÈ jðhðAnÿÿ>¿AnÿÿÍ'@ (50 \SFFIXLINELENGTH) NIL () \SFFIXLINELENGTH :D8 (P 0 DD I 0 DISPLAYSTREAM) I@É0!@HÉHÉÙHÉ ÈÛ¹kIñ¡I€kºnÿÿJñ‘J‚nÿÿÍg ´ @ h(69 \UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 61 BOUNDP) (56 %%SYNONYM-STREAM-DEVICE 26 FONTDESCRIPTOR 5 STREAM) () \UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD :D8 (P 7 SI::%%$$MAP-FIRST-SUBLIST P 6 X P 1 SI::%%$$MAP-FIRST-LIST P 0 NEWLENGTH I 0 DISPLAYSTREAM) o@Èa`ÉYOµI^É ²'NÉ @ð²NHÍ¿`ÉZµ`É\µO_°Ç[ÉNð”KHÍ¿J°Þ]ÉNð”MHÍ¿L°Ø(41 CL:SYMBOL-VALUE 31 BOUNDP) (65 %%TWO-WAY-STREAM-DEVICE 55 %%ECHO-STREAM-DEVICE 10 %%SYNONYM-STREAM-DEVICE) () \SFFixY :D8 (P 4 BM P 3 CHARTOP P 2 TOP P 1 Y P 0 PBT I 1 CSINFO I 0 DISPLAYDATA) È @É*@É@ÉØ’ -I@AÈ -]Í'¿MØ[@É\ÉLÈLÈ@È%dKñ‘¿Kdjñ¡¿jZÙÚоHNÒÍ¿HNÓÍ¿AÉ\ÉLÈ@KJÙdjñ¡¿jdnÿÿñ“¿nÿÿ_B¿OÚÐ_¿HOÒÍ¿HOÓÍ¿HJI@AÈ _Í@¿OÙ@È$_¿dOñ¢¿OÙdjñ¡¿jÍ hNIL (152 PILOTBBT 140 PILOTBBT 88 PILOTBBT 77 PILOTBBT 49 BITMAP 38 BITMAP 11 \DISPLAYDATA) () \MEDW.XOFFSET :D8 (P 1 \INTERRUPTABLE P 0 DD I 1 DISPLAYSTREAM I 0 XOFFSET) NAd²Egh É0HÉ@²@d3²¿H@¿H  ¿ (75 \ILLEGAL.ARG 68 \ILLEGAL.ARG 61 \SFFixClippingRegion 14 \GETSTREAM) (35 \DISPLAYDATA 26 \DISPLAYDATA 19 STREAM 8 OUTPUT) () \MEDW.YOFFSET :D8 (P 1 \INTERRUPTABLE P 0 DD I 1 DISPLAYSTREAM I 0 YOFFSET) WAd²Ngh É0HÉ@²-@d3²!¿H@¿H ¿Hnÿÿ>¿HnÿÿÍ' ¿ (84 \ILLEGAL.ARG 77 \ILLEGAL.ARG 56 \SFFixClippingRegion 14 \GETSTREAM) (26 \DISPLAYDATA 19 STREAM 8 OUTPUT) () \DSPCLIPPINGREGION.DISPLAY :D8 (P 1 \INTERRUPTABLE P 0 DD I 1 REGION I 0 DISPLAYSTREAM) e@gh É0HÉ -A²DAl -ŸA…d3•µùi¿h«Ao -¿HA -¿H ¿Hnÿÿ>¿HnÿÿÍ'(83 \SFFixClippingRegion 68 ERROR 40 EQLENGTH 11 \GETSTREAM) (23 \DISPLAYDATA 16 STREAM 5 OUTPUT) ( 63 " is not a REGION.") \DSPFONT.DISPLAY :D8 (P 3 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) {0@É0ZdÉ YA²cA@i µJÉ giA -µ o XIð³7JH ¿JjHÈ -Ù¿JHÉɵ -jHh ÉÈ ÍA¿@J -(119 \SFFixFont 105 \CREATECHARSET 62 ERROR 50 FONTCOPY 31 \COERCEFONTDESC) (83 FONTDESCRIPTOR 41 NOERROR 17 \DISPLAYDATA 8 STREAM) ( 57 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER") \DISPLAY.PILOTBITBLT :D8 (I 1 N I 0 PILOTBBT) @AvNIL NIL () \DSPLINEFEED.DISPLAY :D8 (P 0 DD I 1 DELTAY I 0 DISPLAYSTREAM) %@É0HÉA²Ad3–¿HA¿ ¿(33 \ILLEGAL.ARG) (5 STREAM) () \DSPLEFTMARGIN.DISPLAY :D8 (P 1 \INTERRUPTABLE P 0 DD I 1 XPOSITION I 0 DISPLAYSTREAM) 0@É0HÉA²Ad3²¿HA¿@  ¿(44 \ILLEGAL.ARG 37 \SFFIXLINELENGTH) (5 STREAM) () \DSPOPERATION.DISPLAY :D8 (P 3 \INTERRUPTABLE P 0 DD I 1 OPERATION I 0 DISPLAYSTREAM) ¯@gh É0!HÉA¢±ˆAgð³%Agð³Agð³Adgð¦l -¿HA¿HÉ*HÉ ºYAdgð“¿k°gð’l‹Agð’l€jÏ -Q¿IJgðAgðð‘j€kÏ -@(82 \LISPERROR 11 \GETSTREAM) (162 ERASE 155 INVERT 138 INVERT 127 PAINT 116 ERASE 105 \DISPLAYDATA 97 \DISPLAYDATA 73 ERASE 63 INVERT 54 REPLACE 45 PAINT 32 \DISPLAYDATA 23 \DISPLAYDATA 16 STREAM 5 OUTPUT) () \DSPRIGHTMARGIN.DISPLAY :D8 (P 2 \INTERRUPTABLE P 1 OLDRM P 0 DD I 1 XPOSITION I 0 DISPLAYSTREAM) 4@É0HÉYA²!Ad3²Iô³HA¿@ „ I(48 \ILLEGAL.ARG 41 \SFFIXLINELENGTH) (5 STREAM) () \DSPXPOSITION.DISPLAY :D8 (P 0 DD I 1 XPOSITION I 0 DISPLAYSTREAM) /@É0HÉA²Ad3›¿HA¿@jÍ¿ ¿(43 \ILLEGAL.ARG) (16 \DISPLAYDATA 5 STREAM) () \DSPYPOSITION.DISPLAY :D8 (P 1 \INTERRUPTABLE P 0 DD I 1 YPOSITION I 0 DISPLAYSTREAM) 7@É0HÉA²&Ad3²¿HA¿Hnÿÿ>¿HnÿÿÍ' ¿(51 \ILLEGAL.ARG) (5 STREAM) () (MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS)) (MOVD? (QUOTE NILL) (QUOTE WFROMDS)) (MOVD? (QUOTE NILL) (QUOTE WINDOWP)) (MOVD? (QUOTE NILL) (QUOTE INVERTW)) (RPAQ? PROMPTWINDOW T) (RPAQ? \WINDOWWORLD NIL) (RPAQ? \MAINSCREEN NIL) (RPAQ? \TOPWDS) (RPAQ? \SCREENBITMAPS) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) TTYDISPLAYSTREAM :D8 (P 3 DD P 2 WIN P 0 \INTERRUPTABLE I 0 DISPLAYSTREAM F 4 \TERM.OFD F 5 \LINEBUF.OFD F 6 *STANDARD-OUTPUT* F 7 *STANDARD-INPUT* F 8 TtyDisplayStream) T@¢± @gh b ³g –@ ¦@ ¿ @dTð’±…¿Tµ VTð²8@c °4`ð³ð`–h ¿Ti -JœJgU ¿°Ç@c¿WU@i -Z² Jg` ¿Jg -µc -ð“Uc¿@c `²Cg@ -¿@É0[È%KÈ$ÙKɹjIñ¡I‚jIÙÛ (269 PAGEHEIGHT 216 DSPSCROLL 197 IMAGESTREAMTYPE 180 \CREATELINEBUFFER 173 GETWINDOWUSERPROP 161 PUTWINDOWPROP 142 WFROMDS 121 PUTWINDOWPROP 104 WFROMDS 96 \CARET.DOWN 50 \ILLEGAL.ARG 43 TEXTSTREAMP 36 \DEFINEDP 24 DISPLAYSTREAMP 17 \GETSTREAM) (251 \DISPLAYDATA 242 \DISPLAYDATA 234 \DISPLAYDATA 226 STREAM 210 ON 202 \DISPLAYSTREAMTYPES 168 \LINEBUF.OFD 156 \RUNNING.PROCESS 151 PROCESS 115 \LINEBUF.OFD 89 \CARET.UP 81 \DEFAULTTTYDISPLAYSTREAM 31 TEXTSTREAMP 11 OUTPUT) () optimize-TTYDISPLAYSTREAM :D8 (L (2 $$CTX 1 $$ENV 0 $$WHOLE)) @¥ggNIL (14 IGNOREMACRO 8 \TERM.OFD) () (PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST)))) DSPSCROLL :D8 (I 1 DISPLAYSTREAM I 0 SWITCHSETTING) 6Agh É0Hɵg@œH@gðhð¿(11 \GETSTREAM) (45 OFF 36 OFF 23 \DISPLAYDATA 16 STREAM 5 OUTPUT) () PAGEHEIGHT :D8 (L (0 N) F 0 \#DISPLAYLINES F 1 \CURRENTDISPLAYLINE) P@3—@c¿jc¿NIL NIL () (RPAQ? \CURRENTTTYDEVICE (QUOTE BCPLDISPLAY)) \DSPRESET.DISPLAY :D8 (P 5 X P 4 FONTASCENT P 3 FONT P 2 CREG P 1 WINDOW P 0 DD I 0 DISPLAYSTREAM) -@gh bÉ0@i -2hI -I -hI -I -HÉ -ZHÉ [dÈ\KÈ djð²%¿@HÉ -¿@JJØmÿØLÙkØ -°UdlZð²¿@JLØ -¿@J -°8nð²(@JJØmÿØLÙ -¿@JJØmÿØ -‰o ¿hdd@JJJJggHÉ6 @i -Md²" É.]d² @ð´Mo -h(297 PROCESS.EVAL 282 PROCESS.TTY 271 \INSUREWINDOW 259 WFROMDS 252 BKBITBLT 214 ERROR 203 \DSPYPOSITION.DISPLAY 184 \DSPXPOSITION.DISPLAY 158 \DSPYPOSITION.DISPLAY 148 \DSPXPOSITION.DISPLAY 129 \DSPYPOSITION.DISPLAY 106 \DSPXPOSITION.DISPLAY 61 WYOFFSET 55 WYOFFSET 48 WXOFFSET 42 WXOFFSET 32 WFROMDS 11 \GETSTREAM) (243 REPLACE 238 TEXTURE 89 FONTDESCRIPTOR 80 FONTDESCRIPTOR 71 \DISPLAYDATA 25 \DISPLAYDATA 18 STREAM 5 OUTPUT) ( 292 (SETQ \CURRENTDISPLAYLINE 0) 209 "only supported rotations are 0, 90 and 270") (RPAQ? *DRIBBLE-OUTPUT* NIL) expand-\MAYBE-DRIBBLE-CHAR :D8 (L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) ?@!H¹HºggogIoggJhhNIL (49 *DRIBBLE-OUTPUT* 44 \OUTCHAR 31 EQ 21 *DRIBBLE-OUTPUT* 16 AND) ( 37 ((TTYDISPLAYSTREAM)) 26 (STREAMP *DRIBBLE-OUTPUT*)) (SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE expand-\MAYBE-DRIBBLE-CHAR)) (SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) "if we are dribbling, then dribble this character") \DSPPRINTCHAR :D8 (P 5 TABWIDTH P 4 SPACEWIDTH P 3 I P 2 STR P 1 A13945 P 0 DD I 1 CHARCODE I 0 STREAM F 6 *DRIBBLE-OUTPUT* F 7 \PRIMTERMSA F 8 \TERM.OFD) C@É0`–@ ¿V²"V ²@Wð²VÉ(VAlIAlÿñ² WÉ€²AWÉ€ -µjƒWAÂlådjð²y¿Adl ñ²@H ¿@@ÈkÔͱ¸l ð«Adl ð¦dl -ðŸ¿A@ -¿@jͱ™jð²lA@ -@ -±„A@H ¿@@ÈkÔͱfdlð²h¿A º@J -HÉHÉÙñ²l @ -¿@J °@@ÈJ ÔÍ¿kJK -µ±@H ¿KkÔ»°ædlð¢±é¿Adl ð©dl ð¤dl -ð@ -¿@jͱÓlð²!l$@H ¿@@ÈkÔͱ¯Adlð²3¿`dlð©dlð¤dlð¿o ±…¿@ °vl ð²Ll @ -Lààà]HÉHÉÙM -Ù]H -HÉñ˜l @ -¿@@ÈMLÛÔÍ°'A@H ¿@@ÈkÔ͈lð¤h(575 SHOULDNT 546 \BLTCHAR 514 \DSPPRINTCR/LF 501 \DISPLAYSTREAMINCRXPOSITION 493 IMOD 472 CHARWIDTH 457 FLASHWINDOW 452 WFROMDS 442 PLAYTUNE 381 \BLTCHAR 359 \DSPPRINTCR/LF 321 \BLTCHAR 307 NTHCHARCODE 292 NCHARS 270 NCHARS 262 \DSPPRINTCR/LF 244 \STRINGWIDTH.DISPLAY 236 \INDICATESTRING 198 \BLTCHAR 187 DSPBACKUP 181 CHARWIDTH 161 \DSPPRINTCR/LF 116 \BLTCHAR 85 GETHASH 27 STREAMP 17 \CARET.DOWN) (559 STREAM 553 STREAM 527 STREAM 521 STREAM 416 \MACHINETYPE 394 STREAM 388 STREAM 284 STREAM 278 STREAM 211 STREAM 205 STREAM 129 STREAM 123 STREAM 78 CHARTABLE 66 CHARTABLE 41 STREAM 10 \CARET.UP) ( 437 ((880 . 2500))) \DSPPRINTCR/LF :D8 (P 15 SOFTCURSORUP P 14 DISPINTERRUPT P 13 KEPTWIDTH P 12 HGHT P 11 DBITMAP P 10 BKGRND P 9 WDTH P 8 LFT P 7 X P 6 CLIPREG P 5 FONT P 4 ROTATION P 3 Y P 2 AMOUNT/BELOW P 1 BTM P 0 DD I 1 DISPLAY-STREAM I 0 CHARCODE F 16 \SOFTCURSORP F 17 \SOFTCURSORUPP F 18 \SCREENBITMAPS F 19 \TERM.OFD) ÙAdW&𲿿`–A ¿AÉ0QHÉ¢±NHÉ È \jð’±8HÉ -@l ð²AHÉ2[•AkK¿LdlZð•¿N°nðœNNØmÿ؉o A -¿HÉLdlZð—¿jHÉÙ°nð“Hɉo Ø_¿HÉ¢±¨LdlZð²,¿OHÉØHÈ#HÉ È ÙÙZjñ°5nð²*HÈ"HÉ È ØOHÉØÙZjñ„¢±@` HÈ"_¿HÉ_¿HÈ$¹HÈ%IÙ_¿HÈ#OÙ_¿HÉ6_¿ W ²0W"´hA -`ð_²`È_¿`jÍ¿¿A`ð³hA -W$–A ¿JOñ›hjdOOIO°eLlZð²3OOJØIOOIOJÙ_Ogg -¿hjdOOOØ°,OOIOOJØIOJÙOgg -¿hjdOOIJOggO ¿OŸ¿`OÍ¿LlZð”OJÙƒOJØ_OA -±\@l ð²HÉ2[•AkK¿HÉA -¿HÉHÉØ»HÉ¢±!HÈ$YHÉ È ØKHÉØÙZjñ¢±öP HÈ"_¿HÉ_¿HÈ%IÙ_¿HÈ#OÙ_¿HÉ6_¿ W ²0W"´hA -`ð_²`È_¿`jÍ¿¿A`ð³hA -W$–A ¿JOñhjdOOIOO°0OOIOOIJØOOJÙgg -¿hjdOOIOJggO ¿OŸ¿`OÍ¿KJØ[€KA -h(981 DSPYPOSITION 956 \SOFTCURSORUPCURRENT 947 BKBITBLT 917 BKBITBLT 863 \TOTOPWDS 853 DSPDESTINATION 836 \SOFTCURSORDOWN 802 DSPDESTINATION 667 DSPXPOSITION 632 DSPXPOSITION 594 \SOFTCURSORUPCURRENT 585 BKBITBLT 555 BKBITBLT 508 BKBITBLT 448 \TOTOPWDS 438 DSPDESTINATION 421 \SOFTCURSORDOWN 387 DSPDESTINATION 303 SHOULDNT 187 ERROR 145 DSPYPOSITION 139 ERROR 25 \CARET.DOWN 12 \STOPSCROLL?) (962 \EM.DISPINTERRUPT 939 REPLACE 934 TEXTURE 911 REPLACE 906 INPUT 843 \TOPWDS 827 \EM.DISPINTERRUPT 817 \EM.DISPINTERRUPT 807 \CURSORDESTINATION 770 \DISPLAYDATA 751 \DISPLAYDATA 740 \DISPLAYDATA 720 \DISPLAYDATA 710 FONTDESCRIPTOR 703 \DISPLAYDATA 694 \DISPLAYDATA 682 \DISPLAYDATA 648 \DISPLAYDATA 600 \EM.DISPINTERRUPT 577 REPLACE 572 TEXTURE 549 REPLACE 544 INPUT 502 REPLACE 497 INPUT 428 \TOPWDS 412 \EM.DISPINTERRUPT 402 \EM.DISPINTERRUPT 392 \CURSORDESTINATION 355 \DISPLAYDATA 338 \DISPLAYDATA 327 \DISPLAYDATA 316 \DISPLAYDATA 290 \DISPLAYDATA 279 FONTDESCRIPTOR 272 \DISPLAYDATA 264 \DISPLAYDATA 243 FONTDESCRIPTOR 236 \DISPLAYDATA 228 \DISPLAYDATA 219 \DISPLAYDATA 197 \DISPLAYDATA 152 \DISPLAYDATA 89 \DISPLAYDATA 62 FONTDESCRIPTOR 55 \DISPLAYDATA 43 \DISPLAYDATA 32 STREAM 18 \CARET.UP) ( 182 "Only rotations supported are 0, 90 and 270" 134 "Only rotations supported are 0, 90 and 270") \TTYBACKGROUND :D8 (P 0 X F 1 \LINEBUF.OFD) DQÉ`ð²/`²``ð¥¿`ŠdjHµô(65 \BACKGROUND 39 WAIT.FOR.TTY) (45 TTYBACKGROUNDFNS 32 \TTY.PROCESS 27 \RUNNING.PROCESS 20 \RUNNING.PROCESS 12 \KEYBOARD.STREAM 5 STREAM) () DSPBACKUP :D8 (P 4 XPOS P 3 BLTWIDTH P 2 ROTATION P 1 FONT P 0 DD I 1 DISPLAYSTREAM I 0 WIDTH) fA ³Ag -b ¢±Agh bÉ0q@HÉ\HÉÙ½dMñ‘¿M[HÉ YHɘIÈ €jZKjñ´‚±Ä`–A ¿Jdjð²0¿LKÙA -¿hjdAHÉHÉIÈ ÙKIÈ -°qlZð²0hjdAHÉIÈÙHHÉjKÙÔ^¿N°5Jnð²GhjdAHÉIÈ ÙHHÉKÔ_¿OIÈ -Kgg -i@Mjñ²#Al -¿Al -¿Al -¾MkÙ]°ÝN(347 BOUT 338 BOUT 329 BOUT 310 BKBITBLT 147 DSPXPOSITION 130 \CARET.DOWN 41 \GETSTREAM 25 DISPLAYSTREAMP 18 GETSTREAM 5 DISPLAYSTREAMP) (304 REPLACE 299 TEXTURE 291 FONTDESCRIPTOR 274 \DISPLAYDATA 268 \DISPLAYDATA 259 FONTDESCRIPTOR 251 \DISPLAYDATA 221 \DISPLAYDATA 215 \DISPLAYDATA 206 FONTDESCRIPTOR 198 \DISPLAYDATA 179 FONTDESCRIPTOR 169 FONTDESCRIPTOR 158 \DISPLAYDATA 123 \CARET.UP 104 FONTDESCRIPTOR 95 \DISPLAYDATA 86 \DISPLAYDATA 65 \DISPLAYDATA 55 \DISPLAYDATA 48 STREAM 35 OUTPUT 13 OUTPUT) () (RPAQ? \CARET.UP) (RPAQQ BELLCNT 2) (RPAQQ BELLRATE 60) (RPAQQ \DisplayStoppedForLogout NIL) (RPAQQ TtyDisplayStream NIL) COLORDISPLAYP :D8 NIL `hðhðNIL (4 ColorScreenBitMap) () DISPLAYBEFOREEXIT :D8 (I 0 EXITFN F 0 \TERM.OFD) L`´E@dgð–¿dgðœ¿P gð‘h(73 SHOULDNT 58 CLRPROMPT 53 DSPRESET 37 SHOWDISPLAY 16 CHANGEBACKGROUNDBORDER 11 CURSOR) (64 SYSOUT 44 MAKESYS 29 LOGOUT 22 \DisplayStoppedForLogout 4 \DisplayStarted) () DISPLAYAFTERENTRY :D8 (I 0 ENTRYFN) ````²2¿` ¿` ¿` ¿h¿g ´  (93 CARETRATE 88 CARETRATE 81 \DEFINEDP 63 CHANGEBACKGROUNDBORDER 51 CURSOR 39 VIDEOCOLOR 28 \STARTDISPLAY) (76 CARETRATE 70 \DisplayStoppedForLogout 57 \DisplayStoppedForLogout 45 \DisplayStoppedForLogout 34 \VideoColor 21 \DisplayStoppedForLogout 14 \EM.CURSORBITMAP 9 BITMAP 4 CursorBitMap) () (PUTPROPS \CHECKCARET MACRO ((X) (AND \CARET.UP (\CARET.DOWN X)))) \DSPCLIPTRANSFORMX :D8 (P 0 TX I 1 DD I 0 X) *@AÉØAÈ"Hñhð´AÈ#Hñ´HNIL (32 \DISPLAYDATA 18 \DISPLAYDATA 6 \DISPLAYDATA) () \DSPCLIPTRANSFORMY :D8 (P 0 TY I 1 DD I 0 Y) *@AÉØAÈ$Hñhð´AÈ%Hñ´HNIL (32 \DISPLAYDATA 18 \DISPLAYDATA 6 \DISPLAYDATA) () \DSPTRANSFORMREGION :D8 (I 1 DS I 0 REGION) '@AÉØ@AÉØ@@hNIL (19 \DISPLAYDATA 7 \DISPLAYDATA) () \DSPUNTRANSFORMY :D8 (I 1 DD I 0 Y) @AÉÙNIL (6 \DISPLAYDATA) () \DSPUNTRANSFORMX :D8 (I 1 DD I 0 X) @AÉÙNIL (6 \DISPLAYDATA) () \OFFSETCLIPPINGREGION :D8 (P 0 CREG I 1 OLDREGION I 0 DD) ~@É -Aµ@Éjð²?@Éjð²3HH@ÉØAH@ÉØAHAHAH@ÉØH@ÉØHHhNIL (106 \DISPLAYDATA 94 \DISPLAYDATA 62 \DISPLAYDATA 47 \DISPLAYDATA 31 \DISPLAYDATA 19 \DISPLAYDATA 5 \DISPLAYDATA) () UPDATESCREENDIMENSIONS :D8 NIL ``dlðªdlð¥dlð²¿nn(dlð²¿lð²}C}D(93 SHOULDNT 60 \DoveDisplay.ScreenHeight 50 \DoveDisplay.ScreenWidth) (87 SCREENHEIGHT 79 SCREENWIDTH 65 SCREENHEIGHT 55 SCREENWIDTH 37 SCREENHEIGHT 29 SCREENWIDTH 4 \MACHINETYPE) () \CreateScreenBitMap :D8 (P 3 I P 1 MAXPAGE# P 0 RASTERWIDTH I 1 HEIGHT I 0 WIDTH) ¹@lØââââHAÚlÿØãkÙY`ñ²I`kØKJó²vI¿`Ö`µ#l d`¿dHÍ¿d@Í¿dAÍ¿dkÍ¿``@Í`HÍ`AÍ``KáÐid ¿KkÔ[±ÿt(175 \NEWPAGE) (165 \DISPLAYREGION 159 ScreenBitMap 151 BITMAP 146 ScreenBitMap 138 BITMAP 133 ScreenBitMap 125 BITMAP 120 ScreenBitMap 113 \DISPLAYREGION 108 BITMAP 79 \DISPLAYREGION 68 ScreenBitMap 62 BITMAP 57 ScreenBitMap 51 \MaxScreenPage 34 \MaxScreenPage 25 \MaxScreenPage) () (UPDATESCREENDIMENSIONS) (RPAQ? SCREENHEIGHT 808) (RPAQ? SCREENWIDTH 1024) (RPAQ? \OLDSCREENHEIGHT 808) (RPAQ? \OLDSCREENWIDTH 1024) (RPAQ? \MaxScreenPage -1) (RPAQ? ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT)) (RPAQ? ColorScreenBitMap NIL) (CURSOR.INIT) (RPAQ? \DISPLAYINFOALIST) \CoerceToDisplayDevice :D8 (P 0 DEV I 0 NameOrDevice) *@µ`HÑHHid µ o (39 ERROR 27 \GETDEVICEFROMNAME) (16 FDEV 7 LastCreatedDisplayDevice) ( 34 "No color drivers have been loaded") \CREATEDISPLAYA0014 :D8 (L (4 FDEV 3 OTHERINFO 2 RECOG 1 ACCESS 0 NAME)) @NIL NIL () \CREATEDISPLAYA0021 :D8 (L (2 FDEV 1 RECOG 0 NAME)) @NIL NIL () \CREATEDISPLAYA0023 :D8 (L (0 NAME)) @NIL NIL () \CREATEDISPLAY :D8 (P 0 FDEV I 0 DISPLAYNAME) … `d@¿djÏ¿djÏ¿djÏ0¿dg¿dg¿dgD¿dg¿dg^¿dgF¿dg¿dgb¿dg`¿dg¿dg¿dg -¿dg ¿dg¿dg,¿dg.¿dg0¿dgT¿dg>¿dg@¿gh¹dI¿dgh¿dgR¿dgP¿dgN¿dgH¿dgB¿dg<¿dg:¿dg8¿dg6¿dg4¿dg2¿dg*¿dg ¿dg¿dg¿dg¿X@H -H(385 \DEFINEDEVICE) (374 \GENERIC.RENAMEFILE 365 NILL 356 NILL 347 NILL 338 NILL 329 \GENERIC.READCHAR 320 \GENERIC.WRITECHAR 311 \GENERIC.PEEKCHAR 302 \GENERIC.UNREADCHAR 293 \GENERIC.READP 284 \ILLEGAL.DEVICEOP 275 NILL 266 \GENERIC.CHARSET 257 \ILLEGAL.DEVICEOP 248 \IS.NOT.RANDACCESSP 239 \IS.NOT.RANDACCESSP 230 \GENERIC.READCCODE 216 OFF 208 \NONPAGEDBOUTS 199 \ILLEGAL.DEVICEOP 190 \PAGEDBACKFILEPTR 181 \ILLEGAL.DEVICEOP 172 \DSPPRINTCHAR 163 \ILLEGAL.DEVICEOP 154 NILL 145 NILL 136 NILL 127 \CREATEDISPLAYA0023 118 \CREATEDISPLAYA0021 109 \ILLEGAL.DEVICEOP 100 NILL 91 \GENERATENOFILES 82 NILL 73 \ILLEGAL.DEVICEOP 64 \CREATEDISPLAYA0014 55 NILL 46 NILL 37 NILL 7 |FDEVTYPE#|) () DISPLAYSTREAMINIT :D8 (P 2 TTYFONTHEIGHT P 1 TTYHEIGHT P 0 TTYFONT I 0 N F 3 TtyDisplayStream) «chS -!HÈ -Z`S -S `@3µLdJÚ¹`IÙS -¿HÈ S -¿jS -¿jd`IhS -¿`S -¿JÚ`ñš`JÛlÙ€@°(139 DSPRIGHTMARGIN 127 DSPCLIPPINGREGION 107 DSPXOFFSET 99 DSPYPOSITION 84 DSPYOFFSET 57 TERMINAL-OUTPUT 41 DSPDESTINATION 18 DSPFONT 9 DSPCREATE 4 \STARTDISPLAY) (167 \LastTTYLines 155 SCREENHEIGHT 148 SCREENHEIGHT 133 SCREENWIDTH 115 SCREENWIDTH 91 FONTDESCRIPTOR 76 SCREENHEIGHT 62 \LastTTYLines 52 \TopLevelTtyWindow 47 \DEFAULTTTYDISPLAYSTREAM 35 ScreenBitMap 27 FONTDESCRIPTOR) () \STARTDISPLAY :D8 (P 2 \INTERRUPTABLE P 1 W P 0 OLDWINDOWS F 3 \MAINSCREEN F 4 \WINDOWWORLD F 5 \CURSORDESTRASTERWIDTH) I``ðœ``ð³AT²> ¸``ó«``ó–H ¿HŒdI µò`` -É`È -¿ijd``hSµD````Èc -H²P` ¿H °:`¿S`¿S`¿°•dI µò``h(300 \OPENW1 244 REVERSE 237 CHANGEBACKGROUND 142 SHOWDISPLAY 113 \CreateScreenBitMap 90 \CLOSEW1 76 \MOVE.WINDOWS.ONTO.SCREEN 45 REVERSE 40 OPENWINDOWS 7 UPDATESCREENDIMENSIONS) (325 \OLDSCREENWIDTH 320 SCREENWIDTH 315 \OLDSCREENHEIGHT 310 SCREENHEIGHT 284 SCREENHEIGHT 279 SCREEN 270 SCREENWIDTH 265 SCREEN 256 ScreenBitMap 251 SCREEN 232 WINDOWBACKGROUNDSHADE 220 BITMAP 215 ScreenBitMap 210 \CURSORDESTHEIGHT 205 SCREENHEIGHT 200 \CURSORDESTWIDTH 195 SCREENWIDTH 190 \CURSORDESTINATION 185 ScreenBitMap 177 WHOLESCREEN 172 WHOLEDISPLAY 162 SCREENHEIGHT 157 SCREENWIDTH 149 \DisplayStarted 135 BITMAP 130 ScreenBitMap 123 BITMAP 118 ScreenBitMap 108 SCREENHEIGHT 103 SCREENWIDTH 68 SCREENHEIGHT 63 \OLDSCREENHEIGHT 56 SCREENWIDTH 51 \OLDSCREENWIDTH 29 \OLDSCREENHEIGHT 24 SCREENHEIGHT 17 \OLDSCREENWIDTH 12 SCREENWIDTH) () \MOVE.WINDOWS.ONTO.SCREEN :D8 (P 4 REG P 3 YFACTOR P 2 XFACTOR P 1 W I 0 WINDOWS) Ú@Hµ+h´&```ëZ``ë[@HµAhYÉLLØmÿØ`óµLLØmÿØ`ó•Iµ¥i°¢HX°™Yd ð²\Ii -YJIÉ\]MØmÿØê LÙ¾jNñ¡N€jKLLØmÿØê LÙ_¿jOñ¢O€j ¿HX±ÿV(209 MOVEW 186 FIXR 154 FIXR 127 MAINWINDOW 117 MAINWINDOW) (135 WINDOW 95 SCREENHEIGHT 75 SCREENWIDTH 55 WINDOW 36 \OLDSCREENHEIGHT 31 SCREENHEIGHT 24 \OLDSCREENWIDTH 19 SCREENWIDTH) () \STOPDISPLAY :D8 (P 0 \INTERRUPTABLE) :¿`É`kØ -¿mÿ¿hl: (55 PAGEHEIGHT 32 \UNLOCKPAGES 7 SHOWDISPLAY) (47 \DisplayStarted 40 \MaxScreenPage 25 \MaxScreenPage 18 BITMAP 13 ScreenBitMap) () \DEFINEDISPLAYINFO :D8 (P 0 BUCKET I 0 DISPLAYINFO F 1 \DISPLAYINFOALIST) @QXd—dQ -¿@Qch(16 DREMOVE) NIL () (PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* always initialized now) T)) (PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted)) (ADDTOVAR GLOBALVARS WHOLESCREEN) INITIALIZEDISPLAYSTREAMS :D8 (F 0 \GUARANTEEDDISPLAYFONT) Xodnÿdh`ld -gl -hdg cgkPh -(80 FONTCLASS 63 FONTCREATE 38 BITMAPCREATE) (85 DEFAULTFONT 70 DEFAULTFONT 57 DISPLAY 48 GACHA 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY) ( 4 -16383) (RPAQQ \DisplayStarted NIL) (RPAQQ \LastTTYLines 12) (INITIALIZEDISPLAYSTREAMS) (DISPLAYSTREAMINIT 1000) (PUTPROPS LLDISPLAY FILETYPE COMPILE-FILE) (PUTPROPS LLDISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1993 1994)) NIL \ No newline at end of file diff --git a/sources/LLDISPLAY.~2~ b/sources/LLDISPLAY.~2~ deleted file mode 100644 index acfcfa96..00000000 --- a/sources/LLDISPLAY.~2~ +++ /dev/null @@ -1,1838 +0,0 @@ -(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/LLGC.~3~ b/sources/LLGC.~3~ deleted file mode 100644 index ddea752c..00000000 --- a/sources/LLGC.~3~ +++ /dev/null @@ -1,296 +0,0 @@ -(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/LLMVS.~1~ b/sources/LLMVS.~1~ deleted file mode 100644 index f09d4507..00000000 --- a/sources/LLMVS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-Feb-91 22:40:14" {DSK}sybalsky>3-BYTE-ATOM-CHANGES>LLMVS.;1 18758 changes to%: (MACROS \VALUES) previous date%: " 5-Jun-90 17:30:26" |{PELE:MV:ENVOS}SOURCES>LLMVS.;10|) (* ; " Copyright (c) 1986, 1987, 1989, 1990, 1991 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 [\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 (+ 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1406 3161 (CL:VALUES 1416 . 1721) (CL:VALUES-LIST 1723 . 1972) (\MVLIST 1974 . 2009) ( \SIMULATE.UNBIND 2011 . 3159)) (16758 18469 (CL::VALUES-UFN 16768 . 17724) (CL::VALUES-LIST-UFN 17726 . 18467))))) STOP \ No newline at end of file diff --git a/sources/LLNEW.~15~ b/sources/LLNEW.~15~ deleted file mode 100644 index f345aeaf..00000000 --- a/sources/LLNEW.~15~ +++ /dev/null @@ -1,847 +0,0 @@ -(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/LLREAD.LCOM.~1~ b/sources/LLREAD.LCOM.~1~ deleted file mode 100644 index 8e7870b72a3e1b6dc20668cbb47ee9525e244410..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 58688 zcmeIb3v^u7nI>8)*%%0=lw{)=A;h6DMi!Q+w@QK`DoG_*sUAm2@(W}N*(IY#S#o4M zJVI!oNq0hb)4{PJArBHak0d=!t4h{%gMpe(PtSzR^mMvIa$#=wG@6jxb91L}7p){6 zVr<{<|Mxys=bWli6y$3`Sz1j!0rqRa!?v z!GW=0Uo50JB8jokNGvis>`+>VgZIqwpfgs?Yzac zU9mYl&W`xRLPxhxaXWiFo*t*yp&X!U(l@4*Y19&*Or zLo1GAtjpKq?m|Z#=8h_|pa)g-c+o(YLwWF1!=YHHC%(HUl-R9~e)?7#cfUFkx@}b5 zHPRm%E%Y()pyG0S0s*&jaB5=ip2?%ivH2T%ls4O7VpJI)866vmBzC&DD{b*$|A>mH z#Aqb3T{*Ha`N`?|<43ul$nS8u#4ufo%hTiW_V|1b#a4Sax*ptaiv>r=`jwu6fUPa2 zv^f=;j_unOOT5lvsq4MRf`6COpG)Y^cYTd@mT+qB;>EXT@=s3LQ|XKEow|%t?CI|J zp1GU8!s*N3{=Pl!48QkWIPHAfE+W5gx3qa(N`E*w66^;`C@!ZmzB4q2p@xESK)1`S zjH`2#{ZkVQ!DI7>`zDS~Dn3_foXe+(GKx=$B!+j5q3m|sa3~Zlj>4r3#&#-lEXpvx z#z!U(O{dd+#}6HvTo|0g_;%J?ELI+#Zjg;l)(8*hj&dU#k|P^>@42DE$cAWS9-nSx zZm+`K=~o9r3c70;rr%#WBro!qhYs-Y=oGIqPPL6-k;P)gv2x|wthtng8X6f)QatJ3yTUn>Kb^6BI~NHuDonk;KZS5EeKDUM zh$y)TXM5vv@e_U}l2Y~~?HlnY@HLbF0x~|vP`xW{9csuWR$iAC?O(cPYVlrE@w1Vs zv^CnW@_J(Kq9vc*f(GI%vcS7yc5;h-rb4e$p;*I8{N2SH-`K&^dSkNT&j}yTd_-*! zJ+mh57{XM#UbQzwzIR1qa#JqZluFw$xVrY7x+yi2Kar`sCT*pN&5ia=dH`e>auH=J z*^)~()3|$09Y}7@VX&NbT5UEDJlT@As+${7L$W!iwk%$4F1;m315md#tni?3iYSZQ z3gc+i#?dOqVMzk!lwCoM(>x`Hp1N`ZOxd`(8HXt6XrLk7EOO}@+Nw3QRW!6NxlI(< z){tvTU!G6f?D+ddb<=Eq>F4Ro?P?Qn-{)SSSHZ2C?fD`0MHdzUwP<`B6J904nQp=_+zLK`|;;L~E*0%(Mo59*+{* z3nG*V#s<}qcyLVdVbPkSTz+$uH{ewU2SU3QZ&#N_g}lB3LGro-B_&+lrBN<(lqUd+ zMfG|xd`aCrC@JDxZY|CoD757+ZOdKSmfKa*ma7|dk=k+vJX*ajPnV4IIJG$RgtGzu zvPWo9eyu^AMuKB%yueOe%E-W2UrbMy%%m9P*`>5g(V(4)b$da6XjcY70F7Z^F*nHg zkiMz>nFcN;6Q@$CX&ckC=*OsnoPA3CF8&)!n+uaLKDw)qhM*8nEATkQ z?^J@ZnA#5@0^vc*UBJWf@!>=;9uje#J7a2J5OR!=7a$`5bJxs(wHF*23GM?Bu^e^{ z4~ItjgQFpiQvv~{0Lfvc%Mik}O8$Z+wN?{eVxBaqH%qakL$D$Roo_ElcO8WZbi4J9 zx;(lNb1w#r#<<+fs7tW~7(w|u5}`dYk}XFuGC*at9Dca<_yLT#)>>z&*Dzv)=d7>M zTGz|dww@*oL<_h)KBf+L#6r76F^niU!1GbAvwE?@jLjfrM!}*C{sII#1m3RHP1x!* zls%E#)66{-*qOaT;NsLrsGFRik4SFPG34xVa4cn<2>C7QCV`p-4h&w#N#BV5K7HzW z@P6jODEexAvDsYkthz}s-~GgfPQ_M`@3&*A?2a?-@z}eIH)t&BF2N`+Pl$Fc$p&sq0OW2GHiiU~JxUfpiQD{PtXe>TSay6=5 zB-*}iEe*U*tYuFj3ivIeh#V1mL&G8g652{x95;!R20X`_x)I8NRYxZeSOg|>#)` zg5F@-8g9VaGE4R#Vv^x#9o9?k)VX0D!_Z0YXt=Z9*l^=@*6;pAYq^oZM?|jN)v=) zwXspzD4CVE=wAWt$p6fbCA7cEwS&U?#9&AO#Q@R6ij{Vwo4+fzNmA2_FZPQ)arW*v4+jRR10=27K#<@_1 z925y%f?h$}ka1mwUiu{I@D@8O8H*+sIdue9L0v>ucp$?Di-krzJ}lh;K{tpK)*Txw z(2Z?n>4v?@gwn4O;>8MXZ!=yiQc3iC0Ba$*R~ybcxnI zs?mr>Q+c9+wIjp`%ByZF5{;(nM59P>)FwUA*sKwa%^K0zB8kS9hSb;XXF)@vf@BC; z>qqB42L!bhZut;xm7@FD+op;YLt$I9WE+`qv(6jMGK-)lq4e`cu!F>@_IlPDpCTE zCXAO%M9qNfvG29aFxx9o=tRs4TTeJW3QQSK2v z+71;QqRMDwC#)qMY_sV|jA~|^4mR7gLp-uu>MV7`&&)$gvh?zznITya+<**|+l9!a z_+jGrb{v>KrohlWId^bAH9dEaGBzv(^=8lx#(SU=^YS zbPNi#&Zqz^9O)yWjco}9f~(UObsFR#I$@xomM>ibjgbYbzEgc{NZ8G*Oec&rde#S* zn}%3k8DDAY3>9_KTq=Du ze~LR{Pan^pj-J^d0t7=aaig*dZ9h<0mQdyUV?FU;G}O_rCi=0FlAz6$4vA5I;IB*; zfWsyY%;s7$@G>5i5XD*_52=Hlu+T@;gaUiL#-)UW>xMF+7X@4>aKnD=J#;BIY)7B; zE2Uc>0RJq^$}q$fO*t``Bp_DsytA1AT{hr=Q|XvkxaVjGp(89nh1$qMg!vpD3nm7F zBLiY=gpbdxw^}We&`V~+?>)Kuk=cnx*E%RD?>#yFXxcjQO1d7OQ;(+WC(fqViO+Qt z+2q}XzIyA>s}Y_Cp0!<)_D;pbS0(FEN?36lE{CA) zZ&+ey)*ZeW7oiF(IW{F$a@@3%vmo3tHXhSL_LrGulBqN+aKNyTAtmXozzVIP!YU^l zB$Si2mJ|#)Xl{))2cxmSu&muK^RjlqVys)qrd6)3YyaBoT7iBh2!MV|S6l7F!I4q& z1Q-kL#6GXa#0v|2yHbB+t3}f0iN^Qr;k5PaE776V?5?R-@%{R1iBxBhps3 zC6X0UwXbH!bLq=Ti$L_29N87Nq}0tKbFYLUgie@$o|Z7K(occ1FZ+S^OL$ndAtO)c35k z*TAyCBX3wD>2=(^G5)*thVY}`v;KB^Am8|zYt&82mel&XXLGY^%X=@XEvfX@_nyW+ zAy-F=P+RO9GruzvTYW0VQ4h!7Oga&(HY{JFZd<%k-M0GNjM}jJwAvtgpf-NFTR=F0aYq}`RbX=(?N>)`J2hkoa#=gPQV;?3bp-db*t+9{&y{p(eHO)yhxHd zLQ2tfs@!yZIJ-$z3IQJ7@?|rRsjaF)YS9-}=PY$<@ms1J^)5}Q%}-6K?yYrJJ5NWZ z?kZ8YSKYC?G>oo!SHGnOmTpp=$-v@`s()!5p}nd%mF~ztmE$@4T>7SbHpHJve@--z zQr+iQv+kVQp3TTkFaD9*nQcu^pvLD_Z(8}`BdS;JZY<}Xd5-L@YRJk-GR43fwAZ|o1$hU~^jY`GpYxV%o?#sb2_0)1g_Yzx4Q3~5O0 zk9I+2Kmep=G;}-mm!M_EquNsQgD-=Yuqnt3HADOMcp*T-_#4_8jCBS_b}AlNfejIE z*rnkuusaxw40MhJ2O@i6x$rAD+`#fd$JoB%P)A}{ybtTy4V$zUuMQ5vY^u23g2MG- z=V>sq7Xlu(PPIG~3DM9g^Z*6KkowOO{4gj+7rN4+_#xgDRW3hhU@_!FM{ZJlFoJa` zUavmI3wgAd&kgZYN7+cZ>W{~y=FsI)dWLo-q8&tg_rTN01^D!ck-A_khsO@$oQQ)Y zIYK@qN*8uO9b;3I3zN$9QDx@%+$=c`9h*X6dhXcdJ(CN{(PIlxUwV{>M&UcuZak(;%-ye~rtg_PMkOkjv?*SYVMk&fdeB_Qy;IZ2CXXJOI5CwQsq8I?Aloyt(=VOB*0uaE?+)St)Q%1q@fm zRxy9@ty+^!lB2;|Y!q0h!=}O(3+ZBO6(bLYvfHKQcS1YJOpq9W#5ATxLkZnPg+}{> zSalL#J7_kvT^Xz%@|jWw6^Qt{=>TVaw6y?!>>S+6Bn5@X=|imWk%HXhNbcNHO4HrzS288)NmqW9qiTZ zN@VZI^@`2QZe#ZF*oM9Bx=nk7b zvwfyvz|{!dFPKD4L%{|M?Tm0~HjL7El5Flgr8Z$ik3-(c-h8G5j0LvLqAQTumT7?) z#KYRs&`bNSH%UYob1qM14sF+c0D8N)+#z=qsDl~Q|{Jj{gEcK%4hb<6!Mn0Na&d~km#%AY-= zwoilKF3zZ1zpB!lzX+y{Ifd-gPNv$ME7o?3Yx@k+o0IOOH#b8SZd2R8uXg^WC8zd$ zi>v#>G)Wchvu`0abN&joy(uj91Tbx4iKB6B%1F~n0E9tDpqN_-YYnSPU0_Fs{9RzP z`uu)!9Ms!h{bVc9NBGE7L)*0Ry3l@Qqb>}?(Dm>VghpGLQOUi8V*T49iwpKlXnF$y5B;$(5hpQnRZ!04c-h*X4ysWQy{@Ml7tq z*bkGH(I%SqDcuI--V+2DornRZVXDoIc`-*}qsbKI3TT$z;wG01J8-g17dGz2mXoJo zg?2%A(=i~IQ~G0d7fPYdH6ahZRGN3tA(Lwm_?fP9G___;rA`AyHmvD)9%VRz;V4BB zV>Ae9L5xt(t8^j;7?||*VQ9l_w{E)CYFS65tly+knWzgn9DtmM8=6*T8h_T*xOh!C z1u_R;Q`_%=Ql)L52@^rP{8awK^${J_`EQ!(HTiFDVR}ven=5xbJd|vq zotjf>GgIqkL9JWVW<9ko=eWtFOljDkiqY=#pXK_d>Gu!PHeyQGN;ZlesI*P{7Ay&y z*1@#xJ4}d|jv7XFn_ z>`7ang~px#YLSJUU>35U`h1Pn&u8P>m*_EU+`;&F?h;1kINScn zFc6*|rp+bO)5g<7X{Xh8vt*Fmf$3@E=>ehM!PB!tOiw#cPrI0&9csINdO9^u(}*K7nTy_p%{%G5l>C6XzqHab%w?(3} zZ+|}yMmV$hF&D!POA3k zw#TAiuMH5CX3j>UTp^l;H1y3l&&R3AKYq0>RZ8idsDM&PXoGj9gIWI zh;+3H?qX5NNX?fZ68Q=Wp3<+Vyy9PFY#@S-4p*Z zRO%s@Cw;SSur94An-D9qe3R}D9*@l?jgUh}MpJ@UIbj8q3@iX%L|a8l0E)bc_XPkB za}-LNqp+dH)drx(%UVeT*FM3OxdA_Pep69Dq#1J*?K>JJ0UsnXZh&^bWv$*KGxcH; zbsUj=Zi;;0E6;aGnE*BnQ{^6r5+zY3z4Aa^<1Uc9pzMMhW(w_-Hu4HyFK)nD7s70t z8gM&HK<&bKOu1;2M^0Bk#DQuon}oQ*iLfJy7|ix|n`zG?=yW<=^v7LLPc;aN&0%aA zcEEJBD+K-DM%%zl`i7Yc&>AC;n6beTm5%uUX^lG~6%8tLh2-<8-CNeo~c zNgWIIkF_fik}fErKNbomb`5usD?dDh2caobk2IfQL=?sgfkUq_BgxA^#s@YP`y(T$ zi@kw)14HaB7Dk6mU5ebr3hDN+FzQF^HdyLz|Elmd=Fx9z&k3#jpib+qvy5;eLuOPm zoiW;n2#ZizUHtalV|yCJMub!_njrn`Iwid4!Uga1(?rg?6f*zO=I*Zkv0Wo@ohBs& zL<=-adZm*!P-i&7CZN$Pos5cWnm8beu9*P>wiG-;H%x*j#AV$w13lA)u$drs6|h3r zYydcI!Xh1xYVvU<#DXP|4!e<8gBly?2&tnT>M-V3BRiPRE3iFbxt-@{cvJhZ@cC?8 zYmJCHhY7t(u?PlHeNz<;YXu+r2+*<&q5j;Wrw``U>+y*(d#=nZvn=yd8H7GFMN|(ReGy*0nx=bXp1zZ76=!S zAM6$yXAhnf#S#!z=y*imuE9=qaA3P~#jl3eSuX24**6Q}a@r^|g>@Q}S+{D0KXG1Z z%-`IYzpe2|DE!6VJci1GmyxplFi92$xX@4*cS?YsW-)Qe|pevsvjO{EIe;* zSa~^UkYHJ?ZzE~2M68F30j-PDPOEJtVtqTrdK^82&ejG)%gVloBgu9l*0-@(-zLQR zcC}3}*6+|nU1`&^z~aL_>m*^5HqPv%w_K+>1qCJppuG?fx(n@WIaT|2?t~0{B6HEL z+IKeKW5bpx^a0ob`>B#nd~NugVXTnA{~V2RB~uVmlYyeQHB=@u$lN^q01rP@d3i%g~9ZGBrqvM-nH&8d9?lCnmEWS^=9ijeG8`-I|pB6G>Uc(NgL$q4H@ z-vXingu|Ij?}rOxD4)GDHw$k}W}HySp#o$sIhOAJNh*CQPLNDz>H_J@P+;BI8ZeLL zl0$34oJ_b%a)@C*R08uDU_Jnt$5xWD0?dcX!+cP{Z4e&rF_b96e5g9i!=h{$Fdx#x zJfXonA&}FW9F{O2Zb**hk|Q~FOu$?S8*oiatpa^q_Ndo3mfLOg_&r^cDTP>t_ z*EjXeW;WEBtsHk?@Vj}v?airo@OryLthc?q-u8<1c89uGzuv~RE{}^YTatH)!QCZn z(g$+MyEU8i0ZpB*$tHcEXp_DhOP5r_%(@$4K?V*$>D&a;w1C+ZBcoHwStd1y%95HC z&pV}^Ru7fTJ8cc5c<6_6>J$%sN(}uF5B-oB`jmP|KlB-G=rh{T(_-jpG4vz3Z{s^N?=2ss>%=cA0*|(dpli!rfT==G8nF-k5R~ELPWY|*LY4yGm z*ggQ*ev)B(Urv31Vf%o9?R^Z}`vhzsQ18>j_CXD{4{ES|NWk_XCgTqm$oRt|U664t zP+SNPGeFqd^tViPU<2!Ca`Q}X&q>ho;Y{5(5T^Z|^DpEI3q=^HzO6?uWVnL3(Ow#8 z=7V=7rPDUUlDioUlzJlb!Sm|g%m;t`hDB8jmdx+g!?8kmhlum1%dimD{R<-HOw|2f zu~YHHwv6SOFu2JRJMAw%~?&OIui z_b6}2cr|8l6DDHuy@C<&F%9UC381b^{+1~ATMY^Oo|DfdrkclJ6aD#@|AUz#0Qh;? zF*}`CQJb&~9jda_iqm_JoZ38_&)%(WVVa&_+6~8@=G>waju?YP>O~%9dF#-O+9cs| zMe!RI02#`I6Zuo zsw{8kK_Lb3P&e5&z))s+y$ClLm2pbwvV>h5B^@Bzaw2p7r|KsBeOGP9-~Xzi628C9 z6P-E#TzKg}(bE3KUYeTynO{iui z`rsF1UjVW_9)7Yoy{9w3z?BJLD-BlbSLl!R1+^h%wboq~v!{>cv+cdX=|Wwxr%-%< z=I3vPAtv=xPk#QNMNfYI7g4x0zlc5@&ttncjO#*nHe`3O(+j}-*}q9QXD}3R36oFjr>VdV^E_Jh889-HD(( z7tU~ZJ}$fCkEW00|ERFM!3VQ94>7?Tnwgzu{FLy~O-l^3@^v2J&wioWW#KohOkM7* zOR++f&prSM@9YimMX z+D>PF_F$#y&^qubbRb;lKrHoSyqSS0I-qm8;0}CV*MV^MnnZo}+JrTGbs}X=)a5^4 zS68qo{2)>HYQp;3>CEb{D)m4@;Gsr)q|iPCKs0@|VeEHpOrWlp!e7p;eoGtlPZRY^ z8)Iia!WChvnqP;2h;?%!v-%l=##N6b#&Zb<=YA_nA3-wbja#Rh_cvdaS>1oB1^+Uu zyKoPS2L_OW?bYLkt(ES#Q9N##d39zEM8JAB9vmKy?IU%OPkq9h!er|8ILV8|l*`=> ztxaDSoTs4bNyXRQ4clgE5uDo6tgr3>_5fL}?Ht_~?^9z6j*E~U2&EU!(Qd`vg`L5I z#}_sj$s#RnH#o!w^|2U&+lyg;*6qWFrIs%2+VI$7^%KJ^G)R6_1%EHC7aq9r8w}fS z0MIy6HxAQ4lP>0MdtZ}NgkIwpwE@9?BuRi%uE*cH8MM~*{^lG8>Vmrbh>ezsZdjZ z&`;YIU@wGs|$NH=6wFb1rdIf(E8#h z-X~@UbV=_hi?c?0Hx`!{fHl|YDLq8(@|2#Ub^!||9O&4!)}9-9tbNm|FmvrLkd%@* zY>k@ZoJQoqkuv?B7zl$Nq}^R5m3I3}pw$htw5geHP;H*eZh%R4JAe^zTmV(bxGuOw za~y5jYH^@N+9&*lOYzfh*gEuM`iiseD|K`7f&H1f=Y!N?j)F+QJ@Em!vU%FQ{6uo;#8RXq5IwF{)U0&s|UZ`8|)Lh&$5j^wbN&z zQ@S$-g*>bjh@BcK9FnMI=(|E5&haQ;<3*B&Udqx=@q*|$dU_nRQ{(8NDbS7%NKsN7 zDKESt+_8J5jnAzBiZK<3fL%Pq;>hm8$kub;`A`4ymHgY6f*s+89DgtFxEq-)`K5p8 z7n>1Z$n`J2!z#k!+i=s-4}G9F$b&Ba!SLy9YOJSU2(jR45*8$6O3_-zfcGM!>~sh3 zMT_MRL7h%7z%#Lg01zsJH#!^&_zQyx)COQuK*|t_@5tOIC(_d?<>>u~56q|WGk0v_ zJ~|?BgX5v#4ah@Y{Xq0%I5RM*Ox|~FVL~}LpPrv5LJ*J|*~GkM@yK3YdEf{kJWu3f{I~JR%j6*T zy^?kgy|;Aj5N?`Xx(eq+X404cNT#KoKYa7Ry4>QAA^=Htd+#i;_H5tsrYOUUE0PDV zIYO9d?6NRHHoH+AIg?Q|cPZ@eeHk`CRKyx@%+;g-pJFQ&)(bUyrMTHCW#3a zGnA!&1>d%&SNoQ)jTL(pPU&{5SFBKJ~(tQ+nfa8Q63!UCearbeYUCTE@aSQn` z=6d_Is376bL_XUh!17vOoKv{Valug=xwSEXM%0P|~mQDs5lb<#wKbU_;Mu_aU(sc0zT#9uht}#X}N`C1YS_?}bqpg`g zPNlD)wPB+UZqH{oi4uZ&l@Y}!*EtT=p*eZcf{z593i%=R zh*pW3sqx_$7P1$v3F6xBqO+0Wg>;At`7R1}0pb&TFat$!$!e%$AcAg=;%W(;GaTE8 z`y~V|5hk2Sf@L)iq*`js7zw*mX(VLg(nuJwv>r%l#DkGhKJ!^CsJ9$1$Q|7nMK|Pi z?1pz4*|y-)r&T0|;)Y^iiUIr}pzR#P)myO8#6$7hp^_S|f2LE2+NASsbhvj_sEN4Y z9C9iA=5Q8Ki;+J6qDQ31>U%`4smAvC#tj3wp$W(iNo7=21qhHCh6CU}ei#x6aR@4c z^84vRTXNv^LbdFPBqC!G-1Y(~2&dD=Mga_ug3Ed#8`4q9SctHVPlfU^QBHy4W=a7A zDXj_mtP)elB?7%mXONOvW~ts~I6N{c}=pw0qj1OoolpJ2e4lrEUTpgp8; z(f1tGg{g_7Q->!GF3j^WN(f_6109icdh(u$G;0x>+=V1)m5%Fgg^V?a6P?Eo9;4%w z$LEA2;KYISqyw|st+c_k=I!3T-3AGYq1F)##`^|>>?_z&uv6%y1J*QxAU*OT_54zo zxKk#-)Tw>kpnbGx9~Hw`FWm|C9Uf93zOJ`d< z)Uj}Agt~)i^C;W!L6<&m!|fX&5Xv@nnC^B7imSv2B0D3jx9D$R6sKZA89;c8$yJA-eYUpeA-k^c|}& zr7!PI2f>&vh&p2>e`}o_Npome&^Mac({HJz4xOmRyDMW-E8B? zC3_mM!4#flijCXbZ^|#-$PDAw-1Pp%mZ9{``IE8J(dCaar4EJ#A%Au1&RjS$`{q7T zZ26`H98C7yN6L@`2+y(|0gq7XKMKT5p0_yZw1oL&6;D9Lt^=x?~;W^%670TLFW z#8_CP;yAKI7%Rv(mbX4hV6cfSX*w36YkVSoXnx@^u=&6QuET$5Kv|eLHa$NF4Cdp# zl?ZDQl!X-x3KL93X*y|l3+iqI141|z+2NW1=mi`5*3Z5c53ep=D>&S%(PevVs`<`W z;q#w*@|L;N^0*>6`KO-&swmvcsZp`zTTl_Ohe3jh( z$xuh$s{|_i@Cb*f|y%@S89VGlf&=`;V$$m$$v-bUZUTIdIiUu`s}B*?Za(t%m&bDqERN(~l)sQ(t#!OW zrt)?n)`*+A?65n*w@FM*M_2roc$pL%-lh;HubV z=)n)DDeh~+eeOyReu;X!U=nilO{A1V(0h-QUV9&2yEu9j*bZbdvCtxrg*}PDY<85C z7tI(*#v|*kfIUN`F}O~iX4;qaX%{=a5+T>BYlejH!^6);v@f2HWgKW4iU_Bwe;vM) zH>^GB4bi{0?|xcTI%S^~Gbe&vid!4!%$KA$#QvJ;hOol1lqY3896Zs?5M--nYDb14 z-Pv%{<|J5sxm++=X!|&Ld!oSg0iObL1Ku$E5KQHP27Lf>3}xgLGI0pt>$|E!AH=Ni z>O?;%OWjvCFlAXcWv|a}>a7#YuGcDlo9(@+r&69vAz(|Q4SSCG5{9>>p9bM8LC!Gs zOqwLBiY%nylG>5B9=^z=TU5%9eutm^iJeyV)#XzEB>nJPc2P&8tNw0~5zD@Ma=Ed5 zjaw1()p*?{*y*=?Kg~Q-b*Va`7(SniTJKzZ#ag%cN)S#1pVdQ-BJR~k;3`?@ z4`RKuxu10k53~;~BUrRLL$~jOIO>5}&k#YE9>PQ;;;;+EN`vv1AGf?EQI98XI#p6E z1|bBD&{&LQVN?rK45VP_4uzZO$bPJ`&`xcMK*lN7M>pV=1mQvwwj)FRk--S={exTwn=I^^ z#vF7-izyR5v(a|L4&12Xz|AF&2OZn#tpZ~)QyEx!Nv-P~ii~!SshxZK`$wU7CU$oU z8bU+?(w$QG50_$zrC${bK&(}EjHxXOD}f27C?eKv$v3a!;vX1mnifV`s8*7ReV~)c^R;vhsq5fUi8nM2-ck!jV zeRV%hD{tQc6ZF%h84GtwgQXcVl&F<*k({ z{e8FjwZ!tJaXL@=NPOGtsQJIB4NZINpNcGR3E#0VhlqbW)WlUW30u65p}a4A)#6Vo zbuE1z=Wk9sITyu5Vwf^ztyyUOHh$CEY?Cn$rvQU)w<&fuz)0g75Xw~k&= zO~p>2dNBXe9wt;AX(K(GUQ%lZS%!#X9L7MX0~T#0K@n-cBb0~+MeAXR`t+%9!$X_t zS_1l@WhaU)YH@>dl+U4os~x^X5)hRja4R`{CZ zexkno^RaXPkQo0tm%c8#ikrC~T78=7YR2;4kaiuJq8((4 z-j>hq<%G@FWJ8n~%Iw<=zt>d}-$&5_Tom;d-G5g*kp7;5bRx4pMR3CJxEVxa zTsuHy*MkTqcpUX7m@$yBO~St5FW_n=yeDDDWr*aVzh1oRgpc()_>d~`WYjL8vyGsG z!zS+%eDM3X+}w%Gx*rsw!#>d;6Zu{xz#!ilg3Y@aDb4k|7ewN-1Q`UMCg8kl2SlV| zA{C+>1om|=r?0kSUVvEl5&{kp0*3KwjzGW}M!++dG6qilY36(%p`c5Lg6^83dttr= z1ux*}lo16dH25|f;EPQt5h379_izHFFREKs)XkX-Thz@(RJ`yJu0o>X`SUtZXU_i< zfc=GN=KMbhaJv{8uV-Yu#!&3v7vY^b|1u|K&SwZ8n*rP}6WE_3m}kz5r-3r(PclY| zRKOjn$B_DIS@e_gcdmADjYwp){%-;qt$$?(Rsk7X48X!wnj%5~3y%Ht8o&!`>x!xX z8R;z%T#xn$_Xr>N=^#YN2xot}R<9=Te3hW{Mb3;<3ZLQ+M!}6p%>FY$BKtpz=$Czm zqW^b7z3dMK;z?{NBF*_H(pS%lwMppIPNb}MJo@0q5G+S}4mTsNm zxX4z7ll59#pe+$Xrk%(>|@ zcyw-5CdSI)(K(+??UcXUYR01vE|++8VW+^O3m-QFtAIys24LZ88xbM!2$#CjbvQ5J zV63_Wc(jA@==^)!BOuLx*Fi|&(Yc!hcuMi;oQF&OT6hF(ITtq|&}RvOb`9a6ls}jB z5=*=px2=LFw&4d%@jCo~D>mb&Ex)u8KgaUlrkh`hTGrVCAJvbmT>U!Uc#)C~%yE)? z49f3D#v*s5zI1Q&P-{eX(Hu;R|T~YlSqs&+yM`ur} z{)`0|$}+RWwX=S#rmft;te{YmUGB$~afPCbD%ZOhCd9g$%6uig9%Fh+^%Ku@iqv)t z98B{nO8;`Y1?i`de$4U&Cx4Fr{w8&(z&HU>I#Mhk8W0c-2#5v*L<0h%0fuNm${MQ# z(H`*63oU97GtvtiRU{hVSr9gEMIIeIZ_BANM!>T-r{2bBciW2E3$*JMX!jlNF3|2} zoH$l{G$1nKsXe&!mH`M9?jeSH{tMhAd_1m|dxY-OEfyonF7w_4*!57MyKt_V*s2;} zOgW#B83qA7&hW30fmthR0`vX)YIb}2ouSq2^}+0>A#RArAZeX0#vXinNQ;Fm3S&*t ztsgJP70(Q~J=pdR#jq3Vpn=#0NAR`oN2Ba9A>&U+983&PiQxLgEiEoX5on z&RFn=2TF&r6x|JDjNvU~Y652sxKu#)A|M;+g5Ate#1GZh7y+*|Lj=9wN*&;rn`l7f zZ9u=|B#d9W8dx_N62^U`QJ2*vi^>b`53WU>qzev=N-e4|>1$9rp)8GrhGTd!ppZz4 zD=DPdIH;ip*wic4;K5;-(i-&k0qCq~1lzvBU9mBAV2m~E&SSgNWF#$Qu6=^Cu+gCTeG z8gkKst2UD^AIxs0T{mGL9>J)oMKau!$39%uT?>%Cu=iK*Go3)G*bWGN4K=`{t8~-` z?4#o>)hlv?X4jC5%zhOBLobY$cEvma^x|`+8gQJWObv#?IBV*rlc+~kjB(P+t(L1B zzDU(G5v8ccIOrz6>NQ~}r~-KCs9p6&$go;%OaUUG=+ z9>JiaC{@QsM<6S7n+~E>FHh#j^24TMgr(*6Bl5sSvg(LDR82MLd$8SIJri~+s%NSN zBS?~~S`&^DR{{+=8kT~_w5;ivZS_WI?Usi>Jq=p5yo+e+nrKH7Y1L}rHHd9j+*uDV z1o2TY-jaht!F)?cZP{n9}GBgUK z?rFMrN$lC*xx86gJw(30k@?u-`;}t8@#SlbMiPv_fYtbew@cBpozSy(qu+(m5~JURelz$BM!yeXJU;({-gtce zpBSW?@pwfy6Pfcr5JtcA|4~@ADjSc#U7U{0`LA+~ne(U082!%whD^M#oYC*R7*FQ> z9WvKQ&A58OBaMFRx5}N27BjF4M!#Rfc)adEbB};7f1!hrG#-x$@RS<;&X04c4`=iP znw+0cU(HKZzxVLr(C33qCFt|PIx|EH=<{K0#;+M{#)~{c&1QUB2b|2glLCFt{caWX zIXA0ApL2JKxj(nN4Emhwm5JTu(C3`+qsW{S+iaP08*4_Nb3c>lb75H8jKgMN70~C` zu^Io0`wipWdpZb7oAH&E(C3`6e||Xh(bz9+#@lsR1Y5DjqtD7LQQC?4a9H*J>m^wA z{!3;+6|l-}Fs_r?Sho{lv>LyEkKSthzF7YftKN_4V3v9RHi1>|`>SBp`&a6)>itUv z;=FGugH^x$sYv|gkIP}zFaMKF{R{c~TFqGX{?|0D>XumLG6SoCRbB(I@EDtj5GLUO z%;Ibk_R|HDWS*rRt@A(T9^vD^=pZDp>X*4nSoO>Qz@ z1POhY$oIw&0X4J$D(DG@G`b9510$?k+Bf@ykgc_v3EEGNKGib$FppI=7`KnwtDs4d z<-Al&GV5z=Se|efigdp*xGm|GVYjEIZsIze8U{np{Z$__d9T)xOY=lBblp67H})%P zs0&*um4NI9?o|ge+q$Zm1Kcj!zo;;ou38KVxMQZA`N=S0PQr?6UBPBR4S<1BRCuwj4js+nltp`_QQQPT~4Rhy$1@hX7E zQ;U_~1E+)Pjlea(QX@6(o8#bk>2URv-2}VM*8LHk zpV6yv4zY4}HU_;gB7CkQ^qVAjyo>SC>|VTGBn}ZY5bPs>z>zsZ8Q^RM#XG#3 zRf5k7L%8s@V(@TlLh%ls3eR#JmV_T(8k*ki2ldpx={;=HGf8D)eG}3b{nA+>{9>*6 z$%&+jX6J|cSS=4}wxv|XL_~c!t5kt>(XA=f%hSU(I+=Ew!2YNlG86Wq1PS#;d80{oztSBF16Szoogd~m7!B)LiZsy19W`IPC2 zekN;?PX#a1NdJe}9JT%c=Pv8D?a)tb2rqBwTk4v!gBhGM@`6tnc)>!^>bmcbHOnka zX*0AwWf-Kxz$+qa@CvflUSB&Y{4l&?Tu%(o#)_oy6=D$2M^}cxE9gxZjXV6$$SWAG zwZrGHs7gv&FDK0T8VfYC9DzEfcl2PV;l6JHu*@I$NBzUe_nVhTQ(7@0|c zQ1UO7CHgfx;ex*yjf=W#tc#ymfL-J(T8+2BLAYujIM!C@4VB$M=;Gw+<#B4h0&S$L z;7iNvDU!DqPb<1JpepsFbLmwx{lDm|LlnJ)ZJO9NJ-1oCPixq9X^yKkLO0@9ZNyEE zg%x;9ZGOJxFhM_)umV=?hTtuv=V<(;y0R0kD=Itkq+`}CSOXnsFX|f0wlGwUGaFdX zXo3!OC3K)(rBn;j-3Skb$G9R5!NN^DsWP46^l$v6SHYjx##yO}u~HLbr6$HoO^lS97%4R|ol+BDeJ-w7YLHe| zskt+*Q)*s`a)<@rmx(()KeQ47qrx>al^9iQC2mw|;)_So7ArMzq1439N=>X-#Guq5 zKa`sI>Z!P1sfn>tgES~L@zs;@5~U_yP--Noz(ww2U?mt>2?kbzft4U&B?wq}Ihr-V z{|>IDHsJV91HdI!9Hbe5CC*mSsZHe4oi(9jn<9omR`%TH(o2FTy~sR`zc<6x3+Lq2 z20I!8q;ABWk^t3bxFgV0#GyYZJI4}WgM}h|!~_|U<4zngX`qi0wSg6$giv_;sUk$* zf)gg3?nb&eVFG>{PCt>)ZpGP>UZu#pghHr~LB8Lo1Dz)c0qtU)FH*7r!iCdO&B&;OFdf_!F#^KI zlbbjlr8~JmZ9fdMsef-H7&sE$R!m4Rz-kS5nxpWSQPKMV&FI%|A>Cth1J0<~~NYAf>SfVvIG7DbEzDjuuch86yTx@`q7 zQ`%K}-VzUj{eqDMAOEN-INzv2QsAxw2SFK%I3ndBocrKE0FDm&cwH;EtSb6qjK3l; z4#0}MCsYUHFHV)xYW(0)S=j@CAXoMYWDp4Kc-OAi#bG{|2a)Kw2n$fKCksJJ2v&Z$ zrE0>LA4Xv9+Y1&(`RM9M`gLJPkbjW}zhFBqy8WgqD|N9$e0esB>%q#I|4ba;g>9}% zj1~`JL#!)d=LRO~r2XQmiXJ_LT{RcIO;9~kExLVoEhdKUS`L47<78I_F@#_9C;^TM zymZ*C>X-tR1=2t*o4{RVHv{z3)J4ctZI=9Wi%2ygo@^ae^7v{wVMPz-Q~<267QFS6 zmA*XUdr62bnHW7dyrgDS0|%bRsUZ`2Ayli0F7c_Jsg|t}df~owXeOMi&2eB2zk!-I zZfn}NU1Qs}rd`{zn|S(}bWvZcz+VXQkcdBoZD{>}-K?_>K}5d$%JA}K@Gh>u4hABY zlAn-5@^9%(LQ4i`dF!tXb|JF$>>yz}g8yINPyDtm&f;O5#ltv@hjH-Qm*ONI#&xoE zV)eNMc&uisc?W3*;bpfJ(Z&-xE_*h{A?C0(8hzp`3605$4T8ktQMARfbVA6|xOUHY z>q)#=#2`x}KV<2|>ZycYmX4E%vKeWRr4y?s6D6{A;$3O<5rBf>KG`5-lLjH1Gzi(G zLC7WzLN;k&*`z^&>>o*@wnOBz187pB#$$*^m=!$rnvhK=o6yxKBBmhl(d{QMsGD$A z2V@hH_m=*M0ltK19%(y4LSM)wb_nDQG6*$x!0b`(3q)egJ^tb+=mPg*A(l#z6Iu2^ zDzVc?LbVI2q(O+)w^3Dy_d_b-3?0ZIq!R3AK&ymYjc1w*KA}46}Q)s8Wbm!u&tu@6vcpBDVT6NK*c-3SFTpLl-p+8qG zr*vJ;noeaqYdV$fT;o)>le|kxKxCdKdLgs=_?;x-R+tJWUBXyJ`ck^-Bxy-!^g>)W z-EUZ}ny!i$85S?l=)#q{)wC0TEf+`naE(ZXLHkPYS}eW3z*qSYskf{HoE{wBT69KF zE$&sGT679}!?r5)J+;g<-o9Gn}yg?v*Di=Hx$DRT^UWr`W zWv;8WT))q`ZcNwPvGJg=6IQd_hG-%`ER#nT2y2lwm^dF?UJGe(FD!h+6~Mq=Xb(d> zqF_AgP~5*53y-L~c806$VOVSgjo?$g3j4?ODu(AW#$_cRLhZAB3>DV*eOWpMuy`!L z$sJ9{s*CKl*lF4)l5JL>$d48$^2vh3TLo~m4UdGz#`e)WLb!B%Oo{OuMF`S!Y$LEhvjaofG_&ifI5 z#gMME7nk2Fw!$6w95GB64pS6A=Q0@EX?k{;-iR0t4Udej@mTR_lq$gW_qvYS9R2f$ z56{oVrjH&GZ_RL*6=R>Zhiv3;2jGI&nReqM_KrQ_$XI9;?+%9OCS+=$V;~fZ#1T8d zcNQx)#2fBXH}=4xy_1OtZKmh$DZoj4a*C@oy)RIBfm~OWjlkYNkM|hn`O!fh&E$dx z_VF=wxFd#FFk}2!PT?iL!Uyh$#l_^t=g!TqMcPb{?HL~A)AdEe07X3OgO^d18?}zm zc*NU!hKX=oFEUd$8{rA%<5&0SgYJ(O&mVzbul1sj?sXR`m)I5W!{eRey((L!M_5W9 z7^(19hM~tcMsiFUKU*|$5O1FzRqmZWHl?%sV=x0^1rFXR%p z(-+^+0M3j1&Jp4p&NRX0hQjO>ZN6gHw_U?jP6c`|6KtVi=qK=FeDqwQT zB!<86R3*9Kj`xQ{{n3yb>!*k6MHGH%oQjPpuJ|6OSHx*~GGWBb(5tE)lpn(+2%-mLx(082Io-3wlk*o1!JOA;aw;3GHbii&QI6V zyYPiKsZB^adi=144j;H*M*L zaC(R8lbCiqeWDzj!1Gg`H1VQ0)no;mNjTN+#V#*M%2d>@AMuB6Llar$W$M394;0bw zO4n&~m6fhu=fp}kdD|*ppj{p!+E_5n+6C!2S)}a|0D;) z`3?DF`tXtTURbs{HeX%jhCi0EY$FmuuvISca23O;z!-C*yK=0r=|}bqjxNn ziUSrXJ&HU=^p_Eo092(AcdK(S0^zii9wWeo{~AbvmTRg;lC{Cpa>8U3 zsiduaG_n)#Aa=ODc)zkEF&at$kR*KbQ$a-FD@Y7TG06dyEj~}B@7iAilOc%Zr$I}QnX*7-yKb(%IJvkRb+GpP+W#ZVei351CooeZuI5>Os z$izXk9pLa$`H`5sH;o5J(S(QM`$x1d$gU2>CSpe>@uuCJmNEu%b>HMX8u7TO%&4f> z!($pff@uDVq1r=}c-kFrUQo6ejnE13lmJJQ=%Fn;b}md#&eAhb+?)FsAlgo2XyEFo zB0Rk?fp5R|eb2;PAsn4JM&C4Un}Y(gB9Q?RotT@Mb|~I}uK9MXUE^yxChJ&RTY%o) z>BK!00WYe>k57br9D)J4Q|ZRt7ZjqMg-*Pd2`6Fd0q#(CQ(pW~Y5+djNc9G~Wza8! zTyFrz45|s;qr5n7Lm`GDLR62N=OI8l9#pA^QNZP-cWtRrxX+>_g{iv~rkW^B&GN4d zQ@a$VPSP(8fq!L~20>x1e78+T$Ohn*&KUyK17yUpd=Vy0pfL58e`Q#7(CeasQoQIO zPKe4db zS4f6h5f%;7B_$#(I!L!MiZCruD(4k*f{)7BtSL@ycwx<%bSf(=#)H{>J0V3CLbRfjbq0#pVY7$QK!!nTSC&}_kjjsrFy z%@s_cB8kR{!x$n!lZ5+H5{y6|2Re=R4lBf^Z;UJ)SsW#ZJ>6_O#a?rQU z<>n%?3w{oWfx}mj%E%u0sRyw9i<+qiFq!jo_&Fc|&m<5B2RNaNx(2r`C*uMy7Pvi9 zl9y9N54;36Y=3aYyyoG;CIZxFJcdOjx;dAa^lkzt4kB|SZVsSzZp2OSgb`gp!$-}) z$}B@v1vX4Y-#8%WK0pn@35{Fje!^`^1UN;4fR{7oMJCa(;U>rVcqL;SMg*vC-1@*H zrS9SEJAX3{YaO7P;nm5#VM>L)7ZD(^+pz6PAwSn8JHV?In~j5L)0A{WRxKC`&<-Y?g$dh-&|hwfw?XG!zkX%g(V=k zRsez#z)xTWy%n8t6DUA!Wr#|F*2)mI2|_DFR13(g3{kr{2PH#zg$rwpX%y2njYts{ z_E15T<8La4Qv6Ne0~YZ&&$aw!*vW5#8~{gocuAn&{4M!_08SUR00PF4>Y_2=Xs8I# z5U@KU0@OI13q%dnI*5nBe69i1LxwmlKp_Gdv*iK-VH^hm5m|ZFfr7{op&V$42=Sr; zfMkd&#p)Iz-1<&IEzu@OHWs-|c5-f?40aJ1u+Bvyvvus1UZ0t4hmF?O`sLmJBk#$8r)uCVf~?GDK5`Wus-4>&B*qd5sm?adB=5 zdu;8aEKnO)PH7Vh+?MrH7a%W)kQAo05Tk=e%CO|9x0q81ny81@63~^usRbY%e-jAM zG=EbKKsx$n>WdZ2-`suq&Fcl<1h6jZ4zP|hQKi_n6#*I%aZOI4CV+GzKy3i&I3PqU z*?NG0f|G(Gg%Q=S*hGji6%>Q23oxbv?>WG&$}TYW5ewxMYKT}U1(?7R3*`VcL@bm8 z)R2vMD2J#aV5JDqAg~@pfChnWMh@WRYzj&62$D(6jjDinL}{{rcqy7f)Ir8Dfx5Db zxOWDLm}Xg!r$TlT&Kr~_yMni;DJ1)Xm%u5cb%wDP3xI2}!GnYnwcaq6VgZOIT+|yl zNXQU14|XR*)I8Xo2)U_2usa!|2H`d?LvE5{h~x2qnTHa~6CpwnxcJDB4+3049V&0p z)d_M~i3Td4a1X%hDA2{2$%+U99^!iRJTE74e^>|U_ObXvx06v% znYPf8bIQikPIvKffY$?<90i1yz&Zy4JRnv$YzQ&sW_1GrZU}^c3-R(|MFS~32-e%W zeay04;B%CXC&tC<1p=Z1(FNA1p;8e}B8h8YwE~0S!Lm+)0E2<`2?V$XRwfYOE`Z5V z1*pB z0The^ObgwhU=Vl_qVYjn6-nF&@J-Igb%TU)fa`{990x?*q6^HhaKjy^FbQhzFVluxaOY&yd-cKfdjlGaJ33_`={fD^k?szT&gTC-9J}4u9W8QmlkG9%KgVGWu@}Ce=vCe(b}?G z+}*#laAI+$vUI;B(ZU8l?)CIzrhqY%&p+z-;(tzdWU-=8WuK{*=8smEc8{{DR5liq z;|YF|jO1Aj%NU!KBxW9FaB$Gc%B5v2bA#an0q5_w+dp)3%sw*Y3wW5ie73xR9k|A_ z1%36}cKX@z#mXmZ3n!NNveB)5-QLllZ`3pN2Ln9RZK{UKRt6A~8@N^Lp6Sc%oP+0`-~xZr8AnP090>ShchmSzb66 zEiF}8(7V3P8)V`g7G$YxZnB7X`@3_AMB3PemyJo|Ox+91;c6;hd8DQ&(G!n6Qdu0E z$Nt8#ool8d!M|~wCzI|M<4h~ zDpFOtCVEyZ^;CpoygJ>}JX}7tVtG}$(rP4AteN6OaIstbNuEoU*K)a3p<{^isj6a=csIFc{)(m5*p7L!@2c}t%j37nr*HAo%-x_ zS+TVmKX0aLe4`H80UY{<{cI|hOvKU&S&9wD^3oXd4u{xO6w;BnB3A^}4ud2KAJJ5n zdA%dX%?Pfug;aLX7l@{ci7XJ5%8m~Tw1DZ2w=krc@O{By7RerBKHmuc>m3QOv3O!X z^M-~sQuq2pYMbAywP7W^+fYDj@%pbyGxc{e8 zk!~R&7#2UE>vp$}K%dV%4JgH!lnWIO7)_q|xcppCC7=lE=guY$NMuTd34;V;V4YSV5!IYAk0Xza3Y&OyrtR2aASHGP}%VgZ^%R#x;db2G-ncbCUXFb9VFFnT5Ru~w&cZbD8W}%Ei-yH8BuH# zJ&vT%gjgU}0qkTG`BZF>c21ma##grstKst4Y?c%fWZuLxkyu`)HE0Y5(?l94D+?>J zSgQ_8HYIh_e=ubV=~S+e$mI!71^tcn%(z};kFlW+w0!c0cC=_n+0Svne=b@CZv2~5 zNudtQjoA4M5-hvMM>C?!6R%3z6<3&RTV|iiNN*|+w_cXcCArLP*56FOB&2itM?nb? z^LhXv%{&iz8E88hDI^(@yvaUlgQ6XR+E8!-&M3lPftDlc5I24pQHD{(pg476%rTf> zraKKAL=_rj|4^u&`n{m~4ad0)>2|25*F!bUp_)FgLsj~UfT{#hlm0)GG+vOT+2H=Y z@B!;&oyhSL0y^c;|6R-xN_A#{F5~tKm?A+Bga$O3Gho(ylo*a%F*-Sz^pr_=t!JCB z0Kr|HEuzmyxd|f}#w;`Zn^h79LkB-sq~pG;s%@rymqKbNTZO>VK5?M(r6}jbeSSGDPGzgMO$YXJSs)Ca<9h}^N;Fh@CN{kF!WgV8`!0U_*zuv^i!)=Vrh=X)4C+{Z+ zL+=_ag+M2!yJiQd3(Xrv^tQtr^}<)xg=da+aJk0Ua9XZ8M{C#_hRCzCaP^ zVqzSDKf?xA1$aN}+Pll5%H~q<`;MeyJ9jocak(*BJ&)_}U&xj-mm3c?DIkUW>AvQ) zqbc{5Wyj^lR8#4m-pZS|H>bBXQmrI;DTBjA;r3dR@ zoqM}f|Ek*be3sv3@#Jv*Pu0d3Aw0G_4e)5{<6HC+PBxgz==%N2&wW9 zZ4~9;w!o7YEh%LapT52Q2VHIVPyNvLCrZ54`^O)Zw@&XYZ??YLoRfFH|GK=htla(n zi%oea9}e4!o8?E=}Ltl(#C~m(O%75o-CTOVfi**;kf5fO%7P$^$RTcgvo)eqec;{=PZQ zn$x?QG9&BtPI;H=6g0NVOuyl~Tf1rYX?d5-$cBAM_RP_u>fe!l7}#z?(35Y^X>2bbYd6OBoN|D+_s!~;#Qb=-aYwD;!Q3HvR2~w05G70g;r^iOFo*O|icN$Z&Z9pHZ<>FTzlxi7eVYXoDr0rz8U# z9u6>Pv07QIu-X!vJuyE=*{0TV$)!G@>{Rv`e6!H?Z<74Ek=$ey3;kJi$L)X!x!0t6w9H`DjO`twu z@sclgP3=odr09ERpte0cN0A>I-kmrIcP$Q!sVJutSreiXg;)e!r_!sNJX=%jE<=70 zhBP@s{mgp8t^@yM^S}-+kdD{{+(QQ3dwZ=B{%k|DCny*#SK*?PhGTv&O zlebk{uo5t2bLC2Q;-xH>_N|HRo8L#gtJT=M;fT-Ch)+w^9n%h&9<%4u(p%XdSzu|r zL2o}>o8I1(=H5QP^1%mEUs5#;krIT+n<``w@lt(hKRk33MM9o>m~hXzZS3=d{>=S- zWVRWJ3CK{0WXeU6gk#qQZSijwn z3!1^{XSpnJ!3>#Kh#+Q!Cc!*v#-c4U)X7n{nVW5vO%(r+by#?_z0ZCqNqI$NLG53f zrTpU`C+F~|`nd7nHAWOWvBVuJ|2)ySMX_tw!qT{L_VW?N{wAmQH^loZ z)^jj^TVD^0C@qqnC&LVLO>yqhUVl~6uEaoy)JCK?A1Y%(E7oo>7xKB!s*-@4s3%t} z|EMmIhFr0{mlP(<>H&#oR#`K-b_4C$lw5rd^VUN!z3YBTu)4J#vn~E)mzrmNjo|SW zFmsvPFi+#HC#3UHG5(p)N_h9oqqFtp=vq%k`IoITbJDb9#qwVOp<6P7)eowBw=~ta z8sSVCU0-POuHS_vb|wfW-$`SgTKV8bc`M%DlbV=&=Pe0LI$OV$&(cdAudwr9xY2@t z@Fcc24{To@n;@>=4d+en6LKUr!T+AkJ}37~?D_meb;n^yrrEQp2|gSqh2!xC1;@en zea(rvx6cBhn0Qx*0ECbUm*?bdJ$TjyarAsxb|8X_N$*}i-2>T|X}T26l*(Sss`V%20+QTsskH_Ps zAD^yyxrCq^6)0F3t@4-~R`Fy45kQy$@7OCG9n3h(Nd%kOH$lzXlv}-Up&wwVl1jE?L)+N@_CUCN$M&6QvkJh zm{CHB;?|R~;$$BAXi~Qfq@jme$k8#`gl!xFZ2S(H{OeeSA&{oX^n?F8R2XV~45h?C zl%_j`(pCErtanWf3`T0FA`^{j%yTuuf|EmqT|~ID1lv+BxaAyhtL4~$&YKZ=vFzj4 zUvBF_PNX7TT9MU81B)@iryEfbxYj%sS*aUlll8)c6v%P|LIcT*JUK3W2G`-PgW@@B z2nlk%qLeWdrEC^1h_H6o6{4s@d;kS0oOroF=0D=e1W5hv8?0b-isWYYbI}aPaU%=? zbSN!Rg&W1_)??AnVDzay$ZjM0P?PsCcs45I;POSyyXU~i21N->X}JQ;<_T>GTOkCI zCNcOu*e*vPD&VFIqtP&%usrhoiF^#p2^fdBFVbxgKOy0Qv{_Mb%T0a>=#MfH+8d-! zsG1}?IW{Pd#rxToshyiFH$|U|&b7{T)jI90-hXiPeq%@SrSO6KTi>cp?`+OOCs(Jp zPj8#d|k6;q)J8 z>pzft#(Q8A**-l1`>Bzq*9M{NZGWo`wx>CLcT?U&gWW0L&57#b6Buldej^5>xY*tD z9%0X6z&E7BE4EYI#Q6@kd1|HWg_TY9iL#PtH9pdugGa#yD)&_SR&0N*jQp~!+z8XM zR!=H7p}#e%En%QJ?LzQNEWu?gVL;Yyj3v0_0kMQChOk^YFe=!GfL$vxy-IS@N^H0z(&b_uK@zR9t6r|dCy*`wbWyY%p> zxxxDh4q|}o+Z?tpHxGoc@zoXUCft)PeC3v=4h6((VI$kycT8|tv2M9&k$1Hj{6FZD zcd0R5QLnbv_0)>>kI<;@#=4Y#PRi`5-^KC zaUk?srn=+7^VI3&%5Sj&&>dF&WEjv0rcs{=@^i|&R(Hugh{ej==UR=2Uv$8{7+|9-{h>BPS8>`QCpa2-(RezViPxf;BYaHU=jsu`T zK9KiufxJ6phgPOH8*$G29&}k$OHp6rBV9)dpJiHZV{GA;D z!cg*d8MGo&XjlTO{%(`Cz2ON!A@|w0z^J!e;LvKyG}yn&IJCV{k+7*&_RXJl-=M z&~F1j=3JF_WM9S9U#024Ev9cyV5k?!U!f&C;6^oE;Yc;c@pnO8$*)(ik`Mj^t>o9Q zio0Uhfw*W4q&TCdX6I_03{|KIkfnivGkjmao{@Xh_b%Evi#}jgox{cn z0%=SHOv0jGf}?_ux8^i#$s;#3+rgb#v)7pxi257r1rGi%(Yl}1Sn1TtKmY9p@Ym-4 zWZT^7@-xy74mB~iDI~dW?j)+Bx*B(6Y>nG9Wn0GD`m)uko25U=SkGl_=P|jm!Q|Ye zXf-~yZrftk+uL^h&@CAZvpf0Km4DW^`d+5%d+9SD;^P1{J1$7yCp`V?3IX7@Co>N= zGaQ0bwo@y=dQUpcJ4&|dj;S5Dt^De3?)$F%>MhvLq2Uq38T5uwdO+s@sNT6fNaY=- zg6BvsCmkYFgBP+f@6d2t%`6%yYuVW=2;K24FsM zlW4GTC=->bppl$lJ>Ki}qbN^Lgus-?8Z`UI>!on7aR)oAEfR*vK85E*L9lSM5$&h) zO4_DAp@+);v^0piiV|!dM~ddQ2M9#QJ_2y0JN7}@7wy#mvMuEC(~y2ZL~AD}-c;}BL-I;{ z_HaQ8QeSgP zLEuZ}`apZ(x;FqHXhR<*;BRwvN07|o!JZLdRrPj4s5%%(Ck`EuQKF^$fjiGGd%>Jj5}WtuF1M}@Km7@^#(s1Z_r5s z(;Y(J`W*-nG74dS=j8mc((+6d=gmGBVU_urg%d~+F5(u+Jf*@GE2T2>gg5|(1l{K% zIDXc_SepChV-s+;a@-F??CD@J4|*TZB(lWoaBQd#XgPg9me)H^9}Hy*xE<<-zb9VjonRtUB8#>|JLgN zh?P0Qo^8hJKj&BVcMw1~?>`=n@SPh!fB{ujN~1AV-GCr@*qD(XXxDI1JLsq`+Rej_ z(9uEzQSKdOz3Z3(%?x_c>0~G?<*it30;6SYk5^%EG*Bsh^dQs(yqXJkB1a%z9;MrgXegCRB77 z2O1U-!^;+82|D0Fk_m@gDL5*Q5%SQMDbxV^`mmK!pf*Gi!~3Er^89d5TeW>EtJ^g> zQz#ZkA;EWY0Yhii$S=1H;y4AC#HbF0e$^ucFv4?lZ_l8K7w|(@t3c-w8T0sB;7m1Z zw6XRg0B1RN1xZ+LuW`g5`exO^??l;$C}c_!CsWKvDiqUH^`433;&jp#+fQS$m=JQ% zJfqkV7^5AQd}W;he*?bJLx?)dliA{aN;LArj5zK_Wda7Ed0>y5DEY}87s7zbBzDr( z>##%`yL%m0;oUaFHNFu}v1(HvGEMc{%n#7;VmQiW7Lr5H!W*1P3!LT0a_>68Ok%TiIk!Dt3f`~>ML`@>#Oq96dnE;}LeUk{d3pBMIhP?$C z64(jXszTbr{02H8SHMy9DqtF5{Cy5xYT6$K{4}t(W$P)O0C*k5ur>jcva%PcJ&yaZ zdg!FAxLV&SE1zy5jdr;8f_RA2j(4?QQ6mRNPkZan%LokNU?Xca-n-jMhpAvU(JClL zE;Kmo4{8txreRbj>5i#7H!AiHgTUw$G!C-r+Ms<%ZFf{B7*D_|G1nxBUD|$TCoQFh zns7|?G^dBB`ETztH>sOAbXM_9yuW(K1P&6f-iE4=S*81D>NCaj(@RG-HS0f10VIw7 z@Eo}KTy$+~n!}3^q?S?hhBPM|hx#%>wsDInAXA$NcV&d~zKZYzhT<=w;ogn=O|@QB z;f+26t;VCho}0sEfg~=#`E;xQ0yTAg=c8+Ph>|?MDvAH{AGHYBXy6PXiKU9ca88WE zH`~_i@^(}kY(og9{*t_X4rB2Yr=+&84ipUtzu5lxGp(1^2GRXKLKjECjo>43 zN*$xH*6K%z7gldABPaZC%gW8f8+KY?f2*-oydeatfQ8~D!17&+O^SzqWmAtv?On6; zS%fG?JTQ#IVR9cS5>%@pIl7=wBkVXhbSj_2 zV#ajpv56p=fLG}cX(?tUX(nfK5*RsvvSjh`2P4160&uZ0AU|2cvtGRZ4lZmeg99e+ zcnZrb;GhVq28)MqT13ba;g_be+=}&&h{@U;k(Q+uv^T=~U*Cv)v9IJeBNEJgrYb{9X7%TDu+U6BeA$I%x{QOMYics{UE(n7g zLjeN1wuAN=LI#uwhdKz!KcwZ>1JHh>scfp4ib!-g2(@O#0)XLXIJ6FfnF=4J1W_BW z@#ICH{0ThWjwetc>qqipBuPe^2&91F=@bs4O3=+?lUZ?w2oaw3uc@b#0W$&t2VX~S ziw(omf?rj}cO2&7NL5Qq)nlcZ#RXmz3F8#bs57M~m7^tv`&XJBibtrVaNczvY|eSq zXP%f@rs7C^%Y>$JmyReEC$KugT&Q6WjP&<+!=mI+b4!s-G#=sUakuUx>IxkO3F+_% zM34HNjMnO~I3dy%YZp7Ui(Ax-H`Kq#acQPwi0wI$l<{>IR9)?f%5mZ$wkI-q z5H%6_OO>i_xtL7kX*ocfpY6c~8Gw6mmIeZX?U8eIQY#|96cJC2r?^LFJ_{>qTp<}C zglGd}*nmy(gfD+Ltau`qetY>j{QapTLiOSIDy8t{e-lHv5{B0r?tA5D~$V^wTJ3ECzOx1o|8_c*FMZ8btEYS`T6RD&17os z(joEM+K1DPccrzRnTB&VjUDpV!;QaA!`O)YEPJW`6Ja@=tN-^j*>>=7cJKZe)f1Qi ziLg<&nAD`WdYDd#Z?L!dk)YrXv7|YkM6Q{V^2ov>zJ8a&&AndX}PvA4+`eR zx>pmd1}Jq7hBSy|(}Ye+u^cyH^q zm$7P7*{W&?r-%kswuCnO&cnW_%VX0GX4H*>F|E458fFeaDhHMeX))xQNI+dqN3X$_aV8lTnj9B*hj zhaJuEpOxwRIo2d!ao?Gb*}B&LzUELn=pAoshX1s!<7?>G!q;}VjiP_y1lFs~${D2E zatN~~EbzT=Cl@OGpr{~CI-GlzEs-MJ*f1bnyWtb)7%Je;%0)JULMi$SeFUuvmuwV& zAWd=l65mH*qxg&7ILL@VOSDvGk01_kg8cl)@P(tLB~Uwvr9*`pKsMa^4UTxO6B$o# zwgL7WBE6AKVNoY}s1ekTX`W3{mi(g=YWn!qly=3TMu*xbQX)V8-QX;Ll6Sw>=KHC)Ue1oz@`Z1Rq;_L#q@>Cnoi^2^xEaUZTC>R(%AY;xVK-KdN zcGQC-grmjCQ4g$ZeYF&X6F1dhFF-I*7Ax-{|STSDtv=A;#$Sc0CL+VmZ`Bsd&pPd=`PP z-aBuQFw|S3vQ;=`%8i_xY9e>M)|*5PH^-=$`XTiH#=O;%xr~b!XET>iu2{aTzCZU4 zf3;(T?R@rg$vJ869lnS2>8`cm>fy#XhRI%TglDstS3jP~zWWP@^?|Y~15P(nwv{Wg z&FXioy*FXA9Sr<-ZpgY~mEYyE5l+0B35201@l&6qa1w!?fQTo$qY zxz0iQ<5kAOH+-hPrVK*2*CJQ5i!ipb-V zf@T5ObJ`_b8uii-Ss_OAQ%Z-wHJI2p2@{zTMr{o~C|zS{A8cyah3&KZP&lNi;X#$n zd^rDPdJTrry4T1)7Yl-A4u3{J>rUTT>KxAtyUQ4l&e*T(fpnbF1J!`BB>3D*pY;)Y z1;dJ+AwZ5@h^O!fc&3coaO;L#Cq9UyAz<4NERi#&9$50xAu7!cL70qxx`X4mnp>8@xFIB(9K-C@5Ny+Ck|CPKjZAD z4>+~I*YOg?@h6M4B;8ua;^{Miy449){SkcO&KADtTHC@ommI3_jDO^f1Y11uzj}6FIjhtb%>S;0I6#NKzq6o z03rqeV1;)A00e{j3IG7Yl>Q)jqsFxj0GJ8Mg(}-(@el=gP;pRX;-j0mEg<}z&qem_ zGc_@ni=Hso0Q)#|=8><&>Bh?Z^5Wyi7jW)y2~5a8Tq(XD$>D4=M#R_V$j%TZH#2>C zidu6N%cl$OXH#OKJ;ATt70^!IV11aDV|T_DjvZT=mugGLg{#jO#@bh=#SzrMSNYn6 z_B7u9p#poS+Q0(DN8peWDR8TpK0wpHE~l2(6{kRT7-?}p4ulSO&?sl=7%R2_BYA;m z#`qp9iyFu~>WKAp6YESOug}|VnBDBi4YlQu))5_Z*`aEsNIrpYlEx{1ga}udB0ji_ z$+<(!m1C}qyg&X4<`Nl&b;|%O)hC2oHK$D5H@{}b2Zku^+@6XxUhQb_$3HWTaFS&r zKm;F~?bV=1Q;IAN`rA!3ewXNN?#J^t^n#H>xlU}z6er-=Zi|3i&7EKGDqqFxYTKcm zZ;`49Os9e$tu0sCT~pd7bfqjplXPpc^f8>EX3cUCW`kXSOS2>hv}UYxoRb{EM=?1O z2*hjgz5*K%J_bs~3wV_?d4Uba;NA?vR^nJ^b`-J1;W*}_Jcx0yh)Q)imyd!Y;^Zme zMY06=3VB9%gRc&DoGidACMLD7OJ#3VtEVUr z6*#Oy_StnKLpKTxWo=47(o=xgfP^8*joB$C%lGQCW4Ad8pTcoxWt{UtB$jYCz={}P zK($Elh?=vg+@O!Epu$4!6dLv;gxLm%s|;tq-dHq@v8sVWY8+ujH~+e+J6q5`aO&n( zE+QX%-5Y%y5|29Y1n_CmV4hT0KUm0FnDmX^SzI{Il*%V73PWiDiNVehj#WxP4bH+d zr8ZX)TE^{uw8D;^SXyRBDy$4ObrjV#i={^q+Ric;gaD~2Tz{gUFlfgoKO+(c`5=d_ znZn!U+Q#&*GC*EnEfSB5i!7qX5sXiNrGAF5D&u~=8*&xJqcv~*Z6x(62|MU)v$#~H zrCFeEEM+%*twWgVZ+5inc7iS;gv4;UoVn6bgwee|Y}`49n5KR`rd{Pv99cNAOn1Z7 zDPB?Z>+A^yH~99q%kE6@`VU0pc`w{)m(dD!;;qHf5fq-#DACf)9RD0oAFC{262F(;DICWq7jVP(R5-3(Nf`E# z3My1kFG}4c+M$OdL>N&za5V7=TPjmoE-^mp_+q6pN3IWF*5ix#D0K~c1lMA$WNop8 z>mlv>XlY)*PnVYIde}}6>1Iwm9L|Oyd zGD${$j69T##v5ddnXFv;k{MeZC5KN`r-MZQxVcSA<@?Np@F&Z?PO{| zt}Vt~hzN>T$Ho%y%J4*-*P=#}VOjDN`%xOkmqK#K#Sd25rLjTtoUn4az*N;34cc}u zjbZy(aQ=6g+kW-QV|jH}+79;`)rrKaQ~=OokRerdWdB#8(sLc9%|t!qI^LojU}J zE(ua`?ytK diff --git a/sources/LLREAD.~1~ b/sources/LLREAD.~1~ deleted file mode 100644 index 0a378e24..00000000 --- a/sources/LLREAD.~1~ +++ /dev/null @@ -1,1666 +0,0 @@ -(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/LOADFNS.LCOM.~10~ b/sources/LOADFNS.LCOM.~10~ deleted file mode 100644 index 1491348f31d2066fb8eac36661c43f04be61305e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 13466 zcmb_jZ){uFb>|~x$N3{gk{#D!Rr^+{9m=p2K9Zs+HFHQwlu3!=qxnaa9LKao(teC( zQIq60X|Z9=>JDADqIJ4BO`CR2(>6=nl_JG0PJ$9efC9y~58H|%#ft62J`BUYC@Z>d z7-sKx&VBFkF|oH{U4V%9y?gGx=bU@~pJ&f>bS9pR4$s6B(cySWI7v}OuXmyWF!+6s&}Z{LmNy1DjS^^gKBU%vc56w^Qs}Cj!pPO z6KZf!cm|8r%j=cZa!FLz#GvT@A;@n@1-^W-5{-992=l+4FpWzzJgJ%Id1fJdORggdOjZk&!`BTHXS-o%DDoe1VD4 z(BS`$=wFRS(H$7`1_Gj}FRxuJZ;GudNb!LFHa$aPeWU!bO7+SnV~hDtbjQH^3Gdji z%I@G$x50WaQcO&Tx;-i36_M$*h~sxUK9wC3j(Zh{L+R^v>~rA1aIeENW+4h8NyZc1 zo}q5@D!k@40Wp)rMu|*T(4MrHSIme}9$^sVV`jvdScovxj0lOzTs$#7A4$z5P61>b zThRI$NTaaHVnUl563YHPdmWCPvoF$>`=fksegBiXyLiuM^ZnOz&btZIR=%hCXuiLm z$~9*(RC6W8RgbpxoT3!(yGKIw?)2$7hF18^Tl(u2eyn*e62xxf&-DC(rt3+bt?gGD zf12z4GPaQG^~Dx5g<<$L78`tH4i zK4)^*l0Up#f5to^&S-Dn`gMoLH|7;*&HI=Hv*sS5rzved z1zmxn313hZr=nS6X)2o*KEGFxEf7AR|8^^*iz(srj*3isi8?+e(vhq-FVykdo+eGu zX;=yia7^V>rl662`|;{%P-K>p*$9qNp%>QJ?-!Z5cq$W3rKhy%Xhx_$%-WFfhU|}_ zvD+bUA~F^di772PCB}Rr5rI?%z4paE;9y!47y+Lj&shz0tD}N+gt!NDZmFb z(V6UI8m2Xx6{>%npHq=^G%3a*{@^Y|8Ji7t|M%CyikA=`2zfFx9~~lrw?yA(sgA#` zQ8OZ7sEBLij7r6Mze-u!2A#qFvkL=hu!YtUfnIF z^7PBwjvp;Z5xlnTc(XmMF#7xuk0}y6XhQ%3 zo1IBR%6)J~)9L8EwgA@{3fNbu!7&I_Dm^XKQJ=`pr!u)o=$J~9A0wm+@FOk;i3L;yy>bGyP9`P$sxh1f8c%c6L;4B zJY7GoFDS0(78K>v3@n8?-@DTTcz!7EZ9xcY0)qb`T}mpXUcxP86jT0rbx8{PORdZc z8AVDSEtTr3;S-EwTe;?#q=@9&*#E&+ zu5mSgu<@ydFE8-qrFV3pY>mpEZ72N%H-YG5xJvW%t_ltu15o;yv59E;>8`FN}+!27WU9hSd5k!w6vvN@wB^ zhKxag>^M6ZzZ#Gd@Ar~3Fmx+4YLj_5Cl+kWIgxjet9=1P9&MHK!Qz@WI~GkqVWGQO zw(&j{UWYvz5Vm6qU!^x)s_cH-P@*rkCbu2CrbZoa zP1cu z>Dogj^x+T?`bt@R?)U5y%*Nor%z@Hv0mu@2gkt#fNDsuWUj!$U>MFSxiU=*-? zqzWZxNQB1{60V&TNQ}vI`KVC@5Ad~9T51WZj1ZEkLsl0OGAfTJPu)qKJ6K`rwQBAc zM^r2?n4LH-hIN@TuG^@$sm%x)tq3vL1{{+?C-nJWTzeeO$QLTVwb0k6uvo!W@~@GJ zd^c{W98~3tat5x>gfZ1oYi0TjU$#G7zY#MuvzG6v?ABlFP?H;3Ir(kl_j){sbgotV zv`lPT+qXU`0bUG8q&3;TRf#i7=00K0m;ia&*eWi6zfkFo)IVw>e7#j!aRBIqoP2?| z!1I6s4Grv*?<8E8fzY+>oBwWryk_oIf1qX1^z!!2zh(HFKau;^542}~sMCoz-?;N~ zZ2lFw{14u<95c_z<)5@p6_Vj5KXGNYw}en}ncOyCeY8(HM&9g;Vj z9iR-0&sUN6@%gG3=(e3PB9GggYsS5ZBjj0d%(fW7hul{tvi8sb+87A=pq;6ud<^+q z0CvhUBLO6-gh-g)$Z16P?P+gNP8%6FL->)MS`dB&{$voWO$0>;?P;Wz)0%A(DT?h0 zX-OLtS7GgBoF{w;8Y~E3h|c2W);w%e=L;Efk^S_6Hj8SX53Yg;wNv6l$ZoS{h))oa zAQn721S^TNEaRpktT8ea6=>rA%@jq1f^7s5HJMlBAEjUisrXUk%(kMEY6UdlQU*0C zvpR*W1*94=%J_S-5hKB+Y}!btVc9;uuM3v#mHfdKXDf`_QOtz^;OlyCOj&X|&$tjW zd?w#3H3;LY=D6_*Gi+|GN04kDnUz+kaWL|1NqK8F!8VC}_|NrvQjZ(iEUVVza=XTX zIUX>infRK3v+TrM#?SA@ozA`w-!<=Q-n~EOT-?6(gz|$({a^J$Ps>E3{ybB?B9002+Y2dR3v6F%+KmcGp$ZaEB?5$+jw|RkqGVVODc0tWw+4N*k7e$6JuME zR@5Z?RdaA{t`^XG>PPdv49iq}70Y?AIbQU+Ii})w=5)6tC#lHadFK<`w?+|{+&&;6 zFYFWkQ4$_1Tnj&(Hpv|ZK9S1FBp0$MlVt=q(R5lv-3nPpJc)Totzi*-@Y6PnKmyE* zRBV15+aOQoQjW~vsr=M7C@KWfis6x(kCQy7(kKh5X5^%LJA!^_xm5ue^YhshpCF@{ z$t9<wzVm$7f>3%BLmH_#48plwV*ndOdvQ;p;FY4aD33=bSUA|?xHhQ*+txaf4JoO zypm!;DmthV1G^$~ORK7E@zOkj6dC(34q?MfdmK>Z@Fl%c>P9Kp;UIP1c|cZqF1@o9 z`|0YQpP_#6klq_k#NOe9&g}eR)jRv{E3>QP?_SeuM-rEQa<+EBs5Grcc6a_}wd>Mb zZzkq`UjK{A&W~fOdw#MQ|Ic?De@|ic*r-TmV^gsRmm>xIi2V`PE=hAJQzAUgrc)Y9 zF-CQqE{G#RlMc8Gwpv6FMQ|jDMAIW6!xafnvR2(kM4hKU^$$ksha#n~l>GaywIWwp ztCSDWOpC&ODnKD8gJI@_xCVr%nO^2KDoi0)%g5&_50qYraA6Be@LVFcEUXPP;KX-H zh{aum*sGGcu$_HgXE-8lMf0Js?yem!No8l;zE@ISk2mj%>FzV1iXFQFv-l6Q{iWw4 zlWZr5l`@S&NEu5E)mbd5=j(+aM#(jk%g#dM{;ZEGl(%^6T;5xKcmb=k1EuK2TDq;{H-e zd1J15*R1Y7`>EMuZ-TOaO7u7PfCIg-)U_W_@@3d5qi3Pbb2crt6nNQ4@Q@Z$fnFBv zOf`;pyQ*uzj|vgpm>cKRHO!i&pO`qFOXk7nVXVwXr?SVh$=|^c! z$X*2u0C{u}pDnKrr6O^5egPX%XQC5*V2-{?CwvDrkJ-ddV%IiM0oVa&SY94(F4lB~ zml&V6DxLXK?5ne~sPV113`XKW628ggBI!Kb+(afmpF)co#u5qeaP)KzGH!RWi0E#A zYqk*B!kn}2wgs^4tF&S?OLmL|$fZXn!=~_9df8#Dqca&B6Zm4l0~l6p(St2u{Fq=% z(~QCbn_knsTd2``w1TW1+w8m_dntNY=gmx%I_x--a=E&_TQc*%R9f)zcnZAD4pUE` z)EJcu=w)QO{bEeM;O_t!B8WBeYXR2#&dQ%QMPhBab$YNW4JoT(i_QjPZB&OS7Jzoy z?6qWNH?| zN|q9|p^bI#u~E`p7+3%b5s5q&V}A!qctI_=HVJrPrx1_e9NZfQ)F!b=#dApHQqwTp zve7*xy1w}%CAf1FZ8$a=U>zMrPnW>mz}o!d0xP~7J6a83m+j1 zo-etJB?+PRvbn&NZoD?$U<<9c#FLFf*t?x()V|?VF5fy-yDHo8m}98IAuQmLd_18P z23y(*XW_U~aJRJM&VolNh?eGYDwH^_lqe-KxOiP6Q~QMRTnC)&o-pe6F)*!V46qkk z6{35kHfgQ{4({gO*>59oX#9ufmZ>9(z49W=WA@9(Yx$MWwgI2mw2f4yS0Pv!a)i4f_A_~I4DO<$$5EO`3|=4ampJ!RN__q z(0EWT(heE*a2bDUhnSvi4hK*?1fLZJANHc)e;nOB%>Y17TS zwMpGwn0ZEVxYAGO*EF@Z5+FARYmO55Q)_%boyr>;S&T>FIpu2xhJJ1&y(Xy`Q zfVRL0-F%zbqzxF%-M(2@3TInbQt-A4Bd+FQy>UQ0TR79w7MqjW862`$SZHZkXCYgA zLjjO>w)8xL`>$c3d6nJo(+^Vf&uCtz<9W^7`0GmTEp5bE+t$t;D=fBZZ_m{;`4uTx zjktM%jmNCfX#PBezTHkSh4Fw~BP)%c=7*%#Bei=!R>k2l z$eO-)6paByhSsCm3P^H8K49e96rayW=As-pQMc1N*FO$|OeFlM;+x?W^)wM@4o8#7 zUbN(V6z(>H;MqLM??n^AjvIIQ+C>H*%B4m<1Lcu4mPV$g(94Gt1aD_@i3C&RLzZV0 zJ5c_#u}B3&D6q1p7F=jGUt092LBm5)$wWoEEss@EkFYKXbx2udu^cjT+T^JyWhknO z448MNPa;&>&LmP*;c!>0%cTozo0u_}%TcweqBLwpeyWO+jDZ;d!AIMMNO-_WDvY4M z(%Bx=e8~t7Ix#%Toz06P-bii%R$L zX=pHY(RqMRTn5kx5iaeNIIdH<}N#9cQz>+O_*)STD)ouh|pk&`K6>C^0kZsSrQ1-Uf>w zLr)j^SNaqRS}4)jCdd?w3A8oR(Ky)!0c9F|Sl%F45HD1(td-iA)wZZ6J)k3*p>Q4| zhvFd6f0~MUVR$Qa>q_+~m0F&oqDt8H9mY1yey}&v_%KzTY6p#K(|f8+|2*3(i~7y3 zc&~DncKJf(S>Avd(bB(^cyqRSA1c&mZcx4Eow;Lg)c(!kfoAZPQ?{fE;t1%SNky_K zn@Tfjq=y1ud<=@p=Gwz3l!^;i)`}#UVr}_ySqu-0%EdK&*jyUv9;7zLU}bf+d~tbI zEN@%{JKCjW<^vZ>VW*HHsN%Sx_`@+cyW?QUG|Hupl>DTv9yA8>;+PdF8HU^5@O|$? zIOCAK;vw!AX4>?${Fw}DB<80#FapMH(^qLIeoOk%=;O4JXpnE%#?2FMD4#&%X@r{x zquT395>Wga+$gVHsjQYNYZnFT%KXVSnrwrc)yw5Ao!(Y9#m6_Q7;uewOE0tTQw{n; zbwhwr9q1CTP(~GwD3NBPm+6ySsPOID=I-#qVo6XiE8s`)IXpkE1USy!4)!rVg(T8tu10yE@R|~1O*?R@ciL%Pfjp z`tp`2E@M*yt!#E*hIL)OSjLy{kmbQxd7}(@EDO31v0mNWtgKX4D_fQF<^=S5h|w&U zD)f!Kc{TE)mc>^2sVzZs)s2th(?kiozEMGwpagA@-J8?&F}}63RDmhqT7CM2sEm|H zcq95K|H>xl>lXYU!NMG%*>L$X=)=zbq4owB(UB;wR##SlH}tAIet|J03ecVSSY@q< zvnyL9RBP2WFyaEQU0$hvtbBroYhr!1ybKms)*xP&yXiPp^?EZ`*4L{WTlmtxdU0d< zGT0Nivyhh24JmI}SdpwkRB1mj8%IKD(OZdTvrFW#spMiQ27*>h%8x@#WuZXU!=L=~ z8w#grz&@VT%c^M8TMhxt!D9@_E}mXdol5#d7!oQm(Mw{c@oN>EtruoAI3)kcfdNPA zZ)zP%BY31!u_rbYtdHj9(j4mb4Ab##in+WU*W12^ZJRz5jPwsUFeRSuj_AsBI)}P* zJK{PzF$5RkIhD{RBMC{m+1ViU&49%U?(Cak9SZDnS+^Jw=tOypP|9PXBH8Xi;GU-M zX>2U9`cEb(^uso7zV%8L*;qz1zZ%CR+B4}W8lmVZbzA?Mg8n6i@l81XeFextW;Mky z_`|I>51Dt!fQ25|N1qEy8MJe!gU66y*(|VFfJig7l#ZW@W%2KP7RqZ^%Ho(wR;Xb)Q)1a0H!#NtnY{sigI82uT?A4HM#FNSbDwZi@jTp}Ft diff --git a/sources/LOADFNS.~1~ b/sources/LOADFNS.~1~ deleted file mode 100644 index b8b2d446..00000000 --- a/sources/LOADFNS.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 20:14:50" {DSK}local>lde>lispcore>sources>LOADFNS.;2 46579 changes to%: (VARS LOADFNSCOMS) previous date%: "29-Dec-89 17:36:11" {DSK}local>lde>lispcore>sources>LOADFNS.;1) (* ; " Copyright (c) 1983, 1984, 1986, 1987, 1989, 1990 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 SCANDECLARE%: 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 SCANDECLARE%: 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) (* bvm%: "27-Sep-86 15:28") (* ;; "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 (SCANDECLARE%: NIL T) else (SCANDECLARE%: 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]) (SCANDECLARE%: [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%: (SCANDECLARE%: 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 20-Mar-87 18:06 by bvm:") (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.") (for Y in (CDDR X) do [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 ([NEQ (CAR Y) (CAR (SETQ TEM (READ] (ERROR '"filemap does not agree with contents of" (INPUT) T))) (COND ((OR (EQ LDFLG 'EXPRESSIONS) (EQ LDFLG 'GETDEF)) (SCANFILE2 TEM)) (T (DEFINE (LIST TEM)) (SCANFILE2 (CAR TEM] 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 SCANDECLARE%: SCANFILE1 SCANFILE2 TMPSUBFN (LOCALFREEVARS FNADRLST DICT DICT0 ADR) (SPECVARS VARLST) (RETFNS SCANFILE0)) ) (PUTPROPS LOADFNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1987 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1239 19389 (LOADFROM 1249 . 1722) (LOADBLOCK 1724 . 2232) (GETBLOCKDEC 2234 . 3099) ( LOADCOMP 3101 . 4264) (LOADCOMP? 4266 . 4966) (LOADVARS 4968 . 5048) (LOADEFS 5050 . 5194) ( LOADFILEMAP 5196 . 5600) (LOADFNS 5602 . 17674) (LOADFNS-FINDFILE 17676 . 18192) (LOADFNS-MAKELIST 18194 . 19387)) (19390 45960 (LOADFNSCAN 19400 . 19578) (SCANFILE0 19580 . 22987) (SCANCOMPILEDFN 22989 . 25291) (SCANDEFINEQ 25293 . 30591) (SCANEXP 30593 . 35355) (SCANDECLARE%: 35357 . 39548) ( SCANFILE1 39550 . 43221) (SCANFILE2 43223 . 43509) (TMPSUBFN 43511 . 44675) (RETRYSCAN 44677 . 45074) (SCANFILEHELP 45076 . 45958))))) STOP \ No newline at end of file diff --git a/sources/LOADFNS.~7~ b/sources/LOADFNS.~7~ deleted file mode 100644 index d6348593..00000000 --- a/sources/LOADFNS.~7~ +++ /dev/null @@ -1 +0,0 @@ -(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/LOGOW.~2~ b/sources/LOGOW.~2~ deleted file mode 100644 index e0989c8d..00000000 --- a/sources/LOGOW.~2~ +++ /dev/null @@ -1,126 +0,0 @@ -(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/MAIKOETHER.LCOM.~2~ b/sources/MAIKOETHER.LCOM.~2~ deleted file mode 100644 index 2b6c496dfbf6caef123e7dd34a7eec0f37ee7388..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6504 zcmd5>-ESjT6?g1(>9(Xwwyh9bv|J2o?Wi^$f5acVbThWcnMuYo-kEVemVMZ4;@vpw zwIj!AyTW-xyukw$RH;Zv2npx|N|%jVv`9vx4*_Y_eL%oJ(D(EYK=30tSkWxWP!+QlW|s^}EL&nx zMfZA1MMqIIB_<@IGZC6v!h1_9vv4vKTi$HP@;N4C3+YrLkqfg(c&l@7ui0vBvre0Z zS^s-wbLH?#tGU0o)#*0g*zX*4w;KCzR7GV)mn>N_;+KVfl+A=wiCA^B8_Q={GEqoD zS{k!&k+jxp+kMt=w)-qxZEUw1_nDB6i3fLRY&;&vubt)0#G zoyLBj&GdVnLZ3w{n#pe5;CqV;iE7cbM8hf@%Bo}x`}w9}e%RZn*Q_Y(?{yn*HaiE9 z!#4s!VU~)CdoTvHOcXMC>?MpvzL1*fesspCi=>sw-IB!$<=jj}Wf6fn9SNqDi&0i% zX{b3=jUW(ZflrkDW zE`*fOvAlfY@$7*2y(fDXm(SC%7w2ZDA!fUE>9b!BT9?GuD^Cu;6C8+Ke2Gb)ag%Ff=3UO;KtE!0}&yY#a0dJT3xD3aqbhx7D76QH?pXeRVi+WYw=;fzLg?`Az=L_^`1$s9fSY{-KMwB)ufMC@U4EY2_5BV#`MUu;cX%~0Smdqm zzPNJyWsZ-*?ng&|ut&&u|F(XUCj9HO2cI7ODiFz${m=R(E3hK0zrq%5{~)f!6%D(@ z)8QCPXIahAt2K*zj=|t&9pr=?Vd6aF?z5Y)1xQD{S$C`eznJJ{=_CtZy~_6Q@An$_ z*uBR7{^p%Vf$eo#t!DcUyS+(458=k;9CtD7Uav~rkeZ^h0BjWq9OeVF0W@dm<1sy- zVb;wWm^wZsH+jnVMqOsx9s_xQO5V9itIo|$EplS~<%N^b#_s9w4`t=?#ev+q@Z_z@ zER>0b)61db(#lg<$bI$|l0I-{?>-LMe7#BC#KpGpczCHyF-<Gd zxcT4ru*!AGXf-G;@ezugVq$9u% z@e`NUYf=g2QrwVA5()u3Dy@nt1CW5ZlDc9_B^``UyO^V_V{hdegH`*}A#=mziHefI zH~S2s{cLBFW1S)uFc_}4H*d8Xtk+>%-3F>7cI)8w?M4^js?+iWDN@~Qc^8BkhFy5# zCxaJ;(G(CjW!_KbmPfymV z1lWE23_hXKgI7w;)1S*6Zmn0Jv_c>MKrY#JhxCptJw7)mzay6)Pt%Mq;qxp$=MOJa zXeBTrC)~JUTBzWBnhKer!( zVRl4?0v}EXorJQ(>oK0$xu4)!YnWiRp4&bB@dtq)%Js1vWBDsRo@1!eGd{P{8_>Q3 zcBXL`nUrZBevPa0(Fgy2YgF_7hHAcFP|6VyS)LM!1R;r6XUhx9Arvjf%056zFIu9a z#j85Jr5jX&P*BPct0x2zAw3Eo-kgB5j2i>}xeFxc(JD!4a+1JA!p&YhaCx#DZ3>-aDHU>c@$#MW#V@bP{j4PF6j;ZG{T5u4FpLU#KfgBZA-2Es<`SL(63OT=uBurxRRD$auzg<{tce9xn8 zah74MZo(hOpkbIh*ku)%=6 zK@{H)ukcMf)$^zhU$^Ve>+t;-#I3+h3prrq!oQ+>X9MJ(=Y_z1gyYpEAS?~ zFNcn&cV?$HY%6_w9o6p3%g=;)*}U6%ZJ#f|wmR*0W2@Kfv@f%RecX-Rx<54aSS%@ov5yIQa0Bx= zG4ZvRBMwxDJ2;C|vK4Lx{I00#t0*-hK9~A2z;*C+L5jNwy&A#L)4~|PL@$JCoH^|9 zh~q{Xft4@J>r@;7D1D7f_13Uw4;15q9cnlOeW>*cc7Y35xj#9|h_mGN8<*j8&RK?w zKwM0A8F{|lc#AculI$Mr^#Vy; zFIW$fMt2I3*6hVmuluhS#~?%AoS>81xx-#%rA~XlgOh-BVPR_uMdFO{a@VV*J7%v7 z{W0cssEyl>P2A<)=1Kv%?z?z+2FrRcJkKO8uU?!XVR8R{duylLY2&t&Dc{zI+7ReT z)(|RQJmZ}osos|k*a1X4N|Yp3g~KY!dX3hfC@|(kYa~=SH0s3Pt3yiqf|4DauTJ7V z%+Bw^|6635A+lLIHZfenA)A*z9%5k_hrFi?d+`o-xrY7u$>tq2qLw3Y)Zr2L|I0Po z^h2Bd&u(|~scQ@0M33)hBDf~RF{oyGQZJ)SVJJ(og@0zOHrfXbuxP!}?Ys>xb@w_T aDhL~<{{i41ANgD!k9>k20+2*kdjA3N(W3eQ diff --git a/sources/MAIKOLOADUPFNS.LCOM.~1~ b/sources/MAIKOLOADUPFNS.LCOM.~1~ deleted file mode 100644 index d1276f2516185f56d9a48e6ff582f588114a9c67..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8308 zcmcgx-ESM$l^=?-5_`j}WDAbt^}4r=lhQ`Sa`+{Z)jAvwhvHbnx%AA?7E=POV$zXl zMiL}>x5ie$7Q2h0eJIj4Xxi*P1;`e=eUX(I2vA_T4|xy^81+M1*uee;+ZP6XPTSv^ z4}L1f=A{Bf&b@Q)x#ynmdrl~?6jWVVD5#pUpy~zAE|w*EMOs!^P}MEP&{VS=WETxZ z%3D%S8=KBarozO?|Wiy_r_X#_s+emW<}Syl&_SpmLzqBJI@8(41Yts%mTxB7c;SB zCXo)ZHwbO}YYnymtlGxz_N}d*CSx&=f^aw-WR0~w>>C`+iiu1jk%^{*PARf8Z{O^lRsVbhWfD{rVb6ob{ukVZkOXcnuiX8 z8zrSg+@~oPs1eU-${xx^MP8w&l2m3jv&e7Kz!4<2HLPk5(q1-zHqUA|4He>}S$lDf zgyAeVf!G4h;h9>V)6@V26GMZc$2`{+dt+AXKhSF>Py2wdJh&=rl3HQ`S<7Tzep%+_ z>Vl<~lm&3YGMTAZGy*Rw<#2xhz3`r8!pH3I2-rj;{N|-9EsHSs0jIDzVpd8nqYcGo zby%^A#A=)QR>jak@%T)kFf?T+h%4wEa$*~%K<)UP;f~t_H zAtRG%nr`NCSQ38O;ANAAMim2kvI3igIV$=M)!=$b(XGpu+4fHJ?>DyY?y>+WGt??L zq^j{u90ma^`~Rz|c=-!>oyjKyA&rGZmIrfGU6m}A>kB!X!x3gE1;tQwS#f4SnedDt z2vb>UKRPul=&BZ={}9j*D<5ISJQMtY71l=qZPbH(b9|LWm_CeJ97F90*jo}|SmJ^E zTG{Ro&Dpr5yBAg#2uc$6<)a`5YbThd}7xPtgf}v4v+G zt&^P*gl`GLSLUCmZyXUn`1}q}+4V;5fq$db2mprQI(YFPSWJwdarac~q2GaTzwl^( zX^JM_1Z?A@(~XVZf5m1WoTTCU`SbYTss9P!aP#w7@KKB3~qqcHK?%VtO(~Suwo-z=3FDz#~>?3Q!K==Xqrg{#5-kGwJ=ID zvueV<;W6g1%npAdFki30^RaYl)b!H{Vkb*sN86&qs$Q;GVVBBO)PZ(}nxZdTMYb5X zmn5Ml$1F)=$uZN3l)We}y2p05AzU1N0W*;XuwZ3#?TvO5 zVUOL~X~IphH}2lP-P~c@TU%{}+9ChydDAhiP93M!!w%Wg>IB1S?IRhLvc=*IQl>rBg4`Y1!#p+EvTGqWU_MQ700|8MyOVa8G1IUiX;@xdGop~CI|d9*rzs#9z| zJb{0|eE5RA(R;5*Z(e!S_J8s(Mfnu8UU{deJe=v|-znxFP80Mq_BjY5$t!QY=;-KVwMqGz|c4(sc!BycW$rUYL?gDY?1(KDz{^^!*+&)!h-uA zV<;+ld=iKu;95VU-4*K zJ(}))bh>!tSC9O?k4_ekrqrXU-s!^v7zVZ#+h-q1^nY~r&f`xyMer|6oOAdn9sTXx zX}{`!uypP8!{^9hyjyfPE5hBJnVX%)!bbbzXYY5~7irV|znkhvSiBA-5D2`c_^t`5oq1T=jisX_@QZ=WP;eRccHA$oj z$GR4%^aM2djfBW-VY%x?G0CtA5-TQ>IPq*5k_-pW(lN&z$%Mj~)J@F}rzS&kJd6YW zVR(orQY%%%x(OEuk8QF=+5!HA;l%*|K=fV$;>rDK;A$5n)#I+k1C$wMa9*-P~E*+rTv@#mud{JGYwFz3nDMR8-XEqQ#Od zZ&eX_^4cn_E#KVT+t{?>a~pf5wQX3fiT5}n-oqi;7~EH2gQ{^Wm!p(VI41}~AS>l$ z+|rhxU!Gk)y*$5scKO`C5*Q8sUZ&|C2yxB1Q{*K}!XEAj98{zd;y$INGS4ft3B)P* zvC01T{G&+wsqz3Tg;GkMMW)~6M&1M}x&n@%SsX|6<#M(0I}U9=NE}3(rzbMIiCfPo{?WvAZ4JdVmCsOyhdbrcz;mbe*4t8~>*}^;bK<%Fq3~ zjcta%`g`p9ukPRqjJ$rK!B6)-{Az>GlizPO_ywRon&uad{7B8tpLgch=|!ut-f$AN zRsc&!x3O`atw&nDAK#z)8IPRs;|rT%^aH7Tw)7buz6*l0-O%UseAhXv)ceouI^Ijq zQPk;9OWj#M59A#_Pe+W@FLkffU+M5m-RU~R&(TZuU}vQTTI&uE9Qv@be!j!)shPtw zE&eLM*q!-5?C)T+H=AnR;S7+E=jOl4mw4t6Kfdq#jmnpR?Bi=TL+Sg-&zBxQIuh!+ zPO-7+`%&-b9e(xBr}eA%eQ$62-tHaV-T8Gw-$N+dU;As-M5_OB5UJlf7Rw+TZWJe_wc~{rxAc-iK!Z_}nk?bqZ|9yl)ng z#E{ZuewJJ`4eH5GJIs^Bl6VJ{#UJxH{rvBf$Mq;4a*x4p;kW$U;Tgcq^C*u$aTMX; zJb(Uue(q;{z8%K$1N?aJFY#A+aDREGL*SnteB2H|uEN{J6TZU?Fr6y`Fza9eI~>@9 zEgRjte7;E7)*P7r+w1)W?8&+<5PDfc&}1U6Xf}aj3`u}l zb~ZqYgT&jc7>W}=D3Od{(oj(Rlc|h~42D7pATU6tT9%L?(POedpH8Ql$u%|4(rHTV z2_T(H4c>zukXwZcK_(>&mkAk3XsW+U8YI~_MwWuG+`Irf0eLtXLqUh&sP=P11yPAK zk{NE{gc>TqC?F)jS`x9Ng$XE-WEfHv*NS+&|A_s(*+_y}Mb)%g$2+===;OT%hZi%OkhGB&Z!$Qf=(EJzml6gZn3ocB6%6kGcr6>u`VfhHN`9+;AH&?WF3^}l zLf|HKp#WIzo+-?%ev>O?@`@p&vPdM@-L6633sDnUoznutg25Jq)!v4L$pU$P{GKim zsAPkYA(Y3Q2VIj&67bQlhF=5k^8uR2CwNV8mJ8d0+Gz!?}*B$U+$^ULu-|^!YQ#_xUqkpZ_VlP?m4l d<*!f>ol9;qd245T%PEuvnV3$caV|;-{tP)}Scm`s diff --git a/sources/MAIKOLOADUPFNS.LCOM.~2~ b/sources/MAIKOLOADUPFNS.LCOM.~2~ deleted file mode 100644 index a646f2d7f02676f1db0f6c3b969ae2147509d205..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9317 zcmeHNUu;{~c_&3#O`6b?9mO$hPdj0qlrmz1y!_94GB0_r$ZK8RL*IL8i75eA5$Q-Y zEeVpc)@TK6Sh1pS>sAbH(>*L`P_)|sS+#)<1I7)=gIK_*fd+#O4A|3vqI(#Fz3e4u zf9ITg`A=M$0eL8}2oibjx!?KD_y2s~cNA3ACCyN;E@`@YRWp_-nJ>%vWx1e|fM(dL zscTj_K;}(VR%|(^k4@)fOC^!;fgIUsbH-gKL$&=I-9&owc3z+Sa1Jy}s67yxVNFoA;uj_+oo=Z)bgb zx4F2t{nqY!b8oREYs*xpvQjB88CK{E(gHB0ugW{S*e)CB8AdR(s&=VM*4@;SFG$W+~AH`NUor$G0@$e_b28l+~Qi`l^tZlv7 z+#~zjuVhH@mTX$YKgx2RmaGM`v)lZm&F#1LIQ;+(kT_>7l_rryMv7*lpA==01%F=8 zWL|kCPs`P-wpLQFTDELkB%`GKL7fC6L{TkUGc?)OsBtx?)BG|C6H{GMP1VS&VrF51 zcs}Ftc&4)QfiyMiF*M!J{(?YXRP)Pam|RINbF7#r9v@&m8>4_6^E59fr-rKW06_XqdR$N^w#vn>4RlR>)L=JH(K~1d_zEP0c8jVUdwEso9%% zo3C$gHS@4=OfC3pk#H%;*4VOXhg7?$ngdCmV%r_0JtMLdD>%GjYPTGCrca5Ks)l7$ zN;ynMphpe_rkJdi9AoWYfY5i45Ud)?qS;VnT>47OFN$LNQ#zcEvQPA>@nL zrkW--p`9A6-w}H#S6PDLhsu=dOj{}D9=d8HOePaVUP4G!S2Y_?5n@#>TP?w16Rwnb zgpI^w77TY831uf?k}j zN~b0+f)pm<0_AM01a{)Qi;b8?(uz$$qnK7#%W57`AJ&&wVMrhdJl>LZ5`(3hd41VZ z^VCpC%w1v1D}ub6B$^^$oAyBtH!EsIwX0?Ib6+Fyh?A4>4Q71)AY?!Sm94cm+D$}B zvcB6y1SfC2b^CU6m+WkBw-L67lm%r>@`ltTZy46D8)f1I+;W!8O4%kc0#!2x`BRh_ zR*_n^<1EmPy264ZG)JtGY!$^r-*4Jpk7vfU=`&v8KgEYHiYad4?SFo}I(NELY&|-K zKVSanVt%vt{i1mH>f^TWy+14FKg+DXqkg-nKAPz$-!3YTrrCR;%vPwa~~B<$v?Ze)9M{v;csNP`k5(j z@pxK0p6)$3TRiq@$G+Z!XN$*E+VNEH?9nYAEFj8a`@&)~ER%7H^z=G%KRb+r^>Hi#&?GaAtNIXd3PL58mmt=NSl~VIid}qlsVYu ztoI*pEPH!@xjc1vq)k;1eZcl#-N{)T+OLv#CO{f zTM{leF%Cr%C!tx8NhS$bq_aK}ML>~P3W!`0raz2rQ_kZ6K`6j8b7$sjA?%37%!GAu+)oC$!(*#J*QEP!?gTYw(NGTfl$n#D(1!#b?N+d32R9el-e zbVYmk+}5->QmPmn+?#s+JKCKa&oQ(A`p|I$MIBuCbi@(+#TS+zKF`ge)B5S*KZpaV zc<239Zb~11aP%LCKkx(*)h6fxZX)uQ1lI>rOee1Pt(L@+1m{GlY;#Q!h}f#+#Ia0p zCUbp>M@S&e(X2WWfFdkRl9)sS*RPYkdwcuMyX0)peuG%zr15%iNF92b-oI@zZV_J7Q+jT}W{n0bIhtD}s zXT98+x}I!z3h%SsYuRon+cm^u%$BoVQ-sHEkWcu^wO~pY2bwm?z;{4venpV43ff@pQ9Py-Pz?_ zJ>2U3#r>)Oq2W`$@6j+P0nfjbyXQ(DVDRtYCff~u$i}~L1tRzUHoE}``FW_=(~-N= za(9-_@r^okPRJo#zudi2f3-s|cc<$FU&o)T2Rh4+kh-3_D=(LLps8QzP-lAP=%p5Y zjm~#xe#MD$(K|FuweC=Y6;IC0y-css%zuNvS`>KW%ycymz!lFVid~Pv^iGg=FbGm=jrbpL)9Z7{3#E z5U9XJcjo&o_UV$%QPwZq_g0II_OrboHrn6py>s95H|=jeZS{WgB0!)2dwhJBD-LhG z5;G3Wc=!xG$A$Z+Y@(j%v_mw(d8x-bz#Mx*W9;kSo<6Bd804NnU7j8=ya>oSD$&?e z*S-!f(bMnH^WUR$?GQ(Ch=B`pnZ8N`2ZfmqTk`(lgSH>W;rU_ll=tX5uw5(yFzaH1 zoCNfJ&(}H5@6x%VK)ELXU4X;&p;hGRhNJO%(3Q?mj#5u`u$VIqCu~pC)bE{U^7Oc7 zGJ=ZsQ82dOuV*{-8kBkM{)hj?)#y0YWOcs4d_`|@3%^XS41C7Vxqw>>XYXG5>rPhg z2KBzZ6X9UJqu=kqo_RNseZN2;MVOps2!KKL%zy9^%OOuv5{))yxFd`uz$}Nk- z5(gs7YEg)w5-Z8(GU}0AnuU%8%Xx6T_u;~*XdE!AXiHU{(q)$YpcYxuR#9Vx!zogt zw^W;wbUGm>(s3q zC0_CLfggpbMACT`L2fnjDhXgtOfnYbN8yU5ppZ*SAO|F{Rt!nR<0u<-XX6CxBRB-c z)5!@O#-m96kczP55V(<)C#4|-u|!;K8H*w#a42DC1ST$i)OjR6nECZI1*P1Hwi9A+G$Yj}x2MCx&Du!|dc^rnx^w2!az@oaQ zU_Oqd#sLAngQX}sL2?xk=qxUkY?MiP*axWU?-fpkk#n#tIGupp#AytRNV(%BgCvn3 zDzHY-mIRv$wPAlcI;yDX6R;0v4Z;c&pjd~;Xjuq=7~`g>SzH@2 zY&bv@1K~qYk^b^1NOw}KC=%NKatX;k!vl@vO|6WAkw~xymrIGej1Z_KB?(-P_39#N zX?#@#t&%ZBaMSUrG}P)yGnE>DnG~c53qaGr$z9MO9in$=jDA3$kAw>?st^U8V$oV0 z&(cO4i!}vJ9W*6SU|mg=F*&g-%!(ovofiq>0g ztl0nqP)p^HNgC^Q-zouqn7T0GZA>JDXfcjb!O*Ix$P4OtGj;PM;G_h0Of<~>+5W7- z-=|@a?v5e-1jLB0{_jj%l`*^|S9H5?7at+{a;5ycLpj<#+@Qs!4YTTj&c-y%jIm;T zOmqC$fGeiPPFa*P6Rc*Gf?ye4bGwS04N+T9xbW}?&9Z#+COP?v1hE`v5Wj(9T@Ao2 zxHb!nF@=P*>e-2vpu7!$D<7neu%ni5JCp9F8 zdX!E>na>Qh)A+O7L>cM{)ZALS)~|p4HHW_O+O*cMKTnjEBc&rE;J^Te!XbukQ1fFv z8n8i)P{WBUmG}EZP=A+qo#}$Z`53C!zNi9H9M%epwpbJ zi<`8Oixa1R%{tT}c9SF&^1rvU#rx4N`1qVjgsM+=*G7A1L;W(=(Hm(Lk)Xnk5mUvr zo{BztmiYzD8F_<~`33zDwZl`0z_z*VTO?@FikU}ql{NSn5{u}%VTln>d6m459>CBB z3@6`&sS-PkZ0PUr=#YT6K5nCe=m3g=q01#1_}I6OZ}v#WR6s`cGp;@VxOz`o%aCD? znAiz(9JXOt>sT9Q+%<-se1ZM=gGl38EV0Id1@dCt;IPnwaN&r8-90I5d@oy;XpMMZjk#+ii13~mD!TSUNLOADUP>MAIKOLOADUPFNS.;6 32845 - - changes to%: (VARS MAIKOLOADUPFNSCOMS) - (FNS \DISPLAYLINE \10MB.STARTDRIVER \PAGEFAULT \COUNTREALPAGES \MOVEVMEMFILEPAGE - \LOADVMEMPAGE CHECKPAGEMAP \SHOWPAGETABLE \DIRTYBACKGROUND \WRITEDIRTYPAGE - \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES \DOLOCKPAGES \LOCKPAGES - \DONEWPAGE \NEWPAGE \LOCKEDPAGEP \DORECLAIM CL::%%COPY-TIME-STATS SETTIME - \PUP.SETTIME \NS.SETTIME CLOCK CLOCK0 \CLOCK0 \DAYTIME0 DAYTIME \CHECKSUM - \10MB.RESTART.ETHER \10MB.TURNONETHER \10MB.TURNOFFETHER \10MBSENDPACKET - \10MBWATCHER \BITBLTSUB \BLTCHAR FIE) - (FILES LLNSDECLS) - (PROPS (MAIKOLOADUPFNS MAKEFILE-ENVIRONMENT)) - - previous date%: " 5-Apr-89 14:47:33" {ERIS}SUNLOADUP>MAIKOLOADUPFNS.;1) - - -(* " -Copyright (c) 1989 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 TEDITDECLS)) - (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 TEDITDECLS) -) -(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) -) -(PUTPROPS MAIKOLOADUPFNS COPYRIGHT ("ENVOS Corporation" 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2805 32022 (CL::%%COPY-TIME-STATS 2815 . 3011) (CHECKPAGEMAP 3013 . 3131) (CLOCK 3133 - . 3282) (CLOCK0 3284 . 3434) (DAYTIME 3436 . 3587) (SETTIME 3589 . 3863) (\10MB.RESTART.ETHER 3865 . -4023) (\10MB.STARTDRIVER 4025 . 5407) (\10MB.TURNOFFETHER 5409 . 5567) (\10MB.TURNONETHER 5569 . 7562) - (\10MBSENDPACKET 7564 . 9836) (\10MBWATCHER 9838 . 11159) (\BITBLTSUB 11161 . 11583) (\BLTCHAR 11585 - . 11717) (\CHECKSUM 11719 . 11884) (\CLOCK0 11886 . 12037) (\COUNTREALPAGES 12039 . 12158) (\DAYTIME0 - 12160 . 12313) (\DIRTYBACKGROUND 12315 . 12437) (\DISPLAYLINE 12439 . 29688) (\DOLOCKPAGES 29690 . -29808) (\DONEWPAGE 29810 . 29959) (\DORECLAIM 29961 . 30107) (\DOTEMPLOCKPAGES 30109 . 30231) ( -\LOADVMEMPAGE 30233 . 30348) (\LOCKEDPAGEP 30350 . 30466) (\LOCKPAGES 30468 . 30584) ( -\MOVEVMEMFILEPAGE 30586 . 30707) (\NEWPAGE 30709 . 30856) (\NS.SETTIME 30858 . 31136) (\PAGEFAULT -31138 . 31250) (\PUP.SETTIME 31252 . 31531) (\SHOWPAGETABLE 31533 . 31653) (\TEMPUNLOCKPAGES 31655 . -31777) (\UNLOCKPAGES 31779 . 31897) (\WRITEDIRTYPAGE 31899 . 32020))))) -STOP diff --git a/sources/MAIKOLOADUPFNS.~2~ b/sources/MAIKOLOADUPFNS.~2~ deleted file mode 100644 index 859b38c5..00000000 --- a/sources/MAIKOLOADUPFNS.~2~ +++ /dev/null @@ -1,429 +0,0 @@ -(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/NEWPRINTDEF.LCOM.~1~ b/sources/NEWPRINTDEF.LCOM.~1~ deleted file mode 100644 index 5b5874f050caead780f93e944f2eed70a15c3eef..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 18491 zcmbtcYj7Labq01RS*}eQlvKrG82K8pVvsdyy!cG&>=FQlB_0a`AR+ouMH1+M7A?Ax zoHlJTqqa`kKYd7c?AlJ^iPOe;OdAj&XX?B#{nKfGc1C9H@sGCCX@9goN|w`^&eV$g zopbME7a*8Ur_O}9d-p!hJ@>rNS%s3Rc`Kh9o42y5F)KfBi_--&kulGvM9|8YQ^l-R zDg?#pV#-XG&ADt>_ncWuiAZ>)KST>8FshtNiePkNY~jL{v6*QRnVt=YXXD|Z2n8=~ zJp0_*`f62dToFO>o5@nZR3dkL6R9LJ>OyuJKPrMnr!w z79Pu8xH>j7A)?{gSZp>N4~mPl*80O$v4*8`tJU?@FNjEd%zXZHG;Vx+JSeIcu4Aj9 z+Z&mfjZV$Rr-R+lim9>r)r(^@5u9XpVrDiH1#}6!nEFx&Fi{bko{r3jOSKDEKDT;J zT;Dh|D?-a=u_Qd>5_YZxsGqyK`uVku=dUps7#EC8;uK#Pn+ek?;=syuP<-(>3#n{s zHn%*R$}iicFMXPjO&dQ}vX_d9RH+ji(JzklJGe2!;c!IECa3#Dc{7(1C2MwebSYo4 z^2xD6(JrSFy;clAJT9j{=UM<$Dg?p(hP+YF5)>7j{u~4g4dE5S@>TTg3 zZumlx*fb!v^3jrrL}x_KWHf^uW<+VJkSfZ@nHlk9vLsLTXlZFq_D)X=be;n?tg>b2 z#dKJJZSYP^MLOS1MmwKl6N1s2FN+8dowxI45N9MBbD#k*U<7k13+!W9oEA`{Tw0K1 zkQJc`Tue4KA__Q#;5)-5ms9i{Ie3xi4GW^Ub7`wo#-JIINSpbyDY~_Sm=+-ATq<8q z*jYSI@!Im0y5|BeznC+NXRSO2c&MU4bkn|ayo&;*nH129c0`={M6p0zQ|L*C7Oj*o zWdV|fbsXxlun18gL0~zQN(8PbH4ICvge6aeF=qa*O~mK%aX$bWOTP2TeZL z-{(7;V(O5jH?(zp{VDf(tFJON7}RTNeye^izh~5j(v{)e+V0>(cc+;QzgIc^)-!Tc zt0D#;yqDMDSN!J~QC#bxqyAa|WEYO}weVF*<`qO_xn*2SS^gUx>SbD%>nyUL>fiwY`Uy&Bp#+7VrbP7ofM^&eAzt57k@TYmUBUH(;#!m4=)(e zh~UNMiqHnBGHzOm35*`;_wWQuAdp^+$pd#ZSEL)lwT$pJ(e=>{xRS-87!ocHRm|hg zC0{X5trS2jiK3D(&aIPt=_R#@GNm}eMgEijE?-~5y|{}<4SoC9OU+TE+IYAcJ9ev8 ze}FHde5(3&ZP4#CE~oDsIBwt$xAouN^nJtNx33#!VzJnNL<$Ncv8^w!v9Nd#Q_{5r zlfj+6#xJHT1AAXztfu#Fw$ie2PXrnPd#FRuV+VQnM&8e(bdrQj=_CeOhmwd=v_I()Oj90`CzV5&$0XmT z_nDqFj^ir60gbSxxA92&FSWn%G0i``@`j=5uN#{7mXTQ3tby(E z%0O**>u9nZ(!w{M!>Lk zziYKg&${Sq)!*g`lFnPk+_s*nNg8ccPAcx$0PXt{+kKVeHD-r*@9e!c7&wxZ!Z0{90?_dD6eu1#EhMI+;>;7^K6R~X z0gMJuO^DzK?9Lt#9Uv?4322AKsM6$2P^2s!Nl0qX5v*VjSJO(pCT+OLl;i+b7kDu( zmP)Cj^EA_54Ax%QLzRHPmynG@`%0yZ@sJQJrE)5#76X?vuUYde1plaGncKluDTnM(qMvwIWdRc+kSL9YBNpoX76-ZK18F?l~@EbKNDAnV3s zpzG#LjwR!8Bb;-|{(PYEprOs}Ha}JgH9tb6ZwCg>2VOJmfXUQXQ}XuX*48iOnA~`~ z^Cw@;+9&RKI*|N3*3mzzIyMJMAUCI#*TTj|2^%pC_dR}e*V&$Rw+yZ#-p}FRR zxymEM-^*1QEPeQ;7T$f5W%||wmGSz=JlkyzsQGVJf;ZGjb4FDISL&u@pr1HeL<650 z)w$hUn?HNMs=vAUvv*p&!<(DF|4if0u7yAUX86w!FqU%mfah3&H|zlBXqU5gz>g)g zi-xYrv+Xv5-c#P%^!;Pk^WWxl^!^c_9DDpO5F`!f-M7^5t=8IawQ8@`emd8ztzGPE z)h|}Ujb(eFQM3nQ$C_DVLECNIpQ}pE_E^hzq`s>eZ{R{_Yz5Vr$bMP<^ko46XUAn|_~q{*L->d<5HNE>}+Pyo;R^eALZ5A8i?H zbNcpu_Q|b#3}BOwTT_zu&CL%#D+jg|oSF5bw7~gOt*U)$@6F8*{;p-8+Wg>e?c-{| zZu3;G`f}_Trk;_g#T9=zM6}S#>5al1Ufi4Wm>-~_5A1=e{zlc?*{T~vIv}mT_YzNY z)caJw-yYDn?$2Y1x9tJAP;Ib(_TAb~)d@eCs))?s@d0~)NffuzhwbDoHpiXD8K*Jq zG)|~S8-1T?*+Xjg-S0S!TkHA_MyX^CZl1p%_he|i#T;|^rf=I>c1SgTpne^)eXV8R ze|`v8SF4A*UVRn4S{;jOUS{yirOywyT--NK8#Q~_xxH_6Ufu88L+ct{UMHyP-bkoj zwuc#9|4$6l9+o_R(RX6=gHz;&LQ4105s?@Sw>+x>xTov{uC)ElNEFuFK?NC|;OL^A6mi_H`x^L(gVs7a zVpCpA-dP|^*iK&SQgol}%OPXQ|vz=xXj`LDJ!9lAjFf_aW2xr3N#Ra6wM8A+M zh)^b|je|KON@5a6lcdZ505g-|_b$LEc>4)Blng!*Y)MSS!R<@={EAt&b9B53V3cDx zaqIvKmvI}%`U=f)#K10HT}3n(B#Wgu#w_As)AJ&RDei5?V#?_wkB+3GXWQuHqUat8QAUYHdFq(zMWod+ z!fA2x1SWBqV8ZU{3aD@{f++~UvJ-F)c0N!v0-x`!?(^vexqK^Cy&+&1Hb3TP!*9s) z*sPDgYHs&gFk^R{|7}YB`?^(iEWeupORN8-F9Z)=F&kh4rq2tINHK-TbCR(i1r<3w zf)QT7#T8<%<3fZW=RtBJL(ukK96tr{zo+?peYH8ZeAq~n&G!y=y*sG+E%_GqufGvg z$29yflwlLE&9S}Ky6lXZGtkWzG%Hq2(qC<*owxe;jOxqsp%yUwdLwM9J@?*H+kByArcK<)BKUi{g9*h@7=u3Bth(hm0b+V8%MVY;bBP z5IBU#37_nEJJO%GvLJb=r6B%?2y_tJcTj$tm>4LBpqv;YSd^pL9x9@n*Fgw#rnK38 zA+HCoc053?(8TWAofJx8ZslGhAWV)kg>oD}n*!I|>3|^S5hSOc5#jH<+wap6+>o?& zdtLjxL9=g;E&i73e0*J7NWZi5?%M#_OEKT91=_S!)xRxQ2xxF?{u~q!zs>i$$FOZ7 zYGU~PhF>jl!tiTPG}ac>CWG2tYF7->|J1Sv_L`4nK&^Mh6j?(4->$>w6;H-#-Ys34}S^74-1X1 zG74d;;wv1v=?+n<7!0Z44%+UWSBXHHyDXyYELg%FL{U5a*t#pc$1hVqox&m&w-ak8*u2qx?#nGwW}a15|TT%7OPNakFeJzx@0 zL@7lZeF__C<}-T;f!~E_d0#Ei?eE`QQ!aV)pJf!=Z(e@yqSk^quK%?!gb;Angr4dT zL10L8ZxIT(ZFRs#kVXfC#MZR~2W5?*GGLXIIMGCB=Y&zhET-m{DD#9ib&`{ z6lPQTv*k2J63=`>p#f3%rCgpa)+^n3Ki6z%=V0=1(L`Pu4~!ZQ1}WD<=#yB3?WM3u z=@kd*l)*iKO;F0?Iz^t#H)}V{!Q)!`as8!*>e4Q#!>>0Vu^OMYmaV<7FZe0yJ0SBV zUtt`Ub}pB8-hJ=wXRN)(M`|!n5HU7Y#CYpJtefWB3tGJiY7-%t^Z#>rOK z_Vu!Q)efs191@YnVPmLkE??K;&bxnL&Jlz2Zj$3clAxzsk7MKm6D$a5Yc8_CI#h212J zs5{P1URDHD@AzjC0IU472wb(ce@0=JgiTHXG7oC0_VREK+bRcOLU2SyFvM%a?gBP~ zA+;uwIOxIQgQ51)?yHd?CEtP}{KC?sUrP0Mg(+BYljLQ&O@>jPdCAE~w2ddKB9W$& zFAT=f7T+l7e%%v){JycR7flw!Mxfv?)TB|@DrlE{^&L=*SO1eb@oI2{HM(vG24)8u zylHA>Jt)}WW|Gb!3E(E9q4QlWp=xgVKq6cL*3xD^JGC2uB zzN+ayT|%$<$>GwsW5;~>FI|)(?6&DNtfCZ1w|ThJTe`FV0^7RZE=!YFmOq&MU?CM# zY+LBwppQTZh)@%wY?*98gL;uQIgQ&X!wSbV4>wYl+4I=#m~?VH>RYP{SD#JCIf(xjAXWo!BB?n))C)0QU={-&N{|b}O)-lB5wOh3( zZe(7{T;8ppHZ+gefOp<6XRhD3U)z1^jY??y9-}fOH~De>N~U20yi8^tIViIdtPJHP zBuu|Myu&-`%24{9b^ZO@2+5xh*vI#8*@54(k0a%RJfMB5YM2FMFmRV;(HXyX&IjWg(PE|g$zgR-KrwHGW#oYodw_}2tEL84QO8kG>_xD; zrCbxz&5e|Vih(ex0(kd={XijZhxL)lr}_m1y2IlWQ7Efk z;Ih<2*iyNZvrr>`u&lBQZ(eqirnlBLx2e0$KIL3)^{pQX_&90=8~@A~K_}u<_>UZP z`T?l;i$8#=L%SuUGDruFID3L6%ZdLLZu}~$) zNx3HGAq{~uuXW&BT$C1>2TTXNCG@sK^HQQx=0VzN(wl=CUPC31uEe0(XQmsUs0_#` z%%J}W%4+&50jYd*vbS~och>J)-g)mb{{ML8r0zeWZ{Njo&6I-e3E1iHFH|!qN6Y-U zn%(;EAvB=qgcjZM5lmy^P{g=((!Md@V*cDf3zSSB@{$_U&RLI z?(8+kGE^e*>Hj9jWYq#8d^ zzi+8uxYcVfCs`u5G5|`3^_sJ4-%N5_Uy|hTuBCmIul)u7OD|NtL*mZfTc$cn=JBfj zI!ykg)Cu*E^U_~iu##qCO%_4_E*@mm+|o9G_Fo7oA(O$P8L>RLII_v&LPT->j^v6? zcErfk^+e(QbXs#!q#C@^hU4U3=>yl!D}KP^?k1fOc!Y2^0T^m$N#Y@5gBpFx`a#M-q@H<%W%!wKisg(6l13Ejqbe^? zr6BD57+aK4qG*A*WgzAb(v{E~Y z^D3Lyq=ex3e9_L0Gqg(8I5GhERYr6O&I@G}A{~n>6Iun%+omp^x&2MS0bz;b|DlfK zBgg?WuyH@kKfMXF4+aX=+d{~#9sinvDATQ4{lC)Mx%$7mhh{{1vDCUOSx90~(-y4# zHy2iJ)V@!#^;i7-@(oO=mDoi=$;UbN^C~pt{sBTt`Ia8b+ZQp z_UWKZO0|#@LH1O|%LR}r9gS|J!&TvZ9jr&7#~JOwKH)uq?{0dbebR9(yh#lBC-j*P z31=&x$0t29&k>a#18YOsUMLtT9R{ChA4KhbBU_usV6;UX5? zi}=QZf1y?xkTU zJzoDScb5Ojs{R(=JfyaCCWgP3ZSTD4lY&$d4ppi8vu&s(Ii1LASmV3S_Vu%py!=P= z)y#e)*2-$lu`I~<#a6BUAi|-ivVcWOYaW?@=g$6DvTICbH}f|#$E73So}#s&J-+$j z3Chk&8H%7W6}j~0;TZUpsVpYTsXHvZu6S7#WfmQj7)3dPD*^EBi=s=)X}HEJTtF#H zBZyUb4S7gHDOe#j5U-+@9Q!i@igs6UEMf>3boVkHoqAl@%qpSDQVE3^9m`T#gA*+m z;460v0Y8NC0L9aBMv5LuZi_j{IILoh7g{Q4go zQt~xEs>Ea0h#Q7fC*2Yda*uI?OdEnMy@`>(V`=+&0%ljZ~4W%(j9$ z>@yPv()o(*J4ZE^fxRvUR;A&8LJE@(Wi)ui(4O+=YRgiD<+PtD)9*X#xA90;*5$Wy zT;}2bz6|d3TEFL=`P7YEdR?y!>|_zh(BA*y+Y41||7Od&E%jLUHKH0&T_d8uhg~D$ zW}a)JP_vvvWkB6=;0^;2;ebx=gXiXOpA5fu$Gw@D4Ue8#9Wc}hpWo+WIZWzBekr(f8|D(ks4H1I-EKu<PRx&LQ|-W)a@wGuG42FyjN8jNc5UnuRP zHy%|vr{Tt#Dk|WG-z|JU_lB{!uB8Xgy`uORH7-VN(Y0*qbsUmn4laLsuhScJhK+IH zn!#RlODvT;Ep58Du5TSsgLs(m#As;{!&Tq~4}3G*A3}zDak0B!ghH575}{F!0rUq= z@%h!O*Vgb2@y63GY!@zGyMFb;CHmy|+6HRvE?gID*Ttm^SH#6t@!W;07oJ_czIt`- zH}L*xRQO%lxH5Kqb$#{v7oJ-cReY+8PmjlgBknHtl~u9&>lg5m@v2z6CZ5K3%S7Q0 zDt@iDcBv+wySnlDwJJUZ-oWVU>eFji)~*v^v;)fhgaed#`pPwN?Rm_&a80lPc|^G4 zZ}s{m@%%LaR$INgIv(r?6jYbi-pg}yZj&xl)l)bPX);pLEP~PmXuI5ppHKzksWmv5 z*pc-CEUr~vS>?stO_dAgZ0LL=L*$M+0{5Qq(RO0v*=JX;TnCC)uLH?f*RBBlgkUB@ysIz{y&aIyAe=u5B}_hOIJ5QL!b(Lw*D*#guZ&`0@DqU$yM>( z1{2KMmCs#sP;{6l*~8;H;0qkIL%OtLZvlFUoC7vY6a$vQf*zMveXq8Z2c4yg#iauM z;{YopygNTamo=kQ=ZRNySv!&Grxwaz2}+js6)K$NiP==C1pX+e$KaSJQ^hfS7H<{p zJl!XaNSOGBS2{CzO0ic%4XWvM9-KCB!BC0!80)6If@n_MDkz zcIoG375`ApIi(9-2HcG(bMvp|M zqqmqqq@w+d2ZX}}r8Dw>5tr>@J^ZFN&G(X-{UI}%EZaCFu-W}7Y^Yndj057H;Wc0k z9MvUv#zp_(!?}>1gwp@ACX*cov8?hs7II5SF>KT8CHEaZkwxC2%Pt{J0YP}k(uc{% zLzk0M^N`mF4E1BDZXF`eCxz;vZyiy4=zPzB0}(5^1L0{|;c2-G!F15J*ggb&Da?VX zP7Nm)Puf_y_Y0Q!hrMJqaBwP2*e-Hy3ovL5QV|kJxw%(Y;00@p{{Npg__@jeWZ1<) zV0IYY_{UxF6;;PSQ3F0ItZ={x|0vJ$>XqkL;aklhrh`8*`V*%=6ZB`2{!Gyy{8K(N N$PM5ROeikx{vYIP%&hzW0N+!fmEHav?u8u~>$Hzq^a&|Iy zHa0mV!b7VYSFf+FS1V%UnivxQDp5@Tn=f6zv2nS&dh6+{)yjJH8?mv;r*Ce&cw@DC z^XXi&oG$DbuVkm#*kyafP<{4XNWvlFvtBhy3w z59f@1(sPN}%*^zZSgl>W_SNc5accw6_lB3vLQ(h-5Vy0%VR8LN^=oSzFWwXcB*qPi z>CyS>rP0|4h;ViiFajODp9rs!;a&&HCdd^LXA?8M;hdRGilTM)?8s8CY~>Q8`GQ?a z#!Dl@665kkJd-qYOZm}xyO1r8hnmR>K^D*1=0D^ysnsn$~CL?K_RRCwFoqv~z`A#Mc1k=P6% zwsO&;h(u>a)?_q;PP3x8lus7qE>V;xd#boJCwpgR1Uknkzx@=+(TPD}ikz(U=1bfPqArOBrAv!zO&AJYJA&kP+cY5GIox z7I~aPFwH>ZQj(q{2MLMZaX~8Me99`8Flbi9Q)cd5lBkv!GXi{^P3B5*JA=n*UR%CW zbk2kLg{)aPXXP-!#}#?v8<*sG7X?bwNuU+&h&c1P0%W_0b~iS(Xr){+1CT7N<8YUS zMTi3l0?Xl4VsOQ&k(j$K7%t@^q0fl(Vsl?QigyZui*m|`~kN%{0Um*uEdS@b{tFt5R{ z_|GxoxYiR#gS8OYZhV5t!laVID~QRm%OFch%uX;HkWQ82KFzGgoG>*ltSmHtu>?Jy z1@@#o=Yrv8z~;~&elVgD!HdlmU}2Ia zP+F=9j2`aw$pmX4uwIPW12mc|5QRXNVI~uik0{`27KdXCJ8+p0gtgeaY=d{^ra z28=7INBWK%py9Uuhns=#8T|H5!;CK$dXGp&VZ^ufup>XqPEXgUvVoLKsyT=_La4h!+i#+XqF@{Y|jEu-R_aLQ|&b8)H9 z47U{sN2B0zB01?B<5;N&+p^3g8MD8?$4ob3Jh>hr22)J0{oJ^+@JQdv_l=NY?f%$uS;LiwU>OW z8PJPSC~U$?F|`EKNc^FUt;a<0!u(7VnPP3{S>ebe7{n(8%2-EYlDllM5sYHHc_(Id z#OSGV!OY`9O#9biy9E^(g=27L7@*zT3F0P#hGUzeTuAV0gQ%BO^Tsmc%)q* zI>1(t6YvhJQDw=Qp~zS|nvl$%qgWvxo~4y`P5N+=X(<70F7RSTEESUl=V{hm4BpC?0`44T~dVkNi%cr~LVfq1eHYE*~>p zu>Zw}(yIcDvwH{ZRcYMU!LIx&q=sKO-ZFyEGkae)7IvF)uyx~U@O5)G%bIbpF`o6< z{z9nnxS`GMHa}AiH$O$JZ-@FWgx)ahkjdOvQ~LI^*4FQ3ncaB13nyRC*e8R#Kd4^t>^5M`pe~^dQNTra`}n++yZ3piMi(E+47TvKgm`YEPe2m z7T$fHb^6w0<+1u_eA{jHsrhf0hiepWj^4lElVguR27;vHy!(#&z1v#*gI4X0+OOxDwY5t{s;~a00vCc~4s$RYB+3$|Q zFSj;>A=UR<%g~ztd@~qO&p%SXjZa~_^p*1Io%gYGoR7MB|I;mFZBE~Q#6G$8kO6G+ zacfG`zP9R=oAMdmKm_S3TF8aRQvIo@e zyFYRoch~jXj8Z8Y+`RB8=wxWT#T-lcW?9_|~bjha2^Q15%~r2A8QU|l2PwS%hYMoR69J;>k&e`T2Vpp^Mb zffJh_ouV)lTDpskh{WKy<=6}$Jmny8#f>*3QFw0$4PyXGe!v0RPJv&RCu8ox-%+5?n2xbu=dv9s| zf{mzj!av9DW!KVK32x`?xZiI@$IN8Mab{rJ;1PHjnL*6x?e~;~W(MmpKBi|UyPj-% z+7G3gHI3w%hX(fOii=_jEDD2gc@ zO|mir0L)B5-a7!F4AW5P{_AZ(HjDOVe>OVcKik`pU?Wt>*jWk1vhrL z`F~7lf8Vq!j^}qLWNG!k4TKS)D`5jn!1M(H7AYj-0FtpE1s6Fof)W0>g;g6<-V0pl zQO<+r#I1uHy*P0S;Qv4i1bS+7?D?>hCYv7|?0Uan3tI9m{NG?>NFCD%!cm4#yf(-F zTI-54X3ju2d(doHF-d>Dm2%$dKQSt=%7H4f z`+KjsYX*&)0)n=#e-9BWTRTVjA~2L;rknGaVb$fCo(QrWp1uOFbtI7~d?i%73xHwU zY*z#t!&QE;!k)%-ryMj%L@2(j0F$$|D?&N=;gDHG56oD5lnqI32LgxiWp1Y0-VXQX ztPEHlW@!ljLk4;X+qZGP%S;TE!%$8R5hBXjY#$d9<#jN^oGE?wK-eF_s~r!pD=e|M zb~}esnp=g}NC;ElOsO0v&ZfjQcRC=5c_hiHXIKP#9t;L_BsU~)-CNiGq2KJ8V~@Y3 zI-gnB7EcAgi?%B(g!IZxOhH`8<~cMlDSbf6!0f}kF&U=fHrMYs6NNeVbXDNo>cxIm|d!N zgVpBNBZi8U*DoMlO?k3$#}SO%334My91$2`iwSX|VQ7$o+t9XROL2qptwNs%v_=$xIJMIs)R5&b)nxyB@0yJPi)Ce9yO-M8N8oPN z5>o4Utw0$1)AR5XMVu{4DeI2D2t1W`9wSc%{*b&A1-WK~xtuKELIC83E5)7n zKX~`Dwb%Gm4ekjt#-_>`Z~ZUpj`{9_R&N5E{_s~}6ONb9$N&Q{jh(pahL@;R@0%84((PI-uk9{uBzIyfI~}w3D8fStp3b<-M)bM$kRuapW9!w;wh% zrzg}or(o`V#{lN^ydQCkJC}NpIKKnerJ^-ncI5Kq*5&$!%3w53wmP=2m((jat#WWk zL^_9!fsVOMuEm}A|IC~t0q4gn?=S9{>)PTDdiIcLdJ)HHOXqgvQvR}K&RxM8A0S7l zZm!^S!b3VB6;bGDPt`gBV3dM6pI<@VRNFIL*0yH~{e9!%Z22D%BOKUx(jS;BMx*O^ z-zvC5_drW7g2kc;hnxT0$Jr^$ih%2# z_$&foReTmfsOH9JlxB(B6cpg*K`rGjkMPhnIRF!iBPxc%yf*wUU}Gq(*2EMXpAI#UJQ`gFCtAY9sIL2@P$(;BtIMNy&)PaN9h6evNwelVm>~Wq!H^4|*7+k13zA+JiuME-W-UUSu>TFj2-XZ1XBouj7(*wGMUJFvd zrEkZM1@K?0AXV5s(`i@*sgUmRaHqF;fBz-+b$?irF0U+qF!{m4RZPM4(EUjtffNv- zCPueqvH=U~N7mE~s8fO$j%hw=q+4d+V`pH}F7fa;{BeqdaRj-zg@gGU8k2~3;x+e{ z+d(^$54i+NUx4{(kuqT`>E=2Q3#sUVYzdWGkPW3PU&VN%8MhjSl4e

Rnv_aMYm# z(KVGU(1PU6@+2;na7BtsCSrc>oDd@;YL}4_X}aP0di4{K2S);@Wz51?ezc+*jf-W% zb7_Y7;^F2-P*Ia)32nj?AA{k znon&YI`5S;*B{xh?LPljIlTRlQ67++{IY&6-LL^(I=zlND6>3N9>_^Zn16S8hxbzD zfz*5J`iJ+BlD`nLkMG~LLw{f&$CV520qs*2`{e#BE&Jr{)GzC&dFVqQ_6HwM*^l1) zWqH7U^u3>38Mr;aI+1M}1mk{V*2?U^D!ISKJ3l5L8lSpcQ3r>$_G)f>a;O zsFzSGs_$Fsw^bgIgVI|=IL~LxpMOU#xpg9E)+(8WwRA6wZ2e^I7e=PCfDrV<1yf$% zx75^E0L%U>+2(lt3uU4G05_Ndw{$~j>u=ysP-k@f?6R%kO38V22|t0fyk9UUV5SPm zOx9jbmTWNrqt~?_WP;MrDqlQ7H^pvB+L5v-C+}$K=qPGQ&W%dJMr~zBO;e0=%1-JT zHs3GPCi8nas?J;I zkp}MYEZXze&iUYcBU`LYKLxBF3Ml7|w2VA3au0AZy4BRcD{4CmioFO{uas+2hPjcV zP&shtknkDWN6I@Le_a@rf%!BkZUOvz!GE9>w2Wfy@p))N z;LPtGcpevBi_8P21JM$C-PF9)sC4rn{WKZP!3?jVl1Eo+(Cjf&jn9?)WEQ4Bcm!oN zJ>`%zzFFDZI{ruNk1X$ea0UN=rhHNl9?`cSV7+Ea#r7=x^bZ#*X_TX-e_6@weZQ4i zN&TR*dOT!7q+x2AkKv+%=JHCX-LAq4IByUcD&&0GF`%%`<6~3ZP_Ke5D*P;=n$$vZ z2&0_R0_s84LveX0xnES=sqo=iMsjeRzO0qV+pt$`8J$kYz%pU7gnAjwqA_`p2C!Nq zJrwhEu)~`7(yK9@4 z+N%lH$gMPhl4-r>S+#FEv8^vjc6i^?zRhHRiT~0IRqqhLzxR%*j*@<+qQ423KOt>G z{jnKo!(BxnfL6_aYEb`xvX1i9t8N_*2oUYZ@?k{sE$urlU60!`E-8gVF!F9xJu~wsjtaSnvq(y@lXH zt=uOmv7r4twX&|SpD#;ybm!i)3;OmG3yt5kR8MOG{4WQ4J0o8${a7sKj?|UO2(lo)nLYjO0v_5jD|IS>}+2@C)q1_G*?OQH)5@f z)*Q`%eP3?X>W?EGdMX20q_*afx%ckxe=D=bTy`gSJAGUR0^TWF3)(ZAAD^JxS*b&j zG^Qe#?lK&MyfT-?WI1)4hu4uWi=xb;jT56NNANTNzI{=ANp~8avx*Q<>e2{uRenbv znoufMXbt46XeG!0jDVxP6&#Nk$_3rsTt}xK7e2GP&}6NILX5U$sjR`tmJ7(0w}n6) z!gzq;X*(ljkEFE49AM$xbeA^70!rG#5xD&$U2gKp4UW-OCMCz{E;Eco8dj!fICdrebMpTC_=t?T8!oeUBg+J`@XccEhK-)UL*q#f%dBdP%v8Ik=xjEu;e`N%}6 zW;ut-fI9QQZ4MyP0qxR<$jy;HscPUFb_DQXCte+r#icrD6ZQywG8fOFMdB7glq&C@Z`W*P?25Rjt-V$rK#OlRs;!;&yzj))~)#|P4jkSM?_b;Hr z@7l(-(OcE^>aA~FuZjvj)WtW9{%?b_Nc0*rP*xu0-=5-(i4DQ>=q85eH~Rv=FbPyJPIt%?_K z03Ms;kc7f?`Ln!A^ea$b`Ns_H46hIARJXckFn0@N+{;U`qV_-YLfUhK&F09M!P zURm9Xd7G*b%-PWSMuylObp#%r@b!0m5?#C0GRIOvCTSjFxN^bkDr+;u@g_L*u zN9eLRn#?U*1v^Ldq!Dow z-|)&{22V+jYN$aqoz8>P=4}`gyy95a28W=O7vss$@Q?gUhm)<6l}+NyeRWP~eOZ7@ ztBeTB9H_g}Ud$#vhBQ`TG?PSuCMG44@eE1@kVilbN5)X^MZ%8T`4y}Q`N*8bQW#}r zT~(q8Eb!6fTxd#On>&x@0(Ew-2cO2}PYE9s>> zt8O9)JTnu48A%({=aT{=p$wF#FMKNI|5sB=z1Z7DF^0jG1q<x5EMu8Qeb>l2jN}bPIPReSoD7)=L1}%zhag-Yx$_ zA3zm75I^Fd0H%H3bE{y*#`n}mZ?;m&rjtE<6aJ;+>0AhEg6Zj3o)kj$ih z3xeTnM|wYrk@$o*0?gSVS5N_P%kj^@;5)0ff58UQm0#hM68<5eSOURCES>NEWPRINTDEF.;2|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 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* 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) (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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3433 22672 (PRINTDEF 3443 . 4831) (SUPERPRINT 4833 . 5697) (SUPERPRINT0 5699 . 7098) ( SUBPRINT 7100 . 14471) (SUBPRINT1 14473 . 14761) (PRINTPROG 14763 . 15918) (PRINTPROGVARS 15920 . 16105) (PRINTSQ 16107 . 17331) (BACKARROWP 17333 . 17456) (SUBPRINT/ENDLINE 17458 . 17709) (RPARS 17711 . 18031) (FITP 18033 . 19258) (DSFIT1 19260 . 20211) (DSFIT2 20213 . 21698) (SUPERPRINT/SPACE 21700 . 22143) (SUBPRINT/WRAPPERTAIL 22145 . 22670)) (22711 29256 (SUPERPRINT/COMMENT 22721 . 26679) ( SEMI-COLON-COMMENT-P 26681 . 27101) (SUPERPRINT/COMMENT1 27103 . 27906) (SUPERPRINT/COMMENT2 27908 . 29254)) (29468 36866 (CODEWRAPPER.PRETTYPRINT 29478 . 29996) (PROG1.PRETTYPRINT 29998 . 31197) ( CASE.PRETTYPRINT 31199 . 33282) (PROGV.PRETTYPRINT 33284 . 34385) (DO.PRETTYPRINT 34387 . 35773) ( INDENTATION.FROM.HERE 35775 . 35995) (SEQUENTIAL.PRETTYPRINT 35997 . 36864))))) STOP \ No newline at end of file diff --git a/sources/NEWPRINTDEF.~2~ b/sources/NEWPRINTDEF.~2~ deleted file mode 100644 index 5ac5b3e8..00000000 --- a/sources/NEWPRINTDEF.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/PMAP.LCOM.~2~ b/sources/PMAP.LCOM.~2~ deleted file mode 100644 index 5462b6bdd28e02294610493621a00f0e10f3b67a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 15707 zcmbtbdu&_RdB3C-Cv`%Vl9iVerzcA5Qd_O^UQ#c&NO?(7=9MUtAt^_4l_s{OgnC30 zWIJuK4oK4!Yf+$El6Fh7Hib6~EsAcXDQk$GWCS{3kPH~jwiK}c>XJ0wAKL(GMu7oC z>ixd+yrg6_&4QRZ_q^_RzVkhP-*?W9jHE}sT>8+cmrWn?a-(^6U%^d{yGPQj$IF$| z#jIB<^sxJiX?LXTCbKQoNw<_{cCOLSEThvOjg-d!__M2PD+_ZcPe1tN-0afamt%eX51v{%vvzXs)Pscy zx6t<)rG|C&i-M33xDwVs zWcSC}$;$ENC+1GE(<`7gGMX!~&~6m>vemV@r{-7AoZ=*+Z;w5EXzcj%q2U+W)t>}GJeVZG=5%koFB zzxS)l!FpyXxOnAF?_V!l`?_X%_wGIQJ877BZ=`>im8MG|Nl*+qEVF)lXI-3qrM*q` zDNh&D4}1k%)*DJ?(y4J#TTG80b+b&ZILfHHmld$!9mG2U%L;Uct;FmeBIVK^YoW2e zznPVRw32zC+ zkw(#O90Vb4iP`za`H$9Dh^mj!PbEBmEB&3V{f{e3*suuRJd;wBJ9vN&l*&-c31$z7 zt?m_D3JGF8W%l^e@h8~w3R_x%NUpI{XI58N)<_>7Us+>nCTPLT!$q&0&QD5hDrw5G zBVvBR*L0Ccu0aNZiMHAkZXzI9XLUw{iRvA*0Z#m@-p0+D%Kl?t%^bWCY}@#cu`a%r zMAe=RbOx*p9|Inf{XU?1Npl2l^FjNa=+v!Ws_f+L&S)_QF;j zh8@*DFjJ9JBzK^xFh+>n3!}=cmW$x zy?4HPciWF$QMqL`zNt#?y|vib_{IS-g{*Bq*6q|2dr8vk)t~Z-OiO$9*JGa-q_rQb zK9BwD?`JbolLW(QBZdsq29z2?9ZYT96k~&m)wZMe#J@dy&jzEa=YTHt>yk6XMn}>| z877hXp`?ND*GQh6n^q!+9i4#fC9kXdN4X(*fYga3y3I`_xnw6Hr-QUgcZ3V6)aTw1 z{P;+rTr5dRQ-WZ#T;6Bn(SxQOhM@~SMrywR_NK|WgXalc#^0F*h-u???8!_=hS=SCh%}7Zd+vrfl zOr5*_loZkGZ+JoXZ?C?2Og5ocf$X;(=UdBNff3+g%~-!I4-P8E+XH$J?0zG_F*D48 zGnH<@HnmY*9M+?ZvKU=4=F2ywvSVDH$KDy)KIUb-Ea? zdtDnh-(umv@T=7yVOxfVSPKHevTfL9W!8Pxq+i=@GWM!N%+$iEsM@IBxZxqv3K)U% zv}ojjXE?fBt=S{Uz%HW(v}6o8yR{n%A#S^jH@gfMwM)CLskURgwa0g<1rkk&6aCy#1R$ww9mJ*f51`{@bTOB-hsz>f2D-CHO_Pknq(_6f9p?ZlU@kqaRQ$Cxk>vpxdy&+J^ zZKz@(Ax(EApUY0e)$sND9L<;E71~_RKXMCF*Y*l^vZ4!(@7FWN57aZf=j;>2{KiZ5 zL`DG7u&AhgTva63?~+RjC$@i_Ni1Gj;I6D5_RU7t53J{I1tBGNsgwrd9A!fQD{2)3 zz-OvVrV?hyO{LPM5{pOWPz=NGns$5vM7mN^ohUtT?P8UY)7^7tx3MkomPWUI%Ym^*~3)#E3Y=HSIZ+Qa$c zh?WJ-VPdp9!aZ*o%nBynb-61|EC;T?_a^t~a#`A)H{%%JlyW%=h>(=s&gbOY^cad( zcYDGgN`bAIz16nZyXv-b30%Yll=5;%G(1saq&4>*ye^QK=c}3h0ViRRf}=$Od-GV? z0Hn+hOfWH6EHp>Hq*Trq)1c6|NPz^@-q9NW8FL2(!dJevGkKGDc0BC95vB4ZM*J zzCNM)G-_X;SpUX+^=sbP#(hH2WmEe!fdYYE&s{&txnr8ztM8F(X@#s1{uq-0u|=4X z|In^u*f^g-#ZRDG?a2Mk2a>Kl4t8A@hqZGW(*9yl*8x&ULGyWkSK)eAHI^tD;FqQ}?S^Ll}XFo>h+wviX#|Q5NIW8-Ps`uCTCNBt?Cq+me*3 zwWFUXW=PiftCN`hoyBw3F9jh%IVHsX6-m-w*z)z~VEqo+$r6TX=7mgl|I-=q zP(OG5aWNIK^!Nv4BD#rCP0rj7N=0!u(hbi=9|;jPBFA<;f9|)>)W=?fOFZ}6FJhy@ zb(oh}KcHD_aw3LY%uFhuMM|sWEryhZd|M1T z0aY}H!Z8^IXHb*w82xrk$lxHsCg*kHrfBQ8IXdmYY(u0yq>YLV4=rh+U|ddS`@(8J z`qi&MMpJf$x0faI*CKTb0%gfW>Ikq^t9&6hMLTz0SsBe6%B&SjJk}(?@(oCK5Rjzv zp_`OkJ~CT-MA?u`qxOmVgbE_ajeO2LlIBM1?#68sLOt56|0GpTRzT%`?N_<06B}*w zGqpQ2i*LP}eQj*xBjd<|U8sIz{NP2n51B~x1!Gzyuyc~FzOYPNbt4WY;i!c{@C9JX z%X3|5@v^zei6nBCepfq4$pOlOip4ln8z14etrAvTaT`CDy1dn1eTR30ePtN}aiBDl zpUjTr%A_rN>x}#(VJ5duEsB#!$SIY_nM1B@(u*2r+{AIlrpyk@tTYz2>nP+rupk** z9KgsR@~7Ml|83ou$bf;pY`LJ>QQ&cK2Uy{6Vt|M;b;0vCC(bPWbQBc$ zw$!(9Vp%ZZ0$$Q0B+KA^$J2fMXa)HxFXa!dLeYWZ8!KNp*Qt|d< zb$Jf3m8{)v%Dl1hO4Gok3|=D+0(p6wgPc~1Qsz9?fQ1tY!J#WD&?$+z$*Tcj^Hd|;im%bbxsszo90!nFOpS;N$2Q12@GT#<>&dEpc;}bEsDSt1i zQ15y2`di%{b;PLTBrR*xTD*E$dIiyCbI;<{3k%-%S?}qEW0&`gg?SPac!7d<1{15>#^2ck+H(`4PTZ@>8Rp& zqqbj_!wm$plF8P!ny19&|FNqX?4_8|yNvTgD*{vG-zVsn+9oX5MrKU2)f8=0#Noc; zu;HtYKaqNrt>#n&N+s)n0Yu5i*gh|pQntWw)}7$#HMN^JIJmt+ywwV^X}NDHo?g7L z9JIV^KN<7hedn!<9&x?;i3RUk?Tcg7@QcN()9=3Xi;D|m*PdIrNHx?0wHKuJN$B@s z_%28o>z0QBoa+njwU@-q_4(?4^F~*7J8^{z$W^8+C61&D^~S zAEaIbcfs#UNQ$887}K1c0N|q?Dipm5d;W_T*wyZ~CC$YqQ2mXq%p@}fNE;v)0XnDhw~y+S(nT+?du0;~6gNdz<#8&wI?TvdAo6=!lYX1}B z*y2~0f>#oof%mte1_Q`6LP;}j32AYp3}*arEDj6aTtVnlfvybgIi$fV$RJ1kx#gEjc9O36^v#}uebu}adXrkk1I3BD0S010w}w+3R#_&s@R}{ zn1k9y#z3TioyOie2DcE#Z<)nG0;IJHp?6Cap(_Djhm0Ku_!f1BfeO^a&q$U6r|mGh z#CRQQ`t9usopLE12|@;cBvnM3t4*u3Q(JneG(jBCi{fVBDh$`ctBX%BT$z@w;qCPU z(jk%@KUWE>&Ry?suV15s1#rsm_H2NENjt#4EDb8x!TPnZ802WOQW}mh)y?N?S}qbQ zPvH13R@m&}j9Z3$HGx2=NK4*2FomdGUbBIYN?6_5V{YC6!{08Mz+-`s!0nzZ!p;{J z&z=ERd4Kz5*){mwe7G~*uJ+)=pq09Z8G%5>j0@A3RaB2;)f6n0+ODneF>FCGGlpIJ zo&qhjE1z@aQQ-ILNjSM%g#A;ef%g!3e7%`t-7u8A=w0sG_jR6IQgR7h6=(z+Zn})g(O~oG!|~ltJZ*X@uc6KXv7Cw``>=1*&MY&NisoHganJ9ubaG zOJ=U0A;KXH!_10&VUi|St4nc;|Gsb|9f^eAS$fa zE{@FxYx{%hd3^Coda;Dxcu-TDIDw;7lB2(k%s z1Asz&^Tjely4W8pz~pPAiG#-GvvS9m=!Z3xNm?6`gDN6RqKYQ7Ya`1fav^;?1jZkR zYlZUJXJu}g5qwOn6hr&0ekSs0LV8q`x>IN%kNuEGg&U0!oJBBlzdD;B((rjP0)>X+XhlJ-RjjMZ5zKq zH%O)An2;R4O4dP1Wr=RRi;H>&X~uM&j>`qxTNAfx|815_PM7&5axod%=~sZ!g1)>{ zBI9wnmp;3u(&=wF6i-FU1H&Y?ivOF zy~8Xa%prD_7+oQf@(O95$)z98rgKNiIGdq8)f|QewOKZwJA$(@x)W4#C(;ZtkK7$x zw3j9Fr5RXS+bH>D{x0WQI0HB+8MoP$ zygG%J^?#?(Su~5^)_exR5kV5ZI1!W^8G>Wb%aUv0gcs;GoB!Yqk5LkwGKl2gL`?l~ zo|}tGnBM^tk+C`kwB%z`({6Rj5w7DJGdNQ8ayEn1%Yv!_y`l!}6$NMzc#JZrHRsqd z<)%Uw#5#;mkide|r9@xl?_Nl`He7*yH$yiQ(_5%JDUPD)Ghn(-n5q zox*vb_?)NdOPd{^&g{H*pspkCbnN=3qPn=ye3yzf-J5Q@senxucP+72-#tn^33nte zE#i^1g06@0i)$^H&O$pcfECmFwwAf}qjhcP@w-n+C3l)mY(r4Rri#{+PDZWbloR9A zQw0Jw*wB1|k*ZI)sbZe@(MQLvGlqOKU<%rJ7Qq%Bb&Du8U;aeU928YtE;^ISI^ ztJ*^}f!;7-jWMWs0fOjaIt8UDsfdd4Ws!9w4But^mr=|4Z?A4`@Bb7*t zO$YOYghvW_o~B~3uA>eL%LM-j%46YdXCO5pP6F^ z+0@+H%9mJbWes0J9w&PY5HSp#jvst;JB&yeKmGJGKtF@@GlU-;h~X#3LiEWqUPZ}| F{{up;HZBd|Gl6Fh7Hib6~EsAcXDQk$GWCS{3kPH~jwiK}c>XJ0wAKL(GMu7oC z>ixd+x|fuUwOJ5T=bm%V>wEsb@0=S-rpBCX>d=^zNgZ;sV>$Lf-cC%|M^miN$(B-u zj8n|_u?Gq%J6W>hnYQY+ufBf00Q}b)5jx5csR_B(FWL8ejRgXM1U#`wS6B!sh zQe8N;dU9oL{>Z77GixX3PaVlm+WCRcSpDcfddOZ~!zAG_Ge-`G&BGC^kDaDDs-G;g zg=H4#o8$vAjKs#yRI9A`48}Rl%&5D*fq{WOR-QYJRrPu6t;pesc{n`U*S_ha3DU%ET!PnS3S%T42b=bx89dgJ|HUGX>4RsYh} zx14{uV(jZF^VfU#H14KuV&2f;C@ansu_Uo#h+>Hinmg;F?8}`U;+@h=KK0O-!Lt59 zBArT1h}uGG?3kU=I}S6d?q_*yc*o)`pJDjAgGQ{phn8}AkFnTX-`|Mwr!D`TK3QD+ z`5r^p$^}OU`N*jPi$qn)im1}4EQr-*Qg#8v)QhrMA%!~9Cq|-B#NtS)h#Lp7kd9b+ zp?Tq>jTKteN9d;#T)3V7mh1m*ixLy(!4WaOpew`{ORhr( z{IQPulXlD}NN041{ju6zWglPsYtF{4>B|1&Ur8Ul=iEiYL^JKq79&7na>8d7>8i?A6(x;COn240xzg;7hjk65a1II8M~ zv^?n^T%cU0E5)|hR58W%+Lb85DH45ir|AEECy5y++hu=GbMaj!nY$lH=9yhq)nmh}4NBy2Fmexn##7r^B>MJIRGq>T`bpt~{A96^c^QlpvTa zoAcOsyg@^b!qE92C$f^h{ixEjvB$0-s03qL(OyW`{zE?OnXdgZ#!U}r1Qq~+=3`f_8mhTA1-I!~THY_)a7K16{@YJlhak zyiA6^J|G(}lc?73(gt4B0=Z+Q$h z_@m@#Cx;4++Hp|{nBhoL&Xns(capz#yq-KN*{$B~?QDo5pH3Hp4X0=0*4qsH7ksVu zBd}#;gtZ|cY}J%$)0k;wrTDVyNc|A%-d?(-i<(YSC|jQ`~|%?r0xB%BNZg?WGwT!aEPSQPkz zD9E15ko*$lLO8LbCfruTH-q;D6%x6rY{|1i`^IsA|N46JDJO7 zX5ec0em#!n8F+;bo70cng4DIWLY<88V)OfrwCe{NY5r#UNg{spoos%p#4JnrXjnvvjNqh9Gs60wI&`T%P_;UDqB;*RhNV4{Df7fv-n94agmHmATyH;Q&OWsgL3pZ&D z3Bf}Yu7C_}X$HR^#O#n!oz-o3rZ;Zq4tx5%aar0eBi5|P8gU8QAeF&JckmWvYYA{D zvqXWtsON$GK54D|LC!IbR?aP+UAmaQBwISCH#(j@Z~W)PD~?#hW_0_9V*c9r1n;%g z`I>0b(bR)#Y6v6n&~xgMK{lVZH%g+PngQ4(W(y0;MN-tqdJVZ!wRgNHifNKHK6MJ`!@z6Mb;|Vbok#z2N zBqClDp_&}I6Dt+P-IngsT)ZP8qDJIk*9+%=`)p(Ub-2Xyzx^T@6>Pw~L5xX$NMyi!?{HQ8D46d{&IN2zkM0xI`wugYDU+~`=Ct>2wqdi%A^ z>*E_AnLrloV(l9f2QR^W$V8$i7}FvF&PlR*!ZK~uU2$*|j#?N5T>z$>9M^?5FPoj3 zj3a01b+yBk9H18%p~j7ruY&GIVEy9cF308^rFTYw{V=XDYL^eD~(O<+6y@kY)Hly2hh`x{3&DjeG&@4)+*qsV28DIrGG zRw}@||1i)!R(jk*rW#ZVqfv|?P{io}EH3p*}a<2Y~B%`g$7 z8R;s~%(I+~((XKvf9{l)3bZ*Jt%T=g(p1SdN zZ&w2`Dmh8R*ff@|U6Ecvyt27x>Dt9bXZxIUcJcU?J>x;1!~|ZT;9dC}gyyqT`6Nz< z5zR-yc`}A7eQbh53NW~_y6O5mb4Yt`LKNy zKkm_to3&Sq^Dx{a(2CzCG78CQ*N1}byPS-E3v8DWto`1*HiiDk3DN1OqIa{tUzLMR z1hbOJ#`U_R#O43N)iii1Ms%*={Ll!&6nXgs-BN7Ac1>i)G+EuE=@xMWt|;u%RmY!5 zJ<3-1R0K*T>wp17$wSxyC!0{Vz@@A`$RVQy-Kvz3bAR}Z!4N!y148&oa;Xs zciwyV?Mn_(z4nPk=X(8%5E#SH;A}1${9!1qdse*^0@EYy>R0FH5l>`}EUGMy> z*zu-uRl;DMmP7b2=4~BXIwU12-jPL8ibEG#!0fvl9S(#G!n_nMD42vS{}+|DWCg%qRF>X8_sGPc~w#^5!gUe7J1|v}F8mc?L(9Up412TUP zl-SajTQJp^U$f8;z@j%F2);v4slX^HK1{(7fUmSigRpanv|SLF)CNadp5SV5rz%y* z+8H47Nt><_4ezLe(QJDwssMV_J?f7}m6>Cdx@qqLl-*v1tWH~1WLQDWVeKL#SfqfR zuD!Kf+(Hjgx8^_*WRws zDVNd_KV+BCYmwWXIzWpj+Zm%DZ4w2;e`ASf| z-1EWq`gJ;30HwTc&jk3FYX{hurD5ed*q{~`7dg6FDGf)Mdd=f&TCe440$ARQ6()Nm zZI>WlEg%po(w4XOO(QCo*KDAp5>|Kjxi@cs;qR10;ITkJ;C9CrVdqPVX3qkve6anB zeAWN_La;m7sd(^V&`QI>h(MrX#KoB_Dym1aY8n9UY!^zzy?4LRfypNX0_nSW63q#3^&Xt~hU*owYb$8KXv7Cw``>=1*+(3o#~=x)0I>6_lR(mS~B2|Miei(Jw*Bz7cx@FC79B_KvNxL8H za5j$Y6Y?GN91?v$qY}k{V$Xk*GQ2&M;hkw@q{pxQ-NeD;wf`!YeWJp6{nB{ZU*GRn z&l5{mn=g&~FHJ1H{W`9<`7e%F?$sCIz6A-VGm7@}4wFLcQei5aK#)z48vqpIn=6zU z(#76b0VZD?O&m0~o|RjkL_e&lOwyW&98?im5><3FyC$+sA{R2SLtwmNxK=2SeOBg{ zxq^>@m11b0HONFBO-PT5Qg;dstEDM*X$wwxu)r_ys(?Wy>G^#gx)31G9$ZI(Mc+pkFT_%}BsTv7 zp=Ucz=vgU~Oj)U^1u;C=Re!H3ALLVdVAVg)9kQVDu>%8 zDY{}U=yelq{%cwT%y@kJr*<6S`3Zj`PT}{7PMp+AV`BFP1!3Y>dL)JX7glXq>}vjn zYV|d0)6)NKb=li>Tcy4}Tqf+BTtUgl_(W0*Fx3sZv2W9b6fL)UwMd(;-=G_$QgYmo z9KK4{K}ltaZoP|(dM?t8=sF#j3$nK-ZWaGcmW|Jp_$6{N7}@DpfzkY)yi+XgaJiR0 zyROpdbX?s@mw!JOOD|oOWX8Qv@peO;MT>im1Q?uO@S2#o<)B_$Kq62My#5;jT|k_3kKgJN8wYgPFaYQsW(i>q zk*mn)3XzmoNb_tq^++a_JzB!q4DnP`7#7rInOycL&c^6YP|==DF~mHQJGf{sOXN$_ zu(Y`O&Oem!4Cqk^oYO!f^0?ruRRTOo?9joWeGTfjnBM*_r&=%#I4B9X*%QAujh6L) zqtID2i{JKq2Eh@rBz$oqR_@9W9E0AL+yh^Do^G>w58m(?Cc!CTk^Gy8=^rj|b5RNM zJ76L*R>y#bd~9jjtxh?@bzEZxMG8*VWRQAUP&HVur~!FJ0U87vqm0$M=hzYDrcg_e zr|(gG8wBLkhp%PmCSTv@aYz@+7gD9tOaga^FWC)#)1TxTIrr|t3_^dfXLlZ)FK zK1!gy({A_e+Gf&A;Sx7?X8Gjlg_UIp7e2hv_X;6hWqbpMZ{J9^0?AY&V;55R6bv^w zONm^5#w7`-L{WeKkRZPH(>mz`vz@2DI}fkqM`$3QO4>?L=Sj+W*uTtk-L$W256}Rb zVZs`tQ|kuAq6?`6l%l92D#o`(){T%qq!lVrq`aQcbfQYz_i!vBtpJpWU$Jqr_*y8> zaOZ$-OELbN$L!8PaUhq6o;X>&SR`?BvJL=B>jFXnSR1Je1AH5>xj6WSmKIx;)79Bf z2n)k_WVQI0q_j>r95UCcYr879^=8D8S-kD`M^(!RuI_ux1)o}Uh8@tIMOW06a?t9X zSH5*iyS8J=x@{L*!8hbe4M%Oii!|-lPf5$oBvG}KFa<)NmePZ>SDQYLR3a^y4&n(3 z59M<_O~qhcMWOxgSjIkzgAe&bVjz2l0%9z{8rcVJvdYrqxpna7VhXovXt$~mO@_R3 zkqwYguz(tL2nNkmedley3.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/PRETTY.LCOM.~6~ b/sources/PRETTY.LCOM.~6~ deleted file mode 100644 index 0e727c762c855adf59011dd3b187efd7074ccd7e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 30039 zcmeHwdvKfAl^-6I9n5d>>u5o*8ZdIPTC!B+U^d$ zyPerS#_8{zbMNC&aIkxTDo7$%Ih|60P;@wPWn(xT z3{9wT=yYWKbSM~51A&$GOIPY^t5vmrSp`)0KTMToe(R%iS64T#-g9yJ%G&bfdvfb5 z%WL;sTCJ|FJ{B1nyJxL_^~%cn#_By+*ROA^tX{omwwNxL7e_u49YhT=-Apj3LKCNh zXek^}7dBSycDh$Tab@G`iPLJfh|yrIAyr4yd9Gif0X21fZB3OPL-p5`yW1lpBLP)i zzJ|_r4kr{l9SQ~Be9XaEK)s_Os_wDqSSX@aYRi`&UcIWWtz#quQ-zWd2r8QRLL#3Y98})S zevii+f7pZn-c3Kfclt8h{@>p8y!IfyR-fDS4)NEWCm;DVC-K`leT?((d+4z@xbH#w z+elWui(XFWd|7$U`n;S?(tKY2Td(!&|9+C&J}^`3zyDJ+CtvXSw||!JWh|@xyKO)_3;nSRxtLW$A^=dap?(r<#n3mCJYW)jb!;M%*`nR(+ z!lm9t`7Zt6OTXgJ=Q2L7;14p>HL0qV;T*Ld&p;$RDidv!J)|O`adp0svD4dMA^#YIjB-thbkPMPRiZRASEAgbVY`xWFs!J$ zL|KK#WAMEmoy~u7{$d>cqQMXpDNL z8|5!0q+#40P3uA+8pb%4E#|qsV9a!6BG%FJcw|?-qcLi6bX27(*?c9DEvv|wX$Yft z@>AWeR}e{sC&ttOO~#Z}%!9;>=|piPXJLp1YowgTs!`!cNDZ9mR)NC0T3NsH*hc-~ z+BJ1~{aSrx6@MP>4s>)e@X_4VJ!%-=_RO#DORYY%e0}ZO{Q(z^%VxxdY;I76V&jmW zu8g6H7iVOXS2xr{>-axpyMkbB zmlYwGu;BR^R8yeSkgZaNAUST`=Y{0(&GA~}C2`{bub19%SH@f4`BMGI8Q;z9_6#T1 zI7f>!zsa*Zzq0@{jg!308h?2oC(d}K#u?vNolGrAk6$>iaW5Bf5+0wIsakT1vA-g@8(_OA{ebmY?vp;aEZE-cV9{Jk%6A#v!2!arn^tggj27&Py zV(EZH@TN(OjGM$zlz5)kHKtL24?#B2>_m8q^%Itqej1a~_zDT3)4~({R4&ZrRR~L% zl0(q>V>(03^ld_lgw(jS5mIAPG^|FWrdSw!sF4JTC9DyVI(jLWifIU_d0>d~sQQSa z#jey?SPdy!!TG#ZAUwh=YYe=30?Zar;V@QE;L-ZE8g%=$+N!#=x_r5Q`C+yG5WhOB zYHj(^Q>uPdJ#>BJa{X!zy8Zg)DwuZ-YwhyY)l&f#SiW3UmzE!+1*k5ps_R!*tEXt4 z)sY$B?gpDz>sMFS*6~5Deqv?y$~A%%%PT-B)#b}8tEhvz!YyB0-MDm>x^Z>6UNxyUgR3`vY!P6UHNEuaX*s8aUy>7ltoC0j@hgF(ybWO+zIdos)+0iRVt$&}2c z6NS0iVUp~nA&4|uJ5(=p5b{l_2}MY4N|CbRw&WFBlp7&VFWZH|4zooRCgPz?D69&( zM4r?pULp$53H>t4U(DMWeY#hFimH+|S4;xYOC{7J)LEKM=W@~~;BhBQVV)|FsYEJe zvJ5I;_CUAC%Tpq9h#y%x68@=G`}-@0`&SM>!jn`v=;vHAV>`Xc{gs~kt4~)Ww>;ab zhy=Ue|6HY~XS(@e0XCPf2VZU8A*FBTz4a>Npcae2x(MOC_a|IwE89Grov9p=%KJ4w zn&HYKD5w> zdn>B>k;+|LP?m8EJuu_SEKUe<51NP_*$uUU$u7 zxvkq~)~5KSa`1+~p6}j=_2_wEJIMuRgy@p_2vGHU9g|&el)!h5Mw2?3XcwnWLb}bDOW7udf6)Uz@`cj)v9UMS#0x0=OXv=1otP zA=1IqkmL(kyJ{5rDZP+R@=^jw8igjwXG_eJ>D0Y|UNKf5_!0>lIiN!11ItS4g4g=){|~6B-YxMDYwn6O3wrt@&*6 z3~cfOBzHssPZyF<%wz7+gg_9Z+CfsSn^~A-3t>p~kV?{c6o4*2q_R^}>0-K&Oe^%+ zbQ6jph1tj@7H8GyxUyg~U|u4+3{(-d32dHDr+qi&k+6&*AouqW}hEe^jhu3UdaqL5P|J(`a~{DTzrXGy!uZ5@uvxEWzT5s6;LY z8kl|oiQ7E@^N?D4yu>>6%0~V2wdD(ItAmf9I020{3gt$M{GoN|c_=v80i^ZXG=OL> z67ejNOJy>hW>sjnl%9p?w?_*_0HshUk?74Lw_Em;ju2t5xtz!|s65C0UXQ;7qnKA2 z%K-inX?NFtFH|08k<nrN6RqLXpY;J7p4J1y}bx)xi?{Imjz!K#DJq} zh_%!(`E*F2{F^gANr?zGiwL`XAshlk& z%2`;Eg?W(Y{~YM@cq@I|U6sRZO_TTFMNj5M{C44gyb1u8%0W(GDb@I7<>0hDZAi8sPRrl#$Smk8F24M{e)@6c zU{(a2PH0V6<2%hmt$0=^ur!YMm{%ysp8k~{$U*MRIjskpPuVHb;CH9VHS(*e8fPcC z6AnjJQEd3&gnkOeB5ezPBJ##k1dD#0!IBYpA=n9}8A9DGMhJ9hQ5b^VAkBp$qiv0# zAEjgh26HZ*N$0Q_AYXMIfcyFhf>cUFs=pzxg~5(t2r7sOEHkX*6SNdzRo{m{A$4Ma zq!WI}A%)l*c~(I-AOTQ``kgKggF&)ItB_B#*ct48+u0gfFvL#gCre3#J@EbJE&DwF-nc)pb$g|6 z(Z7AJc7uFo--OHQg0GeF`7U$;OeL5JHK>Z~zY9BC{qan{22QNcD?N3A2bCjRqm`b@ z(Zr;v@kY*j&cD5{);Q#i?>ssEkEeY;|JURAJ+koS>8&r-8=uSi8o#Y8zNy#XeJ^@u zUi8hp*oFV~b{&Xkr1ChpH3VOYOBjjK$b1HUPMABHNkD#21Qja;71g?erHq0`=T~^$klLZ`HHHp!!JrAe)-{z)m6oo*UI|kYpa*9k>O>FdU6aA z)Tf`Y5&2ri!$wYKhQ&2COuRzUPownITt2@@z+{+nk)#77+p-L=BCiWMbpGrxwEi4? zI-U>sd_GS--s|%g9oe(eRqJ2b&+kM&=(E{0dAy)iX@x}9=>mC)pz4AuTYv^;F>WiC zw`i(>jvay=wq84j!)9`MUocoWv>YDCD_91xdR1SR81Sjw^&ITKK-b(Ze*3)JZUf5=00}3x*Ed|**W=ip zqnKMagF{Q~VX$J|Vtp6RfWA}W-$4yDc6xtD za126R16)eo`ulFSLO#HcH{wy`03jiq5!C`hCftT44l(aiC2%};-7^Gpmjx&5f7rN{ zh5nU=%7q*IVCz<@^=j|m_VxbrVo@o1?2q4Z?or^vQU0Rg~G@ct)Xi3aAl3NKP_hK=dGdNV+wIg`~~!`%zwYObY$ri==xb}h>(}} zunfEG^m(Q1CV~FU)i@N;^QakMX~Y^}##s93iyrHvFZ%HRF8Y6O*U7c}oSMH?d%jYx zoRi)JTHHVWy7L3;6a0g+(zfuFC zHedTQ?~+S_H4j;{R?$V)*_KuCEfqF@b*;KI;jLK{f;`~SewAnG53R$`+6}nI{5><^ z40&Fdi@8=|I(fXfD}}3Ut@-4Gb+j>3^)8(@gjxdPE?cL004+;<&ymt2Dd^LmFu@U; z69=RCoTM^6n;ERqnl&Q9JX3MY3VhKzx&59)I+Iu%RzSwu_-|0HVmC556h!dHmDMrfgU~*t1;Q!@1Hb`BDh2~Ue;6NY`w(q2 z6k_nXmw;O#pJRXo+DQ-t4A-Se$LjBFbaPulsXPR?@3?Ar@J`r{6G(YAfdHJ1OpqPw zz*c{10@~aJDJQfl*4l3(7$r-CZTxZgdD3U+5;+#k?I>T3a}eS8K|GD_MWqN_MTW2uG`j~O!(b=|wQz(1x49@EMqwfoyk#h=pWwK%*~LfWZdKZD%lKt+fK z!_;hmieUki$YY9L*|rb3pWvpp7u@Cq1Q`(d?oPsM2)`Wsb{5%D5VDW~F#Hg^is1nv zt1y;CfUQJ!1fEh?*H!%*j77xD5aWAvqkatrBf@*DkB*>N2+rdH0B$i`M_k>}rqCcT z`T#f>bO&#U$8bP<>{1q43StKi8b>2YY;4ZA?`Cv>b{6frpm`RyrweD3Ly}=Oqj2#_ z8dOi<-vz;UyCwJkX55m-%*H(I?Ub~ck2}deNHU#ruvXeUD`YS^<{X8OF%%P}LgukH z8=}o!*b3zd6Vq3-9_ew|hR*2NOs1_M6zbFg%_zS}JagPO+R2~n!K(K@uYl_2G5$NVz~FDO`W4@zSAY682>nuR>-5}r=f7R)`Btrm;pg0Zr3b*U zpI>-FZkGK3r=La84nF25${B%?jkT=Q!}ZU>H|#~+j=%9wKc~-g`W_$PkE0U4_D|Gs z|GB??3OG6|&S{Dje!tSEp}9m(>+B&m@|&m`hF8Sl6_TPR(ncaoGht7gRf?8ayF5reP_G_jrbApkfw;Yj&ST6P7|m- zNdvbc$~;eQ2?%TR2$+ar%z{0O{0Vx>R+^|17!aGMY%NO4mBMOqit<6#^0O}QXx_F8 z2TV%?(vK0F)dm$O<&-3W;gG_89Wk6X2=PrjP^2ueBo7OJH7l}s2bCBHYEdS5!1$eL zO{C|UQskL&d8^>gLZp*Ki_wv^TA`(Nl#Lb&Ek(dlD1ET`gI$m=w_pi-WYzWt{N?7o z+2);D=D39XaTxJ}PwbP7Wbb!<=LLVR|0nT8X4>nW_WC3sJOlnhc#~x&4FDT?fHV>q zufSTy?7-o+y#gF(8$IwL>F$o?)5S9m3SivMMIlPspcW<@tze!(V=5~|gMmUXhAP-! z=X%wmN7G!3o-8B?%$q#Nk_u-=Ktb9=NXn9^p9as7rlemAa0z03E^Co?U)e$Un2`(2b%4auc~}qj>Vy3%i-fbF zP2CZAQzbK&q)x(6B?$tT9%%cXt1wno7`>;>?l4wpqp-cFoVMoju5;RVYqp`oiq6u&_@}{=+M_@C|T?1{5djT?xZP|0+wOO?b@bQDd-lG10O*pHuxbn*Svm@FMgxm+v7gJOv*z+& zE$EGyXEWH_Ez6ac0SidyDW15oAKTdLC0;#FdgiMcuTQEwYBp_>GstEv?6P%D@Pte} z#40_|kZ3L-UA4@meU36a;1=UPi3Ih=54eW(4iGojfWB}&A)ZQ`DRk@<-uDwggEk-} zq@W3lndk)4(9sUg2KO%zdK*)TG6gN5kog@dTi!L4qeNYmKs@rtU_dlOgxqQ72%}Rz zU4-(9g`%-7%%*Hk&#x}(hSwx&bx|AkBWZVZfO(oKkhy0UnoZn%B3ZObR2NKO9Ua1p z_6ni5c;VQP7Vv}WKW;(&&UX1H>yzO!|T1@N;XBWsQK^Miit@2^)Gz=mu=n|*L$$)lUz{b>B2Mhm4Pp2E_j}ZOMExplXz}(|G$g(z&zNO z_tqwF`18zmWFP$H=KgPJ@B8=l-{u{yxZd&g`Kp)7a5pITUvKVT*SVk%{><&}T}Fq)xEHB0Y;!?W)3)}hXU-in;QrGwRPw$(|Ao4=Yh)Oe&7_j&!_ zzz=tyJNk#tNE*M8kcmv4Pw#Jw`|35OapN{n{lKnn5i$Ql3W|`}+;`-4yE)y8dkr!B zZ#qp2`D@jxl+@}}+7f*4o}kUH8@h!b=)Va4tf6Y|`3}a1PRrKGUjMtTzN)`@J4{Mq z0PAqx>akhouQomZMauj$>#)^l^~7Z}z^3Qla&l$lNb|gPxba~s`yNiRj#Mdh)qCeb z>*&%k|Mn59zmFK)W~_g|>G>yaMnDGZnAbYSCuEpHOZ_dp`Win+%@0z|?_2X}S<4jB z&)l4TzNr6N$Mpk~=Hg3BeJ$%a_ouhlQcD5!$Hkg7HQze4>HmzoKOeLDYI<9#74X)$ z-$Zy#bGxMgI^6lu3ZUCx(==}?EG{0ZZTfWIJQ8!A8I2^KakEgUbtJ zwW!1^o4)@n-Q3xFRla)jzFJ*YOyfVA+G0*^16-Tr^>25tb>%S;++|lus{7?l-|xJ` z@<~(vxEb_rf#N%EGTmh|H4g7Bsl0zS?U=s$||Y|E-8&gfW5aqoSdxo|G7Ggm$?an8?_LH7i@_^yoD_I5(F9;2fZrG&Owl+5 zuNsmw1P#T2N(G)t<_X|7w+{|*4d*2olfYB#SP`KKJ9-hC0D@w02TX=cbXLZ;BgWA) z)W=`OVOiVugFeqgRt3B-cCwBMA~_mEz)zbXQG`>d1xiL7P;g_2f>`dpM`7%sEiu2N zz*8=Z0UL~sS%JrJ+ov(uAI4r8v+XGyx^pE1nL2|S)0PEo0)y*GcW0D$h>0}?vX27b znp#H@SA&Vo02qgj>=DQYU_CV`6JgYBPZdS2+ykV*ll_j|9GY`VhiPXyMGQk^AleyG zFKx`0cX*!Y9mX2_`xo%sQ49E`Eia!}q&?2a8v^il*GmU$-1UY)S@(O8Z8@ihL4@*{ z3g8EHBj_Fvy|*z^(9K9O+KH(HxZ1Q}ri#&g8E%WgN+eq}hHxz%6-5ZekUB=OUXyPE zrV4c!2FKf%$6@li z-=lnH%%(<^al3Bo=kC8ih@D9kjVt>JZjt z3m-$V84n`Gu)7Ggws1XJ<*uw8)6@bEL(#_1uEI;5E_F+ zLXHJMUY~d`Y*z3VIyDMTraxeOKFI-(2KG4{Mh=Z)J#sp_9l_coqY#cmNC@&UQAe@< zF=}*>qK1iC1V2(`3qk@35SWr6-fB9f36bHr8MQmLr z^Eea)3G}BReCF9gwk*{J>7*rADp&)NE*yfu-dT8HK@I&v0etgi93gxA%ed?+k!<6T zUPPEEdY7GI(NAi@JTenuA9fVv5}p}DFV5twNgP-q|NI!ZoHk~fH{#TEl0S_imVgC7 z5_PzeNf&S)2V-kXfD?SfkOCsvvMDpTG3J9;g{N=S^ zX9~63ae*+TqVq;^2oB=@^43Z}c)aKKXL?aG9W2-{wZHF%g!K`SAYKlR;N)#K2gA$_PM@|^Sx@(Jz zxQT2>Lf{jED5rvB7**i$lln{y;0K?VdAx)JGC15XXH4rGSFwkBG?q`Q^le8 zf9l=(MaH-FpL8CtI4Qn_gCY=^w!{WZu%$ajk5}Haq$x%qVoa+Y9J6qh0!}bWHD*5< z7o^*ZOdO9xaJCMHD7FDHRspR)5@=@$q4E=!9_>_eWFEwX&H=e7D-D`olCXjb7VRyk z1qIFyOoA~!zPwRi#yKu^^~&l>{h|8G^0oT)APgl+>z!7 zQ{S1a_2XblJW=&OJ;|N_)MS7EBS~gb1kSllS!mi+)~-e#^p8tVmA7w2*(Qz@xB0|A zFJ&5kE`Lj3FMriBpM&FY$XC%BRo*a%PBTsgada0EG{%im za-IQeIs(%J0g4Flh8w_zp@%g2px5ZI7qAZUQPfOhLEs_%1PDc2++=)oLPtgj?L{(# z?wJr-g3t%&;Ts}=;z;{p0te(P=cS)}?TuLwQhX%nH*+osF_1+HPVIRl=%{lfh&j9C zG!RZnL6wm>MOa(T0pZ2SGP|Fm0GaZ9C}Xdy3iw0&$sFF_)NwEejP2~RL)&vC=p=Dy z*X0JhnX0Vj};V8@!#iEMoyhV3d zu%e<}0%XQW6ibJqX!9|~_XBJ(@)Ml!E%=RguVsAADvs!}Kk6%q<{|BpN<1SEjj0TW zf{w_m1|PTpVWRGTdUK79)@(bH-qQ^%MXTzCKstacvpzR z?z74S*4yTW&i{3!0HKSJw@|C_(R|*A-Di7(IhlNM89S8D69t- zey9ibIChA0g>EmyE(~yvXP-tOQx2U@Z4xJ6@MEUqbn@80-Bs)HF7h0HEK3oH&s4pM zo$uh(l7;&6)q48a8w846J zU3tJRJR7mW??5sY1A&BN=pd#Y&=2jRCHZS?Kjcwlap0J{0$j%pF;`YMu06)rF+E;l z$d9ElD@%g!Yr`lJ^i)HT*0g0NH=MO_4$3oyxS3bT+c*subgws4EkU}yq=a^YXCmz6cylNBacYT7;<&c6t1n#f_8{s4-EJS zB7jzpNob!4XRk%Xs0OlS-1`y0s#+Ql)3N|6V43XN`z0`sHWch-0@%Aw{?ywAeW5j> z>n@mQbx^2rqRO<|p+j_X|IyBuCchak{v$CDnHje}oS<-r$a+p`2B2@GU{m6Y8BTvT z!9>Sl@w3ffsX6S-L+dPm*&U0L{VEMHKil#o)am0|w0KbJnt&m(UgiNk7$^+;M^y~frmx(USZdx4L%uX$`1Yn5G=t+2w3(_!Xzbd31_1leTLxQK{CwEB%KVUM&K_MFA^U~F2QdI z1KFkQ05VNpVK(9z48*Vm;cL34L~b&{Nu=G`(LKT`CLm%q<q*5#8}~m98^}T42#Iq~ush5kvH7d* zi!Mv^#GZD{$y|ZS(l)Oe287h2Eqo3`miXd{o$dD}ZoF4k$q`>-r^kZ}4S6@bObX7E zW#{2)?x+*JV^64EF~89|$Hpcog4?+E2l4ActvurGcj+xT#P!a#L$GsnWoW`k*tS+( z{A@SJo0C|qklz3v2NEIRP`4KW-8cwY@0-2xo_O`k(h0N;$moj=#EfYi4@pCFUoAG1C`cI@kCmCp1HeYNY3>i!XgaNmX*2T|6dT#8S0W+X|Om=&tt?9-q+)FM; zGalA)Mx6BnYUL?WPGwkQ7eGS9o}!f^2sOJekDJ+ypsW!Rqj+ilT&4faeBnVax#gm)FTxzp?xn ze4Ta~zPUvFB3iM$kyJns2G>FWZIh;X0}*imBs&Smm}KOjAS7lVJ&)iI7!}t)P0< z>(vfO!E2sYJ0fYk=3(I?@Mspk=X;QE-rgq;@JgLpWbXd4_&Q#YKRAw`GwU-K>G|2k z`=(#r`dD_xI%rm9rvGN4c@p1#eB1Pu72m)z$cU9{KalQ#p+r&C1JN ze2HqtHHmFC&oq815`**yi%&WR0Z$)9D6cEJ7>*yXbAS&E1FO-xfy<3qjTZ}KC%@2I z0kiTmYYymJVDNT!283@*AZ7(zYva`c(a``^vhwX$G62O#=On2CebYGsdqU;%2~Q{w zu*9eyZ)E=KELwc(B`0X_z#H~<1?lBnPI8mH=^*LWtJRM*OPJ{$H&6-=+T zfT2F6JfLIs+#q2Q9C=a$-I9L@_wNSmlg9zw6>h*z#Q@PA`xPT|-wBH%I@CS@;L?#- z59RgB;xLvSgC0?IIICd6tvo~I=xCHX?FwMqRno%7VA^j92gmGnIeBNYTpVr}w(liI zN9>3_QOY@(jW2svf^<8Z@B{UWMr0?;1?GEHAUCIXs{!$Y4}b``ah)#Xg*o85FFnBN z!>a8H@zsyxW@C6xa4j-!JjQ)l0hlv<3A!qSdH5oBT`?7>smG0M0lvr3DV25!Hd2VgotyJ_UW)q!KAXJH4MJW%2v2lcxj(&7o8+S?#l`x;oWur|{`jE@Hm9UwB81 zQ=$FD>G%f>u!*Wb*Hz#_I0yo_h<~jG`b#2ibdmRfPMpGJyL1{}jUnyC2a~vs0>{S? z>z>O)j0TbDP|C=d6Q86Bf%>B$9&MJvt%-xG+cn=ZS&(%msI8}u#d1fQZ5W$5=1efF z?0ntqHJCX=N{9D|nYH9>>9O}8IV!=mD#VhPjZU+&;m77pvmdM5wQY+uh$zrBEsK(~ z1xza|FfS-z@3b=gp>`M|CMdefPcXVc2EKWi{&wq)YtZBLN>e8EP0^fXaW8j)yf

>E9>`y)kW z2ns-N71i9N1!Bz=KzQ$41pT8`8`Z0{B9I0D zwgmm#5CCp$>*HUvxO9Qg+(Y_1k-Ws1oF1T!xnjs^J#WNk?q0p)n-kdRVdDoick@LE zcmNd>L;`KT-HYY!0>om|-D~J>f0KU%#(cGt9kw9vE$`EC>eCR}r0c1)%Nlg~|8cSl zo`ZE>_umluHF2_`zfE{IS~eg59wD>cgl2%fFRgO1j}ah79zeOl&Zz}9@(1KyfX4lNBA5Xd!O+o7&W6*7a%w4iTKcdLN*FGly- z)k{TOz=6G{OsAGL)8>e7TdTiq?AvX?@7u+`rgJtHFui(n1pIaYuy)2VCZl_&-ZBDy zivUI*)gS2oC7WJZ->pVUcSDnPO62~jrC8cy^$oq_9ATyyHuU0WjDDi@ bGfqDf^b^AmqEYyXVWVkiq8lwykoNxp_Z}62 diff --git a/sources/PRETTY.~3~ b/sources/PRETTY.~3~ deleted file mode 100644 index a797745a..00000000 --- a/sources/PRETTY.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-Aug-99 09:06:47" {DSK}medley3.5>sources>PRETTY.;2 55681 changes to%: (FNS PRINTCOPYRIGHT) (VARS PRETTYCOMS) previous date%: "16-May-90 21:07:26" {DSK}medley3.5>sources>PRETTY.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1999 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 14-Apr-88 18:21 by bvm") (* ;; "Used by MAKEFILE to print P, etc expressions.") (TERPRI) (PRINTDEF EXPR NIL FORMFLG NIL FNSLST) (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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5954 39877 (PRETTYDEF 5964 . 14227) (PRETTYDEFCOMS 14229 . 14911) (PRETTYDEF0 14913 . 15104) (PRETTYDEF1 15106 . 16869) (PRINTDATE 16871 . 18107) (PRINTDATE1 18109 . 19314) (PRINTFNS 19316 . 19885) (PRETTYCOM 19887 . 26228) (PRETTYVAR 26230 . 27268) (PRETTYVAR1 27270 . 29488) (PRETTYCOM1 29490 . 30194) (ENDFILE 30196 . 30292) (MAKEDEFLIST 30294 . 30698) (PP 30700 . 30976) (PP* 30978 . 31291) (PPT 31293 . 31612) (PRETTYPRINT 31614 . 34766) (PRETTYPRINT1 34768 . 36654) (PRETTYPRINT2 36656 . 37972) (PRETTYPRINT3 37974 . 38929) (PRINTDEF1 38931 . 39121) (SUPERPRINTEQ 39123 . 39217) ( SUPERPRINTGETPROP 39219 . 39363) (CHANGEFONT 39365 . 39875)) (39878 45224 (READARRAY 39888 . 40814) ( PRINTARRAY 40816 . 42556) (READARRAY-FROM-LIST 42558 . 43663) (PRINTARRAY-TO-LIST 43665 . 45222)) ( 45351 51806 (PRINTCOPYRIGHT 45361 . 49133) (PRINTCOPYRIGHT1 49135 . 51501) (SAVECOPYRIGHT 51503 . 51804))))) STOP \ No newline at end of file diff --git a/sources/PRETTY.~6~ b/sources/PRETTY.~6~ deleted file mode 100644 index 82e15fa7..00000000 --- a/sources/PRETTY.~6~ +++ /dev/null @@ -1 +0,0 @@ -(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.LCOM.~4~ b/sources/PRINTFN.LCOM.~4~ deleted file mode 100644 index 32a4dc3be2fae6c958af76b80b558102e97fe8ca..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6831 zcmc&(OK%(373NTm<2s=s$&Ok7-sYJ4A z(U9ySL6D*aQgqh>MpGjNS`;aQF0zs2Xwf#nEV@cjpqp-jB1HrA2Pj=9b-#NrIizGq zb(#V-Ao9L=?sMX7c92H4y$h@6|2<>-S+`_+V_h^(sVEHzgyuf4LoK{q;(Ay%@h5M+X`uP=Xh zwR3ZWvx$wUlAWBpxi*>0k(`-M*MB$*t~&|S@)WwQi1HIGbua}oth*X&wlvgEksYMe?0 zYuNZoi)~l0>Rzyyp?JY5S3tKosV{oET{RuM8lRxhpB@?tNh67H?Q0?YYaVU2hHm?< z@Na8U^XTo`<80CY(IxiPJnEa$&QrBl*ktt)_Bl8{$`)San`T(r&fsP}=zn=eK<;{8NgZc39tv=cMF;4x? z-)a^g_?v$T#bj8pi*S;22`cO5JdmB_3T7rKnYvXZSxqv9R-jW^Nt092ZEgWMktSvw zr(U6)Sg%ki_EfC8u*nCqU~h<_Ym zw)CGlEDeWZN|Gaw(-!!K*6F440;ogBNq8Oi1qhJce-dkq>-YmX%NM&q0*V8-Cqhz4 zTH)B`{8l(PR=}g2CYaG$V)jX}c$T6#^Ng}?d+~V5n(Z;t(_h!w1{KDx=hwug(2&6R zC8h>Ic0>vtprB-Gzu1&a1PW48;72F`Oeo^wL1pIlv5Js!KiFVx#QYbVuqjAGPYes8m`$=vvDQ|=&16<;-$KT8_*Xr)}lRS3hg|BPf zZ@#v9c4lze9UJ#q%ZmuZz@UIh-9@Z`gwQ?&kx5PfsC<;`Eg^J>737lc0NCMYl0m3p zdP*b2*hQ{0s77T|OP{hGZ>r?fY=j))#k~W#D@Rcz$}GNUt#gB3?%Z7KCiaXvxQ0V1 zEWC`wPsp9@awKrv`9KcCT-?*k2jmW!id7HXB7Z1UbqiuB96CM-{t{4!VB&f>nIgnP ze5c7Ebh#41Bo?mxn>ygy*k!B?7M>px6kpJ(dwmuv6WW$ zoY6ewZ$8}&`iRGfIheEJSnFP%uj{`>)&t>@rv+h4A? zE9bjFj)U`F5Hxz?!j!I4tMFow=X9RA%Nkoj`~+wq*!`mFBEoqX#hkXv-C%L&2uJoX z$NbI_gMTk=N6j#+tA=)-SQ*`Z%$N&Hb77I$;Y(v^udgE^2N8ToxiVcemo!k z7AvfPQOnVa42+By z`2pswEJ?G&s){iRF+Nt_Lfu)hONYj{1|!Q6i}6p0W|EsBd}vM-mKDhMMSk7czwmfvR}wA~<5E zkWq1}6Le_f?2(XEw>dOd_&cIr8JLXxb9m&^NmIn>+!1E@Z}UmxgfEVn9Ni`ZD@zge zxv}P)U%o0XTI=+dg-IhWWBWW4Nlf*@!xzH z-%D3e;wMhT{k6My8>4=`^v>4Mk~7-6^69OuA$N7y8Ep@JgbjnP?A~hM{h^@W$hX5z z@z`;L8Z*9=-#jB|eRxz{WQ<6U8!I?6b!_yLMt<#XX!n;O6lR2+nNJMbe9W17f7BVh zDpuZq*vUIH{}|mgj1QmZ3_Uj@opKU?U@Ch55ho$YhDJxE)5a?3D#u2J;>M)LDc>0j zOO2Daol)l`r+3PLdK%+?<4mg^+1*xsXS{V~_ose4vYBg#cekH1L=P+rRn-x(qDHX&at<|*6MKk@a{WX(jDhS&+dsUSO~pq(8$OWj@rJv zyIr|Q`Dct4HQ3&Jf!5W{Q(s`pH1wI}ri7x>_c7&@+?3PIluRD~(kzA06hGVQ1j zWXf@F$`^X3JSR1t@tt!pWt5pR%1!wUH)Y&!#CoQT_YCl5Od0Q+Al7*Pe`3n#o5ts# z-Z@=2uI%19UalL1KDv3*6o`$DNKct{0~$Vm?6@;}<=*mY*>vzsXR6Nt#gYK6yJIe~IqM{$%(;gwp^_4&MM zQx=s{e}Y1#_kK-h)ASPBCiaw~=1p`^5QR;9c1m|$2ZdQS(<=*8X;y6WSA~i)C?KZd z?qHHcjn$*9Aa{H*WmXv?&FW5x6@W4xumiPOE*Xde2ADAEzJMvDEtVXr=8HNZc`>Px zl|{lpNH@#qK#Dwzqy*;rrKJqHgBg-Gic+NVqQ1b&(_V5$@MVHH#+{ z>wLJjX0Z;G=20f6-m`>f)&5hEj^C2O!>CIv&B|nUa~g{1ttEoHk`Qbkl_YZ5{v~AJ zeM<^Ta!yx)o_a!La)j!_Lg5lzAg5U6$mQa-`+bX-0i^&;0m5=Ydq*(hSdO;?2f;0^28e`r3&Ye22#l z)~iSlVwb%=c~RB9M;HrLkGvPdfR6_ZpllL7H*O3(Lv+tuV!csTtn)`29@dz%7M@$t zE?yj5qgX6X=+=tDexlb*W{n%F@WxAbt9OKT1^VUvK;;{}4JRTLGi}pb;B_AmDPC+b z*7_5T0$fwn3zp{U=u#Kq#H@U#7~XTPgHo}?t`r3)x(ps0p=^#-aKc$AUZB{;8k)=$ z35srPilqT|&@`l2t*XOWyHqiswVb?WamMyGn))3eKH?opl=VH{*(1O$dU=aL5fO*A z)%MGv<6SeuUK5arkGt*ZzJT2Ym){@Lis){lGDZ^}ZB|Wa99?`qweZbWAqASB+-w&H zUbb-QV70H-$X@;Y2lYf42c82SNH3a*qg+ifbP!paE#|l`u%T0ocNgP*4TH0i>9Y2# zQ>NInXU}pT#o3+}F7P$5xaSInK_(~G@hC^Lw*q4e;PE%SYt9-T{y%78dF|#houkF& o_0FqQ=&WDwtY5yd+F8SsJcp!(j|@K02**c`*#9R%N$e5zZ?~0!UH||9 diff --git a/sources/PRINTFN.~3~ b/sources/PRINTFN.~3~ deleted file mode 100644 index 678a2279..00000000 --- a/sources/PRINTFN.~3~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Jun-99 17:09:59" {DSK}medley3.5>sources>PRINTFN.;2 13789 changes to%: (FNS PFCOPYBYTES) (VARS PRINTFNCOMS) previous date%: "16-May-90 21:09:21" {DSK}medley3.5>sources>PRINTFN.;1) (* ; " Copyright (c) 1986, 1987, 1990, 1999 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 10-Jun-87 11:13 by jds") (* ;; "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) (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))) [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] (COND ((CAR OTHERARGS) (* ;  "If the function NAME is a list of names, print them all.") (for FILE inside (CAR OTHERARGS) do (PRINTFN FN FILE))) (T (* ; "Just print the single function.") (WHEREIS FN 'FNS T (FUNCTION PRINTFN]) (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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1111 12377 (PF 1121 . 3843) (PF* 3845 . 4143) (PMORE 4145 . 4468) (PRINTFN 4470 . 5065) (PRINTFNDEF 5067 . 6289) (FINDFNDEF 6291 . 7347) (PFCOPYBYTES 7349 . 12123) (DISPLAYP 12125 . 12375)) ))) STOP \ No newline at end of file diff --git a/sources/PRINTFN.~4~ b/sources/PRINTFN.~4~ deleted file mode 100644 index b25858ae..00000000 --- a/sources/PRINTFN.~4~ +++ /dev/null @@ -1 +0,0 @@ -(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/RENAMEFNS.~2~ b/sources/RENAMEFNS.~2~ deleted file mode 100644 index 0d118402..00000000 --- a/sources/RENAMEFNS.~2~ +++ /dev/null @@ -1,105 +0,0 @@ -(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.~2~ b/sources/RENAMEMACROS.~2~ deleted file mode 100644 index 3f49585b..00000000 --- a/sources/RENAMEMACROS.~2~ +++ /dev/null @@ -1,222 +0,0 @@ -(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/SEDIT-ATOMIC.DFASL.~1~ b/sources/SEDIT-ATOMIC.DFASL.~1~ deleted file mode 100644 index c7bb6b9139ee00a7998fe3bf547e547828a3a653..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 16480 zcmb_^3v}G&b?5&-Gm>Rl8js|$5WfxA%u}A1=0Bbp`Gtw`Lu53PHPjED zPAWSN#;iz?gpEF8noXO~c2DSv@ov|$4AUmv9F&~WY?ib#+jiNsY4@D%*_GSu*>k!} z*x$YP`_GJwNoku9^xgmc-uJure)sVWV@A`CaLN}h9ejLXsQ-|!bo9vMN00a(D;@G3 zE*(9zzu)&5@V;jwx#SlfI52Q{a5Mc`ySaGa@R3q!=AQVvx_!NSpZ2ZU zxN-H}zO`#Mt-Wv4x(%yZdxE)?tibNmTN>sLYrB1ky~9WM9^y_LFv7i??p?iU?Z#ED zAH6nt)^Tge!2dp9{j-Fiwl5O?b>d)v zT9gTflff;~$qDD=_-Hc*w-IBLqis8)S!;(sZ1wh9X@4r7%U}TwOnYko(x|g97X`|t zt7uGfa22|>mF|tE^PrzvEJRaFsHIyirNX1yRQt_#*Cy(g-Um<0=}Z{8M(=Ci?cE(NCXhhsP%ZrZjbn)iqL@_8({ZiJ34S!??zOxzd? z=6Zs8=^jsGv%yq+S5)gTSwK9Ui)O2b!?;$BtDB{Tgnhv(+cQ{L)b9^vtt6`G9A!X_ zuisIt#?=kDEQ^f?F#r!-SJ9e{W>R$YwVk_dR9&+rxo~hH9fbCv#1;~s1#4}~fpo%T z^~-|1+UUBGmlO8d2kBi{RoAICm%+#jCUr}7yk}>PI7_c}u%5nj#Nsxz=kyi`0mR)T z869n3)9uGC;@`NMu8@1zZ@O>&nbCD}cO5-^X!B5M|K6d^LkIe+H`XUySN9s{)OzT~ z6VPXW8fYZ7Hru@8yHrjG<MZ3p6ZnCbZd?5yy-XM+Xr z>Po>w{}^h0lVLbXTjT#OTv3bfuregU!PMlai?qSy=pu-1KDr~18$;9*T~W|J(Jb93 z#~nnUG3cNra(dh2k$g;bm!Q-Z2`1BYtXA!h=c8czb#$pEqdT`-*~qV;wuvnTsB+bP z3pHLKBb{of4agR5qgSK4o7F)Fu!|W>OI6(lj%>r^S(BFZ=fMkw>A=OpOaW9cyj|Gi zuJDQM@l>{VGEKkVaB5F`^}}^)kGE3T(@_~j%VOgD4iC=m9p{%5d>Dh5FWIe%gLAu+SH`BS^qJn&58p9P^rpTuZMkEAKQ{G%)p3Sq zn_3yS+UL&<5O`DE^3Ip9w>-i+XSg_NuiA1CzK5kvecSSQ3}*`tYst#0rLaK*hK|?x>KEBIGmCNubTBSxhR00p}ISP zWGz-+rP$FYx1lV_c@*S`z>#+$~wq2hcwT?{k7%$HYamC+as6ztu!HlVTLv1@i{rLnVb zzPv0hAHIvRU~$Nqa6>#p#KF4Fw)yi9h6XQR-0rq{cP26T;ot8bOO1vTOr0cah?kyA z9Q^3Li&KA9OoT2E{&fCKY&tf0`9dHVi`%ORxAG8`qKy4c6FPcqLi6hFugzHdfGoPQ zuz}%h03n;n0P%0_v+^LJvk{mjj1jp9YLWU?wW+~rxHMxn{DLEce$o9NJHCjh`nMSG zs;dR|N-UbiWK{nbDo4c+6#adP{!FP56(hvK>3odt!!Q)XXE9KVHXBG$z&dC}lg2b( zm@U-hr)rprA4&0tQe03aLjIN-KB$iER;4J$aaYxiw!Su~(rQ(@Sq*n6@bfu!KY07T zYwzlEp#nnq0e9Y)CJMU7%H;_69Ma6{D%zV2r z^Wj42=+J>Wh934E9UdGmJvrgv+{H*|S7*yQk-wp{3I_M*+XMxI%mxqT*) z^fp(LGjj1JnQh0C&&3&d7}sJvsmI=|%Rq||J;43#*)V4Lx}e5M%UyCoY9w^6i-~$# zJ>a@Z#n!GyRzuLT%((v#hq5FMp{QCX#72Ju?D9G++(LgY-kV8jcK*+(Uz+O+u?;R} zO+*;|2P#biOcBrG`U?m1!j=P6OsI#JQTacGXWti|)f{|Dkl#>6YVw>aeNmN;s^X9; zJ*tNDs?@7?#nkWvYIv<0_7MvYyVbB$4HF|j2oBh-X=hx}KyyI@4sG#xOi@rS+XBkX z2LyblU9-9LnAQ!tF2)n@HdPX!t5ehULFZL;ZD7l@W_p0I=0hM)t0)M+TtljRajz=% z0N>0)$(>a9dR4kxm2OkT6{_Ur8QxeTg+mJ3+-7Yh9Je>9dCp_n8rN%YRF|$@V~JBX zPAlu`rt_b$X?xG_y0tW1)FZgTzwfqJl6Bm*`D*ThTx)-7AtiFWjc>Oe!p=nni@%mxaBj^13J?Q5mV{0V<5BZ4F z9e<<2-i9oe-|lkO+0}GY->SO9u*4hF6mLka=P~~y#Uo%v!R>ECr)5GPe?2+4-S3%g z}?!T3JY^wA6H#HsGd!7)j>OpjB?#5%d}%uOsYrMZAq#CT5KTu@AjX6;UM3 zfSc_a2R>Tt4;MacIhyt2!(-Pp;-kG%z+Z1AHrvcT+OGqU5e?v*f!EAfz9%-@6q_}e zXL%HS>z4WXdZU|1jm@@{SH))C6ZrRee9&6m7|p|+$QRPivG@z98N|nlfsw+Q0W_h7 zIA9fivpVl9Xd(^D9RbXb`q->1HruGJLVRddDne7f4=n`aXfqw+hwS261txm3M0$;w z*THtPr@o6*ZpDYWi@?|J;w@i~{a|_6A`gQ#Gj&dYhF7is`GMzRvtDvRBMsW%Z+ z1}I=CF)+!&bWpr&4)Lw%&4;#rmyq4OV99;slEgw$@Nt7W* z_5~qU9SPJ@2#5K%%yr`g{t#T;6iPxFg!+02@w+Na#p}Q?#x+|NE_0kPyCc>rta8gX zYV&JYv|F#)k1$>zOvYBKcp4RLwTf(n~V3*k5=7>OaYa7THS3mWssdmgl0K&`)HlYfRVcrpWt)I zhE^O^D@Xz};={gaykBi#WaoE|$EP4EUMLdpSE?1FtjbXc&o!tfLI!n0`m2$8V)joE zH?+Wlw8k)U_+mZyDgdqBM4Sap5^OgqW0Q72Y3iO@b~UO|gc@sU(nm!^=#s5s^@xG- z0TNdGjHCdZBJZc2qzGErJFEp1KgHSNaQU$QjElbfxnEOi%I=6 zb&$sT?^3)k#eb6GdusRzb+DvL+f?a6RlHA?7L#vCp#t+Hl#NGc1z=kU%TmQwp7^gR z<pnUVASg~=F z_L+2;@j~+9OG%C+j>KvgueQ|eDwJ_V8B-5mN{kJT6yHkra-gxZ5-7yt3FZMUuZq08 z1#zgWA~aCd4Me$r&HMc;0>7pTV$;69j*+kX)j)HJ4%J0LEDGOH)KD8N1yxF^gAs1| zhYzZQcdF6~b#R#~E+He9eee*h`+b^TMux=L8ycKH7aj|bgrah9Lynf~78Ie0*rAzV zh+FZ!8j04%7%My%4e^!NijXOs_W|&>u;ytMGEAdU-(icc9pXSPF^dqY6XB@I(dMeh z{!o3?!?jCg@@j(^>f_h*4kw&F=N}X!b0EP!7@$JPJ}-72cn(rm7@LSSj~0}0-(h>2R`Ene2ObQczMRgA@C_UFoPZV zyeO3~quVK6i@@hwmiHCCxRJs>M>Z|O(nl`A$|U#7($=rWtR6$ zPz)n9EnJwoD`t5R5q%rrjluG=*wEe&uZ$H=$A+FkK?c^#v4bDXU5LFFKuC0Mk2@wh zXzFW$A(tfvOeHYXSOptAW9ak>S{J&YyaG75C5TIfmt5s_O2E`bYz8K60%w{xLmFFl z!xFZGqlE0>gZYra#i(DB&7|x|6L7}3dg6=f$s_8iN7d65WbN$!VGZA&H zTOIqXIwqR&eLB(zY~<|L!2DRo6WEX7y=Y;Nx!J*3~M4p8tppI}$KGmS!NFVSnDz>9q%J+?pD$Axs*u zc!w%>s#1%{XB0Zkj*mJf1Hq6ek1AlOC!2&c?^$BLf$XPkj(W9J^-`xJPRY2WbpqK5(6@ zS3R*&J$a9M>IU^RXmCz#(eBgTkKz*!)O3uco+4aT*ii=~7X*9(-c_x>sSa+bgWYv- za~}9i=38|+wm6*fM8P=%l5@7`FCnN+X|W;Jc9Lk{pyE_4RqPQs702BE z51P5s@l=Wg{eLi9u_gWIV87)q=fc>qzOSh1kJJNHd{1qn;-cC?#qX*B6~Cc^RGgLA z^$RNYMU_3IqK~P*T`HGWn?vfsZl3AOY@3*!9cq0u=37*?qfDwcuP1Ja;cn=L9EHnw zg+pu>Ool|6G@jCcD2Kq zk=V5U@?O+Hq`tz#V}%#%lOQ7lWnUl?jKv0j zT-CrrJfr5(syLE3pN=TippQf*K@~da*VOhwm03dI8Hvljs7g<&QkE(5MqG*qrC2Lu z`m7W;NYO5Z1f9;C`@}3rXtQ8-_&1CDs z9rj0rwJ;;`(@Pp@l#H1_`jR)lxsU(M7 zVvz!Bv>~wp&L$IV0?71_B(VdEz&0{HPpd?uxiC|8ReZl{s{u$w(_4_|e(X4gIe!w6*_TvIR1^I5SJ;_nsY3UfE!n|)I zfBn9MawmwDOvJls)NhLe|1J4a@^xAb|C$;uso_Udv5!3V;U)?3C&4ne27(!VREC|X zG~~G5n(J*t_XCxLLb&Q$wi8UX7&Wv(FQwz5T5rTYIzxT&R0Q$EXbLalf>{JdBDTS? zTn!=N(4Y>I9!Oy|D`+(XHebjxwC73Y4Db5`mBKO>*eA6-S8W+IKbvaigATVES|nTU z{gjiOR=xlHNz%}0tF=mM4$Lb7gK)3HvL$Z--Ux#Th5@Ep%BTqbc z`9e50H{ByQLwQ+oi%v7Mp-DFPMO_C&eEVm3<==OmVlP7<*4ocG9Pl>MCcF&Yd)5Uf zLng7>MG`~dD`!{>KX181VOBJD)n&LJNkmLfh4B_5w5PLT&jZJ$3okQPRIE;`15YRX zmfPxNTVc-%t84xhs}o*8XXOQJMRNX3irnB!K)nal)E}qH>j&Nn!=D%{{42{H9-QNT z$@xiuP?85f8X3G4OU+%dys4xmLC^Q+u#mLniOqFZid4*h-IkB-x9JdX`F6eQRcC`t zL|faDFB#RoBu#t1gJ%VC2j?tL__Am#>^;JJucQX&zh=4PgL6swPCLv!ZrUp5#jdRt zaA|am1#n{x7KJuxfdb;y*m>Fx%R47y$r1;=t18iQca+a8@UBr2$Z~@l1&n(g8tR?I zT9`s3JzkfcBHg^FD@s1}%~qFiuMr@xO@BB-*wkWRt)&oo%e$98S64PAhAv%V^R@^5Re7RxiA7p@zr;L+DtfMqVC0 zcD#)w;6}B9wB`q_P$&pt&M?R-{NL8Vml^yyH8@G2c_00G25PM(7mN4c*_(cuNa#no zF-M*gyx!H9tU6I@c)6qY@3g&k4s}sw9e&UGc4AMmheyZH*Q$72lFa zJ#PotqK1|WjfIZay(050KyYlOr+nYgEfJQb8Ou%4BRm9yYASmJb_(4PF)eta$;S+g#^7#;|GV+ zZ+_I@1NDH19;x&d2>Uhm(Id&T(Rh6l4e#B`56PjX1}{Sm2porg5lCy&E<6gTN4(SC zI|nEBP4n&^s29vx_gqXj=a|1CNyR+ z;g@V0>>jZPab3aX^mTibg{!Agl5~eCHjX_Y;5Yj!cy~PQUt%k;7NeSe<9F(n7|)1 zmbKd-)Uf}d27a>!va*wIlGh&F&%IAZrH$Ct6SrYp$E&Pw9An(zJYgh|&){LHEY>Oy z)IiaU+%8S~cQOC0+Rpq@4g6jWl=K64`FAz! zzo~)0UIU+%F^@8awQ^A~vKPkGw7e-k0b|3Q$ul2R&(bor8Yb{I8GW}D>(sGZ)v@I= zKE*wd`y9RQaQ{&M{v*D}_Z~jt>mNSgD?R4hd!%#__F@*g@Qy&pR#@I1x&K{JZQCNY zE^mCQw)tt5h1tA-`F=sqNa@t zw#^DZ22qb?5wU6Bar{J^C6O&|JGRfO55WWykqZS`9g$Y% zO}vp}Rdq-N&ILQSyk3vRW53fLvBNDLa9FD%Zighgrekraxp*xxW|}JJFc)5L)#P^d z;k6dnYm=yI=d{_s!=N9jP@bG**459aJ+Vz~eNaVihvDMR^dZ1g%|PHSBp3lnU=jhH zl_8!&9GfxEOL0P&=BRq+ae*F@qE{6qI`zigf@oJo2Sew`eW0~7-1f`eSoEK|vF$qY{;k6Pmi_LEBo6DIWcR@td_Ful zKM{%H*Bs^BwNhMlRsvr70B0LRcmQs@gpt9y`B%{gj|oq5xAR{N1)^dI>i%mH0Y%lB zFj8+*ccX2&BNn+llW;iD*^YNjEu(6|N&ag(k?gD_9OmvJm-Z!7Lyb11!(XW+`-(CV zIfn7_a``Ce$@w9!hN~M1h5}dyS+5U|B~M^&1=&s|PVTxkTa5D2!i@0jtkE|=DXGHg zsq5qNh+(HhqxH*4Vsg3iCyck+Mf^dN-}qeO1{^&s*T8Qu$YH~;aJOCiR3ggA z@wJT555FgPsZYzhg+t<};VCH1w?n?t{6xXrA_X4GQk{>7Vy*vo+|2lEDgLVzcosjP zhBvCxXVq|})-!`-}xVu_50aTLK>8ZFw~A zDW*7Ym_o`t#npqC-?ni`nG230V<|gn{+3j~jE<*tJ(A{FeR^>2bG_vLowPh>Eq5BJ z@-LzI&ZpbOhUBN%M(j(~ZLsw- z7DR6XL=2FMZRT9P61vbr!x?&6PANeIi2$rS&%K}?TX69e9 ze^+3ac3Atg+Jy^m0j)ole^^WrVSbQESG7DT{LKh$(D>#WF22=>AEex&N?r7nzqCm0 za!}lxe&gN3@*)h3XLTR@Ejz~0zuPt&RhMC!_V1LFHPU|Rr13M13WU1F>5Vk?0bc@PApb>ze)I2AeNlFp#cN%?eks*<{@faklb zyQ-6QUw6;HyC5k?mDsW{{rB|D^z?N1^z_VX+-TYnOmqi}BL|1_gNM3{M~@sldZhc2 z;-T)t#iNHF9_)Su`0l4d>G;$49X)(#OTPH3l+dhpaf*Mw4ML^^4}cmK!}ft^RP* z(SimI)<6bbHUL}_il)Nc*wHz8%1IdT5z6=jiSXoD9i$IbW4}Kb_iqhPo~oOi7;8r7 zHe!5oY}t-*%G%)#T77+1(wm5;`@ujxOPlCl8LJyehkGQ`SVn{cfd?1>#l6~Q12J%x&L};po zC|znP6>hamwcltrZK7tGo&8~mrWJ$sQ!j+;m^@VvBJ}Pgj@7Lg39au?Hvo9mL99VJ z{D}wrsr0k7R+wEV98CCA;d>ail9`~@zZ0-4WQ8B_Cw#j5$y3z2o(4$+XpuQl+w|nA zTY;(TO{TH3EBxtnbZgSvYo+@98LVZ7%w-abtk-j5Y$;*9{Z=%Y@zNyJ2DEDnKtIyZ ziLiI8zn@Xdswmyf<>-NAJZWuDGP*sOu+m{~(h7y`Q5kBAT0Q znsgXO#MM`&TN1RAX|{jvx`RaJt+uJ8!N9j=GYiHD^aWx$-PhsMIbif_g zRJ5hS{Rvw7>daj>s)np39rQ1jgUB9|*h;E+ylyO#V zgl{|!fA$k!1G%-i<{jUsa>g&81{dd}B~L^n&cy_9eJ#K)b>UQOuK9Ruu3^?U=Qb~7 z-}cX~KJA}d<69WbPGqOn=6pYN8w=yv(V>SXl2bQD$FnCBa|S!wJ+2AM_0@PnI&?Bo zsV@=-&FBz2=(iIQk5Nv<-*=XyH;%He&(ncFf8(J)E9kSc%;TQ% zXFY4mSvUP-sEtjAQAgey|94`GT5_A!PZsP?OpZCp8%&Nh!fZ3)9U1Hx;+ANOg7*oh zXg_(@LGl@g4{DLs+a3*NB5FesPOVWe{Y}TJ)!t|(47FcRn_4`)bGwxa{T6DQI5vPQ zR~v33;zc&nsq)K!Y-JkFjoQ$xMjXH{VJxw#HW*m4O_OI#V(IVv=dv@t^V!)fq@H~z zyT?`L71`r1Z|`K8{;>Y!p7zRz^W+{+IlHH$JPgWQ?1v6F*6zK!=VQDW!xt~uxH&`P z-cH2w&Suhw`B|xa70piS+I(o?oy73`?)atgDJyxpFY&kU8OQq)@6K4R$S=pI?z1{h z(`ZvYQLBC7^bmnJL@m!kX{F^B)j7?@37c!nHT(fsoBFQhb{loASge+wN~F-EHnp0D zL$73=+J{{b(#O6LO@_id)FaP2pTdf?-|A1L{5yH$@FoZP0^!tGfNtFlPZ@x3>5cB_ z|1uCQnvQT$e7EUutG5>h-9Yl4qkx8d7=3)7moOdFc1x%W>d79EG*?*czfK)nuAZbd zx*KM-KJa=?7^V%%=l4nIp})7-cosAC^=|ZB(N~(~6-ru}aNTM!<$@CqVe9b9uAw$` z0?A&i>aY5sIZc>kQ#xV|Btpqd-R-JygDNal1+#8)?3#ncp~8{whxZk3KhnK_uzRS` zy|4Q#`wn6r_h?=Fzk%O>%lI&mTPUS+LDrXr(kksT8vMSjJ)5?Auy45SnjP9{?A%M} zh0^k-{JDHx%mot-kQQq?A)CH0Fnsa+fUUx_vEfgCxqCb@7L2iw;_N71c_B9P z=?CYhex8d3E)M@<;dEpsGJNrz&mW1}%mmxGi*io7f3FD*-L|}W686^?OkqfPFE1uA z>gv_MQ}@)HhEuCv{jXURco6XjP{&5nkzZmlF55g1kwn5NtO(WrLZzwrv7*0Uqd$MH z0#uwN9ZhB;wBrR~`d>gttvWCuSAhM$4I~Xo-V$BZxW;dzg8dbbe6*?4@`mDMa3Vzqs6r4nv z&9X_iHDYAra)GLQf&9E0{zVbYjbLXsoMnR$@{e)HD|lJx^(+ZU7k(0INYXf9D1)kZ|kkGm&C?O&iXzZi+h^O z@mbk{*)25^9_T)&vDnX6 z_eb_cTDMInX;Tu~Q3+8<)BYLQ6*X9#4ZZ1TUw=Yt{7+E7G(8aDKwM&*kl4bHRFXRQ z6H;sJfkA(UKEI=esCZ4?zkR)7h@{Jm)Sds6W|DZZ_8RQJ^?*$b-pj4B>g zxx6awRfUWy_NiSFRk%+T)~P}_DR#l73U#VL>b)6yu~$peIH!T;tOgu97;>B9x14rx zv=?I<3qJXLuU#8}w3^XGUFV~*_nXQwNP2VKWs_hI>`J{?bSmAr>#} zc2Cz3@95h*x|Y>7BxVZ6D~MNoZ0~GpY?9foS;ic1Txw=#+8JILkB??|O~gz$_jJRo zk4X`##Sx*!EjP^AYIpnKe7NF_6mBUPm6O21o#QX0bs8aqWj!#HV8ojW;}n_n_6K|D zDBY0WnMM%mpj^YM9@rAnQgo)pNg|X8r@R4#Ob8j$J&t~c&&`3FGc2> zB69}oEcb$MO}Up^F4RWm+;e2EwX`}i=Q@RdU&IIT>q3ui)<)i}c8*71M$Irjjt`Ay zPY;2Fm~kL<{8nY`*FYi!r4Ao>Kz(G+8JTO)p(8%DQx(H0-31E4IF^|XIjrpBQ3WQM zvQ>JFh{wUfwY#=So$Qzoaub2C-o#T{iTQv%Op&_*&n%(ikmF_izc}28t}N=J_VaS`hJNqDeoQ zF-*wbCL|yvV_Hi3wZIzp3V|O$gPQ_zID)`HFCj`QNW~ulzXaQF#jwmXgxMXkR)f2( z4-n0BVAiF1^&-bNfM~OgDxOBgvT8*tN-11j_ZZDk>X1$n`iGgH52v5b82pI9x73qVe5Z=}7K0pBd{d%|G^P}+e~ok%KD zhPplixi(1h4xUa0B}91T8s`2D7Z)F(9YkU7)Y0%>;_i;ieFCyMD_H5rYP<(x;U0WK z-C-iyhg8BMN#e+P_bub&3W1J9cTPm7U^E{16wlWxmEyZfVc5}Cq$l^bdb#nZZVj5nU1^x1vFGl z$Z99is?{Hg4Wu((oy>}=>}^8cPW|4Z@>ExKhS+i z^X~pkDuUep+I44@Uk9>p=%BLM4%RD5I1}L&r=``AXN0$cNhx+r^$0=f#=T(GxIv$@ zbdK^|{J{%xPC|}Gs++Qo;_NDvQKTpn4_=6k50B>Fj`wkvva{^VMxrrR25rQOPKAq- zSeK=D;L7VsWdEKe^WO;khRUY->y7nNc-2sIkyhSG88FKIP|8sUGg(zks1b3jf4NzW z+^&kN)W~v`YoP#_&+Y-pOy@-Av?;>2J%Qncv%&G;Xdo$h<^5mUuGRB?%XV4h}Ra*XsoC>TQOseBd9PU>3ZP~WyZuW9B+v-=(8`0)ILF{D)Y_MJ||DW#f-zk4n@eSZX5)Y5Xx zbJ{QA6G*e?rtXMXZX{RV0eGFiv^`RgSlPD+*do?ohv-xw8Z~Bm3o!{e% zh-;eqhA;25B+M!M@(mTR-aU>+uYo$-1)t_aBDMtyuwctobFWTPI;d6V{%#II!UpVR#b7?=BJil zf#MFK$|2)lG+)OsqLQWku*;w~W9dxW4jZ?&igO)=4Yyr(dv`$P_K?WT#%(H>5NNZ? zZ4$`K(ww+W6>kv4HSnS22^RID_W(8qv(aQqSmRk0hUDz5tz**X4~SQ)0EP-YrfeO-YGb)?G(3-UuzK zCs%^3HhpuR#=M5W-x7@{@Fo?dqC@c^rCD)$@K@-}nT#e9s51Ts6LWAc3BsQf_GjpQ zg|lvPid*lNRR3SN6_fs0-A9-osC%e5uXa%JN6JUV?<+qQXCy!WvWh&TQioLd5jC(& zrITt)KyBW@Jw1OD6=r9L+SrVt8!MrZSmH|3t_ZfJ4Y0dl>5gE4R!9u+an#fQktf(o1%`OX2CN#uO(10)v2u|`F2S38|I zQVL|CpSoMglXz1?vuW8;*>CWMKo4VPqch1t~4PuKE5?aLKI)(_2XTMr|hch}<>h^{Fk;w3e6^}2%Gpa{!6~$H5 zqLcM!3Z;^nl0+(`LJR#(wS8Fiw-9*R&L$TT!=^+&Q7JY{v5t%BFGz8%6zx(-W^CHr zFA+&hJC^mqKgjK`B!JfV7fN5&vsrg8n7f3$hr_{vSi}s@?{E0zQt9T1Bbdz&adLkc zwX7K{9m9Z4o$(hj=-77#cqE(QvSRj)+-jXz)M+C>F3Kx|26(jd`rg8A&SYmL&wD|m z>==(i+ysZXkyvLLgUs5j#=tlt$ei%oS;H@}85br&JS;m;Ii7b)cnqk)h9m?z6OVBO zA}oA4j#*Hqm|h<&x{15&a-tG20!W0DTX9qW$g{0vkFpvZiOBU4fd=`HB?w9?`4Hom zylNj%u&z~p5&UxnS(n-ji$MVvkc#r zEQ7wSQ1bPXD*U!86jkBNDmOrBg+h~DO2nZ#xBL8i!I_~~&9HA?4Ow}YHULA#L3G(p zZeNmBQ|fRCee|vXo|&%LIs*gILX`kXlNU>X zp>CU@AzMp?6MZtqk|n^&q9afBx~|FzvCzem+g#VK@-1`|LrcKp^nI>z`u;8BOwfFi z7-x-kQO&*uC7>VYzMxFXB9=&Mm9&$Kv{7ITP_UP7gPMmsV5UX8mGZ4IVntk(& zmMais_hVOG#Ca%=MDNKU-gyM}be8RLaFXi6tCLk_tJCVhvk?)lC<2B`Ob2ViiOG{)^=ZfEGpfqXTJK3p9N|AK|1P&^--6Gp6=k0 zA>iS8%N@KZJ`D2@@%+n);e~HluITW5T)vYIbB~Lri?K0tYZcB}Iv)hMp$dzeo3tPW zIcnKg&>fa%UiuOihdisx;nIdMubc0Eqb!i+f?f(3^*A)tHwj)?N~66Vr+xFgWlvXl z0Z05BtuF3l4ksrZCH03RKu1PWlhRs^i&X0NtO{P5uvU!*=P`!HV&Q0Pi(YRSbxUzP zw3eDilMbtwe2x?T;vE-Wh{7>sxy4T81=Sx0$!~(9f|hh`JR4ZN$4CCbE14Z6LZ)}uWpx6fW%2LqT`6o_&Pvi zj+-!eMr8@Z!x$etrLu=9qV0>z2$E7AUkMV&ac)G3XGgvY9;kwn7H5KB6^jdLY9c8P zu3TQNl+BBEE)y7a?8ZuI+lYh91n1BJ4o@K)EvR+l{I()*L!lo$@%KtKBV zx9EsY^lN2-->h4!EVqi)^X$eQNdJf*(jwr_y{~?NhB}9 z;;%A~Ub*}mi`HHO;!$7eep%GS@J09nfunFT0%>>Jg{KX*i1*t2=5Z!|%e=D}J_cjf zyou93=ffE%DWLzG`z9x;*fW|Bae9o4^?oqoF=Oye? zzi0Qdn0x9aK95V)si$oMd!p#R(e- zjieWES`h=wixI?G;+*KJkYmx;*lM09OP3?|39@rO3Y!lS_#qRpzxxYz2#o#nD#({* zLi=JB`>ZsRo4*rbsn9O*7WC_Qojs6aoav?s^KunDES2J(xl(*3gL2Eyp!iA#CC+9L z9)S82FTj}2YS;2Efw1O3SFq;C+{FB874zdN_=75Vz6$gTZ;AS*v;zL3Ta3F*_^;5&clQG z!H17@AKZ8NNcUjjKzH$x?tMp!BM2W;aN9k;fbFn6y%GdC!#dQ}fswpcf~QVltVN3V zYm$JZS@M_*(JjBktx-BBKZQnQe~a4Yl-+Cs?+4pdPMkKU71H32X7@cie!ZFVBFjS( z+q~!aScfN}tuFftf+r9_C?r-F@UusxIK9+`iS9*rhBTjZhV+q0NJFo4C5L>Yxr!H& z+@2G$Z)v0MlgD_kJ!B_lI&iG5Si7CP=$eT{;qjt;5J)>N+uKOz{TPR?{K;&cBfQ|_yVSPLDs(FX8(04TQb3i<618C|$?=a_*^K`v>OmMWIoz7_ z-Y@3%=F{rQ$Au(Ih1s}IzL0i~3qrD4Z{8{Rc9r9Zz&J}Mk_;BD@c9=kSh`C~^(t$2 z#exlKO@tm)*W6GUOl463@tYN|h~cFN)ixi*%OZHGp(+jWGjD$JYSI{hG?H2xli->o z0-bWXQcLlJ1=g)BY2RlktDy!k+s|)=zgD3rR*I-?x2RAnbAO`Ye!6|-RhJuuX)(@e z2{Wf_7Wx59&HBwu&0bbRJ@A{ITl8N!x9#G2%<0-=wOoE)@g{vd`(ki-;Z!JspS6^3 z)sA!Z8OfRH1)XaM;3d3$b_@;AFT9R6csF^1n@v9x@P#E<)a}((I z56+K~HC&m9Ki~r!6yZKN9zPD=vND}=6j9Uf=+MR}J&~Oi9k%a}C*`tpW@=?rUTEy( z7<*Db6g6g}dZbF?DvlSC(KwA{*T}A<^F}lNKvZM}AZv3W;$~;N9qHYxT`FJc6zUgU zE>|DuyU75)13%gxv=a2%)XP7*3c%^cy9$%T9ODhb zT+e33O?Zzp`R$TK5}a_nz^xhl4uhO&h4w#IcOKz5xM!>KG-7d=T>20p1=9jB*LS{2hYBw$f`5gkD8*%jV)kSyf$U~eO z+V8~WwteGXe{#kKohQ$80&3P*`OQ-nDJ!|rhy4r-v?EICj_yc|ik13yeNX#@)&7#a z`rtF%+Q39$>V`<(|H-92?We4EJnzZxy2OXG7j&C(pF5K8p677EEjlib>fN~nUt1<{ z`JdqG;fwFsI9&bjS)pB zY)r>l%h(Q{wsR@|Abv+jO8FQs{yPK~s&qqD?0T5uGXCu^8at*P+gQhleuDePE{{7(pDiR?ZIN^t{{LEs^%^ zT;Q7LseS6HTh*~Hbea{QjTe`hMXHA25TpB!8Hz+mC%VE1j^I|dIG lAIE<(;n2b2p?yb&ij=Kte3$-wpZ@&7c%6j%x1WCc{{fb=NsRyi diff --git a/sources/SEDIT-COMMANDS.DFASL.~3~ b/sources/SEDIT-COMMANDS.DFASL.~3~ deleted file mode 100644 index b1acd733dbddc9a8984b0a520147264fdb6755ef..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 52737 zcmdtLdtg=Nl{dWiKIeoagcxFoF(Muj5h$VJg<7?EPA-s>oJ-6F5YQMPdU7G5Nl@D= z1-xq%18Q@;w%TIaI_=>|Tdt<9t<}yo%4_PK-r zI@9m_$mWCWBO;hgl5jP z8C@VRC6;54J~CXqA{4HxX|4;l*42h%HI6m9Yq(@lODlREY_6>eMVs1M7mW^=EcFld zZ>j3-ys5KS=4Z2mDn=g~&R@|Mt!WL#qN984?atY#u%xzbMJQTVCH12CidYG1^v0U% zqRw;_$cweLqRKo33u;5nbu8>ujPCJD4Ej;q8mtc2jShRTGKiYi6s&0suB;o~;~CvO zT!_luh>_9ZnQQ8rV{16ev1nB|)Y60w_&D{F|Dj<|TT30Hye3KNv`2^YJ`>&A+k2aZ ziLySHnIp~(Cu*F*Gh~`H$QjEDmRM-~l1WoCDESi}nF-HQw3?4`HZ{kZTIMGzOYlC; zynD{VOKC2E08m=;5M3bCR*S`G;o{_G@-D`x5_6EPED~(QG-HPAqN_s9v1p_&+KM?$ z6zIeyrc2J^#A)&PPoTX`eLG zg1~egm6UDKdJ0fyNS3_?Yg}rOriy@2)zVZ~Gm5n~%es5GU=dMkMRZYO8M4na~8ei7Z zR^8GXYHe$+n4r^U^zw7=}pa{Xlr$_WpX)AVJI4EWoOx~(`sVTRdvm+ zRc%cxn}fCJ*Cy>(!RlbNwMs^l?y67TTFfg}2So*MTQR9J!jjc7AaHG6I25U>smFBa z(6MUrRuiiQP8G?zw4m#PB~DEBeNxlMl7$2Qb%{=R zflCO`y1Kaz-RSS@yxG68fAi*!zDr9DKke~>nHW7T;qX8RU{eN4fv-{n^ZF>F~%FKZr})&Af;iJ zaTUywj+<28l*k#HDdEOVDgmHCi^p~MtmC35l{-zK7+YzxSyy(hP)Tlj0A-o?NyUq^ zXsSEhY&x5}I%j0%KCY`3>AX`Bj9HUY35D$KEI}+lc@_AN9L(EuAqbUcMO1c+d_fnX zsw`3YHWk?uT;>NiYp0PzH_Ug8n>@27_P1a2>7)o!Ud(Y&u z$;qw3P}ro9Uvp`NqQ17{QU$X`G7?k-JN{&PGu_0>F2QWmL5{h-=`M*al9i;PkC}>P zU(cDp-NSixYnp($Oh2=3O>1+o1{ABUxml(=w|EgDEqfC31++3#&L->Y!cD9#UqYEg zGNV`9hl}(TTYIocXL+W^L}SenbW(OXW}L3knbj!Mh!)VX=DMnC^tZ82>ohfB zAwbx;b+U#MEzlZktczx1PY*?b66ifBbf_w;9~CA+SeKCL3Ff3uyMs0)Ve-^?8)6~h zPB1VTaaBziJKqY8DPv3)F{rCGDW@?-cnF{-`507i1|waDL{}hP;!I6+0oE)~I$0~6 zRHl+;vhkAJcDhiWvPJCu8Jy=6tUnlhL*JR#i`SUWu-jtQifC0d7|{it-qILqs%ni@ ztqdwac-x|;K#_#1474Sdf#0=-NgXb`=;A7fQdJ^IrRAtchU@+)GMq>Zc3DP-Qi)(A zWGRo8_}J+1ITTNt(S0noU%*^;v*{*w3CtxbSgNL!M%kTBwA0s||V3Y$YK>)l+w#7@X0sqH3hx>R7` zU2_*PcRI?;{QKPo^IPhgz*PsE(H>J?NY|8wB5vZ>-NZb_1vma1Zv1J)lqQi{h_r5o zZ@L+Z49pV8kcu(R09XUZ(j)^}g#|VJ`5Irrf@=4qqG9_yDY?gChxcKceS}CRU67OX z$Z%eDChhu3X+EwWi$U(nsuBAHld6KUHqv4M>1^&<%p7(T^j|nBnfu2W<5ahd4m;Nc z-F#m}EZ$eMUamTr{?LjXu4ns>9a6b-9qK~sY`~tr9g&FjE?q3~dBSXKe=x1wY#ti+ z1*>Dttyppoq^978{(&I~g^{Y@=0KxK)wiktW`F;d&OYggbKM&40c!-! zkaoDnY{y4bU{{Ky9shiPO>h4o+Vj;^MWn?ACunh_WXoz%8k5;|o2y$BlD#2oSRC9u z;3Vd^*lkQzNE}|x=_5doYh<9ihNl6@L^$W_n;B)(OSI{7X?n4% zyjnbI#OTCDr|iUu#*Q8+xQPZpSJo`vwBQD*#>W`ijxvE9HePZQMFA(AhWSPm8LH{ZIvN8Nk9Bt>DnW){R432Pg+hF|393 z0kz=w2I+}MSI;ZEb!O?TyM?A=E{mF>LK^_YX%7gUe}p~=#I9g-N{B|boA&aWJ2&^= zovl$6t-;LFgVmTv~@`E8baUb@Wq*^ z>=uN`oUC$89tz`kP^R!aox;Kl!y)oDQmpT@-Fz zd0~Bk^HPzyF4lwt!+7V!w{gD?GeV%=DItR%}t_8kvA?7On48Wh*r8C+$5lqW7H&bY2l~M)%}%S;kmpUfnHQ zK(bjWHj;~)J8=Xcs-UUnoOtB#!m4EYZq@;1(atTxAb|f7cql`gZbQm0e3>mytGi`r zpkt%1$w$$odH2iCraE}6NE(AL_iyd{2WqGj6>HbP*c*yZTsZ1CUc*GT6~I)VX;OxO!tJ z=5N5%iEOB|+no;7qSNthU4Y2eAuJ**Tst~^c~gcUccigR&>zggfUGtkcFM&ut)ULI z_G$E4HKlXNQ@7UFwTM=03dvO&n4+c**&X7YgI%B2&MX)mJ}*1+q^%+|sPxB{>XP`_ zW)2_oOY(c@*+S-Ac43CcvA#nvd6(1SyIR(ovvC3TNxq%5WpKR;W+DFN-~McG9`-Jpkt+@oT;$q5GC<<_k4h~VQYi%t4@TGPd-Nycd( z$95>SdV<3*Zs{EIHw{1~TUFg593FO_>e1nIC0bS;=V(aUfFwhj4X0}sA6YTp4Y~@& zqH?8r9xAIA5jqWFe4I^9XHy*;dpd5^cA7?q&q}wW@d9^bq`SzcqHbiu?-p$VhaG4k ztuiujozUuoLqi=K=ZWEVH?L*b60JU1Ekv5{UHk zcLsJCM|el0dPsciIFXg-T}EWR4DIEJtm&hbY)O@%_hY+=&u46DLW0hPiOX2~oGgKu zwez%W%}9Moe4_)=*iL*Layi<;F^50rw8l=$!_G|fI=aR1?PSI$=YFM2C!d989sJp!N;H-9C9d9> zh{%aaUNlw>K5$hc(v)bd=d3NSNi=>U5xPWQKAH$EOw`Ry)SQ(FmL;y5k@!Sj;!4ku zzz$~lYWaciU6g1^v?kgTs}iddYZBKa)+W{^)+eq_Tn8##36t!HbCc3_PM!;9YvOP2L@;VnU+n*#TWfYV-#uZH{mP^yEIwnV z9IySQNxAu|6a1~*q^t?H#JGJ=QNf^%(=YUo;pM6D_2V}QRm z@fY$mPoq}`q1YM;~0(lxdssKvSiJax9iU02b|Kx`*T=F&)De zOMIHYTeVjH?%=OGUb#l*0FF9oU`M++R*%+Ro><02?e!ssb9%?KCU@FS z*{S7 z^{Qo_j(K{q@!ajk(VC;gO2o0z*fhjX65QVXTKctmr25VPcfp?5UyD~(R+dPH z>Zb#IAa#3?u>o|g3tjV=u6e-+Mde_A*Koo780{4xjNpV`bfD-qP9N;cWTOn%MOU`g zdlqAU3wUHAr4q}|=3I@H=|cw4jR9Obc>r?)cEGVQqT2(GgCN5@5jD^Dlmy~&d02_= z+&S~&{5&i({zRe&mDU8uu9vrSHaO!tRNeLMgZ0i@`*4F}9|>}nLO-&`HPl$KYAMiC*-~YkKAz6%0rl8!&ycaaHN6%t6fQSur?rF;)gtrZ_1l(T(<>NNmCBg23aB z>+xfyW?jwh<}f)miP}e)x-$+)TzWP6E%GOs9|5g+xBOPdD+{Hnal__Z9jqCt-5&p3 zO>LbdZ;w|8ayK8vBVazXL)80ri~8gH`ZMPJv^XOc#7tTyHL|$TN4Y1 zF$2sY zeS~=@giN%T?2eV()7XQTouCzax=?Yf_^C)^n4~Dm<=Ea}nt7ygBz||-ov~sm$|N=? zjR_Wlc}{#1b!Sm77Z80i=I>%6^COLV6eAJO0n%pH*5L#;+7hOnlG^=9+82|>M^W{%mMEas8{C(yy;X{;24l&d8M5n)xnvi$7ZHgKvMKfsm<4{Rx(kzfU$rif zOxWWD`D%r5cli&P!19A}cjYa~yl!`6vdmrYOdU^Tc>D3>a#MM#DtI`4Bz`phV&gO6 zJk}?U6?3aPrMVcLz1;P^exz5(+dB9Mq7|yf6u?Igp*VvNilJ}R=>lG& zkA+M-=GTYv6F+rULsJ#%gUYRIlfQ-fy^OZb@2~0TyI{zFobl6=)1jve_4an&*wKqp zt~r>DTokRB`?m#`0M7?u)Ov0+XZFC=#K3yHY|*$0I(FHT@h+iT7~L$)K~ohWDa$%C zvCQLus14dq`V3Y#`Y%8Yha)sMe_~kyNA+u=$U~sWXJ3z5v)J-RYrIRzG1d`eRa(Ts zZ(=ATE<3XlgUTrXz&R~(i=DX1qTG5(7N8OQSmBzzhB7mXKg?(NmeJu0AU3ZI$Es;| z>Bmd9Iat=oGWKfM^mGYOd!}qmwXvEu9Nfb!0Q=!g4(j9Vn)PGvJS=y3h(_*HIMtdK825vbsaZ6F+7MTGd1YbD8EDUztC~KV= z{7~0soO$HT0VW4lkP0V~adX!uSi<`^Y#kbc?o}pcF)Zj&M~CX;xm7J?}i++3R~J(d+d3lG61X2hx zIVPBuV%i!;8sPpz^-}FkL9=x%W*j;g`_NSAdW3Jez^XbP;ySa zy*^mYSvnkgxS?_Wp*tGmm1`jy97w+D?uEC3#dZZB?1fXzS9+#Am&ooEY-$Q$LlMVQ zAm%ftwOkW{4y(#lCPP`c3tH4rR4Dhh|6%X8eVE?KEP2Y^uJP>*)0^NL>5VMscJwH2 zxRXjwnaiupQ;xF8u@44CI1JTr>ei;t3^a6gQ6w3!C&&hwP*OWmvpxP~AXvR2e|$sU z_y+HIax5nUwGGyGk7fBX5SigNJb+EEEP&D10=^p@yDMb+#GL*r-v-R3(EtWHpatCe zox=+_nEMI<5@Hq#HDjcybv1MlvDKb4Sm{^^AIFps9&^^i27KH3+gkip{%F6Pm*NnA z363>qn8+23FtfDd|MOYe@nL33L~s%HbdGdlrkbDo$wYV-{xPOxC#K|v4+l7B1R9hs z=0L?1VDpun3<@?oKg@(o0-Nh~O0Lq!MTuSom*JC72M*+B0T@057}<7PHk9DtKtRV$ z$bppGF)bZ`v}qXyHYsvVF(bEsm>J0ik-T*}5m9+qJ10-e11Fyrn9O|mX}JT_(qyJ3 zLs$;<9IRFW^V;F+`Yie7P~*YmPr&7}`*(OVIuU59 zGUOz4p(IC+v7_Ev7QF8&>^ucg=ueDB z<6TE%rAJ~VhhxQulB&P7?gZLp=}d&s$`0Gw42>PQ04juJ>?FJytsaP>2)&_b8=3X1 zuo;6tkAzxq08>*>5zM;tEFsCbh)`48?70D(wHLRtKG zh40FVmA|)R^M*|wVkbfyV(CTBEdb22gL z?9#xgXm;J+?lQ~uC+TIv5@DsbhptNs6Qs?Pq z+_g9Gah(GEn7#G*C0lf=CCgl~ki}ztIK!vxHO0Dpk{NE$mAV^3ZI_`COCD9_?YMal z9B4jR4ZJwZs7kD-a&;z9I#$#`XR5nP^4xUj48&H4h+pIPq(dSgJBg1=>(Ybm1;_Ckay1l0+6*`r{iIrj_tb1JWQJF zx%x^Dcc&`e9yS||_gtNX3Vq}=@V> z7ln*0>AeQ$@A#lIH_~{wnMH5zEWZ9nn#FrR&@66~-g_2sGOZn(IhKbv^08yBzBS2~ z)dajXTUI@zZ&y%ur_*QDnkSvrPmK;Q=B#e$gchX_2G$>FZtpX5`~C?|E~*KE{JGYC zG2%c;Io=4&og0-+i+bq0MX|gy8k%@4U}nAWUF?0K5`B9mpLgSUM8BFBnt0sJQV@PePBE}K2i)YscX!81OJb!Q7OGBuNs;3|2tlr_2-ZWlRh3+1 zT{7EgzJTR_NSxR*@BtUHz1YTP6)VPymS(SL+3r}`-LaBWu4ow+Bx^-W zC$A{iWOg{SqG6N6UD5LKSUFd;Vo$6hd1=|!Masw|-UZ75b8 zHk(Eit8MTv4=b+0R|?w8#^dc+isJSP1S-uTYx``x%o!Ij0FwLn#Qe!~00H50ZD55x?*FM(`qmg+C1JlFXrHNP>+Uk-<=b`o3 zT)}NWdY9bo_PWvSw65Xs>8D&nl@AML_J1SOY27J5|H_$tPJ)kU>=uow);FH>I?qjo zqh2X=l)1TN1{>FCOhg~%jIvMw>viP_E@Pbm%jwdfF)8oiZ-xB zhNc#@&qo-`)rjSq4J<`lUDD|MoHaY)ay?LX%H)TA{V(r%;rDA7n5@J1w#kwGelUPHdF&?ar*T>@&%w|kOhj8Cc>aiY# z?%UlJa!%8rU=^(tWK?rv;yD+@zqGaW8eHUL5)QEC;_GRM&cj_jC}a(XWGhpC%sva6 z{23Jn=XdGJyuBs3JD5B>z^<5{mcx!>$Lb1lz8h4=VXxPSC4{}U`@MHkvvUT;!X&xl z@sft__fM9r1%n$a%F101JtNZ}Hq|a)ubAyU8rFdIq6vt=YBB}d)A$dpHepN9+=Ly# zQ1m64-PG9;O2ZS0sNn~a%c9EJCaYp)n&-S&sb&Io-yToI%3|eYh3}1(Y1ZwHN2*8S zcZ7vdoot8=J?}g&HW<|gzXBmU^J0055})8&?<%s>Yn`QhAUuIRo?$MZyF!Dq%f)~a zyPM^=OYm9-cS?}PRGtMA3`(qLp#28k2@l#aE2k%@g>g4SO7c{LLx-P2e_C8^i?vPeEW zzoadS9tnS5N_qB6`sXsiT@qw(tUDMSyG>(0sSk=0&M~FG$F#%8gyh<|r1SxWgN;z; zS5^5t>-0@xBmYZ&Ajd9z?gfcz`An` z);$ia>v@d?BDvJXy9F-ZVec@=Nt6@0>HjU1d+5K7a9*wFa>MBwB@lf^d>g4%>oZ3tu%GblXYIUXVtX^)a{8?`w4LkOA*jb;< zQlr2aBijA`q?p>r-Dqk&kt@)x3h!<7P0ae~{FH8R7Q>OhbvkgI~r!`%SY zUBgI-0q8Izu~l_fogrZI3eA!1BLsbJqR(f7WD*t6b#qBcky|8#wOfLu2@Yd7F?Nr{ z(o#%|sp^#V>P9JfElPpbBNF^Ai#;g8pGuIGSwD~jr5M@S z`}I&O2+Jn%hNYLJC1LOA@M+u5U#jt$=-td8?LRL6(%g+!s;E5SW{XtomuNt);?kBw zy!c)2m+0>vR}U=APPA!Df$g{j0ygr^TQFPQG9cqY>AR4lmkveiQEW<1Ut( zg84gg^@-bpa?@Wf2QRq@R&ayvh2q7~cy5xq3}>)g1vzJZO$J5DVH;axLo((aHG$F-O8=I3{5}R$e&r=&giJUVU^T+1SN1l6PbK{lmev#&9 zJ1Cp{u?ThD@?Q4BIYuoX<#3?|&}U6-j+li8Vr7cpwW;%B6GI93LIM6C9a_=ddkWH46J^M2|~SE*AJt6&3;Es67_jmIK7EwED95i5tf zp#nwJx*d6BCX(|TAC8rWCU8bDJ5~{Xe~(0lW2LXP``2T|ub0I9cKZS|;fS0&8k-lJKOcGSiOt7^&y!W~ zJ1DCY9-9L#=$!F=|7A|_cF#JI(S%%=f(Ee;W{$b4N0&4T^8xEBD2{2$tfvr&vq`R~ zkhGPV7gd%DCLU5mO482HB{o2U@e2u(B06tMP|q-)m7tzu{6vChF)uR|FnAcT*6+{* z__fP&Fa#Yojnh>!cpK?75Tvw_oA%F0g9FAe&DZH-ry5Ql8@1p8w(*v%q|Ru8B=a?!{k8#}2F^<_eMjGuL zbG18rjCSWcCnpNaU7`?pF^duut4c@?22Vl`O4G=#>NueQiuKPzv%MsS&3d+hHR#XE zM@0=cA9?PH!S=qrLU(dV*#c{2KyITYDt%#&!B4dvA2)bj6Dt?|HVSYeYkMV{0MdzyGlG{Xr<6{5`M5O61rI?_q@6 z=dK4%2zt(~7{6aLXlkrNa8-31z|PW?!Mrk~=9qDSQgAjzV}J?S_h0W=0tnWg(*HK*l?sqOD7AQqIoGp7F>|za114&z zILi!_FNj*!@0eFm%bHLt>thn5EX7|Xx+URztXdFFRgWGb!8aNEONrgiB5$?H!y5h= z-=6!ZJ~C+Gt!K46kh3>^egvAptUk;6kTVOt zt;jN$RA0toJ6RWuOqWx61YtSZWI30NK1z$rhvSDRuf!`4chmm=dUV%XU0&J6wpUkF z&h!+-iVyZ#j{uwNU$x@OgkKx4e31orPMc}R4;l%5B)UERLYZ3Au*+PBq(9O)@wCQ< zUD@Q`NJHfz7?m7JJ`m^7y934Jx@?wHDD-*}tUzn(tD5WJ5;I!WRI^BC*i+<)9p3Ck zFdl)^4RNCiABDAHIBJw@#~578BDluEy^2NAFm{BiSA>Hr-IC%a_q0V&ht|}=0<{L$ z-;r7D=O?w*8Z#w4${YV4Iyq_kx5!$us4XhCf4D;rSBEvNCg*eqt08&RBtdT6tz5P& zPZs|{O#F1-;%wnS8Mr%fJyotjzZ>;Y>^mm^sp{)(S zeN|hxkewZ*p|v}x?RF75r(UO2nP=lH#3A^5ZV*3g1?!tyo9o-6jTh;$(W7RwI^96N za#I0Umd)90dS6B_}bkK$?|kkmV});+f<~|I$>7#ig>cN{#9>k z5w9(vt~_E`{s}NFd4?+6(Vq6EkaMy&wTg4Zp9bs@l}hW49y*7eHd|9DV5HQ5(j>td zRv9lVbXir`yzJ4eqkCsc^D?;!V=EAn=#s5+$n#7PaD>WR|4V`v>G_{CmbBUkgmUlc z91;b1qYmrcJz$GEB{#Hzr+=OWVEG zGe?NWawSCW3zkZV*4|lKOTIpMyahqf*~Z&fPbkz_ccs^&2n(sac?Mc!Q`m|4L-@y= zOCbCn0hQ}UqB|S0JtQv-Kc(dJ)jWlW9bHEv<{E2Zy&DN@mctR}X!3iAA@w;b)F^*E za#ZM1M2W5E57UI$VvsrLeVKOv7*QeaJacB#7^`0|=puISOB)d?T-}Vzz%+F)W=*?2 zt2q9#3VB$2RqP+5skuZzKP5=2z+V4qzClvS?433lGZ|ZuLCfyZ;bq&-Z=wHb|IP7! zxx3=@=@;=!z&t* zgrZ<;D=yfZ5>l1*)ezzp1U{j4Um_3h1q<}ekK~yEA1x!^hNVujZ=QwuQo}u<>Rxe0 znpk!#GM|aNWU&@*d)iuEt(I-M8L4nJ+ENeCuq&cB;H|j1t^xZ~BpAZI(@2XrsV}5A zd-@He9OYHrPueuh( z@eW*%(L6?d@tCStE!R+LdHR;Bo~C`o)t@T8^&bia3|Hp3+*z-;p?Ex59ZFs0=Dj90 zx5W)Z1<>lMT+I$LA;vXNyODt|1rbpR(q*Jvuv5RP9{LjHyYZ3B^?J-ByEvd_DuCh2 z&D~+&iX}Ns4D{#)q{@^p(gR{wq~nR1GuAAHoH1(Wt-V})&;G?+{Qc*m9`!d&<5cNP zVi}LooH6C#^_r+>zrt=>27KHou3ZE9lPj((4_3br)T_OUh0T*rmPz$CDDfLru@bi{ zsvlGJ(T2Q@cxjn>W9nCG6hs>XR7cj@C@275zUgy2kuYqFvY z{t~%OwbguKhbEx!xN_3_;!Lu3?rdZ_)ST=IF}GNaZT0y5 ztk6UX>^O-Uzz=TtE;8OS$nsf_JB}K60$6-p=WObdW84V^it7*wD3$f5et(4|%-wMo z9yZ~|dw~SGfod>B*ki1rBa&e$;fN~Z^D@Cw^t8luR2-O-<&^Bgy{R*5lZr^|J=R<; zL7otKYb5wjjAf95p~n7Mx)Ez!=*x=865O?de{j06k#dJvPI_cLmkB;DL0j}A)-J$& zQA=58!M<07d)=ivQkJB+(d(KuV$&QDk?pntH`EY z^9>f46K=zo$kCkjOeXdo2|Dh5UPU<9L{@eK8@}rbLGR3&uEc;I&V){SaO=jne~Y@p zqBhxv>egN&Ip)ASnt#E~@h;@p)Q^jQeYpLDn}BY1zic)OnH49&nf(W4t$&BHyd+B) zTI+Q9uO?@F86LT|ogc-;O>x2{v>8_Jraw@a_rv-f#+QaLPnl&2952Jt1M24)QGC)N zJr+Z{!GTemb&1*HrzSAC_*T7ppY@Q+bxK=Sm&F@$%vRPBnNu6%N3O@PCdrl4A`mP8 z1KOy@4548Dc;yks?3{LbmTU=&E&F2s25;*0>YleBtL~lm_DKAm#*Jln#D(mye>N^; zE42}4QN4v?$=S6LHc7fOOhKGn_9fGFs;0Mard_~@>f@7@UY(viJA1(9&QYUzf?Pm6 z1tder1amaO)98wL>?;YhV|I<^LsGBTs;w%gB;9cb@My)eU zt@uhxXpIt~CklOPBLX6%4CIN3&D#+NAA6Vk$+&xcml2Dqgro}=rJeAljXQV=+(1$xx0UJ(Dhy1T>nfH4==|yn zAngY9UarybJc&Wk)+>8$3(0TLLOY9>9X8QqA}|?PT70Djt}CL@QHaa|DxFy7^>Z?Q zZFI_~^Ud5r8nX+;>6%RByIH@KH_h4OA24IidP0kBA?#VdIKV38qds_9!WRO&lW$1L zQ$_{Q=He6a+Z7oCu8MEDd(*&jkJX(c-QtYmDVLceR^prmT*v4v=zCAylycs zPq(*+U%W?iyi#CJ#d1XTMll>`4X@;b{6Ni%j($jN z_6ze(+l3s8(f#6ptua=rB!WuDeMTK%7>(}8gc=WQj~LD((qm%OoWR5)-wO*2fzhFh z+8}9svnY|xuqIrnryyyaifN@)n8G=cJ18X;xw&do?&>j%5&}X3gVyiUd98OCq$1*1 zvXi@>Ez-w6)?Z5whw2Ba3aqCEqEakJ8#D3+)>p1!%x;np&%zR9vM-e=RXF@PYZ;UG z!7AxlagT4=S2IF$@-o!kn8a2 zC7{t2_~%1*Z95clphmeXWb4Mgq&`8+3soLW z&M}dz-g|r0jlA0pG=wTkLXMQZJLG8Lkw8g^+Bd2K%*KB3!&C@oVICi*qflHc;cotl z@Jdf!g50q6v~LPo&5Q4{G;`kO?jRfZ7hK}MlvzHg6^U;FaZn&p`z6)-y!?pIA1`#u zR6*@!6)U%C;VylnF89qur{q4CSSOE{m~x8*AJT-o6YB;v(w?s#C~f)97`z_HSL1lo zu|+-|mscaK-sNU-KX0hy0$JR^GyCj0JqH7xM8G}}a5h-u$+939RMlAUI)FH(E2*gMcX^|q4GRAsQ<$u?xt67W+1-+&khT$g1x=CRjmIq@dsSAEO` z&7Dm6+L6dzCYY-2K9~%sie}=;>}ryWf`)3l_Sq3+on0RRlx11kw!bzkV6C&Hng#P;g!!!~Up;Ti|`X^2s2*e~L2?F2&p(R*#-H2PbMc<*`^CH@RHR2Y)N0@!VCGrDP7>|F6Yg+mRqpABo7qGWoA3pAJ#&dBy? zVR2G*PxxZo&k+A#N-yO4@b+*7H6Q@uAvHMIYGWl|fNezy?)i9d%gVmX9Q)R*uP`J_ zrsUs5ofr4L-%}rI;Eh&PVV3+0fP&-pI(*hC^Q}Y76qp~6OxTxz(((by`d~}Fyg!94 zD}CiMvFtP?pGLj7WKhRK9xB4Eck`hgoZei=1o4n9zTCYMaL?hN!Q9RYa7OtPG?-`l z`3#yn4m3UZ5Eytib#mB3AOV{u-Eit^ooQ$yAD<3sT^$Uy@@lgAY>?aJv#=EIHf&Vd zvEH!OmAL{yZKXPSGz&wr7Un)dkwoHY7a^!-ixK5*0b=7cig_e&hF>L-&av|~?QDIN>7!5|jyy6( z5MMM3upgKqPL@xXXZTBZh^}L_v`f4~Kz>8&9K&AHh!ZCV5198tg=J9Ujiv_gbzEm0 zV+MK}>%(R;_t|F~zjl-3eI_2L^#j*^-s+NxRDGbqoDVg2znwa}A<)=!%nW1I&$24E zzGq4mIS{hH)d0O(rd8{?#%oc!6+C2n@t#<5^7L?o^ilVHk$oS!Gt%?3qsgB~x{(Eb z0fuvOnACr02t<00Wm-)}yY=LJB2}ByV)9ZmoYZ1;`ziD~)0^a(>7G8HQ^=j$)U4H| zZa53nGRk@n&ugiTH5)xVm#K8A;P=J+DfaqF;71mBTmZ#G>!5@Ly z0+p}^dNV>Z@Sw^&EU`0~SAy2Rr;AyyXMzU+=`$nv607Moj@xVN)~Mmo!Y# z;M(}1>(Pd_y2LdkD1{+`uMrBLdta=^PUCuO=!q2<$1BwaVdu0NS?ZpK?eVp^JO~#S zDr33I{5W(hszLdU(V+a+@v_&ybI1l{X;f76@_Pj)j|#J20x%sXR=dE2eN}`RkZFG3 zE!Hd*V?%M2UJph&A#ZuFWIX)AOR__;!Wm=hUXL2}dwpg)_JVFVs5H1HwV=Mb*SWel zb(u@Z$rih6s^$8YtTd^|9cn9GzD!!R_JSs#WE|<8?zk<-S1si|3s{Y3;R3$BRmsPj z;>WIBPBhg924)ga)3{$H^-$&P96ML?I>%1ehy4j^9F5r2*8$gQ_*6&#hHiXjLu4mW zLAuxHpEK88o-`%_9PlQbxLRua;VK035Ct#0N-lI76h;mk;TVU*EDN(yW>SSAqmG6n zIPH(H1{}VF0)HP5PiiA6xLXiRMI8UlwDYoTZd`+#(!(eb`m-0#4Y=!M2p6KWp|SDd zM*DE`7FK*Xxdo{gmpp>s!^utf6*>&|_#TPQS3k;V9dD%7>vTg&T|R|A5qXS85pF4@ zx>-|XQmyI43r%pT%7*T0)Mn7;osFD|)Hzd?bE`hX9USwHYZ3AA=;X;BzKEaa6~DJF zR5q#+jP=|!VEic#$z}mQ>_-GVY+7wTsK6!f+k{=FH#m8_NfK1$(9Jy0ODs7F?@9?$ zFQ^$V%49f?#r{k(P?pyWB-qqySpS7qX5fsWrmm%BiG1INZ1{IrY!Jn)BNBAp661*J zxFos6u|Wv=9|FQ6%>~uPT#;3jRMJjq!fJNIG*jYZb+#UB}>Z36eTF z610AljU zC3x|4>)H+va!^_l?$pYPNg}b(EP!)Y(s6DvtB&BY}q(1A*Yi&gFP;$hyrsfsD!cAtH?JEA*mkv(yOETblewR+J6 z1hbNEXbMbJp(yZ6p=`iYjLzj2iYHy@3 z#^C|C!}hs0YKqN8rBGYUwI@cpaO*TyUWvMs-xo`F7oX3{Fs-{|6;Q+8;JW@0!}+=R zXD(}0$YqVHSjDL?Yg9O>KKbM8oG(%>6E>!V;XqUuV4rngLzb2<`59fSMtpccLmUrI zl-yZ$+^XD&_?d>g$~hQO5Mkj6JbuI6QCEfch0r=@M!R6nH{eRAyfF|f)<|7tIkFI{ zL;bqvH*g9K=mga%=JR)s?$a5nGmDVE&r{Cy->U;jLw&wH%X3O@LrmcvG0Q2*y#gYi zRF^!SxhYOkR3mA!?`Pf#$y?71 zDGAm<$SM)bUGtT88d@VkZ|jj3T0dk-(!v)csIkv!>_*1?3yDtpQl2OQo!cdaoPvJq zhoYauwyhsXh8oGBv1*4e9Eb`h8cXF0Wlo2h6%BG%;GJM2Q0+%C`w#36gSWCv6#KSh zf>%IOr9Mt1`!c+hw(u%GM-OirRnXH*68R)ACu$~(Q!U4-)?=JsNUR25%mkm5pfX0g zGII zYF+$5t7mtsy}k8dKuD+9IWJV4dnLd6y|+c_erEa|POXTJuN2h04JT5`vqA9r{6MpPu-SnTS!m6u(Jm%G(vl%w zYe;SQqclX%4~*?zy-Hi-^|Zr^csvQ+u)hl9t5XRfD(6~!4}@X?(!*i*`ohf8Ma9 z7n|joydN)LYoy6_Y6`i~Y>tJSE)GnjTy>h`#**mLv~d*rwQTBp$TXlEJj|dQz@>gA ze)M|4sI|Jx-S^6|@8w6qkNy_>qjA_5uT-z!JExtN*}g_1u%k&eHiYfU^=viEFz4;m zTq7W|b|#O98P=njWQ|F8cdO(@CW4D?wy*~COwO7jQ8o=_-hN|P)887Snco=-mDx0u zmHoXjm{HZv^M$8|3fV05ZlUt0Jgw2AaPB`E%dJX-R6Z-K`a2>N8Q8ap2qfkIl!^V@ zOzclG!B+q|Gr*=A(_mvve3Tgqgr0m(zz~j4o8canpULfJ+QRknu)fzO59jAA`S?qt zODvY8UrIrUTxoyQ5=jdjpPVRJFCpDWXXx_wRjI&BUifJZeu@tdw;tzMfDMePUTFU! zeKWc(RS)f_rZ24!6nbu-KRWyoL-E|t0Q*1Hztw+p2R;`pF7DlL2ji>D{R1SW`5=<` z)G)s&tTu8TH+6LNk{%0>E1liRuDMFIKQVfve>V_sDF!WZHT{YKVtg)S6bFlU)*GqK z9t&lN&G>4)4t%)YJ_1)o3X4bU!8wuvjtfhvk-(HJux&2`*M}>>rSGIJ#vQ)bO{Vu# zXG9v~v2q@%9YuQCYkC2)JgT+42Cn*EjR)8G?Fed(f~yR(wy&tJT@JiflK$a9jBOIP zaL#EsHRb*>eoKWhgr@}DMvRq<|Dsr>aH$ojIQjLQxe*@tdd#DB4muC^xGYuz zeh_}q^o<{CLGY97+l7z6GYuIKz_HzeY>6wwFf!k2K}s zDegZK6{uSO5o3j?vA&YnCXYuGyaaP^V%q@I3N|HfizRNYMqP!{;~KCvRc1*u%H)Fe)ESF%fZbZQ17N?(XSaq%{Ra}+3f$*A=TrW1EIW$)D11>{K!dvXX-)s#7wa~ z&uo_yPX*LzweEpkC2qEWTZ4Ie>x~7v5mLGUN1>+(^6qh-$g}CxP-;$Y;$z(=pTm7O z^>MemhuqFu6Hl{Szq(mA4Zo#X7dkH-g;7gz65Zd zQ5$QmYON3HT|zxf5Olb>%&tOk=T_AM!v$i(hpu{Um(hqbp~A3SZc_O4-?H^PTrg>c5M(k#pLLDtOL zd#=9e+0z>YR%@^B^ONsDd>vrs>(X!fVp3*uLd2G%3ddf!0#mDBhqS(q&lH`CPehju zgmJ}vrig59sq@VX?!VoomlG!* z)w=JT+(hc*+VQTkOUCO1`XLP?^}FZdNYOlIh?kWu8&BSp)r1MAKH-*t*|&ZbZg>6R zdmGjn)I5YE;b0o;G}53~@&Z%GW9dG?R}#1BuVl76(~VcPkO(gz&C_uN5v=8hbQgJi z0v*2dJ@OqC*S=b=0+3I!l3vfrFv}~jAr(M~nTdyetGwt*aUaNNeoK9Y9Q)muCC8AfJAL%v|tOsWjtc=UT`V9cN)j$y?~V5^Lzy(7nV!^x3X29G*A$BWOp*2G#L94$)IP; ze&!Xdw`Z}6{Su_E*ZWNgszRMe{cgHm#Fb$lF~sSm0jx^P~xp<|POOFzDJ?jQQp zmd<%_*VEP~->*`!9Utks975PohkPPY8s4W?BF-fWQYvRcbC|x7mKMwOn$hf3yFr4C z|8u}P&gT@I^VX%R+DzD*NS)Jao%K@gDoc2<9@L3!V|ZTov3m0PUH?PV6IB0d*ddM z0*&KSe(vtom|E<%b#70(3#rq4&oeKDEHa^E#k{`i<}wK>_wY15(QaFABd-3!2>Aik z#kw8P+&TJ57~kj-ZOH8dH{2OKQc9B$xB8s=+_ux>#6>kNJPp8NWv*uHuC2P0OO)yu zE2w?mlUfd>PeO2UNUij<%<+ZIbErx1{8EB)`wxC5%(qlkPpNuRQ8((95bHY#+Qdlj zzew;OPzcvLo5H~w_lsD{$L>SIOhcR4bgkZVltN!58c~V)hy=B&J0<852G$;A1{%Vw zC8??hv05rA7fOmx>=x|{n4h&!&7*xQkyut}Ww9yuvsiGOJgg^Yv*b2%o4!ltBhKLt z?-hEZVm_HvRXjR!l3~6APCEAYY(nzd6l_U_Y^68Ma7Z#}4XUJN4NqobhciJ^ea+h| zv07P6CTO&Y(%O|0YrQK$C7^6=TDmgjt8AWYelWgD^S+dB%_3i=`p>VkUUFv7Win7q zR~G(ZiS>S~OY>1;_x9*cWgG~NRco5EntK=X%{9`<=i3`3rchs6=b0GLzL=JEtB?fa&$o;rBgNj+u;Yf{E3Rl#RGl4wuv0>h2vJ2OQ>w?YIZ7Y`IWjZ`} zw3zGEQ|^NXq8zhN=*qliV`I2dRde|29zMSr$Ic+v-#@vv1D|%-04;1!=g=TjyrCQW z@R>)ba0fc^y+fF+boFh)1$Z+PFQ_16{ikjpIvXjMVoefjMh!W#4!VKniPTy3X>DB& zLnNC)Hz&*0Ucd{6nPjWEzRL}oZD$6b2XH-F38N8BUdf+$;W}-t9>+c!>W0ybhS*;S z{3eIiRVXefa{8ig^;5BdSV)gp15GD~qF1&ISN#IMYjP^CdYS+Me^gbAj$LQa)Rj3&3X&_V|vplF|U#O2LD>aM9-Wf+Wp{)DCO znu57+5BAQONPX00@s$TjmATB0R%^9P-0#M;fE7ukn|J_>J>gja)a{MZ1H&M>)XxIcbXL zO>R%l&!*M4X?>vAQDIV7 zL>IOP#6d&rUFyJRi7AI`7%p&toBP%zXt>I)eYQy`G*74J7!Lq~!k(6EWIE|Jv^kt3 zC^n`RLRNJ9=ZcKE#Wue$<#OVT6@q@8{0_JOxu7P5RX3k+;NwIm*?h94L7`K2hV#-h zTA#2#dcDWT8$l1sQhA5Tz&StX!ueVZ%v4AXy1x=;-e+D)Q@>+SWGrJs%-H`eu_{gd zVjqSf!E=Rc~ye)dbmc;F(ROIOmueE2X(|e6f3I2|h@5dPu`!5b65q zUn)(c4Ydy_ZT0TVnOv7gJLz3z<+5J&9_>k=Bgv&=u|+bKrDfp8)Z8#WH<79cN5scT zxhZOF5nW;0^Up?|kiOw;HevHJ z-nu?EH@Cmq)fcAfXdGYAGPw&;vG~xO9h);B?c5Wa13RnPa@GY0o@h{yypj*#(5v*B zeGWdHWnWw}_2`|g?nqK+m`i5JP3+`u<=#9~)dSY40ggmj_)l;cE09uwT322DCDF26S3qsGMS{;_r)){CAQ;=GOH;tXQ4a2z++!Gi32|GL;5nJs%0 zd%%TI->G^b)c97F^SbuZsb<6eNM;5qF$0s_nY-`{Ztp(UFjf~REMHp%E2W@Cv12UOn@vI zUeP>1AcO_0+#Rdjk*ueWS$Jzjcdv}i*2OAvND*6X;RLkeT~leBPI|Hb0Ng8{O3GRw1dMVCjTO9oB&TAQ;O%5k zlucgBDAeP4gCu#PO;V*6Z#{V_p-?#U7Bhp~oASKO8g@(YkOWzS=W9^idc`(K;>rHf zp|dB`3s0sO9#uHA4rP&qH+TLZ)zO;HnGlr|zjMAw;(nQK(>cIQFH3BX1UW*dof%|= z4)=ETCjEQnrP1EMGWZrU*#E?0+a>r5^g56J-gvC~H+U^JA5+h`L$d!WQ{Y7gWn;6+ zgQ0GbPamZJbP>0y@o}$74Wf8n(;D{q2oIMgav&Qw21wv@fmFAT7>`Dh7+EAq@d!_aSU z`LgW6$yEOxTVn8s=|-(5CCJKf3@;sGWp``vCO+Qimxr~Ny>^aWqHiD32U$LAuVE*Q zfNr>7VQ;)c_#U<4D!PU`H`7~UH_jl$jKzb*kJNQ+jQb@?3;`v@zj-UPNgH?vN~~W7 z#+}jp-}^Lw%NCJ^M=lWL21I?_~C17HOfFAIW=8| zLpbu!YJtX%gQ6uv2-9E&gby*P^E2yRS#{@&; zB$gR*_8^oWX9k)oH@fi`*PeuawaWB*@Psx8Jo4??IYBTtvwr%xmv`oF0(NkV6CQ&kONpV7p}a7Y4LLaXQC1KInc4< zj$d_KYb)GWNIK?(y!n^-@*~9H?mJA-*5iZ#-@4W!5=)Ht-6_G{M2Ht9C?+Sqy5{Cs zv$&C*4)aK{?v?ha#qd3_g!L|%ClBA9#2ViNZ1ElxC~}P}r395BzFovYJHB3OZVs)i zZw;~Ru4VdIC=chDs$#Zs%kb?Y8v1s5Z^H!$7>lLxYQ;cjX9UhDLqNJFXtI~Hj*&ur z7{EGgPV%p6c;p#{@*OkT8*&F zaQz>nPps(zl`8*7Ju{l-MhKBAn5{Cl#8;T}uvIeI)?x1yH-l(D1$Z~FAPrWM0yYxGO_jTf^`Bf@w)rN5QpWn*Ozf+fAoaRh z>?;!Mt(CmoD14(5ygyUJU0RG(&zI=XHsO z?+OVnV%}X6)E$MKhi>2uQaR<54C-Xdkyte}V-41?(lzKkbItHwiPhkdOon78_E`pZ zNM)Y`<;6#wT{mybB<>+CL}}a^RNc_v4H~(YMF*SpEvRoqaA$CVMk-nkp2oDBXhmPf zlo6@?#~LK}=Nq|F-wYNWG1|(aQxK~IA*IVDS#)^{RgC%a0PJf{(ZU64e`9F+5qSRourytC(>9?=Vfr1;HBmv? z3Tk0qmsoPB>L)}c1R+I`5v^BA_XCt2yfv#C`5-kWz6T7= zmmcXisuX;G%S?ptf6N4*m!Na5{2|Kvf``tKT8>{E$$4)brt?wit_Tp!Ql>_dhDslEYD`-9rF) z;AVX&Jv$+|`W}<6ObxDIlNy`~$?!BQW8P5)3EFpR@K$|v=|i`R4+5@vQgbf2PU&P) zvOU1cM?R^KDWUa6KV>?+Hnk>w?=-Zf6lWpIZL%$562s z9Wa1~Gu3VGB%CRE0@`51KBjI>Yjdy)w;ft!XkZYgaa;18ej^xx{PoZW;2zmU9l|hx zB@jPMD>w%a%-2T|i!IXZuMeNS%l8LCHmF z#rME%Ongvxj0c+J&AUJW<<5(=pxLQrN~yOQMI8S7Oz@|f;7gg{Q3=|gm11NgeGf_S zbD0cOu=sW<*zUSU69{?EF^VM4){kkV%1OI)@47Eny2+PXf5m*ujTfF z^MXe*z7XIyf&jgGw(AQ4msoI!kiiBP%Jzzo<>}dYMYuqG9#B+!B(f3Lq1&>%;rcKM zOc5Dz6VGEO+_(R^bA+IAjPQGWUKC4Xt|))I=+sw~g;TQ0Ppk5fz@W;*)1@knrP!jp z+k5F)1zTm~{wWjtx9oxFL9M@#p!FsBd5#&bli)K9wh!>Jl5pzzYMZ=yo-g1-JtPp) z^;XzE=H&&kCmFn+GK1Gcxxmuzd^&FswNCCOL3lEIF1(Q#<=NyQ+$n5?&DV|azP`C*6C2QP z_j!Fc&|&jB_-l=@asP%-`Q6&nPMg1D4066`5Gj3fXWj$ui6E@D6xA%TiGRwxn1ehp zb{kra`R|lp3v%7S1>Ca^$2O+7jjlPYxhjb-3Qc`_AZ9f3A&UZd^bXai#iuNr^&MRH zJx;oCC33mxW1L=2WvEJu^aSBU&JOgWDAfELue*moL(u3R z(^(TgE^FeAGJ1^)xF$ZU8SD~>r<{5d_DMg&vT8du6pB?#YERTWtYQS zv$@1Z>SGRGu~r<~OU|h~m`8TTdqGr6c%Hu;Q(MRnQ`W756WqiyPLk&>%0!+wOPOn- zPi6OGR6@AAH1~v@d=hMnTJbep;742Erhd^^%hRwv-@_cNI}YMWrPqwqyEdR{GxhW> zkkt9cCaiFsXE&T-(HE6i5*c4qBaJZ1am{kR2WyT~t&YR-c)xD|$Hz_78T+V=(itOQ zc=nTgrmvy85b=Fw-=N`Dyv)K>6Js{T_+b}w*QFK&+|LT?XV6~gonl8xt~ST?);e6O zX>^bKxt&e8#-GmiZthkud>Gd}1d8uN8*r+5;YHzRCA)4AWJPpWcrX*YQ-Yr7KMjyM zO+C0(MZs$;Z6K<7FCgpdd0yG$Ul7MU3kyEUlKT}o-`JpUx?Swg#Y!rF(#97Cv}l9z z_sRcfCG+YVD+}tlV zx{Q_*H+1#(!Yp^mij$@q5PsP#|Ni5^Si#}4<52rX&1v#qj&CBH;0M8Vll3xSyao@| zJBJ$@QAy(qh6#(8EyAaS-7Bryi_5cpFHa&4FMj|yptj@r%!-fbim#K0@2Aatd#jd@ zH|O%$uN_Lh9Mm1uklY_krEAOVhQwoz>SOURCES>SEDIT-COMMANDS.;6| 123487 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-COMMANDSCOMS) (IL:VARIABLES COMMAND-TABLE-SPEC) (IL:FNS CHANGE-PACKAGE CHANGE-PRINTBASE REDISPLAY) (IL:FUNCTIONS FIND-NTH-STRUCTURE) IL:|previous| IL:|date:| " 3-Jan-91 18:10:48" IL:|{DSK}woz>SOURCES>SEDIT-COMMANDS.;5|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 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) (LET ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT))) (COND ((OR (NOT (IL:FETCH SELECT-NODE IL:OF SELECTION)) (NOT (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) 'STRUCTURE))) (VALUES NIL NIL)) ((IL:FETCH SELECT-START IL:OF SELECTION) (VALUES (STRUCTURE-FROM-SELECTION SELECTION) :SUB-LIST)) (T (VALUES (STRUCTURE-FROM-SELECTION SELECTION) T))))) (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)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (68497 123358 (ADD-MENU 68510 . 69173) (BACKSPACE 69175 . 70154) (CHANGE-PACKAGE 70156 . 72956) (CHANGE-PRINTBASE 72958 . 75140) (CHANGE-QUOTE 75142 . 75497) (CONVERT-COMMENT 75499 . 77259) (CONVERT-COMMENT-STRUCTURE 77261 . 78564) (CONVERT-COMMENT-TAIL 78566 . 79966) ( CREATE-COMMAND-TABLE 79968 . 81946) (DEFAULT-EDIT-FN 81948 . 82085) (DELETE-SELECTION 82087 . 82769) ( DELETE-WORD 82771 . 84872) (DO-MUTATION 84874 . 85422) (EDIT-SELECTION 85424 . 85872) (EVAL-SELECTION 85874 . 87743) (EXPAND 87745 . 88874) (EXTRACT-CURRENT-SELECTION 88876 . 91244) (FIND-COMMENT 91246 . 91940) (GET-MENU 91942 . 92319) (EDIT-HELP 92321 . 93396) (HELPMENU 93398 . 96187) (INPUT-DOT 96189 . 98321) (INPUT-ESCAPE 98323 . 98571) (INPUT-NORMAL-CHAR 98573 . 100606) (INPUT-QUOTE 100608 . 103690) ( INPUT-SQUARE-BRACKET 103692 . 104043) (INPUT-STRINGDELIM 104045 . 105444) (INPUT-TOKENDELIM 105446 . 106426) (INSERT-MULTI-ESCAPE 106428 . 107556) (INSERT-SPECIAL-CHARACTER 107558 . 108818) ( INSPECT-SELECTION 108820 . 109355) (JOIN 109357 . 113027) (MENU-CLOSEFN 113029 . 113247) ( MENU-FIND-SELECTEDFN 113249 . 113949) (MENU-INIT-STATE 113951 . 114758) (MENU-PACKAGE-SELECTEDFN 114760 . 115811) (MENU-PRINTBASE-SELECTEDFN 115813 . 116689) (MENU-SELECTEDFN 116691 . 117117) ( MENU-SUBSTITUTE-SELECTEDFN 117119 . 118079) (MUTATE 118081 . 119191) (QUOTE-CURRENT-SELECTION 119193 . 119960) (REDISPLAY 119962 . 120201) (REDO 120203 . 120697) (SELECTED-FN-NAME 120699 . 121144) ( SKIP-TO-GAP 121146 . 121923) (UNDO 121925 . 122725) (UNDO-EXTRACT 122727 . 123356))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-COMMANDS.~3~ b/sources/SEDIT-COMMANDS.~3~ deleted file mode 100644 index b0714ae8..00000000 --- a/sources/SEDIT-COMMANDS.~3~ +++ /dev/null @@ -1 +0,0 @@ -(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-CONVERT.dfasl.~1~ b/sources/SEDIT-CONVERT.dfasl.~1~ deleted file mode 100644 index a2d436bde85cdd68c26c5da0489ad493b3ffc253..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1806 zcma)7QE$^$6u!2TrfHkhX<=*;NO=GRDeeekv^3JFac)vK&b^-PLMu&z0%i_PNtL!} z6GAG8O?&VJX`%C-;AP@r51UkYm}tw|hy901ys|&gi679N>$Hq9O2S9Ub==h1Dk8}NrqG}s0 z*Z=?8$^OLl<7IKMju84h{B|OgN(o$!BedDuQgRVqZ0@Reo-z`J;Gv%^>IT*U4~`xuKJ1Ua@N?}f8mz(t*4g$D)SMcN7BBGkkrasXb(xxN5U>@-M;f0VZ! zg0)d_J?2E=7%%7+4g*Jz2TKy`fD3ynY8m{4YfR4R79|x-oM0)!%^|~rqnSj=Wakz4d1Mzy zJICNmm>BH3z=g>naa{(A6g&_Ezb7}K02h?Ofj1m@=G7r+r_VCAE z_8!|O1b*91GGD9RLXRMiHl093JAfQoaF=6upi_UkQ?DPmHR<(tHL)gj03F<#`10D; zlbSTScDuSZyzadyH_Nv@S$JVgsmTWhXOJQMS^*MmZIDH>axgqzNN&>P5>2k`ZHe+G zl^3aeHpD~Na})+>0cJv=rzU*LDCyi8>Qpe=aMKH%nFI?XYTvX;PeBI3r%H)V1C z>Gmlkc0n~#Sxt4c5yisJm_-y*%ksjs*%P*dD`F=!aDNuY7p52(tc(EZ4QwfAbdpegHH-_2rrH<`g?|TgC|FAg_Mwzy3Okw*#XH;Z zVG<_+kkXHYjq>BB1#1LwVwi>aVQO+Lssa7u+vQA@x9=6a5^;eae}`k#v~=Qd=?Q>o zD`5xNdx8xn0Yy@^N@JY(3brh2vA(eXzW^262(>Dz!LR+q^8E2N*!Q-wQ{GO9^PCZ#)$jlCd(lRv)kTpB9 zjIzVhvqQrIZ}FpHF( zY-koAu6usBJyAJJ4P_Ulcz|g!Fch*vH=kQL<>5!n^Is{S&xgq371eBw4F_hr*IJ{p zJhd|^Q!lSv+xodCPClQ4k@*ouX7#I!2tBW^j;wj>qs>u1HtS{1#xfuW)WWdNSMI2| zw(<%w5<&0w{_m!d! diff --git a/sources/SEDIT-CONVERT.dfasl.~2~ b/sources/SEDIT-CONVERT.dfasl.~2~ deleted file mode 100644 index 865b2ebf9a43b3878dd4b74efc2e43d28703e675..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2033 zcmbVN+fUn8822S41W4-8sq3U^!Sw9r`Muh#1PVy#i1w)m@{=Wk?<(#_$Kjb=51zdc+rQ^+G9T6`_a^NV2_BPyjt|%i(N1}=z9WxKos@K3yyqle4_Sz@ohp=Ao`5G zBytoaKld6Xi^LwYgbB6}vbMuLHC@$=6FAAiInp|_@4_MRN>jiMj4)`UgtaWx!XUMY zy8N&G$$LO!-usSPMZxTp}!9u%R)Hxx%!)siY_;RP1J zCR!G?zzhq3i1zL>p4@^Q*n09-YVEr+};(E_fj%h_1ovtv1EenRJ*t5>5i$R zdum*!ePDJHO#MWwk;AmT-5n%_B+C$FQ{`yDw`@N+PCV>nG5|XIV{i=arZA7UR!Yq7 z{rz5w=>o13DM>V?f}kUFOjiU=N|DlpjY-2qWf;5-_gD%R5bPnCRiOaWEhAmHSOkrd zH&RRo#OO*XvVqLca+-)^S6AtGH23heZfD5p0C$2~{IlL>W4W?8i^rNFo1$R}9J$@ox~@G`*;pgg9~a2aEwDcv+)jA;LU>@B z#4U@Gt{USYhQ>wRDBx4WAhS8epo#Zw(zyV}&$H&nf{SS zUWN&F?Xjl4T3xoARnC9m7c=7*k+V4ppMmgniz(PlEL@K{1-ZL=47H2|1F9pV9!P%3 zm@HpZW#M4oGCV#L0Yf@PCxW@9hv3KzktaJeGz6&9fa%}mm3-hn^Ze!{BPzJ>qu`a-QT5T JhuQu8{{TMUYES?G diff --git a/sources/SEDIT-WINDOW.DFASL.~1~ b/sources/SEDIT-WINDOW.DFASL.~1~ deleted file mode 100644 index 03ef8a40b693303a8c157a5b5c56c3797c0ebded..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 33367 zcmeHwdwkT@mH7Ajoyla948ss&AYe6Ul@<*Id{Y|}* zt+6#w=zJBl(yiOt*D&sG39rz#RpMG)tu2YW{jJ;Dg0|g;x>dJZmpzaBo%@|ktnPk( z`}^ltK05b&&pr2b?!D)pbM7O9ioMkruJ-kA*w~rs*i_xSW%I@@o2zf^-BjJzyJge5 zj_Ml$Uwwx^-f-8o>pT0pm*CH$C0*h_(-MmMV=ePPvv5k>l-s&Z9cwmstglWaw`}TLzh>*D)r+b<8#i^Psux~!&7w=I z7cN}9@T$eNm(QP4=ZS~821c4lZx5%qvbugv&z3ctwql~IA<<=vFS~N_qT2aW&hAa` z)-LQ-;NMNTpE87|O;ZV7f*&qLQ`5T!oOPjaz}FP;Bm(|$%%>^oFATWm#S@;W-_zu; z2}K*56Z6sou7%Z`dpFjkI&SGmA$vAxkVX2@0ef9@)RzdwqUoJ#zxD~p(B%)*g`$BP z%omc^#axi1HP#r2YGshX7HdvGmNo!O{Gp}*CDvx9cUlnx_3$S=-f$p2V1bSSRB@xn z*Wg(iNbj_ycMOz5<_2OgJus~`&=hN}@x>yMShOY_iZ?<9iir0}|LB0FIUWF%RYYN) zYI?wSM|4Xnb(aE+vZN%Bh&RNjVFG6$n;0aH6@Vs!0}&N|vmpbQ zc_0Iy<2FE+VBh*-#Kds~Im{%*5$MSx*LL9C_L<)F69^1ktDc?kuV0yfID4!B^F{$? zya4ll0p^bdnEx!moGrxkPpr?`V+EKu3NYh;#+W$pXKt97arV#L_`kr7tNvROiiB^-shcJ2nw>_KgC}`17+@=Vw&= zTp=c(LQ!fb)>)}NRzUM-jEN=xAMpa;A zHwzeoCy}|Af+DD21Zqk}#M1zpDd~{u=&>2f(^WKs2?d z#IP1HgXtVs6OH);HSxew><=Wo0;*xDi&7ch=1|x#R8}fuinlqDh(!a-fVd8I;vEB1 zeZc?}%ek?lykp>;3CNmwFjR-x?-(fdg=6u6NL&djZ(TS9R!DTI%;GvCoaP6EBJ63C zctSh?%>TlfPKI7dTg-H4%vV zCzLo73@T4J)E=mb#K54L5IYrO{b2ln%>`y#6ITdSbU-3&sWvl~1`;*?KpdLsL2C_6 zrf34nqDbq~CQlndWlNi4Ej2#iM+39KNr-&bR_5a%+d5Bkn6sLmW6Oj}mXSS!V_meg z90qp024+p9(Xf-L3e%&prU*ASzu0MlyAv{Yf??^$&hx`aOK@wepx1nX8XruvL=7;! zAW3sH0k}j>V=P2t4s4@F1D9VaSfq^}AQH8P&v?+&XpEkzai1qzQx|Kh@y4L5f~KfCo7kSvZjp*W5_Ol;k&HTJ94HZV3jOm=z{;bF=|s zIJ+rGoy(H)153|@s)=y=bMmp~tV?N1$tuD(4jyDWWoVBFn?lhB!MQ2%1bi*6iPhCX zmPFuS5y3;=jNytAW_oT0O{lJ;xe+Z;7D0Ly2yYc7?m&6aQFXK<#JTpVk}k>ClV z4*{n+QS4Yqh&JQ0W#HDfe+r%e6dprfIl z_Hb}DkT{4WCngq9jIID<62KUsR!2lLl>=__p@>hX2ptaO#%lbb){#qvehk94!O(ru z=R!nnoD;JpL?4o3m=T0EQ~bY2bW^jq4&0hh#Vk=hYDf22h{BIiWlo=DdbQ%*;XH(< zR-BiQX;=1bC5D9CGlV zMm_zgY2blh4kRG1WAVmqv#{%*gC*MOk2f~q0vLg@7K$Qz2+(DK#wqh* zgCQIYATgo_05uKBV4Z1f1ew4qAjWK>viBjlT7oeNdLZc(@M*DQ6?HD8ttEo5Ab36y z*jw6I${=C}rhwHiKLz@&rUI7NAC3cR<==8SDLi&?pC>U-@2-X!Hx1Wlu1d~3cM&$>I}mB7=?KzGuR_#5%J3Nk?ZmU-(KjLfV!+Ea5HaOgaoL&nT<*#r zA*M`d1K8t0t^8K+!{BYsMy#EP`9Jzf48|ZLrxqdNhm_xT1dn5!v4|kzu-=NncL8rG zarpfWeH8{z1A2l^h3LohW(;;g>=YWWtU*#Mm4`U;K8(!MEN|1B`w+?f0fMv%6qmJt zfh8Z=M~hYhl(A-R|6&dP^W@U4H{n|Kg#on&{=WpA-OAOVNf#u7gbE=>=JzM}?N={c4dhBn z`$gCIj%4PONrW{@67`o>2b7nJaVb(Wa@^FkzR|FT==MT4pK~SfN?0 zPltNvYUK)XO_68ZzIM)z5>F0F;#8v^q_KlKiF)5nNO>E6n+lc_5z90-UE$ z(VL545KI)&HXfcd%=T`(5XZ?W7^7vNHqy=$7?X&5g$PJK9+luXB)A6>6@fI5E=2N2 z;mZc{9uWBXIihg zO{f9ewmA^jr(neODD7lKQwVo_L|g+loa4aYVfrfoXAcI#jiAvqvjF@QlvW&y#zX!9 zEddw8cWKxYPmqPwhNYl6D^Vyp)ald|Twh37*%Glttg!_@-vQ#X<)pmMN2MEaD74CB z-UR6X6B?`h7|9cfHf$`Yk8vbF0k|p4p-#vyJ83eyd;I|Om3>{@f zBab`DO)>bRvfvv95F|hTzJ3!0qgQb-hXNSq7^iEPWOsUCdLr4`R~-+4D69rxeaD*h z^D%0*P(i2WCieVvZn^`&yKcG2#tGj|6TTD1x0Qj_PzQzNX%bX-`ubWf`y|tdfFem= z?g0vz;H>sNZ2kb4h1y`Io@JULm)p8f<~ono4$&`BpZx^EEKs1bMUxOLlSBZq&*(J8zD#uY zA!a9m_xI?xO@$FtN)8!eFHgt#{{U=x&OE6RCO)_%Fp|d)&4Mw?=VinmB#;K!b_Van zOqdDa7$M`6{UKW*Vk!=NaHlK-Hvu+Vuj&Bo6vLSyyhY0?r!)$(X}KuF5Z9}&r|45b zh;|s!=qA*wJQM>?Gn9bBK|v+L%vi{ApDKuJ)vLrbm`NmWTA5M-n-IEcIWX5H+=G6s zH3}M3WJ{JeCYpj^-e0~)U&b>-`5jvkBVe4dVxSr3sr6v;Q1CHf92~cg_a}8>allyj zFtOqu&weVHtrBTVpS_G0I$rZK7c&*kjm)fI+92vrK4zi{X6r?SjhE5v)dnGG77Iez zx%H?PEFTPS57jTu&Ikzu#X%G3hUcJ5l?RgdCATO0li3S7X#A}=-S4L% z!JCv%8o}2k_zx012HjXf$~g}%q*+@vQgq%t# zC*hV_%4x5r;QjghbpZwMR`6FD2P|FF+AZmUb2oPMtVbnseMhQea|Z~5b-g`(oqd}- zde&`i{D^qaH(Su{K~m;`XIF4AxxEu~#ZFgnHPlxbe>Tnnh`zXAAMc`JVUnDppJx#f zD?P-}!W?r5WD-vt#r!S|tU(N-_TTv9~Rm|N}%-vJy?PwJf>OFRH(CBOh?evrw zulAh2`dtIV)5Judoo@ONu@sEV&qj%%#7fFrOqPlu%_Uw<2i!$+r$`9_gI1<57+)&;csj8$s*=Q+h@e}4G>n0~z zm3m&@u*0Sz117WSd{Q=U^{__x9EUo0lByH%_X*}1Es_H5pagBQ;QA%Cf*C{O{&8yi1Bm&8zJbkv->3A> z7JWmL-fTyz_jdn#D{KRLAM{6VQTSkCM@Fu6XHZnz~dh4 zHm59lV!U-eZ+=!t?W^l9 z=+Nc=TOC@8y*HD44MCa&YAts2uX9-CH3@!Kf?t*(DRpY?2F8#ssn%Y@UsME%Xcavz z${z_$;4dY3LW27x_!xuta6n3qx{$}(!pj(m!)S$=jXOQQ@xe?>!0#41y@SK!b`jb} z1yDRXCZH1cSV}YZ4C6->buGIWkC(zA%>32I%M`{&UT!cMS3sL>VlwhN3X{=BTUf22 zp4Ww%;;@%x1%nAbt!OZP*z7}#NO^>sT}#qVtwq<8@*s0!E39Xw<}LA!gbyY;U`ZIH zgWP3FE4nRBEu*6QO{*b&<%Sh!_9jx;H z=u_0Jvhyf#I5ALO;~qI#EHvjZ@X$u*P8RA_Zqz(byQ`rjt_vxcRz)dw(-OQ2_;Qtr zFRj!tLm?F*?+vy+9$F3Mvde@P#8n#1J25^uPaGet{!vL_wk^=RFCh5qqP|7*=<_?& zRf^8afj$MaC>x)!FxAd*934)=er*yg;pE|@80534BfLIZ&$Bap9{RpP_crh@?Q*n4 z!9~7}ea6Dyt{g}n={_o&~#0N4sA;8gpuZ&Ac5M3aez)KG`J- zTsA(~J+R^ILtf*1%-A^A9y3&yAeiS*xIMvSs6MP3tESMxAlu;4 z$$x2(MaHvN30TWkxIK|rc`{e;;S7i(qs&NzB4`>6XD$gsN}vzM%4Iu;Gn9i%jZ`TDv~ z>T7vW{g4g9edwH0w^D9s-K#ech~5E}B(XvuTMtA)^Ng|Q%VaJIa`nkoKr4Vk;E!_z z%8^_V!aq#Dh_u9ho4sO9fWyz+z>w_s=(h~4A;PD{vaS8V-%C9xNPFTJxI?R25 z<{}L6O$3NR2H&fR^)Oqw3n-SQ)zd8V*hA`}2-b!P%uZ*|0DYwXF#5q6@DNc#HvHYZ z{k)qkQO<<(&9+b)Q3bc@Lo>lvQS&7xT*VYhG%PB{>b$Yf6w20yI8QcrhuP;kERges z57ziza*#51hw3Ths<*1Td#wqb76oSJib@H$Kz4?RFwkUQ42MKfWF&D^XN7k- z$R&z)57mqFBO$O;8iq`*)DDIYh3dft)?iLx#RPb+B#+j{w6=U&JJZ_pX-k>5G@sVN zw2pjQC()j8=F_^E)|F3N&a~zEv=vNSkxyI6b*RjzojC+8n<-p=#EFW=ysxIbuLO@K zW@Ksh(~@^V;HCVM(1;BfXACGauNABhWmJ#dU}m_+4S;SiC$Mq@pc~AzHl~GcFw@$Z zG0+WW+ES*4ZZOk24nmhZ#K;C+YK`?zTGsii<~bl0ETl{-+fYETsY3FwmjuTPh+U&^ z#el`-s|ccN+r}rYcuS`i5Ki3TF(1c5N)|0Y2T=JyzYT+TDdSfV`~`tOLXf@pwBL0S zvFbX+{sUy|VB?84_!gSa$egzUp`mtNtoStG+I=yrL5A_a$~%(sJXmZR*!0_6bS5Q-ZwYQfBuO z7Jt;F1h1E%o8ssQ$7cw83TZzrv1Di{gyj}fzN~N%m6ejw&u=AooItFv@*IJf3{J@4 zFa7+rB>0Xb_?pD>)S+bD$CTM_NlVRCXJd}+o;<}}eTuqSRo4>fFPk~2r{EMTKc}yx zuh$ncawY|7R?SbBGSZ}$uLWgfdGdfzgg?o0+XX6zVZ8E!JyNNuXK>dD4zp}`cLC@M zsbaNk&rYuwu*3ZUMB&E8j{2c(Ay?*~6n*Vv(o$`cr`)Jcd$+0Q5%5|OwL=YFjh||e z2cS;&pYpEg5mckrLCx1D54gLqNS8-F;AUIkc*zH6o;}A)mFuopHY_Xz#nm+=2ucsu zyUz?}X4MaQ_?*gGI2-CwNkJGrn0b@ah9Ip6r2RUu{t8@$sN6cy%7qj6v}Y7(Drk@v z0kJqu5QX3XD0tcZiJ)HP1-vT?=a}f|IG)*uNWH44g&3f-NDGoU6K1fYPi1ak!`DN@ z7n4RviV+!0t=YM}10lXiOzdp^hC;#g8yYwW&~kDI8`LM-K6d2Y$Bl z2}H%ZmJdCPqf#!W0qxVEDQ6ncJPn!( zrU9+fps8ea3p7rHW+tjyGg(jMF=EmgN0jVz6W1Kv6^|3jOl)Q&MY8HI>;bl=_}4fM z(#oenf^ZsyZKD2U>tOH^N=!#gQ1rF#2xb;c)~oG1>NAy-MLfDKGw^W=;$0k35N+Tn z`i&qq3&f7Ju1iVk)X>!^V-||pjHa@-i#~pW;2i}148dNQmKKjUj_`Uy<6#bM8G`CV z2(rS3=Q=cUqbrmJIZhSI!a>RY83}B3xf8G=P==C;eJ*#>^A030DzE; zhw$V)>#~2V-vqSEwW7I3i#jjgT&q-!H@*G>XZZPvIO$dO&|+k1jYU*fn0S0U&&>rJTF11YboC)Ed8)Pf_zZ+ z5rXs)T_*b?V{fP6ZB{vc6{oMaSl3AZ1%2t4QIO^VqhCN@VkbXM3zu?QD39EN(<1B0uPDMe9@~) zDDGWWgVI=;Bvj^HUiU|ATnk&;?eUTq9SUAezTTW-n&>{ zCzLl8@~0J?u4_OeJ3p!jvD)GpWz%+;TB2`It+?H`NAH4s7nyv(QbQnUZtItVd}_i) zxZDByIhT3*RZRfaEw+8>w|C-8vBNEtS24A{?F9n@%<3kC+Z9MQU zxNX6crw%^w&GF{|!pUdmLv`%Vb`kMYkm(*h1vS7K@N{miO$vye(x3ia)~XJz-v^2Q;{PhinExRDmIxjA{@; z62=UYFlO*O%xolhT7r8eNb5P%vR8%VJ^2FE;N4VMx{rfy4%X?*Bb?sDK`jU8b95yK zQ#fF|ibP=#bm-N>9#pb540TqN3LhO_sbl^cMx$*gh`!GdiOC*qlDW#K|I8->sZ`)j z(OfQ{#EJ4gSL%HpW#V`VRjOBvvbRmUM?zflMD_V;l4NK2y=(&Mz938QHdeTmr`YGL zanCCUara0}Io>@AO}=|{C}iv&i2{w?BcJg-cG&%-+gsld4yl38DXj2$#5eC8z6!STVS1gcb?}Qh8>;-EZDLwBKMk^mD276sY-h;AQMf8R%pJzso#TR>!+lu zDX${a)z2X&tKWseSM=LyEmxOMw)tX5lE34gLU2fe?2!48JrF8p1rISD#qCDu#tUHC z<36x)c)Y~N>!6=`2Tk7yg%pWxCe|Eao5>hOhPV?8E%2fx81e;cVDB2~ z=XF$9a4(#z-)=dFKHlT;C7cPg9^VWV3(1Nl4|ES1mE^j*4%Q2Vb9{GbFx209;IpCb z*M{n~gPBvoBsV~86Ds=6llcrjhO*$(?b*Hs)puubz-yMd#+%@FQj2jj$pbqQ z#uXPD{&+dbI-I=%uF`P*;rflr6QGS2SB59KeuJ}EV>RuVzDb*8Hs_?BSb_zEi(&*E zr{zN#VK>x^By^O&XU3n@Sg(ag9&i}xYCufuM{r9RPSk5E{)lxF>P~HG%Wep%5X&t| z;%?1|RV=op#-iD6EWdI+hGm$t6dOmYp+p5zjtl$WIO|Vx1G6N)VDsVjgFMUMWZXiB zE>)=7KgA>bbhzk#ee0ciJDwgc7G!$WOnt5WR-$8PopPEDtv7`*7K`j>kVFlV=Bx%U zW_|#(NmeVr;STuMJ$fI!DA#A|W-oMWUQa_u+lF(u#jxM)!@$N5Kwt+)?8r-K8U|yK zjQ9z7TMnL9t(gWvH)(~z8W;lj6q;)u9?%c?;j}(oIGRV*+zqeS!Jff9xR4)6;K78r z!0Ua$qk`Sx+;Az0!GjW^2)-yc;L5?`%qh%VM1jT<2txvAgr6xNf9tpkWpvqZMpqutI6W#`BD@CrO{kbw6*Cms)GK+I{hFM$`p{Nz~%djcAafyzTce$Oz1VMim5uc7}w9>0@XckZq zOQ{R#wg~h$KA8gdj9cM+Zo)!RSAB~HL30!pXFS)EfQJx7XWLXzM6rW#I^cic=DWQ1 z%F8b+LF6C6(NM-0&+u_TI+r|-D(UjbGUNMKl>9i7j}kb7AgxWxiwM3%*uO_`KZ5FS zn;{DuJih|x{@A#GmF^OJj|g?t_2I;FB52$h6DtqV{0oSh8Qe8;8VKg32WH6$KW{>F z!7?(A1ECoyNA%DuG@ zUI&Ca?E`KUlcs{=&gn~atm&!QvXS1G?1Okyi&dQMWi(QlGnC(Mpdr5glsoO@oDSMJd_^SYsSqB`hR=`>N-5#O$^LtTe6 z6=H3$iB0_D#fRbK<`eF(Gak<#?^ji~1*Z9!TWx&~>yy1en0HDWNr!rTR6wl!aPV%w zaw5odRZQnSVLT_{#_W`A@UrS%k>Kc&%-w>}8)3@h+UOCHxAj27QFbrFxu9swd1f%W zE#^EF##2Jn-Ed?ndS*w=*&jWexe{nK!Uol`Jo+w1gfW9KWNO6$dU5h9?HZHCcOAluDvV1PP? z6CpiN8iK_l-#WeKL08=lK$>vCq77j|Ld=1CD zxVFYSGmwl2w?=ml$QILFWOb>*&75_LgO!{mJ0#u>6LJMtWW@p|spfz*J3i641%|WX z@p2nalZbBMAPLL4H+!zYEpdC2K3=|ry+O9u7N}-H7ZqsBrTDH4d5^CHotodP!3OT# zrd^}oUZ&q&M6yG9Pbek42b3- z$Pa($3{br4AKI_{P&C^G(y03|oDMviglSuES>@Uhb8XAqrSi?XY}oL0;H1u0!}&nt z0O9cxJUa--?mz~VZ;QDOWNs5j3y+r^3H!&Nj6k_NA_wk|gupE_lxYWCc6KC|&}x=2!hhq|pR74Ad2*+N&#C72Rz<&KGA`uZXH_)j`TLyb z`{?Po6Y@k)hc7$bFIrytGcir!;)u94sOWbBtN!;}4bG2^uuXvdLM^@vYF8k-X^ml- zt#IHnI!TD`yMPt{y?Om7yNT+9do>>=x9^7PF5zyGLP=gk#-0-0mlH~S_}wIv?uNSm z5B6`AVxHsg@f?4Tt)Dcl;YylEyzq*fSDJgE#^O0HaoJ7L@0n~MNvDv(4e?+DxjnJN z`XQ_CuCA1}8a|X%@!$Poe6Xv(dwds5TZnOUOxc7OiYE;+TP0zUj1w22allidSQbsj zeo-&W3RJ=9c0Rt+(O8FgZ9OSg+WOLU_^Hlr1tP02(G+f?WUq$_t$K*K;|hp{tt)sA zl2jq(b$l~w%5uDI0_Q`>4kbsCs*<&e7h?8MKHGo?n13&K^T-n8J|rBHzQOY)V~fTO z_Bl0ad>66gKKdmVR9p*|zlg-me7HN=?}gN}-6OMx#1mkADM2jUVDyUx`;vwc$Ki$% z=PDP^3P<;7jKSk}1F(&b9m#we?DWH6Vty21xIXug*pF9sz4Ii#Dz@Q2$?A*#_-JN! z7ZCh-7`;J0-h?TWx9l^?HizLTw_=f*^2%n7*ROby27o*@HN*E`vB=v!pY zboX`vaaZ&#a)ES{2fJcU`qD#Slo)$WyawS|*ai$Nm^o6dq-R-ivmdtjL8BC#PKMhR zUB@a9j{OK;1Io26UKftVn)rno+CkKMu%LgVQ9|H9F-RLz%03)7Q^XT7yt#+3iRN5F zd=x^SFre#5hcO44O_Trb4c2n>k9=k1Nd!OG|oCk=hxyJ;I zR~Ij2>QV~CLO?EW%xk+Cz89HxX2l4$8z)~}2WjNi<8x78sJA@MU*`_ec_DZbg2x`8 z#%re`&3_a@Jb^^yF8PF$aiX4Ve2S#;MG)Nh_@CTyA2!tk|+1sdYYtIhQF1J*^K z_tDqWVt1U3*7FH9hS_sN>H9Z&7v^#rY6UOT;Y+RfIYx2x^CSHN#GKH57#!o^8#4YY z65NZ|ulVgYq}@$1V+d|XP<7o#!8AUDGRE$D{ZdFZovyyu&>OXMA04(&&O>7DcA?q{ zhZ^fSI{JUq>2SxLZ@Bj*H+A-OPrTwjA4`51UouAO3R+IIt+DjLRpwOHn{&?%K?ad6 zed5A=^{vScxc1!J(^1_4PZ7cE8uP`Ha4)~krhLl_wp{nYu0t)n`}<v9}mzRYN#7UErI9F5&z?n)CJ=!2c!2z!f@j&J3Y+FA{>lnKIPvP zNmb(wnrvlirHD+qM@9Stg0NxqP<{7n2Qxc8dt@=L;fLji4R%NsOEEe|!F4YF*b1u? z_ZF*#dKH|d#FumMu!nqT6ck+ajG&mMSP;17EdJmn+}vp^Fpwz?8%le(6=NT4hrv|> zKFcQZzHFs_eTZb8_D~yt(W0$AbPY}pc$x)?eQ;`qj?!ok(U!-Tk&=$|i>HLdsh@Ni zGz|R7qFs%~%6%V;zM^Aba+@A1VF9)pvQk*E!FvJfCG>5+c`@;Qx1g=vl|m1@Cgft=!iDdaJV4^Mt#^Iv?5^x=+QYE8`Ib%jh$)i zlBSetN+pehX&jQqNi=X)G*_03XO$F0bNSaD6t5VX;JOnkKIh#OlxOa=v*^xDbqsd znrR(O3!Q7GbrLOhu9?=ww9vU`+H$6a&Nb6kFfDYhnYNPa0G(^5op}%jGhF3k;mcFv zqvy`{{eL_W6lURllfCmLO@Vy<%()#7ab#(|_z8k(0`U-W(GCLf5OL7}9U`{E%Tn-V zjbQ|xOtD@`7|StzHJ~hqD8&f`|As(1qKvO%mM! zDd&`fb|#mD_Ujz2_Ky<#6NzQ(2XoMlN$htd?K2Ylq{Mzvf?tpX4-tqxqOB!@Q3PqC zP}Q~1$Yh_E;0y_p1BhtVcXC+uUnKal1dmAY8xqtdNMoBbyF+5BTNvAkSmGJn#08K{ zGnEE36GSEUFJul^6Np1hohz{yNGv%wI0r`#tNcffR@~IZ9K=ms>;UBrNh_PFyeP3l zGKasGST+JF2NrXb?<11-vrKy{V>a;@H#p6*@^k~o)p4BYrdmc`!pMs-(00yZI0(<$yI2;nN{87w^Y8K?8*N zyiBYzlb8#1!HMZ@dFgEh>A^_|+kR9DNN+DlUz(S`v>?4BFTJB6z0;f?6pV@Wcjcvr zx=d(4HaFM)6R<5gq5Tzk=_?A-SDMpTR2HP4N$H{KLfM3yam0Q4aho;Ika$>vVjiPk zR$%H0=5Du=_PENmGv>D(qo`!IDlss1Az^;kX z+MaDTecH?_m3;-3f855;tH8POqvD|zhrrmQqhp6Zq6Ed1J?qlk5}yfQs7Dd=#|# z9Un5}dD5|y#terTW!M1sgJ>3P(bKd(pzdBoN(4RfR@6gSG7@40 zl99k#5g7?SG7>C0n*^Wbz=@=kf%Z)a#z@)Mmgv0@tC1G2V9^?@oG;U=r)_N0Z=b8* zcr#YyC>8k@g5M?ZZ3J19z$=ACq)E`TaYd{?pf)3JYZJ&>O zJwpUYYyEYO*7}OXz9g~xCH9*VJ1DUO5__}6rX==yi49BaLW#XpVy8*0BZsw|$zd(O zme^M$_9cmxikRh_lHji-0rfd+->f*I1z`ESB)FGA!rp}-({3Ov^2|ck7-NOvf>@!v zAjqSJXjzvgyFe;!7OAvZNRuJ;%u+2&tCFQv5Qx2Lu_H)>K>Iy`LHO3l-k|*??dKBv zj}rV5g5)pNP7oF!FwxlFcpt&k$S+tdEfA(7mi6dYOn`z9XEO zQ(q9xyNbh|E8za1H+vly9@<4$82GQ75lBDvgY_oVGFl;-M^pwLpS0M3^YDjX_>bQ6 zlz0$MxfgJ*V6B7Q7*Dvx(-yyuxFq&l{)Rqi<1s_v*N|7wKp_rMMh(6vy%Ahk#dsth zF3ew#blTSzaZpUDPL`sRtBC&IXBT4BeLSZ2HNci#@y0dly4T#);ie?d;4a=YUvf>) zO&#mwn>TG)w|UE^j_c-7#q8Zra$pX$`)83u!m(Hr;x8+oqn4o37|zyw|TuL98Em?Zm1xpvtY6!N*r2_9W!HF+scN=G|*YNN9{7(fzbLQxbE~5{>X6V`b zhJ6iYJQ{9^2Gh|^;N&MXl*zG7@Zw)SJoXw)CRxuzyM2=Jgxu2YPPo86eKA zGmu60-eGS;TQZzBQ_1WueaQF#GW18H4Q4W0Px&HwL&}dF-Kpki(x^ZJPpU1AEIk0r zB4$gJ6C3lhyWE69JtFB~C?3rYyU-^%O~GZ+>@HV!=WsbPw-F=R;W-`AmQ+W5 zIF(4GlJ#-3wHXyCVWt!Py~D1y)+kVJ6-9aK*$fL49v?j zFjIfQ6mZ}#+$dniiNA2;zkwT<{HG+yQxGTS|0}R1%p&2=+wdZ@?cBrHd1k+p+%zMc(5gU8N;b$I-F|m1ni5X zqRWHvfXY6*i&B?RA*}!^M8~4Etx{lV$V?}K&8=3gb*kj-rc$hhNNJs!-Bp299?|Oo zm5YYQnkOo&LVcB0i%2)?oe|`N>MA0tV^s*rC3iQ7;Z_mLTRitll7vX zhJr0nPInG3NVh;&ug53!{(AXnjbe9^Ml`pl%-$_f26H8@KADO{>szDCs6UACVpPM` zkmNE#ZDu^8R8}ryR;VqVP9>wuLEJz(@y_Ad;aC*KN^YVk?;Jj58nV7MW;RgvJBLfd z@lvbd57=R~lfhzC0zJfnS)mSB5*%v=_WvReU&QOCtsr7E1W;tk&Y%K(@LC=4OK91c17zGDQsw_#m+`-1e+i1 zxv*_(kqSXY2a;IJwVAgpny!yTThYuQ?bfhmN~Td3N4l4_1Unh3Sk{tiuMdMCO~L{n zBZ^sDQ;b8l4Z*g!WHmR>mT8r&;Qb7Zb=A@;4D8l=%$h{Ay+P(G%uS|R64Kb>V&^FC zPRrPbjb(&7FM^SlmewvnuZ5%aVNA1hJs3VCNn0`vT)MtFW%8KA-l*Be6_<(~X>$-n zs@C{yjRl+S(KEX>98A_Xq+04jDRgzKFi~=FnD0{vXN>P0t|`V9F;US|H^FQmgB+VI znn;9eYvy9giW@K||A~UzW6>62MFF}k*@PI$ZWdAJv*i4+(?RZ0e3km z8M&STV{&cZ)ZY!bR`2hh?3?<^fP3|UPxbH590+)bU_5Y80aqMqWK8fGEhkW{+E9>L z?anm@f?|SbYUHf_nst?1Gq%(E#vA?Yu97Tdn9Seou$$&MEG%W`q?&1X1mk2_AUS|# z4O7F_YYncpZuCL$`GPIW+DOXQM_XD_Eo6f5w05?pqluC>ie_6?!JufeX!o8CN^mJi zDw!lNJI?1AO9Nxl+1)y*^`})cwfzA$tf)_)3M(s#8?D?jwz2S!P1HGJ-r*Qwn5a{7 z5tf+z;ZWoR!Pr8I|9wP%tCTM-F{^7;)wm7)lO~7nqq>qlBlLRp!dwx;(5p`?#&mV* zjfSC5tUEDLT{k_-pg0wIX09(LBhkaQEcH<}Vb^W&kD8PUD-|g;6-ul(V4zuPm#*nF z`tYB@oqlh@7=+yp5|Y-r*5+-sGzyL&17D=IxrG+U1csfNB=i%UFVHxnHCPF&$0UJF!|=t8ZK4ITkp=ICVUN%UY?oIY^?=^+QS+C4S}~Y zNI!bF1778T0SCMYh0bY(f)|g6I`b&eZa` zYrnNNfk6AUBvI=qVP3FSQt%v=VXH`l80WOx3H&z2*$WCG_FEkk(2%kfI{JRhT1COb zKu^=J2))~CqhJKFvv_QZHpwm0?v%(OiY(GHH(PD%2`RjX{A_^|vl19A|HLX@z|v66 z6jMJcONc$2xT$yW`nr#>fp~52 zW=PjIk*-Gdpr)PP5vbO3v2ii(vtU^pdk1UC1F>;Krnq+~bHIysYQVd51Etpz{90Gv z)YT(RcQ=-}b~myN7|M)f{78g^8Y9LR4`m+Sr<+VaV7%5hwKFq%b_UU0j7?^TEb>M& zL%n;sFsc)0gFNm0_)g9n z2GzZoE8ma0Q-NJO8%NKQ=D4Lfr}Xs=copVbuT72g4fRhE=eQQR(U0btXw1>wamKFT zUxBFucmb-`ux^XcpNrPz>+UzDJ;YhzLRXjM&BZ6%n8)5Wz%hA)rCz1v7|7(R^Q3aFTTJcW%XaQd4}z_Ri+ z2mGl6K8-{rknG7NME;NX@<8?jL7$^c_ZWeXB4%z2wANs2bTN)+%yg;+o8cykyBBd~ zDrzDhs}}DUk#i$7L7MU z(Pe! zvtk7+x{FCcC*146Ri#2{>=mXpmc?2{I^9W)4P(I0vHBmt6iiR#6 zpf!JlQA1Tg(IO)if;>a7rkef8LjMz@{CSp%bfkvp#EX(hDtRui+`r?D#wg-t1}6#p z1%smm{u6^=C-4Dul$$n$(n;5G4E^Xa@P+FI zbBP3JaDa(G6qZ3rj%0`DrZc^p>RO`^sdWI>_N-pJn4)%McYBF&DnIoXXY&F9K(`0e zRY}(7?sDg&rMuGkNO$}2;qLb4+WjnrGf?o;U(IKf>8{FUx~p^7q9l!F>mI~mmb0YG z-Cg(rSOnn6XrstKTZVV`k$k+{gbWusGnDz#=+}`8XUjh?Ic`t^)7BVS;K z^*n5R^9p~x+DT*Q?;?>h%idWl(}}AD$ozJjx~IMaq@EdA^r)*8*h)JCGMxeE1#XUw z%NL7?GDOVg3=^s4*te6I0J_-od(}rP_t&(xEY# zcrdl-T(pAv_Ft{l6#Sen6A4`Wjc+}nT2@dY;ux^@-W|XtdNtp!7D35P(JkL+j8Gl6By^NiZ z$uQB#U)f7Juw<56r^%OF0!VSB)3>8Weq}n05Cf_8bU0hKqB-3X!`A?}#zgc1eHKo=5dMF#3m#*d+HEyt2*s3pg-EwWuK+onL%%1M`gPVFcZSEQD-rD>g@lZqC;V;p~0%d>jzSu}+doNVT zUVrSWsVDwQYh4iGsls$*-f5=|%n9aEZ5w}BqgTsl|wMVHj}RhRV9zgX?M zYi7SW)(;PCe)Y>zoOtiH64UDXnALSII;@0+$b63YiDW+H3i7A5M1s@7Q#T15YXMm> zI@IhqE`|#pY8}u(f1?JUH?Ncaqm7XV{&3!E=|PU2EiF z|9>%7J+OHug0$wVeK4tf+E2jIY8cJQ8UULztaEu&5k-F=(N(QMNO;jO^1E1yqzzuB z;Pd-^?IG$Zo#my)VEK*6f>R7+#X@f^P)FAFB0~9wT%2}sl<`~qy3)YNdhMrq+8X^Ne@|v;;PRqEyGwU6n227p0r4vcn&^ z?StXfgXeCp>mFFYsb_JWqwcKPvT5rLWWa%XObdk=%ZE5mKZbuNwwO!RWDRsEQ9pKi ziwsj(=KKo0KMsM>x%_zk03f|{mJ-4W9g98|DixI$Rl5*&ghCigO4cuoOuStfbuDvnVT=Rg0!F@2Cvi0#9G@*;!qTk1IXisX zmcjnP^`985+l1wydvovl!Me3@U>txG;^wUzdcgFn71O^E>YrHS&V}*o$wlz%ZNN|E z)L8AZs%8FQBsv)iPDYv4vr18K&5uFyL>=&Jyg4BWgeQtgav`9mvJK08lWQt-qYH^F zKwqK2ag%*HG@rQHFm-=$jg|`m2Ghn)V?OkQ1^p2)qoBpP(YO;AoffBJ zqQSsqe_Y! zQHLA)XLRU_|EUfwr`}^_KxeB3PXY$Df0MqX9)H#W|Iq>e+5uT7)0eCh46B0rl8?z3 z7r{bVUrL$1&1eRH?SRiX;64X@K)~B2;JvKARL0uU3k6BT=o&Q}cLl>!BctunNIx`+bpXMEV9SMoMdpXFoZvr3mK?ch% zNwc`0G;0==CXXBv6jbe6C1DR|aO9f7E;e&Gqegfw*CQ0>#e8gDILO~uTcIX7Xk9_O zNLanMiGf!cdbItSBmGaRHu+ciaw%VYYIkxZIn;aP?qvV7Po{hZu%oXh4#aidkUrF> z3S2%l(m%ZJ#AibG_oRLHYdm1RPM-nL?#6epkId$*n6G)U$^hZX2lguYQltfDV^GUlJlsbvT^Cgen z#mRqdlO?9cE>W;CRvic?QdOCJy>p|GLw1>o1V`{3$c=s^hLoU>rK+5E=0-UOzsf^M zWs`m_y2hI(|jeiB@lEuzq ztNUzgjSQ+E%2xT2xs-A%=SDko{b~kjXRosu))8LcoDN4vqV_GT*T8?M9AgR!R4a%w)?&)yZCnBz#k{xIX0BJ zpDAJV49H3GZV_NPmBZLFyO4ka3>CUnU9M2y)w8%ZIaQ=+=Jr95Id*|5m6g3}P7Iwn zgcjfk>pE5=e$`kN7w7;fVGJAbfOI zQs@K)O6?b1y?-O{2i8p#e48-*vFxaKMKhaJK{A?SR`E zq#r|U=OhJ<8yte`9q<|knV^M1`Z1O{;N=d;N*{}AV@q#R4g~pdPP_I^G_A7tE`b}MkwXU(bjS8*|yn`q*9`9^Cu+8+3{(O*eg z6KR9k{&YiypJDGICB;Wu6?jCm-9Fkfqd`UjlW>kAGU1B{<7gxuvlfJa_b1_7!mhpK zQ;kS#K}owb^#W=52PF{UVa=8=(gW6_;g|6W&#N{oy&Yrcis4v&&Et5sZuRn_KN910 zj|^CAVZh>>g{~nk5Z3kcuu-T~_SMDYtbPW^{7iNV&&v*~QWvBls+C3e1(j6P&k-+h z>vkbhS>oXM2S7rEfmXNP!zA%i{Eb=ln>OatROdyU_#05?vfF6bStZ$tPY zwVtU!8>=Zsz`un?^w>r1epqqN3-LHvKFPs=aSS<}D!6uE9yyY^qgU-dUboABFdb?W z1#F-8mR-dDv>KH&R#7!>3szBuDOg1nreGCS7+FQDX%$tNf>l&uu!@pq1O3CM@$pJa z`iEU9ztBMcuxYA<2Kt9hQ!O;mKWv&BS+Svi*fjHL#h#x_OTXJ{hPFrXrczjZe?H#k zRC^V(+14jTua#f>;JiZ)&SN+@7p-+D(=ihJ+_e}0avD!!t7B(u^h48oj$DZ5&gi;( zw~g+4KPC7JOJJk9<|raOQ(jcM$4g50cvf;S&}}R;IAJoM3lh>H*JDI7W)k9Z!iU6^`AQ+o780S9bqi5*|#_#mnH-vQJFxN zWCkyEXhqI3mL)7F)85Gwz_Ss>3wF{0zvqDe;DBFqKu3kpb}?4%_Oh1<4a<1VI!C@_ zqp8+7wK``>eq9e~Y42_{wcJWjwLcKF1=fHo=7Y?<9&&xgLR)wcZVxOjlul=4ZOQu4 zo8lr)huJ*btOcSTA7@2HI?s-=Y%v|ol)$4jH!FIX5 z#g8di3+P^0DIF}rWQP@XSg%8E`%&970(!u}fBe6p%dVOQP572IZD zZyL#ax4Fn^u2TF}CH@p3eB#$@HpoG(D2fjw!5(V>HK3%A<=3o?g2Vs^Wih7Yx>{L$ zT{1i>6MuL?aA3V`+6H1v0lUA?nube`bGD}ga>ul8ekzmeL$LcBu@W(>G~F>&>w zzNTX%O+$T?&M+K+#yLZIm^S#?59A?YxHto~e}FsdZqd;nA-j_}YUt($?mvr7Qo1P{ zD3iA#x_J?&GS8FXY^KasN&=ZWtgEh5Ec|EatBN(YV~*c8A^HxfsH($Faais?+IXai zX^)nzd@_+dHj)@h9uy30`-jXYRc!e+N0JGSJurGSJQBWxNAVHUE=Yy`Msreu%IsKa zf3939<#@%4c+@kYfYOP$s;z`ay(;vmh@+(w!O%c?0_I9gkaeZ+VdR@OH?zYAt`Nzn z)T$}`f$)*QZ#m#W2OM)imbNB92W=JTN z4laT@TO(9ri_6L$ghk>Y`t?$^chbh{1?sIXS0)m=2_#ImH&~tnF|r()EG`F)lgwH1 zRx0#h;=&=WOU{*QuvpRFl1jZLgROAUSg!`#>jf5bCAMY4h9f*z#^yyrvR$ykF_Ge( zqO)pW63d(+y{{c4i@BP5Vlg*QZZSV(+7@$FplvY^+uxIi0}lm4jZJY=kM_CM%$wpYb%FAsV!I+*j;2_#L!!hoMxO+m9Pn@kd@9J4bqkE%#e)*r}RASe`VcH z1Lv2l@yJG8znd^))~ysgV%_{#JW8%PnZcRQ?s@Ra&^sWVMhQR9;GePka*itt%)J}X zjb~!{lRofBc(g1m>tRHAho)~p&LwJp?coxzzqUt_E%nrb3tqIx%y6t8hjn;!#@68I zCNt@6d?tq_LSJaz>^g<>dQ--i+IaK2d;=}HyQtIkI*r*V`somy?In=xV z(`Ns(2O5ooqrZt|qyg$^M6+%<+5Y-{C=Frj))MXq?M>0*j*F?_xU5};HQtEht#_-0m6iNa125F6WWyuAh6>mpnyj;87CwN>G*P2j|g zGqC&sDNErxyqTc)u!jA4SUJ*Rt`Z8WN;I0Zo$F{Y?A_*Gj^c3FUG`!K`5I_A700om zwLo@=j|vALna}KdUKb_DGN4Dn97E{O66VZP2Cwb{SfHbj*TR@rF@6tq7yf$&ei`H?dfl zL3;Cpdl3?x`fLuSM}<86!lwi@a(+d#R&e=Sx7rVhkhb%1yA9*UDiMAIIKF8eWE34v z>OGu0J1?x{5k?nr_2mv2XOQ+!y4v&*$V;yHJbc*6fwvqwU*)AM$rb9(j+|Q{nYeQs z>_onsk{NSulk7K3FdzZfL_5wFK<&8HU}c2kR-P{;Qj{F~h||^<3~Srg6|mn>P~9Lw z2FrP9Y@xzk5eR0&vV5r>2Jg1EpqewfXoh}VPOoCH+4V|j(el~`HE{1X<73v%71nJf zEJL(6l~N)nB-tveJT9b3Kvt6*QR^jAqh2T-HiU}G1kxm^h8-^y#*O@eQa0k<2%%c4 zw0SwH{rfQC8jqZSV90R?N%b|iSU5&x-*~)|t6I2k{Dcx8 zYe{^B9}IH^kCt`rAGL1;8MgJpjjL)yu>%nZi}8p|j58vNevLQw&ap2<_V3ePikQbh zF%dbiPy3l_w!aHvssAvXpq|WNdN;aO`FE!L+eUBKI$E}> zikzh2Uj$K5wJqh}KYB|(?npc`^-uyu?@a8!GhxCYa$xit;Koi(WC<-N43-H~i8+M0 zVDFRIkHq_*J-qM4Cr2-gp*S^u43Rc0gZ7)YN0qx+(kSyyD8Iv}w>~5T+TaV6Atwc9 z%PJo)b5KS(gv9s+*0TSZj%Jr9nQ3pL?`6(w49d2H&D|n>805u~cdN>Ifw9WkKsm@3 zgs|ElW!Mn-_YATl)Gh}cB2Zs>lLTUbKYppi%LeB-4@50n&B&~ba^6|qgb{dw>V?qQ z2Ne`hp%^a|Lpx}1Bfe!foy;z4Pi!s&JK9sNF87)IVM)1`On|~EyA{RT7bQYC)|+?I z3fLDB$azR^1Z;gj75D%uAof8^W*{CUBQ6$J;AT|d^kVr?Zp(*dz5y>wh?`NGS4jvl zn!nqA|Ku`3Sv}sx1fYpQULO&W#@%xZsyAPFLh6D*=m@%rr&+h0j0;6~?=(Yr{+8tV z7KzDEB2Th%gvaJaRLg5#RkIad^6FBQW_=Q@`k!w#3?CbCR6za0Exr}Cn<2z`wGrv9 zN#M6TNeS^=!HWOf+wO;S&(?#l}%@$@Z_OShr!|AjLg ztyJdtn=;4WlzmW^S98rapw3)#ZbyyP3qtB7>A$-V@f z@Sj`ddt+%voixQCWF`@k`_d9RT>{On|yw~SQ z9%2l^ul>JraW_{`efXovS6bD~m+9q$+Ac1Ef5fuZC}Zk&VM2Xq%e$V?BRm4;= ziGPQ{3g-TI31lmm_836z4~+dXfxmaamoQk=)A4j3-A>Wp<>==LlySl4tZxuj=W`SG z#?UKd<5#(vBW4Y9s_(7k;HS$u_>Nd5zZ>SS$JD_%9RTX08ctFn?{F;tyl(Xo<~7s` z4`hu}w6m@waz;BTFXFFW8~x?UphOcCw<95YGarwG*NY~`RzJUS=EG;f`U zRCD-8#gOePMOn0ud&Digbn@h2js%;rp(6P!T#wtb{A90!}J0x zQJ=!ghe22MFDXn_w>kf^2{K4**`)6O)_o$=gFBt;2Yc#z@ahR}{x4Rm!KY+8X@3{O zF0TJz-=TIn?)`qrUD$O+vIA#^d8{95jJ+{3+TR$QdN9gbOjE-IX$A6((UHi5iGeex zR*od^NW^iYWo&L-k|iXV82wP>zQjNsT^<;#8Ca?t0^>95xqCm;DFH9i#%JgWx(YlSLBwHr z%A6{(d|C9bIm@>wL)i>v&tpus0u6&DS+%R#UbOEJ&qVicu-V4@F={!^EmwLaw$1<1 z?mJ+Al7}6~h=aXC7q|v0Oo3~l!W6g$DolZEpu!Zm1}aQ}YoNjuxCSarfoq_`6u1T| zOo3~l!W6g$DvWXs+^1iz^cNM-HSo7>)Il&q9bajO%)`PAdKe_G%$eiHfu_SvCN|-5 zo6t>!P0)GsG#;VxI5b|N@j5i+LR0S0R0>U{L*ru__(|r=@(YdMp{Wv@Du`?>fP@`%-F~_tg|G06m=|B_R zVlnfiZXzZ2I8+{?!i>yQd4|0Dxs<>psE(C z>H?}7DY2%2YW^YAeSWSjAkI+o%WG_Y4%xR;__;XpG+LrYoMB&3$v-4FPsO-ZjGJSi z2cNP$*zT95T18bp)~1}D+VWA$57}i=Me`HYv~RE&(j;)-CUi@SzG)g1UtOCa_s5q zV)ssV|8RX-FbV5gkhx-<;u!)%43ayo@o`!rR)p|aI-b(T1IL70%F*nlJD}eTPb^#UX2w$v z_U|0<0SCOx0a*v-78|^M640rRVLG&|(1{DO7=Wl|`tdx0{+a_i)zQD{VE^6$zvzH> zJK$CayxsxZ98eTuF8C4$s}u>UP906q|}TD8h+_ z?{dSg5HRJw_Sog^wIi8Nw^ysRY-~|`O(6f3=~d1t?KLVsi)hwmVSj9&kF9&2mJbb_ z3)Lw<7Q<8(ur>wV@J{*VG{J{u5s^-Ex05{O#{yZD(o>YuQ=AeO4xCnS!AR*XPFY@* zvb;EDWl_q?;*@kOny)QHdr@s+ekmvuaA7;CSx!nEo)osTx+rCJamt#)l+`uGDd%%a zG;w~8x@=o}O*^iB^THs%rn(2*UVDFgjVu_AcE8Euy2`&R|$^3gb;q zOddXI#`X|wpRdN6)Q;!gHv&>5XFbe)v!OPZgBJanCuG>r3e=@}lnPRi<{GI{7aDQgN-%FuOElAOR1qVMFI zjD4vH7Q!jE0DdmzD{nWBkk{T7Q{~KrbBUasvjS1`KbFJ$xK?MHb0!1$+@HwWLAdqd2yd=AwRn+b181Ac> zmKHPjMGiPG54!&7fWLG=M}=@n11SgB4u_!E0pkwn9Fw}#(uZV*n5ifS<3IAWhND#( zVy0pOM_DlTJG74z$c;DdXOOI{#yt*rrvu*VfLjRE-Xhw52VCWV%pJ*B&SseQEQdgb z8e#PxGnOieD_)c@gS#EDKzDI8JN-(BK#TNW;@i*pYF~G-BMvwupi*>2 zEqW^~$crVQcjVk;T$kDLri;-Nw$g$3ezir)WRSnzpuX)_Gpd3iS)0@e&JHy8UC+Dn z9-2iDiRous*SKq?R#g&|OCUx-z8*krzf0NUj)npY!#UlF>2p)cr>$~S-CHb6y zrYsb_v~vwCpAoIz^5|W$Gd_AoXVeUzpC2u}e0ktWz} zOE;|U?q7X^K$H|mCC!AS5czw^>*3BEYbZ_3WvFFM&IPz~qXcV2v>tCk3!`hd# z!xeRP&63q+b%c5dFZxrso9<{4Afxz60*6)H4!C?Ss-r(dt5q_WnXTkkIO7lQB9;0} zuXvjLbPcYBunN;3HY+1zH~%$*>@IJ1c){|X!7V*?=hSudY+Qd6{;KiD4eK|qrq}&Y iaOt<`=V|)+HvN#Hzw~?bLw=;CuWAnSOURCES>SEDIT-WINDOW.;4| 84792 IL:|changes| IL:|to:| (IL:FNS BUILD-WINDOW) IL:|previous| IL:|date:| " 3-Jan-91 15:52:37" IL:|{PELE:MV:ENVOS}SOURCES>SEDIT-WINDOW.;3|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992 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 5-Dec-90 18:20 by woz") (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 (IL:LASTMOUSESTATE IL:MIDDLE) (IN-TITLE-BAR WINDOW)) (IL:* IL:|;;| "popup help command menu here") (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)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (10285 84660 (BUILD-WINDOW 10298 . 16138) (BUTTONEVENTFN 16140 . 21662) ( CHECK-SELECTION 21664 . 23704) (CHECK-SELECTION-SHIFT 23706 . 24829) (CLOSEFN 24831 . 27834) ( CONFLICTING-SELECTION? 27836 . 28597) (DISPLAY-SELECTION 28599 . 29626) (DRAW-HIGHLIGHT 29628 . 30758) (DRAW-OUTLINE 30760 . 32115) (DRAW-UNDERLINE 32117 . 32892) (EXPANDFN 32894 . 33401) (EXPANDREGIONFN 33403 . 33993) (EXTEND-SELECTION 33995 . 36572) (FINALIZE-MOUSE-SELECTION 36574 . 43120) ( FIND-LINE-START 43122 . 43813) (FIND-NODE 43815 . 45090) (GET-DESTINATION-CONTEXT 45092 . 45644) (GRAY 45646 . 46033) (GROW-CLICK? 46035 . 48020) (GROW-SELECTION 48022 . 48365) (GROW-SELECTION-DEFAULT 48367 . 48738) (HIGHLIGHT-SELECTION 48740 . 49033) (ICON-COPYFN 49035 . 49379) (LESS-PROMPT-WINDOW 49381 . 49750) (NORMALIZE-SELECTION 49752 . 51118) (OUTLINE-SELECTION 51120 . 52258) (PENDING-DELETE 52260 . 52594) (PLACE-CARET-AND-SELECTION 52596 . 54156) (PUNT-SET-POINT 54158 . 54616) ( PUNT-SET-SELECTION 54618 . 55067) (REPAINTFN 55069 . 56347) (RESHAPEFN 56349 . 58687) (SCAN-FOR-BOUNDS 58689 . 61232) (SELECT-NODE 61234 . 61604) (SELECT-SEGMENT 61606 . 62046) (SELECT-SEGMENT-DEFAULT 62048 . 64075) (SELECTION-DOWN 64077 . 64487) (SELECTION-UP 64489 . 64915) (SET-POINT 64917 . 65676) ( SET-POINT-NOWHERE 65678 . 65937) (SET-POINT-UNKNOWN 65939 . 66560) (SET-SELECTION 66562 . 66995) ( SET-SELECTION-ME 66997 . 68089) (SET-SELECTION-NOWHERE 68091 . 68289) (SHIFT-DOWN 68291 . 68832) ( SHOW-CARET 68834 . 74392) (SHRINKFN 74394 . 77129) (STRING-OFFSET 77131 . 78491) (TRACK-EXTEND 78493 . 80549) (TRACK-SELECT 80551 . 83040) (UNDERLINE-SELECTION 83042 . 83444) (UPDATE-TITLE 83446 . 84658 ))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-WINDOW.~2~ b/sources/SEDIT-WINDOW.~2~ deleted file mode 100644 index 8e201570..00000000 --- a/sources/SEDIT-WINDOW.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/TIME.LCOM.~4~ b/sources/TIME.LCOM.~4~ deleted file mode 100644 index ddc326288102dbc6188178d4ebd6cd2823db60d8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 9369 zcmbta-EUjTbth@9*Xx=BrF9KMbvF~j5-4@4@RA}$(W#*;^3uE%$)QQgw!HExj7Xal zX-UvW;zbmpDGH=7EwDkG7Da%dN&4|9x%F=R6{2lk3iP1`EMWhE0&QQqsoTe{`Gc#w-$M4KAkTTL{!3d_!oDnn&Y0lm&8G5RsFXRm7zm?4S*?UDj zxu{>mBc3L`0W+5n+)40Nj1=>0v7o-S9Sn!GI15J-p=d&z^|OF~ZS($Cvt6&T%?;*f zUUb|4R;s-C?XNEF)VFu8wyIn0>c-XF=32FV^?tq9u74Dnj$Umyced6xx9eATHutvI z>N{5}X5N^-64{@GkU2F{D8#gQBBUiEVMz8TdA=y-FQ!%VGci(gW1so+B$YudOYgPY zto#v#?lSv?r>Cc7hgx;FUPB-I%dnQv<`SCrORhR3CH*Rk^kQP1ti-v7h^bSJv`XYi5{MRVlFiX6UHwqOSTc0*bhdHjNNN|cf zbZXbQu)-XNLEO+wWj4(!N=@@R|ODsSM zi!7yA^b^ykC$S&pNtQFq6;?2F^yhatAL4l55R=5`MdHwxa+U7fgA|Y8HkPOmwF1r= z35_LbKA}k_hYdNF8?-NA(#rz2C5X=ZYuk0iGzyD(vz(;)TB0|OJr<4v+&V9hDTthCG%RTS*xiFMh`~`YMbrt+(L2r>D&l@B;^zvq5 zr=_s}Pny)~8`t-?lGGzAU_f6BaEnY3PMR(U5j%sth{c+>kv1%Ev?~=l?sF99Dun3< ztK0W>g8NXdd&KMVxauQrSEe=M@np@HKRR;#Wc?jX$Td20bS~3+`ed<|71Y1zw7*33 zXPMT|o)>C)LHw)E*92?p#Xa%0DL$yR?iH$btqymZtG-UAwR*m@I@;mqYkX96`);SP z>RY|gX%CUa)r*~Ve$o6j(WS*N=BUy3@QZwyn%wti?NfNVAfGP!vb8D=^Z8%4Juhw_ zy;^L2Ry}%kT@k-8A8#+>!!N&g|5`*@XgIEb8C924y` zibH-MuU_tO5cy?`W2${lamerE)j)@X$OFWo`?AmZ@UwjGlMEmJ zFTQXE!m+Tl=HgOiK`#R|-72#1%&a5=4R?v~53+j)5w=Z4M|UkUfDbI&R-+8C)sXl3+sy=NGWq$E->v!8j)o0lc z;R0m%GQbx+ZZeooK~Zz9<8|0SOo9({-^(AYn`rr9Bfiezf8v4q-dTjB*rf1LOAK0; z{Olr0&R;%_v>ec8G=x`Mon|Y%m=-})?yH`pFKgj2-u1*PEkwGdARA(HO40cn6rmB- zVIArn!f#)1?0^4gDq?s8nq{#k=#R~)9Y3KUuun?tE6PDV6bgwb9~XPZT&F~=XgGow z;TWnMU%Pu^&S|F2v8hT)PZ~kKRDmN*A%e}l>z1h;oBA)qnYIV1n=<#`-JE#Vd=7$$ zVSKn&5GnW{I*mIbHG}HR%|Gv)5fejp7VpM76ryVUqUiMZofhH|z3+aEygN$Cn7_yU z6h2I}7{7E*h@stIz0Ccb$!-2&j!*)>#C^ojQP0fXtVz(2LuZxgFAJksv?qJy^Jz-g zp_BAIOwTbsEYkPz(JTMS8=2VSCyAY%yctt{#zdbn^g&b$%?v1|q3J%dD7rNyOWG|} zmrIQBI=cmCpg^Q7PlKWK`KuOz3HCa%rp*i}uC&nHKhL z;WzI$H}0{!o7?Q*gM%vv3H(3B4pQvF!JWiGI8&Xy>N8Y;VL42#^tnLm`8YeA$z6KhAibkWqF&8fIf`Yz%*0lAvTk9FtBM zn3-X+?(NkAqOG1^Na-vbVrg~q1z6Zs2RXVZ3k6UQ${C+9s&Y-}4waT1!Le$f_SXd( zyFxA`FzC^q zt$t+HCwM&k5}H^5Jjr^P^8q+SJb<=IOij{8@JK@CqNTir{tO(YyR& zV{G+;fMcUbQKN_d$S+PHz#aZq&HcZg4Ua3|`s~gx{<_hgkxA~+f8=w+J`yE^rU`Ll ziWf-ev(;fc_rLMs!m!9)QI*}1UW!Jk#7j&IDY$S#f~9D1Dit;m2ynQaFm4%1ayYnT z1Rg1#$)tJ?S4HHpX=;Y)xtscOIap*7X^X&NtgwXegwh?yve%d>rg1_}4)RsE%k@_3 zCkyK@|2CR@I6hB-SYMzoS~$u;VMpt~lNqJh?6X+plPeINbp$=k-oA&Zf5yL}011nR znEznnKxgpv_oJ2HW(RXA_&X{aC?yn{#?g7SkK_GFn(frrHaBWJ6dQV$FYX0w%MZ)5 zBpJD!M=thtyJN7-Q^4~A){lJWj0E&w6WOWtLRPXLck*^L1B`!cj*g%fAl+mXo^Li} zg0iR*!}n4pZg*03w-bj~t9u~HM1GaF~nFGU!pALJ7gnBcoFyL@l0eCyu4r_yXk(6n8JFhl3kXIDM z{k*e-d1HeRyXC)*!7NbcAVvla1-I@oSV9U|S>LqgVuM(5X3)nuI}m=zyP1_0$E3QE z9biUC+V49^M8Xy)4gQ01cw!_j9I(8*xh;;%aoUbMFx);R4#p3@g?}k_pdWnu;KTPB zK85FMG3HM-cUo+7tG-^+ZBm3NsYoZzz76k01>nC zP|;1?L12g?n`Kjav6x%VaK1=48buakQ$oIt5*721{Psy=W`A%-U>Em@J~Z!nOo_*& zSw7mL2qdwLBCWNa+BvS%!?Tgl+xl~}8_S7G9~t`0=1Cy67j5mFYET zU?E?N%Qk~a_z_*4b&)lC2~$8lCN7%>fj+#pUyXIapwpspFiY3e^#}E}*O|D$52U_d z(zr1+Ag7YoW7>FUL)kEI8-c*JAQah5*LpR=FR5wy z4l>HFc`oLNU8YtT;6J$nhKNzuBs{q z`wuZ)T_{5V7*V~%=0|W6YCXzr6=%UIo?H@_Fm&9h?l7%=hD_^r6Tc7;x0kH`jcR+3 z!X(?gD+;0e?=#%{BmS{QeY>u1^IPhhz?Po+|A!hS7D@yxLf>?uXF zNxF@kB1EZX6r`U~Op#Fuy^5P@8;qg^k1KqmR7~ft0YE~oV7r+C8YQL6e9zN@T9)=9 znhx7Qr(6=(r_xqPCXi(xmlde>lispcore>sources>TIME.;2| 16504 IL:|previous| IL:|date:| "17-May-90 15:51:58" IL:|{DSK}lde>lispcore>sources>TIME.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1993 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) (%PRINT-TIMING-ITEM STREAM "reclaim time" (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "Disk i/o time" (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) T) (%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) (%PRINT-TIMING-ITEM STREAM "Page faults" (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| TIME-BLOCK)) (%PRINT-TIMING-ITEM STREAM "Swap writes" (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| TIME-BLOCK)) (%PRINT-TIMING-ITEM STREAM "Disk operations" (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| TIME-BLOCK)) (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)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (14079 15908 (IL:TIMEALL 14092 . 15906))))) IL:STOP \ No newline at end of file diff --git a/sources/TIME.~3~ b/sources/TIME.~3~ deleted file mode 100644 index 6f84b517..00000000 --- a/sources/TIME.~3~ +++ /dev/null @@ -1 +0,0 @@ -(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/TWODINSPECTOR.LCOM.~1~ b/sources/TWODINSPECTOR.LCOM.~1~ deleted file mode 100644 index d24ea7ced6d5c432bb53037b529d4c58af0fc018..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 55277 zcmeHwYjj-4eIIt0FFml_T|x*9)6_Lg(;y?j*j+qG+EuUs7Qh0#d!gM0SCnNz6c-Wz zLWDw6ww1@JVmFQ3JRHgKvv%C3AJRB&vV0)5C{f#!b8=#xp7tc?NG;{&@uf-A<_me8 zeCl!7-~T@|cV_OrO9GVq$f>C#?7egEotZoHpZ|M)w|^=>T`1=VrVGXVK%qSCItLbV zlk>Tmywg`G*YcHOp}NrL9H``TQ?=Yg(N{c?tLB~b(BaO0s$dd#)$&tLUuJY*?$p_V zV@I8I_V`HVcqY^5^!J_Kc=ox~_2q`Man|W`I)8SmI{)(@ZLFR@^DzC%JiOL8e_>-| z{rto0r?U^QubzMI^v1d6?BLMD=Qo}|cY68!!?n6QRVY^%@{={UGWe0~VW%%UG*CKq zZs6F6lNmam%^n{b?sJ}^hSopSa8}PcoqeU{#`^LLPI`DC_xv+-+UJO_pIJTo%)`r{dT!&~1+Tm9`kHal z_?I1ZPOqFg`^@rrr}M(b2ah}bCvuglW4+g;TdE#*`lriP$1Ug8`wr$Rm0WoyUoVuW z+`4_Kl3&PSuBOY@1J!&jU#xYSmHR6(+8xxDR0=b*wYpJIa~F)$!_IT(mOrt&@%(un zM7%_2U;3DsZ;VkIlYKlhayMg?KHT}ZAfZ8{XPD_)p;pY7^5sS6_|(zPa-rySj72*- zI-bP;9S=4(=%;H(tMLpUIO<@3YprqipWbS$^x|JK8kubry6$ZyI#5Apf99A2($6gx zYgF-UzBq;P%M3Y_#mYj(EiKfXVdv*|#OPw}moJ=N0ZBiy z=+^R1B|n|7P0oTEe!J@OI=a5Pan>7@us8g~srBcVosFmYbhM|?C$bCH4M&|Sgil`FaLhT8 zD=y~E8^A)i->58;rk5kZNGBObyvj_)U0k4othkZ-eAwyuhu8y>p+%k~HWp2$qKl2} z_>C{u6K59p#!uhds@4;Ar+%=0sD7Z{w^%W1HRL_|k`}k<(qRYV>rf)qF1<&P5|Qo{QqAmwxcu z)2f}Q$Ln47RK2&}Q{UgYhue9m#?_zTzx6o()R-CbpZn;h6Tb6$+*gq3=+BH`#1?B} zoQN(kNW=b;^ihAwP)3r9A+ypD^qwHA&gK?q#?nWRSt7EM*H_Zk6`!?ifHkjH_5%2USlA2T5hf>C zK%c}L3r?{B{-VZAl}LhMc0f!@9t?Twv49?UoS=X%2o6-1h;Lr>Bg*}R|E1h1bJF5y+ZxtledWqx}iz@}v?r~+vyi#~9 z?_@L1RCR%e5FAY^O?*1+lydWAHb|9xK(+!38MRiLA`u}wGGk61s?WwJYpWO5m#3iU zub+CMdg0visb`4+%gMwHc@|PIsH)8PULHa$sA^_RH;A{poL^D9YKjjr~jCk zd2kHLhsWe3$T`(h=@$ioiPh7pCl#Z?A_>$@0`Bl(CvrT386D?IdU?G0z*=Ly(O_o0 zvL0RKgJh&**2ntZ?env@Zp|{~%%sGxXduUoSR79n$CJkK)aGtYPU6uWaN{{+wQ+fm_PGk?_n7LUgSD7h5L}79G9td;= zqRqZ#%-=Og7yFK3f32CLj!@_7PWqTU6fzB5P6}YGxa<&Wl4~b(bWCu&Dm(;vCo?)C zPUSccLlC)j+`J&KMS(jgBNcI`)h+Lt=h*$HU~CiHTh#O22*Y$^>)aHy&c%vXm&~ z0#$Iq^_;wq&z4ftn@7iG6|;QhJ1c^ptD1URXCr^-_S}5g?fEp0UUw7a>rdU^`iz@+ z`}O>0W^R65)T^En_4c;bzwP$oq26Cu|MpV6<)+;D^{4J_{i2(C8>cfuYyQeiJo4I1 zJbJA;KKYHQuTSRBynX$(scHPZ)*Q@FuQY_Sqmw(hv_Beg_mg6N{n=aBuetmAj89%G zx^Xx4=9#zOTIyPJyKa7MZKFewZvPmiveD1 z^zxvMyIpR#8!t2e=GVyaT)3$x*=rFShIh`0x2&ro%@n=)$=&2SqNT;rOX z5EY11)aMnrU0$6I-q%s@d**uH6?P8yY{IB>9D-zIH0|VSwcO;a;AYMU7!)hMSTEqg zg8M0!2cyE);zx%3Jarh$#m`j7>?Vf65@i#^qi`j$J5)9?3`@ptVmQF+hXcYd3tlg4 z%z}ehHD+N^*d5A1B0(9Na37V8X0i|!+HN^E3f2xwxG*ipgbX6PQ|Y4_@JE>R(q>MB zoroo_A3~+RhwvuC0RZL)UD|FV%tA7m8;K0TH;%#-$V>BYv6?4G9BhIyt3wd6zW!jM z?e0Ln2djY=8!UuA8!W^m1PZ|~MUnz>kxS>7uB#UNGVpf^Y zLzwg}Y@A;u|C}SeP8;W(PqGf~WSB?Q-QaU<2PvOOGy)$;svZ{%`kpgyCqJ-j{@Pq@b4Rl; z@_H$D<$d+;Qe-_^@7WtK7wd86T&+^0-gV=pl|=N~T=cQ#n;rdFr#1yrsDoY1WM)8D z@eMw@8!&^nVj3F`2_-?(a+JghJxs=NHefFY#*a*6Z@|bl)`Q9RFPkB7ml*b@GPyC1 ze;tQEDcAUIA();5Th1vinu|v6C{&FblB0WyrDWgzZWm;Rn_B9LeckPD#J<{cdm^*n zyLstRxBGRsXDP7{LQ&rq+njg1m*V@%mxj!`BAsq8OV}mxBhR$`u}^URm4w?JrS^KF z&Cf-adRo-vrHicsgz)8mC$FWVOR46UJNnbmrQ}=<7Rp3{Rm|)pd2XEa7}&gL8k4q8 zjtakRoCZVjl`G>o4OPjwM9ZG^`2f3cP<5~nMt86fE}mc^IBc*G4$$htWU;WY0PZZw zr?Wpj=J)PM6;CYSG)!i!Id($ADo|{~0fW)26CNd@`@#;A?oTWOTOnkhkX$34eGSj9 zSn?1WixX*LX3%!w>X546kb@8u6uFLlP|0?zjDujd9`E-Q^Jp+Iu0}=MXSvF!4E~xmjWP1HtEt8SeKZ;i@X-n{GoFT; zaa>`Jd3u*9sPMrrkiNN%L-SKcmaN6VpI}4WwjJuPOU1g@nC-|>8Hu#+| zIL^!$uP3wjy9qb`-OCRVmj%b$e6QQH(!10RJ>E^6d2=ZN_FH^&3C{Yr-JV0>j?Mq$ zcBMWp8Y>C)ooikzaa)nXoU}{kWx-q8En{@idd6SQaa{l%w_g56pgYi2CX zQVhNWgK4r#Kt^bQLYxe=PZE2G1B57L2(b8-^b8_Ac9TOwaKg($8i=9TLY?NS(*ZR) z4VQydXQAt9fdTc@VE%dKONGYlD^}tHUMb@WNsH02#X+tIM8%MXF`Y;DgsHyr*t}!a zm3&}AQ_PT;#<01`K*&E@Bc@F*8uL;b^C>T-F>hL0AQQq|`o=;N3=CcsC2^p%O8)>X z1YYUFHw2Dptb0pcwWW^b72)dXPsS5K(5A3Z7f8f7@VrKaLCRzbKdW&zz8;;86P1RM zSsRTX)Fqe@^g#;nPnQGSJJ>(PY_=2`C3}qWIl#YRWH-%qE4wM+w zuCTfc;gF0(3QSlh8~h_qnBbHK0j{7qDdx^#j2;xDiGReV(>r0 z#X$PT*d68#&QOne-BxYW4&LeVk04(PbWczG77{j81RIR#&vt;VT8yYKCZhc-SJ%e{ zGuruw;6^X4y?6#Z>F3t>h{D}Q;WO&a`;5ZMT;oznaG&U$`0bFtJJzGM&Yd0j*Ai(2 z%-LQwj^&NJVCv5c&*@4+@Wr9EZ{eLb%J(Q0Xx? z?z}j8hNY~49R~Z1hcP5#%T9Upc-;Vq-Bk1`R?7_SQNh>5iN)8Tp=!Pc z!Dp~3kFRCg@-@gS;{o<3gebb;T(GKWXw|fvZ^rCL}fRVDDv(9vJ2EL-H zld#mM9@Ul(*86dA`yD1{Pevxzc=`Rt#Ln2I2gC@xap0BNwTa2~9fiH|)_87Wl1&M+ z0-(l=_9jkh(;CBKduUpSyR!)i&6UpyI zNh@1m)TGu+{Sk`-CMR;V8SsaPqv%|;IQ_*_YZ(Z#8{p8TjdROy3 zjYvJU$^-XmadY?lO7F*iVgAr-(b(qSlv0nyHV0O5?`P^MUKq#%LpGRHGu6R8$%A`} zvCTxYJ5uky`SMEhPv)Y{KaL>sG#}ec?Ng768WIuMvIuO|QwRdVd#joBS|@j+g-}+a zTo+jctzz`G`RJ?7->RpKskCeKpYe@6`=ZO@NnJo@0Sq%SVTQ{#1Dz#E4H;ps!6lW4 z(G<$uGoS@?wd$3S0V|-0zjzp{-@Gm0a)LA5ylz-p$W-YQT%EgBZLPp`gf5#cR9As-OpPSZLfyBli-%W#Alw3Zj-eAmkfcff$Abw_Dw z#><#uC30VaOw-M>!B_9{u$9d3Nef< zKToN}!fit-pE9?G3?D;xQ!WZmF$>5`wWO51%sAzIo$Hnr z=GJ47`Qsv&f~FD^Ve$*_{V4l6I2~B0fkN~ccAHAdfo!E{g2Hp2Cy}~;x3;-{DW#r*<qI}UTXOofp-5$Xf#E(4F zY$5f;TB)oOZ^ni7CwloLlsfG4Dbo(0wXSHZQR?bwHHuxkT9Tg>Z+sCf@1@n|uelTj zMElW;x0WzZLG=z6iY>mRLx<8HG($=wlpn^B(uf=T%9VqH1eS40LF%}>xbOb1mOK48BDh8x{v z1e&zPdQDT-rOLt`ac14hVD1Pyx~|O_6vFI1U5<-cL*2686>v0X90#4i@h|#EE#aDAPdk7GHoh5rWRwQ4m)s! zD-OW9Ot6vktK8l*;ImbT3uHaHx)pQU)DzICWCd+h1t(NhfJ4&O6|AV^JJA({e!b@jm7%91Px41#9*AkL|w7Nj1 zhR_ZcR#LBEGj4~;f3~0^Ty4yGN&t9(rvSKd)&Ty)YV(_(2GIN!$^{DK<3oa*>p39L zp>iYEGHeNRGDti*4^`a1p0W0V;@6CDd#e=uBX}p|T(B^-&Ngy8ja*Z6-T5d*tb;T> z51KiwGtgCf<%5_ArZ+5k$bi9`MJV(Uz&SmHu`Aue_@t=eut3!A;XkX z%?Sm@$e2_6v!semA?3p`26p6<=@@ljE)jWUys#df*c+de-m$sQ&(D4LrTMGWk-vnT z!3&#;KuAZ_Mg`tcrh|~GQ=TuAEtHR-3m-%LC9>F1enEwf`hM%2h;Y{`$Hg#aYvEQBjMWl3^q@>L`NFCl(4Otqb zRxY!mu4Bl;t2v{i^q1JX*dk9!Rw~#U2yuc&9FQMvmw#&Gd2EfxzIg0TNIUQ8zXL1) z_JEn4R)fs59voz)+K~sG=~T=-D32dF?2Y|tjQtKd)ck`%9{>D!Hu2Kzi}P&E1O_`R zOD?^)HEs;|lQi-?9g9(rl-hly1bAbVa5GFSy zasX+xVcgUxvk!kUP4aFUR(L^t!wM&HyJ3~jaSMMI99WHnmV)H_+?0bPQd&`Iif{2Y9l8UvQmdV$t(lYgD#!G3 zD!u<;9r+yjJt+QFSuB^4<>}oC&B=U_&-~9hBO^{<9!LTY`#19#lcLlH-XNT>i4YvA z27$q*Y+`<$*#Z)W184f6d5&CV4SG^Dh$YhxTq6*ParN@ zt#?bvjU)Ak>V5U0dZs?S*eQ~v_cRuHVV=IfCJ*B3U_StqfW*-)ZcNlgEM&_#94W%# z=wciWLf{Z+96=n8{k$2bi?KKkNGy=i5G;;*g4uz{hSBUmWcKOv03=5}!58%%V9*&z zJYUQl+J&zq1ji%r6c(KzQ8VHSBJ{$r8l{5CjUcF05k(G-m1bQ@TUP==9_Xvy5C_r~ zTmTCbiNbc0LV8H4(TZ}G>w{S2Jd@EL}Bka5Z>bC{* z0grHSAfP|%*UeC5RH1UIG01=$8n?g&Mf|`R3Lj7i;zr>^#)-drXtxu~Fe+5sPAM26 zyP7b$f`teO9E>?eN9G691Spon@F0>!F+2!!F4_WR@-zy>T6~E@v1WLgoFAG+virl_ zUkvfR1(*@2{z0e3PH~U%n0I*l^vpuJjovKMd(;U} zLL`=|mZ>PRCjJe(z_kiq+dYz>56a`*Vad^ri7LxxH}&lqcjF4Be-8 zv}Tic+@|IBfG<$eyw(h0(HK(RQw)L`^hz&);b%O+37#;|whcQ%Yc_-^Njpq4$A7nR zN37MXRYeIo1A0-~13(r$lBj}IJUJCWJRq_T$~n-s9|hrVF-p!rE5Bca27eSVO1j@| zj1pFEMc7~_9s*b*(MDLT%_L?7be8cD>*B`wOv*UP;fd75Ot*+m7#9Lhb%~2))C4d{ zvS8P?%*=v6`%0j{7_>YnsDib!DzX3q0yVHdJ%jxxc9paN$E;G4l+g4t0j!b?#q8|- zIM`Rd5^zYncy-Xh~Bm=Mr?Wb9J{tat@-g3LHc z29~lpmCEVGB1p>;%8Kz9!C|T!Hf{w;1$Yca%EFrQ`PS|lX~nEtWp<{ig9>#80V(UA zEg`L#PuTk(puO4!2>6+Id&#m}Ls~H()meUUhI=Pu9cB?U=yS-K32!Syt&mcvG)Cq8 zl`;cj+*DJ@4^0f)jOA{=*T9t$jQov9iHyTKENG3CMrlZAtv*1xGqqRNJLQc* zl89xy31^IFlWoxL947yMU($JCN+#{DOtEpO&}~vVRjzPxm@1aK<|eqIS@CmSq3dwr zQuj<^^I?hb9q$~mgr|UYQ;3Qg~1=39Fx&Xr2JUU+#M9nQL z`W6ixKrO%S9zZPzP|L5=HrQ@Aas8<{fONXw#_5d6D*nn$DspWm6@9&#&tK}A{ziT# zP9QqdGYR~>-W-~V&m??kIu^Rj>#oCCGXh$tguS@kjF{822G9YZ>GUvSPWM}Av5frW zt~VvxPVbuA``vG>Ayu*r*c-gmn*_KcW=F&7^tipWyO+HK{9eM%2c#YoSBFq=RDs(g z$6?n}A5d`m6n+E2_PAX}MWQJlIf13)c1y4xb?SljOn6lujJO9iSWhp3{^%+vnaWTm z`w}?!syP&K4|&yirTyq{ztLY*WK=GCCHiaheTo}hb5mkK#3>DkDsX!weePO1f(DN0 z24;YKq#KwrDkWT?qi|kXxIjn2>mQ&Pv}cTVs~{et(LKj#cdNx2$B+W17kVtl$qfjk;C4n|a!B_2GjKTt!ZH&SnYqc=~bIY!A1g+Z7 zj|BGokHCXry~YS$R5md}&NlNk2qwpFVi;RH?Iwod<@J@IQCZ_K-rBAa8jpQQc|gBO%N{V z+hQ?U1fkISg!^JU5d;_;j1Z*ShVvWVH!dE|1C@+Qgz zzJjimn$lR^m`2*|C;I_i_E+zNcEE0_2>*>Dt-RiSWv$+G<>~tVdUvvK=lp97=yW1- ztr)xV2>kCo^`vky)JEWC==q-Ag2?hVwXNxKUj>osmOY)eqb+zF~oJfSEdiT zsYbmI=@9#hjryS*Uj+yhJsy3c*^0hKXi#4gt}Aog&7CutG^`mPRe-W(keqM5JyNn+ zvu71(Pmy$q%3u^ZCH*@T;Tk1gfQixLjr33ri18$GLHMaRFTx_t-8j$bo1qlx1NUn#qSkeaxUI_M4r*@OX~JZ{|wL1)6G9)-MosJ46HLr zkO9oA4E8K*zib9#-te<}j#=9O<||j8*$g5Y#wB8`v;{6;qk)9NLp(|G$IjgNlt?^#>&*3u$?H?XJeuNVMUgqm)keIXf1DNd?6>VRDs!$cAnXx5-Qj0Wq#RkESq1!`iLGm#-;Bl)6k%XxN)tNmN zRZ4vVT5j;2p(_On@%~7SQPLTcF0QpmN8cP zv5_es}xAykIlp84ypbA732=|Bs6K6~8*7@7UF=d&9lLuilCoG#wl=^lWD zZ8iTER1AH?HpqtkhUPG=TSnQ+!jJ4xFlBHc(cdWXGNiMVL`R5USrJGV%Bj8#h1_m3 z>&NoVBBROI5*UzIqN|dcD?%w@2}p#FZMQ_uTgxCNxLxjRMs=ES%|uB^287>wrM(uO zxd=6xzn}vh&fjjDz=<_#WiYo&KV>M>sBw$8}jB*>QEQ{2AiAR=2rlaXA&BCmgc?4O?l=SkVvKTA{Zw7ya zzCc^k)ddicR;)7^ex2b?N%IzS#wXk?&Ta5aA!EobF7*j?Qguq1j5LlC9iQCUq-;p8 ze>I13vQJDXh<|jF60GFGHYgFwD%)=5EE`TW){dJG|tAcqxaoHMl)qvu$xM# zYzf&yC1*kY8XFHGaR2LW|8Bg#*dC}U7Bbr7GL;G6DoV&he)X*#O9wbJPySggzgE$F1c5G~A0yFCmm&f3OfMgS+PGZVZy-FM@I- zH5zSiOY=rp%dj|XJt|0ZVrgLM`z&}2xL)(HiA<#i9$w7>VCi@!F$9b5F*Gvb^mmWZ z)^@Szb>dgP-X)AS)-L=IZL|-8kkmav0|{nG4bM`9>gp?2hGKB1Bm8ec%4(z2!|@8X zP3{&u;2WIN+hVktqZ$B7`jKRmfnMtQ-vR=VG9$qm|L^vo+Fric@z2A++MWvoYx@|$ z+60*78}9(DO`^8#funAVsBI!;m3g;u7>4BbAPiv2f%LOHa_|RKo8=+T4X&w?Ow4&(KUS1IM7r^)k>OHQOVE zIFIkqcXD`KHTO$nC!@az9uUc|vF<(gk7oQg4vCZtjWOWh!xX-oAp2|(IEsN0!}W0E zD4t>!XeqHxudKNO)#CFzVNJ(p$B#5j91WzR6Z6ejRfJPls;2=j6<}z2GXWBUEN>9i zC$5l3Xcfw2B$*H%d=?~+HsFe1RQukX);PlItThQcRQln02{#A%!i~$lA{phz@5|rc zmcJ6PX%=f+{OFP4)qdpQ$k@9J!B4KRCifZ4NP_=NO+~Lf%VTxf2 z6PW~Jw9I@ZzJu?*T`BaM0Kzu{eL+4C>atbn&@VecE4A;!DEZLr=J>+btFKwcaA3H-ExdvOY%7XrctK(KGR_&Id&6{OS+6K$7&Pu; zl_G#9NE-ImJaRwaT%RN}&4~K-BHr>Ri23zW%nwerUyM-TFSD9L`M2rnF~ z$p8eRR3p`Of1ilA>TUkC#Yf%gs|iby+)?Jb&0?34d7gourB{3gT90uCSCqBN2yzAE zC;$>^*N_BA1Yh@=x4}e)yH<`o_8~MQ?1Rnd<fvl(tCQVqqKmO;@y!n`#NGkEC)h9bOjKGtF?UeSNq3s+Wd^W4OyiG5(m(RY5>N`7f?awwH+emr*h z>k~j&+|g=&A$Iw55^V98fS%aXN)A0R(L991Zu$t3+YJ{QkQWiw?FaJWA^6RYeA+#9 zXsMr&7ypNQB(>zkzUuaE_8@M3aH)?;~--l zhQh#2W?^sf0l~KMLFh(mB!vYlK^?(D)8X$$NuY!T?+kT8LL~{_8RqN(Tcm77lkIy< zMj9#DKBm0r*fORy9Vl`ZM+BcUZCGePpziTx1 z3EETVk9g3QI9n5w{sG$HteG=?@4?`-o@1L3E`8;SIg@Y9xJ1l39U4kOpdrWu5jGAM zVryQo5E0H`;nq`jLE-lMYsQIn6sVchQ}AaXff0ky-Z+W)NgLL51sS;Ld`e~pDJQpM zEwm?0adC(y?Rtbr(%hKbGv0RBDs7+FEL?xM2NFl{Y{EN|pK}Z_ZE;0DzI|&KiIQA( zeo8Ypg%t%3_Wgwc4GyI0gc3pCUhg}CfvP7>)j9HGJkTHGfr_u7LOBia0?Pjl6k>tB zV?5BdbS>8B_X83%*raAK?}RJpTA#$87=s5~6oIOi+SR)wL2hx=$0J%}IA&b+p+_rbfZ4 z)an3ayQWEi;+bym+r<%le!06@+CrzG)r|L3V$)~R;0n6O#(-_o^o5!|U@6g{*EV3m?JG4m16fzJtXEP10E1cX_Cw zg5~d?>86mX0(741#2t3t6 z-VvHi1|MGvVY_yX0}y65(&zOvHs+#GKXVix0%uZVC4W%UI?eG$#q znh8SChL+(eChhl!B4@>TfYcJi^n<#_c5;F7G=w`a>7}{mF3KQ$G$-QxT)2rr(6y8KIjP|yB z`&P+%(PyDuH&8p&@CqXpT@?Fm0K#r;x8c35nBJI3Ez1c^qwkEbB~$dViCu-%^+e=q zVeU=-#>5Q_r41pC+<)G!<#h%Ws~}%h2Rxbzz`;K=36O1rb%xs!8yqINICO+mWRR<6$ z^33=eF`P4^5NV!ZeKLQ_+GjxDUa$+m{}j3yaJoFSTm+%y^E$x^Mwvbd=H~hD-@f0% z-W%md?4S^;3FLreJh4qt@-}dh6T7iQ{n>blda53mFdJvyPJUq5{56K*_+aGqQtXPe zo+uZu*Tvq}Rw+`CbE;aa)TnpecnPQ)*9c7GPmvM0jGI zvbKN7JoZHRKJ@)#;hf{ZNYEET?88DeA>?36m{1NMg1WHB%yfoy{4KUJM{~a;_ag%! zS2B$#!COQbAS@Tfp0B7_i99ahhvQ<*l9}D~F}3^fF*R&B#>W(6Uw6A2v9DsMZKUwM zo0m?wUDvQdIS#N2c8p*fE`Ol4;O>87U+L12QTd%6A`*fEky!pD8luB5ain&CBX;R> zYYtFqm%k|^tMqNx=2uB>wD&2dEjWpE8#sw{dv$?6R^-zc(xGq?sM=ur^a+!oQh{BZ z!NO3d2x6l~B6&DgMB3YNsv36FZ`S zNuvtxREe@JwzQv<5S+X`{-B37FG5q~V3mXE;gW)1eJooNJ zo**4#yF#!K0w-7)wgnUVw$z1@pw8`U7aP(PLW3KK0o;LP;9K?H}S^WQFAU?G`HEF?c6N@z& zi4@G@=-ib7t3VlV;>$1oZ?a&OLwPdnuRsUN zKghUj8y>8>9;89eTu~jh2<$Ha*KbB!BwfK?;tw(YoMp#De>_CCv+kb#le2J=Jy@G6qD=u4~#5oYy1#aKc-q;GxQI87c%9|+dVAdQqwAHfTl3m`K1%Dn&y*r0KV10>+aL3Rm`f3OgK|6n0( zlwcv2iMeRP6DQKaZzoc0$6Euy`2gb--}DGw10*)og2EE_ad3>Cr)ZG#UeXnC;k7m* z*s*SsmmOYbfVLPIDl{>4aKC_=`Wrt`GZombCT{iZ?NvAkY-5s8Q?RLoUnLE$=DUgv zY1(o^!;Ozl&lJkAiTqXkkW5&Rf!^{#U!vN!0ZWe$S~}i#%vXL|+p9j~)$1A)kA3g< zd3Dfm)iF8xL=_uhW-!jPU3DSU!6&z4zJ8d^*CS;zSp`u6Jq^$soO#{Wko{w98dQcX zG#m-1M&PtsYr~MdL%Y@{r-|y?Lo_8L`UNjcv}kT|p!Eepl?nTM|F=O#8Sr zj-qMBLb9R3OPA2%+|A3sBLxlsJ`>HaK;mHDY%SMdz82C&8oG-iI6R+s8f?Z_?#UWR z2ICUTn$Qgp*pd*GAfbsoTe46I9K+h7Cl(<=2`gbi-CyRxJ1$?*COO_J1`2<|hQ02;ecWs}&uqudm$4D&v zAXUMz-YZ+AO(ve|rKJb{7vHD2eR|+;8v2`Y=qZ2M-D}s3@-5)xy>6%8X>Bn}DKTY& z;}@>tC&}1;uu&2z`lR>8N$)G_PjDAm@B7cI*mowDD7GDZ6N?a8FFsj}TrsWYK`S(t zk+<@YJ>x4@3lF*D#uZw3u#7@h*t@LFiR=|y36pv9ge+}v7Gwm5(Sx97xW&9>D!l^w zQE&xsrIH?JuHr!2dqC!M1N3LBejV+7vQP2>ojJuGpH zrdq7kz*0`+%QeI~5p+>sK_UzRrTjs`mCtJnkdQ{yhX=^}r$1N(^$~u&VSK@=aQ6Ij z%cn1FoTD!u^9@FTLIuFRbVo4yVbUl83`F2SB595%5=MWgm@=Veav@Ko2$ezAqya@d zF-=~MAd`le6t>yo0_Kaqu>=Q^f_XrP!Qia1qlk)vP(YHXKu{2Rv3L(_+_oHxNZJDSj*yd$D+7ixn2bc{coHAuzv5UgZ-y5%w_(CCG88#a^TTxeik0Sv`8TeR z<_AA>kRq^-gN3G>8Y(0VO~YJa1|!JO+1Kt~fxOaAx6f zDw5M_084O;wvZ1Lu=ASE)Yn|F!sM53fgGHl1~dzXzcP={icl{WC=W<$h{lSF{519- z--_qVehzYo1j&Uk#vOf60))1cKkbNAN&Ony*!Ilk<~{m8x6uSjkpt*-$iX zJ=1VkYY%l>;(h^Nx4TE0zeM66R&=aLe2*gW4n^Y8R~6B}mVB`@Nb4QnlSJMl^EW`D zHW@Cu&gQmJ<8QSDtg@m(GAx%RqDovBos9!Wo5c z#DQ3sQuspLrRkL?mg3EvM|HoA<>L0;y!>^8?3%wCSvmsD7!c(*&;TC0`~`d|joZc7 zK$^c;p1tuUH(nrWPtSg%@b&q*qN44UM_(y}-h16R{sPmU0ISrs^0(ahD{l8|Zt7LH z>*~dS`1{!_4;8K)_R)8d=zE^%dyeRPmbSJOu(Jh3PFuW8B8MsDk=;oLC`8`bqmI}^ zqKTSR1_kAsg)fRS5RH8pS+MbT`#{XqqNqEFGf6s&uTHUH#ApRNfbSm2eY=F|-L|ka zqg5Q;V7MI*5%Qt67pY^majEx>=M}Bb^gM+Qx}$ILV8 zQ%^lV`1Ge9;@Yc=<)WLLT3m2Gxq4w`VS|ZQPi*o49dS?Y8D@K4N00S}l0Vqt@N>d&O4edViI9 ztFk}LGRbKFw^;XP1H9Qu6k9c^-Bh-oYgMRj@ol&=YZv+W ziY_|)YMmk6qs9fRTyFrt;xf@8#9Fcwu#Y^}_Obi@#e|0!@}x&?(t};A?btxzu1( zp`}%z`9ir+J3(pu@&>m;`VlU4&J^8=Tru?8RDKe0&iM}>cc$DtC~%yVgF-Qn(=tG7 z7fw3;75HN+Q(m=(-bg%6pLQ})>2nf%)F<`4eYgK+r{C;KxyGF#;qUKQr|uc>=AI_C&HBv%lZ*Q$WbiH>3?L=t>u|_8=Y3g{R?gZy{O;=xuL)GcA|p* zeijkB4$2M|58)o)TfOB_jMLwD0vP1W w&LQW~<#QXKawa#export>lispcore>sources>TWODINSPECTOR.;2 111136 - - changes to%: (VARS TWODINSPECTORCOMS) - (FNS ONEDINSPECT.ARRANGEWINDOWS ONEDINSPECT.REPAINTFN ONEDINSPECT.SETELT - TWODINSPECT.ARRANGEWINDOWS TWODINSPECT.REPAINTFN RIGHTW.REPAINTFN - TOPW.REPAINTFN) - - previous date%: "19-Jan-93 11:22:25" {DSK}export>lispcore>sources>TWODINSPECTOR.;1) - - -(* ; " -Copyright (c) 1985, 1900, 1987, 1990, 1992, 1993 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 6-Apr-87 15:08 by jop") - - (* ;; "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) - [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) - NIL - (WINDOWPROP TITLEWINDOW 'BORDER] - [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) - (ONEDINSPECT.PROPWIDTH (WINDOWPROP DISPLAYWINDOW - 'ROWPROPS) - DISPLAYWINDOW)) - (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)) - (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 5-Apr-87 16:18 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (for PROP in PROPS largest (STRINGWIDTH PROP FONT T) finally (RETURN $$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 22-May-92 17:37 by jds") - - (* ;; - "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))) - (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 SPACE (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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3657 4404 (\CREATE.TWODINSPECTOR.TITLEMENU 3667 . 3874) (\CREATE.TWODINSPECTOR.SETMENU -3876 . 4094) (\CREATE.TWODINSPECTOR.INSPECTMENU 4096 . 4402)) (4438 37046 (ONEDINSPECTW.CREATE 4448 . -8175) (GET-ONED-DISPLAYW 8177 . 10264) (ONEDINSPECT.ARRANGEWINDOWS 10266 . 15313) ( -ONEDINSPECT.REPAINTFN 15315 . 17009) (ONEDINSPECT.PRINTELEMENT 17011 . 17229) (ONEDINSPECT.RESHAPEFN -17231 . 17567) (ONEDINSPECT.MAKEREGIONS 17569 . 19517) (ONEDINSPECT.BUTTONEVENTFN 19519 . 21532) ( -ONEDINSPECT.COPYBUTTONFN 21534 . 23373) (ONEDINSPECT.SCROLLFN 23375 . 23791) (ONEDINSPECT.CLOSEFN -23793 . 24056) (ONEDINSPECT.REDISPLAY 24058 . 26814) (ONEDINSPECT.REPLACE 26816 . 27126) ( -ONEDINSPECT.SELECTITEM 27128 . 28967) (ONEDINSPECT.SELECTPROP 28969 . 30713) ( -ONEDINSPECT.ADJUSTSELECTION 30715 . 32255) (ONEDINSPECT.PROPWIDTH 32257 . 32569) ( -ONEDINSPECT.VALUEWIDTH 32571 . 32957) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN 32959 . 33934) ( -ONEDINSPECT.DEFAULT.VALUECOMMANDFN 33936 . 35498) (ONEDINSPECT.SETELT 35500 . 37044)) (37079 83148 ( -TWODINSPECTW.CREATE 37089 . 41722) (GET-TWOD-DISPLAYW 41724 . 44374) (GET-CORNERW 44376 . 45081) ( -TWODINSPECT.ARRANGEWINDOWS 45083 . 51204) (TWODINSPECT.REPAINTFN 51206 . 54391) ( -TWODINSPECT.PRINTELEMENT 54393 . 54668) (TWODINSPECT.RESHAPEFN 54670 . 55006) (TWODINSPECT.MAKEREGIONS - 55008 . 57809) (TWODINSPECT.BUTTONEVENTFN 57811 . 60440) (TWODINSPECT.COPYBUTTONFN 60442 . 62733) ( -TWODINSPECT.DOWINDOWCOMFN 62735 . 63345) (TWODINSPECT.SCROLLFN 63347 . 64006) (TWODINSPECT.CLOSEFN -64008 . 64401) (TWODINSPECT.REDISPLAY 64403 . 68640) (TWODINSPECT.REPLACE 68642 . 68980) ( -TWODINSPECT.SELECTITEM 68982 . 71903) (TWODINSPECT.SELECTROWPROP 71905 . 73683) ( -TWODINSPECT.SELECTCOLUMNPROP 73685 . 75719) (TWODINSPECT.ADJUSTSELECTION 75721 . 78089) ( -TWODINSPECT.DEFAULT.TITLECOMMANDFN 78091 . 79066) (TWODINSPECT.DEFAULT.VALUECOMMANDFN 79068 . 80644) ( -TWODINSPECT.SETELT 80646 . 81682) (TWODINSPECT.ROWPROPWIDTH 81684 . 81933) (TWODINSPECT.COLUMNWIDTHS -81935 . 82330) (TWODINSPECT.COLUMNWIDTH 82332 . 82875) (TWODINSPECT.TOTALWIDTH 82877 . 83146)) (83183 -90493 (GET-RIGHTW 83193 . 84045) (RIGHTW.REPAINTFN 84047 . 86110) (RIGHTW.RESHAPEFN 86112 . 86331) ( -RIGHTW.BUTTONEVENTFN 86333 . 88928) (RIGHTW.ADJUSTSELECTION 88930 . 90491)) (90526 97363 (GET-TOPW -90536 . 91528) (TOPW.REPAINTFN 91530 . 93389) (TOPW.RESHAPEFN 93391 . 93634) (TOPW.ADJUSTSELECTION -93636 . 95255) (TOPW.BUTTONEVENTFN 95257 . 97361)) (97398 98915 (GET-TITLEW 97408 . 98172) ( -TITLEW.REPAINTFN 98174 . 98460) (TITLEW.BUTTONEVENTFN 98462 . 98913)) (98943 109548 (ONED.TRACKCURSOR -98953 . 103654) (TWOD.TRACKCURSOR 103656 . 108362) (INSPECT.INVERTSELECTION 108364 . 109152) ( -INSPECT.INVERTREGION 109154 . 109349) (INSPECT.FLIPSELECTION 109351 . 109546))))) -STOP diff --git a/sources/UFS.LCOM.~1~ b/sources/UFS.LCOM.~1~ deleted file mode 100644 index a2b9c5434ba31ce6d6b15a7e106419a471a6f4aa..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 37135 zcmc(IdvKfAl^+PovaFa4NF%aB%k~ZINRVn$#DfnhUWFhD3Lrsz5CDpztwg2>$b3Mg zN>bihZLrWSsu9$)=fU|JW&0 zZ~Irb>hGL$@Am?zhvjWG8t{Ji_1(vLpL6dQ9ZipA^XcxfY%blM&5v2?p+ah8B6TvY zBH4U7UCd=mg@}5nm`;tBQ^Pr5_He3{RAw$RxVyzs8uU!Wm!d3+owlM6Q6m!vaq&vf_~yB7AtG(D=W3N6ScX-iQ2;2 zrMZ>WYNDt2#M;W`)w$~0iK($t&&T=>t4N}^dvbQQ`&gff_a0B6|71j+r|xTqDr#X_ zwM8bYm0I;#6-#!fEM69ae3ZR;$k}tXy8>aiE+A zGFqMMK9*E?3+9oy$y*YK+s;yVt5r;76rIgg)$!56wtP0H0*L_rJxxFN(9h<5Ptl(r z($CkPqTdh~^3Ps+zMnG#(PTnVuRXGTJ)`N<*^#t5riQJl{Ad9ylN{s<6?tJop3=`$ zm)FOZRU)CL^4T*gKH#ntkEtC@?ac`UDbRX#PD zK73fU{02rGe2RwsaAoQ3fT~x9!ohllrxXsE#6FYgGKuphF=`TFlV~@IPnyJ-Njzl| zohGrrUP*=bnx}hBVvk82Fo}mu0z;J1&6`BgBnl>xH;If%44cG|Nt`f=$4%n6Ner4q zzeyxbB5o2#>I@U1Kr|7?S zs;J_F*maXTUCfr#l09(D$u6YR6FRro$(_nOo%F|?e9A4Tcwbzd#cR_iQ#m~t3%LZ6 z=552-d`ZO<7`B~bO_h-q@6#hDATwn&fKs{)!hmTsbQ}XoI-4!^%m zCX+IQSfYs zPp>YlR|~U5en3&EN~yX|HL}YWR@9)pqF9}+NSy&eO}m?ZLEw|phDMfg&B$dP>A+K0nMk5|lLIyrstyN{%*e$LzQd?P*DoOR*yIP4xlxGU*M}FHT z2Q(fbZK>Yg-Wb!jC=mcv${s&{WGX+M&5w2$iWWeyd_-kI9=Kp6mrmuU3f*H?ak6ye zunHV(2?Sc0Sj;mDet_u49{TBM5jvS+GMFK(zXVS`N z%T_UGjZ9$N@j;=0v0gQuEoV%rl08^oxiq=5yntP8GDVpkc3S38OapXf0;*spMsG=v zcI$W2%pMHVBvcDeixHcDcy9Gaceh|dSZ-Ps-3TyBs|L6Q?ww2Qh_)-FXU`!oB8c4uIHVdeSPQtJH51#)9J6)Yr&0=OOvnES~rqS-@&y$tegBZyPI0;7wWZL+_)Be zxZ}TcOdn+NX|sR&pv)}%{Pe+)c{p%xUw!)ExlrBOw?gx@_AxzKdWZk~-t@ug$EF`; zs&lTh^6mN1bkCL3_7ceuH`7+<^rKw=?B=oQsLs7F$FKWwu(P)NSBu;8+n-z5e1OaN z$8N)&*X_r1VSo1#D=fm`hk1mYM*Z6TdSF zBER^~#p~C<&hLKp@0n44dGQBUXsh)LFSmTK_JN0K5DPL{NJ-ZIFodG%MT&@A%Sef7#>7}DP2+xPa?AwAw3px-@6 zFTS-#$-6GQ)awd_brC^={zeOK467H!4_WJjsM0? zoYlZO=!(1=I*moaa+n8N6IRBVz1PO`7x&P~P?D^OVrVkH)QAmNn7 z?PNcON;Ako>CUC|C(9YtPlBQJ&2lNtT=ipQjhQ4SQftV+BPOdS^Hz2e8oN~} zseXv@rX2*D)KsqAGnqOwJT*3!hA!II-zO7JLRUpEg(++v?UZm>>boaxmGtf$!>*Pl zR04HbnM?E?Q^yOba)x0m(U(+bu$9!Pd)msES=@y_Xs>hvgUjaW9f{r~cSXttcNKRQ zJRVP)MT~>P>s5~T0a*)u&0N{)`fd28N3`);jVT zSSe@#1})!%&;oIp7eFs^7BVVtM^=HI+l)S|44=h)DG2D{S zqltoJApq23RJ2wEk+2X1GP__QNHGn5bGQB*WU{^eHU9G)|8_)LGp$>@=0h#7W?vf` zm-+{4!HM>-j&HRtgfhW18@~uZA8v~RJN0UT1XAkMR0>)$(*O{kZvEWL`yETjdiI%p z*Cq}x`MN`)4WNa2k6|ZiKNuIs0BQUVEWwX=wFX+sGNoIU#Fkq`>?W}%(&}scLY>!a zBiy)-uT7O%csXs$P&W|dbe+wvdaX5+t?im`_%U4FKc&g{9-E0 z9YYO>febmUCkBLdD1QvXK9zw#ke=XXG{Bft4!RSzjCe${zd2)wK`+i*c@@Jx+k^u| z#1IfeIE03PfPgz>tf|~6*xoTA2ri8ooD!AInKp_|-iY4G3aH1X1z7w2+0org!par1!T8jXB zkZ~ATNU8#`G?e!Xk%Gj?ME`FA`n+3nr_g8ifC13n9_+{f3?QvTtkN)*_-1N}ADE0R zg>DR+ux2+gjgZArn?|&OyT>~jfitMR#X?TQ35btj2w?HV9vVz8#QLFRM;?!WT;o?8 z@NFxY;bqcOYLYoDX875=U>+G_m10OBZ|@?2M5hmQgm+Cqqm)OZCSLh)Myj5FeP}7y zUe}fPy)vOw;q3Umq^NH0lZ^Rr*d+E1>CWEVGj0=JOx7X1TDPzbcz`!hE3VMxY2 zV~+3^gSba418Ezs7o8fwx=S7j?~($M7Rl1i!8>(XjD>pifxczgT(nd`3vL3TRfbZD zh(d5f!axV++B%dPX0R9*?UWdb80H+MLu*4`CViN^D(20OA@dH&jSQCvjEkVI1%rW> z;_VTb5;Nl>PpzY)B~#gq6?x;XL;)wSWGeDh%yNxy)H6jr|E#nLk%i5$Ptod#w=pxd z)kg^aOlWK~F7Y?vQB6258O4bgi|VFr$362iUGsYu$c{6EE7OnNW&hZb)G6BSFC2Cx!&($|GDPmsagoGpJra4e=gJVdM5a9CbE<7UMY=db5=Wp*_8)} ztagE$`xtCoU{%jfZf`y!Fa1&HCl|NBwj2z6azo|v_?!O;gI+!VkMQt&IVdgMOMUU$ zYuTl1uWWn~6s;d?!c1w}Dvp-mVgo?%^YBbLjc52hZ1a=$k_q+G+iNcvfe9%d1+wN? zW5nPbLq!Z`mgAFf9a5k~3|=ZSgp{(A1(-qv#k#c(#b$(#4ak^}Y`*4l+}-Xj{W(^k zRqs)|UbegcvrYuw(IsZ9?2^uRuvZm-m}ry$+v zlw;j<#1s-4MPNzT7D2c;b)I7|1UBnDBlXyO>~WYnyKIfYrV4td3V@_X$mPfHAq4y> zA)ugKDxtn_cIkYuK5Re!sPp_T8y|o1bF+chQos25@HN`v(%sq2yPKDFi*2`%xF=b3V0Z#zpK zQjq#Wxd>zi7eJH>G;wbMi6}0-g&3o^g{=p&lQ9@GO|A<#9P1^_qAZ)jPi{8V-g3w& zIxk_i3>E~PXYaXJ0kcI`5htLFLE$WVmipHzI8YAL&@Q6Uc;>u{+yIl zKWI!{+Q!n<^Tt&>z_+hPjlE|klTC5YWQn=jk=2%%)I4XhtgN}7EfdDba%-F3V_HY> zDNEQIulXg`3)B|gt(^-!8N^?}++0lOQspdsyvBb(JZ~ybQD{a)?!j7<4F_DXc>xr$ zrUlpu=pW3UjWOJL4NzVTHDX#p^of|uof>deun|{mEF`)X)8(mRp6oV_!v=8bVyubN zNgo*)5Kx7&kpDfR8M6+bVu6o-;x6!*NY8*0oKEEkG(ZIa8mtLoKlE&zn3JB9Vy%x2#sH{)y3{~r&_SV z5WJC%Ug9L+qCxkzkOoH_S8zG}iE=azEQx`$45twflFnHtiOj_`*`!VHk#I~xET*Iq zj^~0W1Nlx}_&6q0*$E3SAC($Iz)~r7I(>SQ;&=Fw!oo^3C57da;+Yb?6{FxsGl*La zb1@Nu%3Q;aZWrr~8F%R^ad7c%&Jz*lGU=k;+otl#1gvqyyoNkDnZ@jhsQ&9pJdi`+tQM- zc96mVHkv+V`_{d}P7-LxoJ)u0!rxwie;dS#a=mpE6o!dhk(CorNuAyku=+M>fjB<5 zdn7@@Rt^2ewT9$&6rr|)D~PlB1Jrpg(FBP2y=LF__5g*Q-uA-wqzI|fV*ijsw#f|v$! z@y9{zvm6X7kD#wvPYggjL5@^iI|kpkQ<)-8J#}M{HaHf6xLOI34(w|(F#^ZPdZQeX z6#%3u$op?DbFHrsyW6GRY~&3eIsbrtgNSKZ* zaQ6 zh1pNw%9Q34FTyCzI*Fm-HmUEg7nxLVenkGx?ShxM7Ay*v+Paj({?=C?W>1$?cL@r`a>YP5; z?qqE~&1v0~(|K(H;s@^1j7%&;x0WTryz;y81h=u;-Ay^2cjxH$-da{0YYnfP!D_4i zb?);EJWp6 zojd{rVlP_z-rc<4YDeU)y#4u?1OHY!vGy%)U%71UyQ_6;e!8pmd(*<)x4*}eobEdC z62E-D($zKnP}kf;67Ix>JfMdwi<dgfQXYqDk$t_UR-Ho`@ix=9p(I{L<2wgn4~U zUcdPEo|3j3lar6zy`Fq4|9YZF(S<$ zM-3BhQA713s?#NUAfgnUD32ImGF`BDDTTmXi76d>A`L|XMhR#Ih|Ht|oMYKD$Uv;C zC!>$TuG}^H$lcV~YoBIh!q$@7>OgK3m_NY)lO}|h?I}Hk#RZtsAcELN#3Vv4oAjK7 zjzaOpG1icD3ggx(#2A2b-~sZwa7VupG68O?jgAQ{Q8SYwiSW8g9L%U$l^BAyNL=E$ zKZ-PU9w4c^*WJu?XUk@?xt(&yu;o6?49BEMF-zxZH%nzG9>h8y`E8ueGPYS1&%+td(0#_I!nUK5ew_Q zBn}WUFN`BT*Lg)8hI!W$n1*=AVL{_W4CY^c3po|EU>swIA53eFreLzXv9*}2g%n)X zqz?2uG8bdi;x{1O&u`m?8Ne|OzpnwteL$%wOzN_`3@0i|GUM37^1|9YxsSD0ogIZ; zISEe|4oz3*W-lY&czH#wU7nkFf{`OohI>_HWOn(`x~eWiUZMktD$<4keuN@N6vcu^ zj^Hn}9R75`Wtu z4WQqn+F0%pMc%8}WyB7WyF4NViC;zx;UEuygVs>rC(+9@{#z2hdK~<{L(wat+@u3? z7E@m2A?b@CCIXWkMZO>lbW)@_4uMf-3}?cbqZF;F0!jcNlyBv8Gq7C#_trg79hvjZ zwJ*NQmd2lnDybF9-TH6);&eN6&bg4z+0)S)%wGMNj>FdR+M5qD_svL9$SeG?xi8Ca z_>#NmbJ@bj&nP8ia!B*@7 z`Rb?m>^6rvkPPLM0U$C!nDEL4IJkufV1FKtL^b4r=QZXvc?XEKzg_~AyCJX1SQ7pH zjrE$0C4o(7=ntZ%KaY+MHRd&rFAfQ)p&o3j4S5JqY{-Mm;?E6-9&u3v~+~LkzDL*flXj{wLW5n z0}cN70QLM?bilv|G2rCBEZZ*W!X9Ev+G$PhVwNdI>Huf(@Eq{cd*M6|6t3QLO6V~t zhsH)P=6D?0u6NliA7K|$!^FE_=5k_v@dQM6TL}taTUv-C@ematn~8rPLLnY;*+qJq zxmp2SkP^i0pqMa+0~5pvMi;Z=!}#)Mk`@fxW0SUzy~5PttOfYu>3drOK@%)Pk-A_N z|Di**W+Zgui3*>4<5I?*^C!Rk0(=OY0yp*He|IN0tHu+b)D1x}8J9-un;^GFY9 z$fL*{A5DrO7_Tv}aYV#=8|qQqkiS2$^@cnEgg>vzP@3=;I7Iyo;h^(p!4u%mYFH5L z3iRHXin0gLV>B0E(qS<}^D$`A`R`CafG^i&S|G9B;}L43u%AO( zOa#!k7Nt-Vt82!mW9JLavGX_YuX`GJLket9&^}X3s2P(1)AgoZC{)l>X!mem-Hc4S za7N&iNc(HXz5k$|=YG@DMHIoh;*e|{agE(R9#q4zV=wN}{XFg(F`$w-$XTTH6ajv9 z5gj*n7g3C(`x!Eg=b3KiahHRp4Ab2)bfE_kNte4FP(~+;{m>YP9NLhFVQ4RAyctfz zF5)=E$uH#ZfDTx?eMJzHe7>S4f*6HuJC1WKXhW|M)7=gx82V73JOS(vJJv`AfK-fA zO~g`2X)tLScR#p*|7{>3+7S<3#a}2V>Kze@wP?1+`9!1!Jafwlfd@%MI(4;6U{5$I zvBi4|w#-Ca0&nl}3Qgoiac?|E(m*SljZTEBM&FZfm~PPylH7@aEzU3(pWnWE)W@a^ zn_a@m?Me99Hnfyx^MJ+3Jr5WH?IU?)dZw9s*EWV}!368y5M#yjR*pl?^VM`##ci85 z!Py9bbcvJ{irE#QLwS|fKbi0P`;`_JUk?0nuyyNy&R@luaXv22XU53M71aRa0<1=o z?m(~&>|We(A&!G(UPj>Y3^-$V@8V%dv!DTdpJQ>Vz=4C9PJ}MV>IemVn{~B)sKVwI zHVlB?QS<`h7&unayG2+)1CvgaVZ(+v%j^SOGg=7LRvD(>vNb{jy@jEVVdy~&J+-M% zFbb$K2hcL+;>GJc0h!%=c(+OH8JhP@52BKp9yqi|iqaui4Hi^bliiSt36j}^0MuEA zCISGQ=spM}824w9rP(X3I188>wu)uP%^@g^%a|Nh1^e0`#Of4-!60cHa?3$5IKxpI zn_XFE;SOeIwLncb9{hxlA2&lypUsB$y>Z|-(i>&qBe`zJ`pvtqbw%>xT1AXK+Jdp4 z!q9OPjYoV{D<<}cuilff2_o$mt-24cNZ568LW~w9!MCOelkjIb%dGE`b9U1uWAW9L zPJ}iDCYV8O@WmAFVG3DbB?#EllxBMs-Gm271LzJNXw?DCn1WWU z8~T(fXgX?xsXgb(*`?~#^1`RaR#q?0uJi4G20it?ADG%7wG#nkEbI7>Z4&i4!;i0C zy#Ct7|MNNzZt>6F$S(bC5w|{_+h4c3to`r4IDw4q&1r;0T3vtk$#ZgF*6}MJ(l=)v z|K}#L`QeG&yPF5cp(;)+U3>B@9KVxr^S1x~__;9WKwHei^V|8a(eu)^b6p$X8DE-M zddJWz(zP7NA|xNTf6g)GA>w-iZaf4LU;$wCAt)NHUYNaHTgPF{g^RdIk*@1gkRu*B z`#2d}9yxnLLCJdL>`@WG3$v?hRa&Of`s%{+)3RfL4QH|FdR4txyhP3q$&lJ|m>M0Q z!re&Xi2{RadhP+H4jN#SEppGpbzGST*KHp^u?J^Pp0KHtINHA?Ix1&M4iU<2J>WY? z0^`INcvC|cuQR;y!}b-qTsFf`vi2DT3x~)8NB4HJ3y=<8A=2SpKJ_+?rU~^=C zb``g0?KBWDWgdsV-491lAU*KqTsFRoxw~iB8lADh1Fm(lfsc}Ti=g9aKu3#)4$p}s zft3N4fI8jaBS9^l0uc=GfQP?gD3RUV_?5~1_wL-+VGy*f;c#o~t%R}*xNI6SqHz*~5jb99G5ispld}=NOmR)ZGpYTK zxV+3kPd7QlO=cxpq1FJckW2J4+PS%a%{0OhiZcA{P_E%zB#xn%_#8TD9lDw}_`rmH zd$XSxM~+aR5Aeh0{lkAKD8?%o5;7bb{<=;Kg*rm9xnbDyTd4tqH?mUWB$VGu4Vx3erhujcj=pQ+%)0s4i>?g~ z4qfeH&@+q14?`RYM5NUPAP~d}5owD-amnF~IKWSv-EF)y$p2bWA+XOaAA!`Q4`Fqj zx{EhS;Q19Dmi6lVlV{&BDIjNN#Ew-cdKjpt&sTaS)k zNl7oJZ%s>KKH=@&I1tPRTf`W<-`vooZ`x!m^t?9*#NKbq0o;|a|4m8BDFfu{A;b;!X zPV^U^QJZG&82#i&E{vaO=)Yqbgxnx+XtANzv%UG*`jCdVE5C)L2Di<}>O(q7;tE6S z_SStFwD^9ec4GUxncC59DC3=1Mu%#x43?XZn-&@^A2TJc9@;&PpR0X#`zs4y9t!!8 zuBntFM4IFh0G9@SI+*MRcL0QuQ{Xw&j0~*ZT?gy03$Oz^1<-X>!NQX{Mz3pS%^xrYfuyn@hZdn(KQ{ z2X!Oz>=3g9sN^A&;ixJ4py21GM?eu4#hZ$=1+;OXJ)$by{0t^`6oSm~Y(-^O*47oN zDhRIvL`CvecWG)QUCuDzedgYUJzK3q+Uucp6_B#;cJvyjZ~V+w zr`VqMKzIq9!QI8$r5c=({5Qjk66Ey6)?Tht-}tYK+nf59t~XsTm=D35Dyoq2N%SBLrfbmVP7p51A{pW#)y~$x}cXBi#QPw1wlCA zz8(dzNoE$99^`siI-l=qD@GW(Jrw&wfq%qi>H7$vlqN}Ld7TToWs(4Q-DeC!sY${& zVv@M$N7to`@uUMd=5#Sd7fT+Q10;no6S<2P2&l6#ak)Si!z01{riZ&7Xc1T<_VthX zrZ#bm?e0kJ(iXQFx&GqE_ac_-+x0IpJ$hp6ZZfm|T!YYybqQwMIH@_)ae1z19hwI_ zGw!yT_+WdT?9ADDCR}>CU8}yRm3*afp@xJn4%kCt4m|s5etf!G&wGh^`wv| zW-%12PG`+Wa=2GmLDm^Xs0Do`2pfyIsyq(c(?v#RzqpZqKboB2ceaAwLK`s*WvoRb z)b0*kb0MbB8QvP+hs}q@`e`oA`%_(e_*GndfukGPo453(uUdhJdZPyhV%lto=FF`b zj@<9Yhq&?<^gNr`L5avi&}mIAz5}^q_!~oVG1hq?ab;=yTXHx;WQqFAEr)7%0sk2c z_($&CLP2|`Qfu3W^xs$(_#d?oZOc&x(@)?pQ2qWLs{gRI-(P(L)gSN=Ch!Nf15F1L z_&lmVh@!^9Y*cFxZR<19?g?y6qRHdiFL|cBF$l@+o6MN?z&8$}+VJ)_J=K1{R@uHP zqJdPS0}=@e^On2B5qKl1ILM1m!AGi75Lj(3Ada{W=Yeh}G5P_W{E`M_NYp6=Y&jJW zBOuw3?Co4AA$A(Ibvxs;(zXDifsm>kIXw<~#usRp%;!u9Lr-Td3L3ZaP%sc*WiFYD zLq6H@awC|QoNno4vF;YAYE2dKiJR{9nUOR;qk-$QF?Uy8fHl{p$TH^+ZxCgt4k*Bl zMu~N@2MMq34r9dRRRU-p!S!X!_{I&HW!4ui(#OCq;~*Zz;zS&KC0&nQy?AN;S;UJ& z;*FG7R@BAW}9un|6x?$-;?KSeJCbD#B8B&|>Kvg2cm-Jj7=)VFLq&gGpRpX$`&bIIc{i+x`7@ zNpr@YHO&SBnNuH{jN3POBH7@DjD4%{~>zJXKfVX%&W^}CdX$6Vqjj8L#ncZ zPlyo>o}YcD3L+Sxo6aNreS*hud*r&J?|i94F#CWcPS36`!vS_&&EYP|b#jF{w6Or! z*v$y!EZo?&W%?pb9FHUBeH*m%Z;?hZp6$q8umx41^$bLf|`XZ%gUAl6Q9IsYMlQQte|}(YCVag zU*u*8CkNInvOr%b;#J0x zU7a{kU#u+u&h-jk3DSZ4E^yd)Z@p80XOsQ2AX#RXykPJu>cP_bXW&=DflU@Tak7;T zW@6Ad07`{&>QgUiG|HqVdTI)BYl6{-RaB$8&XuRbkV44nV_y4lJ!^dz?a0cdXZa>t z181xgYgGpy56VlDM46v5a~4fk-z2GzYT-uLX4!nG>3MBL^|nCR*r#?XIHxY==My}|$ozM69JL|0 zIetQEh%hR`juTP8IlHFjRxT|7!;vEN1+Ta%hQ=UtHpS7#o0AQ^zK5%?KMz3OH7sDG zAsEnfwjpOcwKD`BWeAK4(DCmG|K1AB{W)On2astTIWY$BksIa!G#ccfG5R46>a7oq z=wc{e7DE;kOb4(?QYFxUsKKBCs3RB>Kw&Td4%{&qkfcCRKp@3Hu*zQr)ldM>-OYgj z?7IO5q6K19Gx(6QASIdO>7&YR(PANW>J)`?(X)!8BCJ;YIcnBw=uSgg!0t4xdqpb` zN?JZl)j=*t(<8Z5F^w-V(`AoC)H!OZQ41fwri`4G8dYudIARrMq*J_tvZ?N2$NJBE zl(j%5qcV&m>SItwNg}GsYG1(jQc3IWiJ;CHZa-=Kk~2GYIE*#pubVT%Y?f%Jl~e%a@()N-3OPyP+`O$MXGY>LS6KxjCbqNXA@daLTo}!u@w7w`6uF@Dq!r42y z!97UJy*31W(Y*(9cZ0u(?O;fy%RfWqZ9BM^BcDBC2HwQ^9O>cG8-)u&MCR@Z{Ok}_6{XPgRI!+vfigkw z_lFe8clGGi{_v!Td`J((%|qMtvOlvhS9NAcOX*z`CxUD#rA40|H9I#) z->l$PYnQ5X3$ryg3apV5S6f&z-z_`}zHxMY{n=TE05|cy>Ym$FGYe}A=Rw!ydlZjJ@0Hbs^OSi36yHtUZ|b+hYT0!feM$BdmE2*3wW-v|#4C)N zc83c*i>TVfp3IPe1}bgkU@t*SAB}RU^h{^n*YZ)~#& z?&r4Au~dm(VK*Q_%KcoLNaNF{?i{!Zvz|`Lcj)c`L(8RR#vr93yUp%7MN_n&raf)4 zG#R^$o&At6OC@)1V@7GD;U)NDoVyLWbU)&#O*!UJma(bR{w<@QKcyuO$o0-yQ z+!gpFj%)lleZV5FyN;(v2)<=}v=V`B?kc$W+j$M7KOc?s!BR8*LO^au8Cn3B$xho5 zk^>3IDQwmuMPim%ho$M#?E2iiGE(wd4~#Po`T>W$rbI#<7h)Mx9#ch+IR~Av7=Zv` zVCQNDD(SQCp8Zx3>bODI)Sa|Ns2A#i2+(7q*ie!>bOdpdScodPv}8t3muzjSunDNm zJUI=#3+vTKMy&>Ag%=v@OxjCP2n7TcN#t{>NqodG+C~ZDuKY~9-4;b)C2316qq7FX z8q@J%>MG|iZ>C78DBOf26NmtSy9`QGk?2H39jDW5ay`8#n=YG!eS=<2THD8&9%`M% zo#p5n0F_%%T-u^XHT}fl&lFEWQ#}F`*Xd?VUkql@4{_(6^HZ>R_{#hp%cV{_4^+3! zF7meIK0IaS!S|Q;RKGmx8y4aOs2kcPe+ixJ;u3!WT~yJu047?Q47&3-8nma;v@lB3 z9?q7D4zi%-Zx3hG&Yi=au+uDX@a6{X$imTdD)8IvPy(ZJ+fGIHF#My3`+4V4z_h*7 z=*f|^7Ke)IdM;Tk zR@dyOvQo5ua)+;{#c^sufQ6Gm>Ib*~i$tzLCgQrli6tzer#li(--U$qyon-cSg= zEg7^e_g;n2TbDr{8SM6iP+PLRsSN78;kJcP`z1G*LEGG7-|YyY_B(DWgSOp?5UO9} zU{#|;q{!Rokyl9QDP~V*Kr|z#;cKj_gX&Cmb>&lPWM%cz3a+b!wH1DcV~A(O&oTVK XrH`K&{lw`fK|e|Q>BGCpKlgtD1T{QF diff --git a/sources/UFS.LCOM.~2~ b/sources/UFS.LCOM.~2~ deleted file mode 100644 index aa9a8aa386e6dde2a3b78265319bbd78aba8b0b8..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 37179 zcmc(IdvKfAl^+PovaFa4NF%aB%k~ZI$dGDM1i*K^4nYzWK!W%n02Cx!iA)iY`G823 zq`dKFlT9+7O}lNnjq|XxyK$OyGfmUomZrpQ{R%owXEx5%<7r39IQ?gnO*7N}u~Vkr z_OEW$-#O>r?*&i~%iC%+#QpB;yN~le=iV)<+*H)LR^Ba#}s8(v#XA?dBkFT#@TAQz~ zKR!EI?D<&yh-!IYgN0$`GvWar>pB99Z@T*8w-moPpd_| zVut&~0G;MNJv|XsncKi1+9K|P-uOswVkABkxrxd2-t6Gjz;I%qPwCOAja3XVdNNrk zsy57S+?pvKQ5V;$&n&K9TIW%rJQ5%7o|#+g9`0AM!IA#nkyz{|Ul%*lc80oLt73i= z=ykrTMka>Za+$0OBm(&NH2t}Y{%qaz6#e{={(S8z`Wxax{!-t1)XfH<8C`^$l@_io7r(PpN0BD;tw5Dv?mLxy&gQA9PoW$J8V`Qn3Md zZlCJ`{mN{7@1^-fvnm=>sgtQ(X)>pJRW3P`I&ws{{02rGe2RwsU}gF3fT~wU!@+um zrxXsE!~v7&GKq60F<}y6lV~@IPnyJ}Njzl|ohEUxUP*@co2R=?VxLJIGKmLF0z;J1 zEto{XB=RPaGl{fGjG4r!Njz>6kD0`XNer39fJyY3MBF5f))^*3foLLzO_)her+V@; z$-Lfd>_wt?Kmm-hDn5*jJf6y>3Yqa9q6*{bWI@G;u%m_VvjOVu^mnjEO~1yp7ehXLEBGswf8* z5oR8*u2k26@sl8}>navQ@5r?-R#zwo)K3t&ytcSe&Ch{Ks$s#jVs(RRWLD0vsv&tr zp*mNQI)j3mb~gipz{jNxjX?Das_QK7rVk5+mzUNqt<38osXiEaq2IR20gXpUTN2zQ#`G;p1V9xtBO^y=bLC8K zqB~!(0D`5XDg*Ms1>@ONGB=y=p0o-x#iK`5;BZSI(89!Gfl=@SL^t-)pN}r!K%IvVyGKWG6peqwlc{4G3OKPH9zmsNme~>1jT6kKF*!+j*R)2VJ3nql+ zrd8360Hd^OfLq}HNpSoUV9N#~*J@*kgH0ORBj@dN)qn51b3dlguscs7Q@Gax%>fWw zNX=L$Q+iW&-2mAv&7W?18(fq5|Gp2du`t-*Xd?{P-VTnaNzgrE(?|^~lJJlR&=;~u z>6o%gX|Mtk9Pt=eh19rpoRSG;WhaE-9Z{|8oqGc<<%jpu2EG{-p11S$`cw4$4;fB( zuH4B_E@Ui6b;YmLmo^XE>E+EXJ6#L@18Mzyt@ZP@J>^I3lBLa4c6xa;tJ7bt*MgfL zmnL7SwQlw`eFxY2ux|3t>~3nUU#QpiaN}C=!H)mZQ9jJ#)7C)wu*@v{eED$5JRCZE zpk6+FHdMC`tkOKK158hr-{GI%D<3XDT7HwX;UtnK~P($2!p=N7l_<1+qZx8cs~_T$;Gzx#+47GdziJVH*Re(hd8 zFs#;tXWQ}TlU6vBw%T*kZT#l#Hmh@5*9mfep()&BM4YHe95#uE zb+ZVXMc%rnURer5+FN@2?%q12$GZdccOTMAZ|$vDYWv>ab0_r-d2;FPU}v57HN=ZC z6AtT?8SnNzOW^}L&kBbRS)ov{g%@}8zi|_1HLwo4BCm!{V^Odi=7Cm))R#xb59NfioKK_v!6z;FhV&gi{u`lLHtk%^(Y%Je$fLFQwH035L=)%cV4P zHGq*dW|Ejlts(!CoD1D(09~KSS(zCq^j5y81|Y_pb`WTiv)NM5O!Cy&?Brw$N@@Q< zzf8DqIIhr3eioZYJ0%>J`tC_tMZG)2*wx~+N}w()bBX?8HIh%3(hOUP{yudITS<+& z%T}($;x6<-d!-W?TqZ~FNc8q`SEO8US8->-4gjjC>#cllkT9vaBog$ zc3*vQuRMnhB@}Q3I%q{&_r+MTQmztcS+sNmJXiZpL^dw`I9t;n-Y37QE)5-fLe@-)`}n!7J@)}4=e;pronIS z)xSX|+dE(5pXc~*N2E2~y1i#1)beWPwb3c5f2bCmZvX1kcI#p&9Xz%9ivaZDwkWVu zuNFukrB2Kyp(Qg70P*S8&%M0gv4pH=zu9+f;_#BM+Z5UWTA24Fc9Qmkad8rm#_zxq z{CH1mprs^Jx>-qVrA5SU5_=-8zQ!-qdCfM%jqCW@Y>9=JleP?X9YIdl+3Kp-TGN@@ zp6T`{Dhai9Z+dx(1qZQD?QH$BcE{!~W;5I|)PNYski&XnKv;+J#~|!e8TbR~32sIM zj7espJ7LR+NAwLeXACju#W^ddV%TS!aDa#y0%8b<&=3$1aEG)to1FmL8y14#(wM<1 zVM$st!yps_)gW6lj zXEmIF_!x!&7EkP5@@Uk=%O6fl)pM_pE@#{8y7GZnrgbWunYx=4)vW`Pu@DZM#DP)W z*_->OY{HAlI)qp27PbKo@CIr{R<{BS$(U!%5#C}D_h@AxZNtf-Q-fG{$s^%iQXtYI zS=u>xr!I@JP>(*)w=A2BmI`RWO(3+&P%05o2yRFi=)hcCN0Va=7Gt8F5rM3vOleUizn7DePss67Yap;^bZqDH-vNeD*opKzs(Rcm9Rx+Y_psjkDBgM!9+fZ~B#k_g(*>MS`~NlPj{d$Bscx^jMT z?ZRa3X}HPAl{cP-ErF~U%xj>uMigu~n$tM$9s??Ib?(yn^VK!HTdi-vlYC)vaczBr zd_vHrB!}Q*b03K3SkkbLrH+X^g&!Hdq8Y}II+u2yzi{nyOIP2(#-DAkr?>Y^hg$z> z`t^n9(k-v2ga2kaGxP4{;#4MUwKJGqzJJte7r42H!Nvtv^~}u9)bZY}hu_OWY2jY#OIKgZEMI+P^NXNpaK;N$DqDq#B3x_$2xd}a zr%Ne3!|!36pR|`usGr_md%*}yNb$&%HOHDH2Im+mVlcCe%)oU>aTGClsmKsg%*^Cr z3K10R);1KI5jr*?V?MI^n#*x_tGo2)Sb5qL+Jn60u)I^V%wbv(2u zlm7MAhfJl{bhFOQdvsR2$qKygKtjhucg zr!B#*Ir{+BaJPLRSF4dL;2G9QAiGXMy3r}ey61=~Br=M?lCUj;aB=E9$6yF-)_F$i zvG>^HFm-m>nuJXi^i1UeNe_|BkKaQG_)|haLAhi?ec$ZTxnOkyQb(b)jSnWdHue3=XS??j6R^(+6IvHy(zf#u_0Kp>;;m#rK zaUc*qLB1<4{#KPRPs&9<-*=}hCHMo_4!f($P6xkC>3bp-U1R)TzCsHMsEvS z4`e4}FlL%u7jQV%OPEDjHie(uY^uHGkWqAA!fY8V2s+Q+bFTtsi>x9}Ko^6;nNN+= zUVjD5I5^65kXL>CPUeS_!`Zxs+mHKml2ZM!F?DGhOHmOI)YDG!q#}rFEIp)Y2K}!3q5JXU%=d4NM)0y z41B!Ce?UBMHb+5fMnvwxT9XY2T(Efo6tSiS*a_$#%$|)g+<6U9UJNy2T0!)Qn9H3S za80gt76F~rXYh+CEQ<5O zIKC8slJXP=6L5KOPiT0%e8?p3(TVTr->r!{%|HS#7?O9c^m0x;FYZYF^Ay!`FhG2F zGHu=LgPsNioTRBwW@n3O);S1Fpe};RbNET_WTu!wKx0p{8nDKXXA9|M5q<>t1faok zn!EguvHt8jBPfK%uh{Bhce-0G*kB0W$VM-55^&L=ds|3@BaSP$9R5T(ng*7{ zz*)vphzCh!t>Z-IVw!ByruRs+CLtD6QVGX%!IOb}r!IUPGs(=f1(%OXP9k8bm^_&} zIYaR~{77M8#nVNF<&)ymMS3en!H;GTHyh?+A_SS+-BOGT3_cq0#Pm~r1^`G=FYlAW z<;D@|u1|TYZrN2@O_k64s@R0&pdN_b+jm~R zHaleov1J#Vo=`mC6d$caXW(}~k*?jLU-smSQ%lpr>eBvsA26@mYex1LQ`$qJ3D~RY z+CJ0K)`xh_rw&wty2lSsh3r1btn0R=^}*Uf3Io_^>V)lE_X<0GKs)AKIxH9d_B{OC zAXb#?t(%}QOyr8JoPbK|^qzp#w@C}c@wwe22@1Aq=r^u4B=6he=ihps7JovXD~{(?Bl%IEa0QgJI8+`U8dy zAhs%i1u%BO6A-(=00VWg%!xiF`;11ybX4KlO=|an{%A;I`vsIF z;HnPo)#G6Ddb>oD0`grD9E0J+MffN>$4mHP@LRiR9Smt+S_gH9X&ol{|AMZ8QbY5~ ztUNPUTdb(LwWlv#fKr378X#tq>=@{JV|D{(zBl4%qaj7v2yWhhOzwGqybLb5yeTs2 zIdyQGR0tr+wiGCo2(!o&TP>1y*$2B<35rOL9v~D`gugoo9=QV`TSf5P2_e_WK?qp} z@pH#}Qn}fgQ~}llD+ld8UrHZQ!5`gCfyf7Mjf9mCF}dmZyLYCU8a%Q+s1xObVqkgX zrn)5Sw{-9WV_|t?;mm7RdxZ%VclAP@(`VbAtgWXxt($T>r!7GIz+IY=iDl^KvLu*S z{%$_OZLD^8Q%>jHIr_afm(|8v!|P_S+NwWOKFGBH$%MK*%4$8YuFRXCc_HfML#_v& zsOy7WZL}kRwK<`KtkNAeX421`yThc_y(uhZtZoU9fj4iNIWm zDV=;G1w{fz31|g~%%t<3lbKVL z;<)K}kX2TFFk*T$u)Cg&1i-?Z0bn}`Qxa=R5J>DabRUc%m6H;l5^IadL@*bbU@Bx%8NWCeG$Y&U@{ZP7i57>iZsU|Fv?8gOgM9t zf;F2*2>^uhtz7mrESLYibstnm=6v(*OYgF!@n@n+YK3yI{%v0>w=?IQ59yqJ9j(F4 zm5=E-Y#pz?bw6|8v;>8`!Vg;qGW>=wxr;uR>73sm-hXoW>ipf(VQmjf7}s7XE^^{a zIy-n$IQHy!UT%3@zgsQtTt2AN5172a`88@Bsy#ki;n#5|KU>;C=AF9AelGaV%Ypw@ z?raGLk@zbq;m7%X;X|Sjo1T~72|wV;QDIdohq>qZ{S{iS!1tx{kM{)-Qt@)&59F~H zl6JKaSC$#*qOdNKemq5;x~Q|U)d5{3=dL`hx^z)jLn|qG^I-VkY^WUG`rqXc**swK z@(2liboBXn%8@Jj=y0%GjOdfl9ajx718*gBZKF2IH@q0R zn{?z74r|YLkJGgpU=%tNY|}B=id`UA{S=?w<}e46p?op`L|%C|co)oEPOLAUfXHqu zK^|;N3vnbKq5@!73s&(TI#g>~LN}hM;Q3!jxlQ=xu@;heZV%ztMPXg! zCj7dnQx~}jzb-nUi`;}?7j@|(H{q8eDImf>rDK2=!iPp>^g2W0hF;NK1(|nroVcqa zw7((Xc25hx~Ac%t8Bt^0Ee2o=j*xc2UqSXQ?e=KVMCUU`t)F{9-_<%2Jb z3IOR_4(P05GXl)sEECPIy+$r@5{Zg@IUW`fhdl1h0Gae=XkFLU7oSJ;as>(jaI-Hu zTI8((9n4#UPH}oT3vkd=!>^2!W6u2!3YK$sKz!Lop$`vY5V$OAz5 z^O_8$34eh@)ZY*eI)4^C0sgFp1;MUB?~SP_djLH~bMYk|5i>L&gBG3tHuVGea$Tkc z66-x4p*9NpIl+jy^Ub`NRYmp1G~xIcUll-5o<0dJvIx zx!VC{bfVY~jd94K4S5)b_F~4H;WX?bjzgUMLjDfufTi141To3yD{3N$QP{TQILCrE z^a?TE?O=kT5B13t!2Yn|Mk)ZLVw`FsmO@H{Nz1tV!3F$p0|C*Fc<3trLOD_Ih)AqO zvo+2qA~oQdTTTevPa@KZD_sJ6!cmDW-j%myCgKu!dyiLWA}@-2<1vy3TG?!LB2+c{ zo_xb}i*}IY9uL^!40G{?oh!$DY&yTyC7j%zgpX}QOKCO_Sd85BfFaO6l1HXznz?sv zaUEV1CRqQ57%QH)avXA=ucosqZrij8&PE8NOQfVw%&q_(%B!^g$wJrPue7lEa_EnP zt=s=|;R?=-^Ko%LGe%CXs0J7pU^S9-2ZC*2_u_^NaU3l3G6Iihz!|%H7mq-i1r6Zq z9t*R14jjaEB6LAkM=0RitSjxK6*jN1VF2`wq8AXyz_F6vEy4mCm~^5H8#csQW*^|1 z(L$iMN-+JFtZ^FXO$>b!Ll0u;$t`_?Q9zA3fR-_rE?naY$m|xvdre~B=z?c@5S7gI zz@a@-ln%jau%N=4?1ofKkjx$gpw2Qh5dh#s_dy`RxIc?5&0cB6S-|9&RVX=b4nbjD z#^k6f*w=v|R;LgQ21(nHTMmN3(;TI-)s`<&c*IweazBy~;pPR(iho`geZXKS2syMxT^~p1E{LaA5+y47g zXTzKWZ7~PWZ|A>8&&yZOc5QxVYI%D39Yd=~*K!<-kbKJxRRrO-=5;=cJhSZkB|B=1Wz+m5Yo8WV`O>>vpQxvo zxvq}$`d9kbT(tJ(bg1roP1Ex#ay-ch<#Kx*K|91XZ8t^Sk+#(;oYK)|T4;*KtP0bu zm~yd~=15T!$6X9QD{=1Wc-CfhhEfOPouqdgqR`B}P? z^O(|Mz}Yq&jYw}F5u^EmYFemH^x>47ijvhiKa-92O0#AzEm z;94ge_yn1^2s)kybhK#b@SI2zSQ%sqsM8HT64cTu5WxTsc=#)Z64}koUzyy0@6LT4 z20_~z4!5@6O6UrDE5ToN9s-3W4^x5hfL3R$dVY0{563DUktaDPamsZOH&H`IG)`hL z0>>*XhCjk{ayG)3DXvL)Cbi!YmzO!{>Bex}WLBgVY7Ni|xkNvsotq2TOd}kjD8bJT zaK;uv~~&!U6Y(JLu~4@}s1wgz}{o?p>nS+6cUdFBl>9=(ZUy6nu>P`1KjWUBa* zjuDf{*vLO>D-_kjkg;{UjJ6#c~UVCik#rkwjth`UoY`2D{d0w>iaMWq|qQDv# zBPRTHd(}Wh?Jyd0xit&CiDUQZu3AXv94}y};SICXIxu$k(}Wbc0c(v!)q{3rHAKbVRiXXMslSyqtnkoQwJBNEn@i&g59F?Y3|1!<_<#4#N6lk}&#E z*LVZ>?3opIpdp5ZkqO!jM{_`SqF;DMZJN1j^phXCFn*$;|Bhu4a)Z2~#fDnX&emt^ zqZ-~W{}z%O+_oOAkLo0eD-5kW+xMi=;``~^<2&C?*N*K#8SlJ2FQ zfE~~&fUc_w7M_f0yMYn;A6Y;l9*7-n3Tg;HA^`;!7y%;$(S5Xsc9bqRAT73U@CaS| zP4`gA(~-9EG-t<8gNg2r(-}jsNMh6R_R#5d3dm%m7SEL|ufSbi2ShZ2 zok~sMleZ$-RE3pdbBT9QbA9jWkZwet9b$F>l^kR;95qEB6#U%u2q?m$cvEqseIs7TK0F3ygp9aTJnJ5ifv6LvS&)(|0L?;#x_q%NYiIz}&mA zZ@YC=dp)$S0#f$fj$Y&Rji1`?6x-822rq$CxVu=pRD-7_|IP4{1UWsiy`SsUH~;I> z&X&HV>rK}S7DDi*O6#R?K=-o{-eafs>QPO-)ncbQjYaIOfKFw?!9{W35Yq-s*jLNN zz+ldRF(T%GF6br3B2ENEK@bkOuSWrFl9>gj2f1FB&gZ+@iV;R`55>Mv;2*JB`aS|E zrAd-mUgv^tnIynn_ZfpwYLf7cm?ZA`(RJx!Jm~QdNt#Dd}_O^(ZBJt^dgSq#Oh(^>QJEbbLnkaZ>yYC#_n!p0)5Du=`NbdizS zFK*=Dk0vMhovom^&_;|w8Eer9wYLM;T!`uOG;a;>!`6dh{WKTm{i&`!_9`yEz|jrt z&0G4?SFON9z0m^$F>N+PbLQ3zNA7pyLtHrvdY(<}phV;#=(Hx6-htdP_Ki`w80#F6 zxU#(SEjb(^vPAvmmPcxL0RI^b_>bJVg@X2UrPj6s>A$fo@IPuF+L5CSrk}uHp!&VL zRR3Y^puhSis^8}yOyCb{hnfy1@Of0fA4QFW*{s$c*wJUA-4ocHL6gUJUh+(La|n{# zH<>Z(fo~p0wXvOVdaC_?t+I1PL<6Zt2P6^{<}G)LBk)F2agZ0Cf{#?EAh6n6Kpb%$ z&I8>{V)O$#`6Ug=kf>7#*m5c$MnJM5+1t5LLhLkZ>vqOxrELL310hv8a(W!}j4#kG zn$MXKhMvq=6f|z-pkN@r%3LxPhkUZ@uUA9T7UM!xz*a@ys9m( zEaO{X6nPHazG?S}Ca3Un3W3KLx>i*UCjdzpg1!|gSr&}vxzjAJ6>&B#l|u<&B9d8G zuG_h3BoKz^-tOPT*Ldu}bPm$wGnR$~IB{u2m9mZvjcGS29oka5^M~~XR^smqZaBdkvzm_ zF<}D(g@Z|4Uug}!a0FMT(e3{Jx}-T{&zfcffy}87O~&mbv7Tj$$q7*JYMloS*LD_O zibtH8gQ6#$r*lDGuhXsD;UuS=q8(i7ot~1vl*zm%K`y2~@c%^$%k2Cs>>ib2Sh zb%Y3^^C+TK@}LIkJc{O&Jov+O9#%o;L9WnwV0}7Iv^Afv0Lubu|{ zTu=Ilg8?@RH>6LpG+oah28iVZTeQUSb)nQ>{Px0gyu9ZqZvCrcoJMea;CGW^Ox(Hr zX=hOz&h5#9izLESo9k-H#93!ouD{mxdPr{XlR?O+zPub-0?;?TGXnk?ISWR&N9YtZ zB%K1j>Xf+@lC9ff@{Yl>LGr9`Yk>KtC)`CR&7tK<0)U_ooN24PH=>446qP8tls-)0 zIU+?etTzMFnKuJ;*qZ@q*^>b>=y?Ve@H|Tli*u3-q8Z&E30Ek-pO!3~#;9a;L;OSZ zn9tfM#FkM#zxNA-nYoVSSYAj zxU#HdDKPOFoTkS4KfwyxH=@=vIQm6?CixU3SgZy*LWmMz2n^rcODa_%H|u*!>6xI6 z?Czz7#dUQ7_np!uqxk#<&Yj_=(bbC=!T--atJbR<3^=B#-Wj^$bYqpikk^ARgu+4+ z$=9lLIIXsh`-tZ^>^E^K-l7)Q>9iWY3)+N`QY8R)%0N5G5E@V!O6}RwdgGNUFb(5G zfS2t-vEGOA9Y|hh=-ZV=`a%(}GLG!(#G(39W#xCSRrpGf4%~Nv!@m3Lo%%bQ?4Je6 zGPC3bgI7@xmexNFzY-2?vcQRxt#mLGgT?_+DwI>7dP$>ECN$_;jS1&%xH_;k6W1U#5I{0`{PLd?b{FIrqXuA3)NqtlcH@Y^< z=0i=-Ya^<+1;WNYwOhei-Pt}~Ugj$du#fD z6GAOdh-{Gl>#s}&H(!A;uu1-Sgo6mBh{3)mYtK*)i5UTbx(GtJ$E=6lh(SK~!5b*6 ztcWa8*-cDCzOT=qay4$5%rsM>uP@W;vz5{DMDZHiW_2R z3_@p99BsTg*}&_2xcd6@0OUPm0yY|g0ZnHba;B2IL*Oxnz^DKn{~hPQHv@Bj4w(A^ zWEw|KjKO>4hB*L@203Vqeu#s5>jNXY7|NH$kOc+P0W6YK2{a&TFlYek$fPWQ!e9U# zxNR^XNr9k%K#GB2jlT-2p#Yw{8v_B@cLNMW^Teo5lkj0Gwgm0=uJAA>SV5>ZuF`#ipvN?LDE1a&5H z`$^-MoY}F%VazG`ZrGJbS+1)j>Cts@Bznr=L!|tO8$9GBaE9sb4)uYmpK3x3j)8VAZz3+E1hE_SY)myNdV=3MIBV$F}9yP>%= z^Gz`7KF@W`Wtvp1-%ZE)rFZX*W>m#>*$+4OoIvLs*HIvOCM?mnNKg+w?wDw^P_9cz zxQ;LIlJopAs;Bsc@CXC=$-z%?<8BTJE(W=!@<>kh>fFMI85~#k*s)QuHca ziA-NGp@IBzbMD#|8Kqmn+pC*-W2AKP$4seQUTX(KDqa2=DsS7xy&U=M<7VJZoX?RS zF1=p35JY6|p1{uzQB_e2Jx>-2$7hXBKfW!z1kn16p;_@Mp@y);>{>#Y>`?^+}OlK2*a=5I45;!F#3D^SIl zevV%Pi{4PS_0=Gl`2A^7)yL4Jw5sOj=jodj+-m(|b$)TK#zuj4QsQch%jUa<$G|s^ zZEQR{=Mdl~zE|CIn~I#TU0Po_wpQiq*@$CaT6t!1eeoRVx_pn~QR%(1ws?**&x7K- ziTe%xc33UDPNOf$o}!XFjIcJ98ku;7QPb{lfoBm_o7j^XGSEP!tSsy$Xz8O-E|s3? ztovF%>Ke8@yvWN*J<^BB9>U~(LY~1&qv=sUe2F>HauR=73e>0@jgng1qwPU>=Qtin zi$t<5?W9vwN#|!~oHY8%yPn(+7V`BNRFtlac0FbRcX)2I%O@t2Mb9`$m~yu$PN(pB zQ+E#Bg&9w$#O-1rtqa(bSyTeV?BO38x#j7Qwglse_k;L|v+@#6#ni@EMP zPLJpT!fy#5u0(JfsyLg0+rRBzAOZU5qz{^!=@`_)0bY+B?UJ0C_8cWykm^$CtV52( zG_e6|)5W=s`2}Sp<@FvIXdDy-9(m1)OafilW$bx`R34KKI$==)LBhb$wF=bIXWc#f zEg{@-gTm?Vg?b<&^r$E|l%x(FVVtBEq6{ugx#U~hHdBY~K<2?|;9Xd+PBLM67TOlR zvCO2w6ogo`L0XYiE}NXemkguyOB|LTX}8;=2(BcJiRE(s2f!9>pXnAi%a}X=(38Y1u)afWYC?z(U3ijriD?O_E@GwbdZHDe|tEjcJCZE zh23U>!#CGyM^=ueQ-SYhml7D3+jc9mhv6SRT+q9Z0_N@AMo-S9U6&M=mFpD3ny6bk z+n?wo1OR@PEMTYt3n-;#poh{8eNh{L{ezDJWO1;VuIQ4*VwKH)Dp{pu7FVL`QZPmI zNMB?J-98D{#Wyd~_8w6s+-*#aRg_{C5UC;^a@0@e*_W~$OmOIsG!28|TcOU0{&b?oBEH$3Vr8>tm*;HpHH*Tp1^U2Z42sGu|B=P~C$= z@$R8`Z$w2S^Q#vxEmkXKwYs7rs^!yT#mUb+KD}O9TR*Wpcd0tJaw5ArKUY0*u~M#9 zt|Yp8PgEDzFU_y6RZgt0US6B8te==3FLr$_eiY3IJCm2z@Q&_o6&o1pjtwQ^5p|wk zQGK+m7FSeDWQzMy=tzxUu2xm?3cA@)u^wl5U0q!fRi4|xpd#-4cw#6K8|og6_~(|0 zb&gf$^?Tz(iGiV>?ue49Tv}UQs?2Y=#_t`r>Kjb-^{DxUxs|6Y>uO{5qeCisI$0>H z7R+nZnkpVum)0uJEUsQ&=Ru)75+B59*E$D#Rjhxgw|giSyT#YVj<%eoZr3W9-WYnF zuc)E1ftFk*s{)At{yj}Uchk?-y-(4fAJWg)o}%9n7xK>mdcKb{1JRy@qF%dXv%AJp zr!%7|HK<0c>D*WztJO2W70U9$ggm95sjO^_uc$;qP3JOaRJ`9^DIQbf=t#x-+_^oj z2lOkm@x7Pk6V0kQ=erRO;wa)%05!aquY`_Cw|6w*snG9u5a%R z1(V2|M9w7ACNW|X!zOXUBpx@3A(I#|i9VC)F^RZI9IG)*gaXk-44W{OoJ@7)r;>TS z+1QIjcb@_nWmS9-8+kI7OBFJsT|^{C)5(I04`A0#?o1(5N=bJApp%_Xr6zT5x05@a zb2{mZIr)^ESMlDsI*Zq)PA0Q@FcxwNB+c7KGP$CPCopU~$C@r7E8eR|Oh9JJXaL1j zNyWP{jk=CwgP2C9*p;(NU4>+BEIB%wDi-q~H<(AmeAi5P9;4P6=wrV#kxrW6$xIQH zwX;}4ohbl4CY2l;>$LKzoSoV0niCb^tvx+5gIJ=MF=K3T4a8=3?MiO$Vg=>EBErm* zm6ggGFn%1Ac3s6{=pDJ%rOFEBfLaRz&#WzORPu8~hXw`Hij@tjky*L0ss`j0h00u6 z>hue0+THXC0-uyNGy>HtsIIfPn;t9_US3+eyfUwcqxqjOkmH2!JYPhK7z!=VmgwvCe$K z0tl9lsSL;i7mQ|8$=r0lbKELS6^|WNfg??UKob*-1xCRS5Z%~MKW$AyC(}#@(}WdR zFX5Y-`o(2R9!eYQRn|x;naOocS-DKfDrBwENsK!_AQUjxt!6T%v?*1x2OF!GrdC%L zv8xTHD6_*(%NzC#ZX02+_D*m_jf3t9n?`C-k-&#MfWDALO2?E{ zN`n=U9Er!cDx^lOlavI_fw1R5H|6yxD?27c@Th9O)V?p!H1o(_+SE6K!UuQ0Qk&`e zhYYwo*Y-U{MK0`|iQ2W6Hjmip<;@N|T@C&NY5iQa`SaC1GmqINOPgox^zvp_r@vaO z1~)%0O}uP^<3Y#?|0MZU3ch<_ODETYWP}WLn|pW{!l+ z!{KuWYcogAg=*HpRhpS~kO|E4+x+JbW{%7}HuDIRp>yr!Z!d&qy04zL*GGo9m9pAr z9^v|Dw+3gTI``fzzwRf&_UhhWFYPSsd~R{;elFu5yA5|zj+G@>Bw(y&`Tdej;T_^O3+|t_@Z`}Agzx$QHXGZzur5{+K z?dC7M)bzpX2Ogq9EXrgdHd%+lkdkH|f%KI7)nA>1WM*|hV#}>G-T3u6h)vevH`_4| z?s4XrtlK$AQPzWR-P49Ytzk%86X9dE^2&`HZ}!%nqV+uo>B>@XLflyhL)78CaF>yJ zq9$>~Bp%VtB4`$Q^WIu{DGc#%>8*RZYY->z3DEC;q?g{@TPs)hzqMx{^$Y=X>8)UU zjrKLfi!l`r>y#Pq_PtBtgF4R&hYwq!P_T&?ck{n-6K6HB4!R<*hE8KqupH)rR)y9> zUgujDS`br0%c9d*oR@Aq6^IUK4qaKTs{R4tL0#k1*(~$WesKBB7<4+-+b>j;>h+RP z2oCPl>**8eAhou(x~6)1rQA@R&QaBqkmkAq2nks7RKAo4ttdev=u=}E&dH#svJ;A=B=WFh}Dp35A=gWinun=2N6Oidt!>@5j6mbz~q56 znk1&Bll>5}OtRleLdY|@(34oB%2<#yvEcpCluQ|@r%v`^s5FBtboOj2ce0dLeZ5#I zDP}>HX0G}$vii&fxHz?jKum%!l%+l*%sDGF1%=EwF)^`&8e~x z`PBtT>Rn2~c%nW{oqR@#Km%(=94j073=9|aI)jAoL1uxp3>nt2Xguk~&!~ip&u5fj z^BD-HS{5KVn>JR9pL^dw@skvWTatM+32+Pq1cKeX-~@j#5CqbDU?4~`#eHM1{u^W> zz4JBx^DO_iMViyi+j|y5O|N8L9iEW-hpWNK)~`-%H!p_L!84n`3_u-ji8=_a(f8DJ z5=t_pWF|G8DS7VZ{l+FUFvB>7vDs3yk67KI%m&cHyvMPVv>%Lluhz@ zs?F(4bd^fd=ri*% zQ5)QB1~fI9g(@Z6rh0((jdZ!#KwRaloQk2oO*TM64EZo*Lnw%XIiZ-grn6(sBcK@q%#;CxIa;sP~^ejj-eCE871w5<(rMh$NcX77zY#2LB>@kP=% zc+VIns%P{2gZquJ;@#AqE?cPRq5<6@CV>SpCSl{SoUU~q2R+1_G^~t+O!C`c+yOSt zHvyYY`LU_6D>nJ6-UNSOmnfEibijvJK>BVl3Zc#hI)W=8gV%5bxPyU;;SOAk=2lk@ z#!V0e%dRl;I|V)OzT7G3nbl_Nj=d3B`+itHnul3+VS4b*9GDt3kd{#pQObkdd=?BCTW2m#W5YvZH9CBasl?6##i zcsFz=U{t62>=YCV0X#bg?=+nl@eh5=vbo5nfEN4%LZ}Rx65)i26c(`!b8Q|@jxbn^ zh!#q$!>{Eu)FqCRJH@=&v0&aIt&!mpVX31vSPIR^G4$17bD*ib7;W+f;Xo!w`zHH#&=7? zugkb@NJoOCl1_qo2<(&uHzUs-YfZr&j519C(@9^u zpKT}A=A9Qg@q%5N4ka1Dh6TVr5(I#KVpssIG|EMSWdOEUUQSC%W`rw@2+?_7KZYij z-mbRqe8cWLlxEs3kSWB6fl-5u7VrQOqgHM-30;l6B*xEEV9A#d2kM+3U}GTA1hLMd z0b-4tqyflkk+MOFF`)R&4cc~MV7wt6fr*3%v9W4xEL7HHEK`+rcyLfqKMznlP)ZUs zq3vM@$+JqjQR&L1%INCKg~hdtYbvJI`Ib z@wuhzuVdrSwbs(xdnQB8|1|yD!n5h7*V4g%Gntus=W1~xleJnI%&tB#Y_$s9+{<9& z0;^hPYG>>?mfY@-TM@>UC;6iQNPS2g3w)!scl%Z{6+g(vPqL&3cbo^|I~z z&pHu!TbG!vvP;_E#$L5OyeE_X&DMuZrB`*c_RV{BR;$Shyyiec+rxKHmH$bo`MXmv zgD(93R1^M81z*oi?tD4>Mcu`|b1+%9=B$v_KG6a(CJ?xKcv$fIYW<$)maqR{^Uq12 zbJ_o5u*wnQYTWM=404vLbCk9OyXNczJkY!C1Nm3&yhvl0R`of3H5!m zOXq{N5&QAS?dSK{`1s3Tm<_z1{N*o3uG1D5_hr)WY+crk4~Q_4dv$nuvh@eU;`FR# z(m#D|`4ic9{%m+j@M&uK`sQzjbMhcflVJ@*BX70~n(HoMDzRFHx?gLNJhIS3E-lN; zAaF9)UVXWyAplZFJSH-OY%W5Hc&j1X6&HV}LYPNhb!@(t_Q>5#xp1$ZCATO@eZEux zGJ^{sGzAK`w}33iF1&?0ZZ-%YVv@a1(ghq~EV{ygw&0LiK{g-6Sf^lt)hXD%b;=ff z?LGIZTDG_<;sg|asFnHDDDCxEz>I^#Ob2<@xA!qWlpN0HHQYYo&q+%4BgVj`Eh%3Y z_l8$gXnRX?fiqc7_6y1}NMkNDi`EZ(iW1vZ-A0xe z0=YEr?$sWr zfD$oyJFfxCvtCT%D-_@cHTuQ20)GN4C_Q~Jgp{TWIhb&f@(&xpsf)2D&TD$fvH)2O zV)505n(&#D3`6IDsZzC&!B(HO1Yr^vPl& z2S(gt!~`sgfX>P@_>0gh3hu%OzAL|ZT0|HLc(#NyY#WYJ_1SX*BVDcPuk~^I#W)Rfa)u;yI zghsQ4bg~FvL3gi$_R49B{UJ&`2C&5XvwMu75ZbYX-RW+%`eld6GB3dqaKoT` zTS$YmjRDf-<%flF7Yigf%SZ}AAgQc%lE_?4lTF(6E{WJA#9}rnF?cR`GLY}og*rBs z%uHHj>q(9yN~xGUojN^5K|B0Nv0%m7qQde?@obUaic#>R8N{u|wwSO$=61Ig*aBmZ z20StQRGt9CUMIK|d_(#ptSubIX!=K5p_6mMj@ z1RqP&TeoSlpXRuPZ%hmOJ-qp$X~v%tlk}2Mb`lNX__#(M`eoZjzx4q5{GUjdmnSkT zsXzBp(}Njl7&7>L*jH!k7qtmEso(z9UzsY;*V2Nweo|nXR)f0#tv{_zc&cvMRhmte z&-<#_gyoPPh~3+FUb-r^lfwGa{&^oX zuiI-z_LmddFQEzAE9vTf)6v$4c+n>gmV>&-4^M>bK4H*>quG&ed*G-i1p;2{)G6Da z?iGG|SQ`P}>)2fQ*z@pdgK^XgN(mj%C*oBCc<=O{&;-cadjibO&94(c`ucw3gN?+p zIC?zEe(gAETXkYv9DV6>Qg`dhV-z{+id%#qZ)1@>*5PCpvu_$nICn%(Wq731|hZxdhY9!!NhunfV26F4ip|WH+ zB32%ui)K82|9E^5GJ>uhgZk-Ijtzh#p^V#1ZpDw)6oC z*ul7alY}819Sa@w526ThRL7@?K@d+BC;~Ti0S|DYAp4t8Go0wryNX7_aa^IgcgS(# zBt%XV!+}I97D4i0*}Mm`ir?D>GGO)$yr(00SD>lrH$hK(^$J(iUP*Y5_7j8mh)uf4 zG_~mPo?sL6p1{@9nn%0*zOPnbGQIT?`8&S{e&K4cARKD@QaU5Ohgf6U zrIVwz0{fGlb^{IDX-V@@U3;&2%fW`Vp~r%BiJ>R1ZQWX<)kM~{mC#?~P+)Xz9nP(5 zYq8E-n}S)Sc1(vtX|e~jC$i_O4V^@yxng(=b{Gm1P`6tMrmoAR^-c+795xUaK*yk6 zyNDiHWV}Q#26f0q=OFBQ=p0mcCUcl0Svuceng)`LV4KX!Gjr9&vYK0a`tn6+Gl-%= z)JB7BGCR~~*J0&*BaAi*Qc#WH<-3r`J@1cu!38L{L?S(B4DOHu!Q9HaGc-xW73GP$ z6-lk^fx)W;4J1bo#NQCl?+$rKZi6@$Fnok+f#Hsc^n+R)G6z`iO68`fQU&IpQ04Qb z^idW35BE^m@gXn$LfEm|m4MA0W@6L!clV{47CgG$uM;ze#MJVrzrTjI7P5m&2R|^j zme&`~zG}6WnM`q4&(}D8uGPufdYaR^DW`MV7Q_$Sr5Tynh;A)QLU-kN^9gQawYr;f zI_J*O@4dCG7S( zITjX-8UJS@vQzhdAZsB8*J|exAnba{I{41keO4>tY~}6Gy%hMj(us9&Y3J%?>)>6@ z+Y2)t&EK05PQUX#p5#o&;TQSk3+0ZEnFl-OAC&keF603{R9><|JR<}J2bWB0k9ANd zVfsY8@C-*dTj3X%za*^dYx4S~xAq5W1{_{4XAp91g|8hj(!?u>YDRqYau~tR2nbek zPz&M(xx)Ijpbs%tP8g95K=mO$(GiQ)NkyGxBUh;`~GKhQC_u8uuk_emX(Lqq;P=O&7?61cJ?6PI0i%>YP zdTxW8L;}Ed!U_AG;xe|Bb~yybqeNVkPgJU~Wwue+J)?b|qa3sUaI%y3GI)SXn0cC%Q5%0Zm- z;orsKEYZt20GbYHjOSoy(o2y`onebPdOFx|3!GJ$Xr@n1tA(6VYAAVlHe zIC9vh6Ogy;t>qJg<|T1}h@B=m%YGs8de;+JkGuz>5hqAu;kU#vW&P%uKCIfnC`=+1 z+l?t+co)MlG&>5Z!l;?~^^w-+Hy6VI;LPL>!ijrToA}7A2vxBFFKTm(>rKS`5-D+{? z>LHze(B%E?Z&2fK^~7|UU&o#Nd}#-n`*f89T=1Qj0{?5Ky(t((;;*HIALsXn4~z0^ zdR~4z{GcaCg;i-L%stN^DARHUzAu%3vOj=OikAX^B#+gQw5x`=vdlmig>{ki<0)#_ zMeX&i4(cK~Q{`#Zp^G}|T1mkhhr)-ZLo?y6|2-2Ta|da=Zjqn|Tor*Vjug>DCxJaR zBxJ``gN%Wm8lTu(cKL=!Y{Wz?feuc0j?$GHa5CvkaA3zU zD_VW7@+m&3&EXAn{Km)eAw~7n=Rs?(s|P|_mq+K5y%Gc%eS>#EqVm^E3}OPlwuuH~ zNr0l))oU=81U8|r9wKb~d2|UueO~?e$P`mo588iS9!^=+<>6eCKQGqcy>vG~T|LNp zb$KxV)aAiyT$cynJci6pl0P_1@0fzy?ihrJ&S@NJDlovv{Vha_i^s?d$;GY~*aVU` zfRZe2z;fRd7cK0cv z$DkY<8@-t0abUaNWwU(N5r}t@Nz0Cr#S;+OZ4k(VZD~(G34^FW76bPDLj=SlpZa31 zmIoK41aUj4A>1jLAWkQ`m>r+I7p_Ut0@WwB$JT5gdxd!HtOfYu>3f<2K@%iH;kaNG z|FKOqrzK?Li87x5g_PTbUmmL=iQ)DTeq9vSMQ*~ci`sROoAB$RgSyB~_;pc-E^-ro zDUt#r{1ZC%XCZueSVpfiBwpxc-BplzN872p+d>E0LLX=gHM8b?t`z}dQiUh_UDmNb zw}23_%*7k;T#IFOdtu&x`_8q8xE(WE{+T)S{ICF!zS1B;yaeFuC%_51C%{DT>w6nq z;3N_iU2o!H5pn1$-VAaxxtT~DCMtfPBb~wW>!l&cK1wiTddXR>$$WI;sFaR9zm}?lG{@24n?d ze_d?^Sorf|4Y)~+B655jCWauq`n>uP5$mn12Q{!R4{W_I4*=oMYcP}s`~^CXzacbi ze-<<)e^%XsU{|2!LX%@ppT|HhZlt4Pg?4H9cc>q9duTO@^&Zbp3x)ffVnp2eW?n3) zBKwBem}Me=zO^KUnpj;o{u?`AXpWt~bzjZXz#BSXdwmX?T0+g344AIB>_VY}o=r} zhIU|*|GusmE-T0JO$RakHRxEj+b;w$$>$epAc#@8w&Nhjg4Xp4G2QJYKEQOQ?1D0{?gA4fI1_Giz?$A~Ig}v;zazrH7qS^N56OsIaf=5mWJU}ASscRhq zd%{tPE#95CWhUYhc)Oq5ft0y79wVuvm5oLxLRG!%$u~^5Xa`B|M8Fnjn2Rs$Ts!V# z)A_9q;pFxtd~91gF8%X>$ssq@ znawL~7y!Mazy*XbaEzpPi?DzOCY|WQx(#ub*(>b}0P?+lxO@$vA|-2-26_uaAIH#x z7cC}8 z0YsCQq^?hyf~KQ3nA&rmnp>_+uPlCQe0A;O+y-Cu=MWR3q(lJ!q?HIDV_DmOYLV#9 zS$=%w;*D1?{-4))a7%yjdS?0OOSsYL+@YG)VI6wsg-K-WY|S9_(dzh%Po9&zu!gRF zNZ*Pz^v_LV>%)`Tceaj9KvkSvzW(G{xOu1G)NTF4iF0Ajfwq`~pSS&Aqvz%8=Q=jO zGqF6m{I;Q0q-!~DM7p=kiN>O618vGfr1zx6#$W;H#vCl!SmnapS5DD&Vt?PDkQ;LM2=Hg(d5{!5~xa+c&# zLb>hxeFsQjocIE7YUtt(hBtoLxhglwruj+MJ}sv5rFXVIQA;m#T^-Z)uk>GYiQ1Rb zp_=bC4Pz(dSdtOS~mtEX_F%U(vz|ke0Y=WahryuQtsVc5MOBZk+SNiyxAJ)ui zfVzBrbC*AVbYX4{H)HKK5HMvPhrY@I?o3DzeDRiz?_%!m8nMP^ZSd%Z8w@t^F*0uv zbUY2{XwuN(If*2&($5l5yBmBYgr!{|f&m`z@Yf6_vYVT~Ho5=ao%SX@!~tv_dY?&uHi7ay8Qk;TR=&)uCL&xkwyCFY!5a z&^&xCW$=Ls`_5J$FOD3YJ|EzRt@}p)SWt{tFeGF+H1c(w7!G;bjBM>lZD0)C=TnpP zembIW78GYdB#+cDaYz9Absoe3od=MX7FZ@2w)|FVz~IfS)bR29t<yf;Bt)bw2E`?ZGrY>5)?Q_V(D*MZ@V{0w zzNU{rYSM?V+D_fYnXSW8jWga6_#TRu%m_)&D-p|{K zz^MB3u$k>gCaxx>7t^<$e6aKorY9OL^ z&S>PSpjkAD+ zF-6BQQ{gPoh;5<{2Gi@hbdQdL(fQ|0j@8;u`!+trS{OPA>yJso=tEuO4cxP5R@i~M zh!sXAXg3tD5r^zVf8iOmY38mw;YTivpJ?d6V;O|pAg^n&q1v^x_1W66hPSJ~gQNzx zt;cG^I!WRRL+j4=y=k=ge!6;M=ez0Z@f|4R?N`T!tIZ6STaTL-8Z93)C9WP?J&m8O zes;`uLgppI=In;~{tleD)>#qy213CrJbydN_ zlQC^K0fqdJ3`TU&1v}ah)Z`><3>FvxBSc$$w2O9>E;S%6wx|Cn-SJI|pgbLI8BJrS zTpAEV|81TlrC2+;6B0ZAEEH7HV-|Q%m{3VnKdG$SB1II0s&EZXGNGK+1kkqcb_)SJ z<88%tzpl@pF_`G?IGr&BizGH3TMwOHr+`d0YVlmj@(LQm>wx%0uv4iCeDYQ#o2sx< zY%cK*YOe1z9ng))vqQ`dppt`3h9jovW7ngf2pQu|g^`(%6tqXk$-AGu#EwFc8JR1q z^y>PCB2@)pR)DBT&gv{qkER_}JVFs_jj{>5>uYO>5V7%gj|Gv8X#)ZsDRyd*(RPi!CHIEys6T9 zDIC!KEQI&isl9qs6K^)zsdi%#do!R@nQ(AX+&9Fu0TcG+aWT5X7mN`x2Xy%^F&1$m z&?g{(1MX{40GniHf$2f6j-_+?uC`)?k-I{%FLb#Bv01tj43yF&$tO7*)~sV&NL*? zwTwgaU}wgiHj^K0t&yEMv%rK)@8TQkwc$)Pm~DMlfM!C-T5a=B=tw*^hr*&uo%RWK z#N*F*yboIsiS^T5lK1Dj_Q)%^@B#-lus3h&D_*q%5A{Y548*k2 z5X~7>GaPdT9ndFdLC>>^9U?(;5OkW8OK(H&82QGqT!?iZNL*gt`Ia1o5Lu%3Qq!Z= zyMX@;2K*y;ZK0qwU9Pt5K>DvQ3;d7jhj!%Pg6Svlm#BW;*xiR$fwfi349*aA3#z4U^Xk&2Y2+@XZHj)r_ki_ofkdR-5h}A_DyEYdf=N!P;F%Ao1SWa zSS{~d6VX7b(Q$|b=#`MF1Ojg)MW>T>3O-Vug1~BP0dd52I1h9qiO~-zc0(GFAyKCg zu;o-hjDTcAvbS@ggxG1+*6obXO4|a6212TGF2|08p7G__Mf2?v!qC$hi$cV$925-1 zSDDMD;*d{vz0?S%C8t{oPSf22Rjug)zGu^!Iy0KWH#2ZGHspa2LMSJq7d_vWx;r!n`LpWh@)w#97+Hak<7Ys-Nj8KfiOh3bpJL!y<-Qa zbC4#Ro(u_a;?jsJWgQzD({55aw54?Ck82C8#NQv>ekjc;2dmkd5!@E5Cvy+}0muWU zwGK-$G1_v&0i?-d(ZcCcSeJCbD#B8B(PCkT)HY6%hxp(nY+#^pI6|i{u!deZgsal% z=6-)&(wwnp4YPqj=E#L6y)sl&` z&aPa4t(*0b+}#{(8fGmWA8>Fr*4fvs$B@A1{MeGh(g+!P3p78V&TTFEz=ih(n)hL z@7tiA{|^aegW(xG_Y%tC0EAr;nfTZFk!uzid3aI2E6M?5BWG;yU*x}7D5zPus;p!w zF!3oIoTfW?87pYth+0qK=ok5!5DP1m#k6qy08EzO|y>tou|NIrTUfE#4F-`T((AB0JtMoa%u8$r7a6%BsS1WTk zuC|VAhvzr!S5Yx|JYJ+0*Xh6-z6;ubmU1ru@RWggk|Q**GNjrwrZvZFRbUbZiU2R& zLt?=XoAZ@tc0>^s~)Y|ojHQ7fCvSnt< ziw4i49xd%b8onhQ(PW_$XIbeeCZf`DPUaBUZMFgApm zo)GyU{Wo8k2yVU%fnbw-@(2kLYC)G-$l5ccLuy7)pe}+S?lJ9QH|UcSK7a#twUt_; z|9UmazT&GXY@W0iBR8?xMK^$y!UjMv7g48;r3#;!Ws@L?I2VA7=_VAwNQPhtDO>_Z zXx?u8)4GYyCwQWJhi(B+ZOGjPN1-`H1Y7BtsQT@>bv3_wX%Tpi6d@^W%eR1~F$kXx z@wEQtWCOGB;p*$p1DN-W24R+8R{ZI!r*9S@pil{G(p$m$p16(Ar5_mx5VDJFsk!e|gg+T#$aOa>v zA_GGL0Tu(o8h;GbKmwe2w*UxW<#lin%@fm_#g~)?Imt9nUsZ027V^ncrzot8o>deT zVZq|BR_cisEL&z{rhoZ~tcB+rB;`u+%dNtZi5+ANgo`Vp?<3-0ASf4r(I zbJQIRDt*?)EIQ!DIK*4Vt9%L3cThD9{!q6KqT{$%zlKM3InNaz$HQ`IhcZl8>JRkdI}qd^2Y(UAfN3%BIIR@DN>?H?7|dy)z_>y| zlK@wglx_vjuWsgzm(s-_Go^BYtsNMtbopnfyk!?xbL6up=*>KR&5~Sk%aJZFy;!Y8lhd(aT`c z8_KrC8U&LV09sV_F*GTys=4`j`fdfcTEA48U!1G5fnc2!y6WPx`C{R5@Qvde8&~EW z0^Gn4t9x!ykqgz!>kG%%DtuELam>pr&n&Jlo(El*Z&Exay_eS(&r{|FP<%IWe^(zK zR?Dta?^m*?sO0t{tWCK}=3Zgcv^!kjSwz($wq=G4G*Brk3)=}=`e>9(y?0Y)8=_#> z!;8F})FXX}>>*6vC+HchG#VfE!v~&;mXr9ylAuQ2Xq433E^QmaJ4f-rb|GMN+DWIV zlFrXeIcfBjcRjfuEadAks3=_}rtTcL4l|xk z$(QJQN6Q$-mQBu%LsWC;CuxfIi)TD-GBg>xjGh0GF^ffat}mlSMf1f`|4Z3+ne+n&inxbZEJh^Up=NBbi$$p0)~O1Yh@^>SKK}OEh5};ozm&< zg?b<&^q8nOl%x(FVVtBE!f=br*AoJif@Gh)ZCmFLm3vCPESZ2~-3PLPe zAgxF$mrYLLn}t#OOB|LTX}4RV2(%Qb5v#^p3~Nn8Bh*#aU*1TWQc<`KM<)>x0QVUb zrvlN5h#I2PZE{V$C!4OCgRO&JO`6-snI>wz#hvBo8vvDCP+nT1$2Az@V%;Q9Leo7= z%%egWq6r-lH{Llvd5edy%-`{B@}%=XbzAHrZ%gjOQ)V7~e`!y}au<#IhK0BR>IN13 zIuD=p;u3!oy11fY0Zg_s8Fc4wG+g5lBExgNAY=a+^iyb za`BiP_A9E<=>k64R>Fs}a7!zk@Mk2&q{yKMeziw#g>w-Me+8djdbzWqUV46b#~a<A#*Yf!WlUY|6@fR zQD-V^tDjP%t8155afKzUuJ9xdBE}IvgZP1)A3q2o7=+6QKMDHjp`Tt@7`jO~A*bE{ E1=j9Q5C8xG diff --git a/sources/UFS.~1~ b/sources/UFS.~1~ deleted file mode 100644 index f5ccadc7..00000000 --- a/sources/UFS.~1~ +++ /dev/null @@ -1,775 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Mar-95 17:50:11" {DSK}sources>UFS.;4 68592 - - changes to%: (VARS UFSCOMS) - - previous date%: "14-Dec-94 17:33:31" {DSK}sources>UFS.;3) - - -(* ; " -Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 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 'TEXT) - (DEFAULTFILETYPELIST '((NIL . TEXT) - (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 TEXT) - -(RPAQQ DEFAULTFILETYPELIST - ((NIL . TEXT) - (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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (8147 9700 (\UFSCreateDevice 8157 . 8522) (\UFS.CREATE.DEVICE 8524 . 9380) ( -\UFSOpenDevice 9382 . 9559) (\UFSCloseDevice 9561 . 9698)) (13861 41771 (\UFSOpenFile 13871 . 17165) ( -\UFS.OPENP 17167 . 17664) (\UFS.RECOGNIZE.FILE 17666 . 18419) (\UFS.DIRECTORY.NAME 18421 . 19164) ( -\UFSCloseFile 19166 . 20142) (\UFSGetFileName 20144 . 20343) (\UFSDeleteFile 20345 . 20885) ( -\UFSRenameFile 20887 . 22052) (\UFSReadPages 22054 . 23189) (\UFSWritePages 23191 . 24411) ( -\UFSTruncateFile 24413 . 25910) (\UFSDirectoryNameP 25912 . 26966) (\UFSEventFn 26968 . 27630) ( -\UFSGetFileInfo 27632 . 29914) (\UFS.CREATE.PROPS 29916 . 30269) (\UFSSetFileInfo 30271 . 31500) ( -\UFSGenerateFiles 31502 . 34214) (\UFS.NEXTFILEFN 34216 . 38359) (\UFS.FILEINFOFN 38361 . 39810) ( -\UFS.VALID.PROPP 39812 . 40104) (\UFS.REGISTER.GFS 40106 . 40361) (\UFS.UNREGISTER.GFS 40363 . 40946) -(\UFS.ABORT.DIRECTORY 40948 . 41296) (\UFS.ABORT.CL-DIRECTORY 41298 . 41585) (\UFS.CLEANUP.GFS.TABLE -41587 . 41769)) (41806 48490 (\UFSMakeUnixFormatName 41816 . 42837) (\UFSParseNameString 42839 . 43213 -) (\UFSParse-Directory 43215 . 43756) (\UFS.PARSE.BODY 43758 . 44303) (\UFS.ADJUST.HOST 44305 . 44464) - (\UFS.FULLNAME 44466 . 45674) (\UFS.ADD.HOST.FIELD 45676 . 46036) (\UFS.REMOVE.HOST.FIELD 46038 . -47708) (\UFS.HANDLE.RELATIVEDIRECTORY 47710 . 48488)) (49306 49919 (CHDIR 49316 . 49917)) (49991 50977 - (\DEVICEFILE.EOSERROR 50001 . 50975)) (51050 52287 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51060 . 51905) - (\UNVISIBLE.FLUSH.OPEN.STREAMS 51907 . 52285)) (52320 53946 (\UFSError 52330 . 53944)) (53990 55674 ( -\UFSGetFileType 54000 . 54601) (\UFSSetFileType 54603 . 55032) (\UFSeol 55034 . 55672)) (65282 66406 ( -\UFSGetPrintFileType 65292 . 65704) (\UFSGetFileTypeConfirm 65706 . 66154) (\UFSPrintTypeMenu 66156 . -66404)) (66436 68184 (\UFStoOtherCopyMess 66446 . 67437) (\UFStoOtherRenameMess 67439 . 68182))))) -STOP diff --git a/sources/UFS.~2~ b/sources/UFS.~2~ deleted file mode 100644 index d2a5cdd9..00000000 --- a/sources/UFS.~2~ +++ /dev/null @@ -1,771 +0,0 @@ -(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.LCOM.~1~ b/sources/UFSCALLC.LCOM.~1~ deleted file mode 100644 index b34da6656aa9f59b2386bd14b360ab6d8145be8b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2428 zcmb_e-Hw}95O#Jqo3xdsJV7*~%?4j!8L+c9tt?}}UK$${VDqQkQ2TV3ECv@?Dcj1g z(Y{FUbKSS;BXkbf<}b-jb79~d!FRs-=9?L_sy5LLjhpB*jnj?E0v=nMtUB^|rU9cH zj%Lkt+hpLeDJ#$AX=$_7Wa)Pbe&J{;Fv2tLXE)#mec(l@CrX0A0Lv`H^~Uqb3c>&w zX#Szv&$mCVy!d8FFT(KsDo(=CkB9zJ9Qt0oS%wi2+nr$?-bPCj4=*RSBF|<@`$xV7 zjM(AkZp00GAao>Alsa7oexYahPgmdt&}8Oh<&!($yPSM`MPF>U+YGGS1UWGIF5i=c zbE(^Bs$qyco^ZzvI=~AOe=hZS1~S&SF^S^g+DqKP8?Mu1hVfmTkadwHh`sJJSYErq z6^S7UpGd$?3>%v7FcOQnE7glQrPWH;iwy}TC=aKAr1qPv4n5E;%UFO8U6^Uc)VaV% z5fl|g#wP(}MZr4{mPYR#pgCwkTO15dDOrZ@rTm_LL+P*>Kl|IEv`w%gLVdV)}V#rUH#t`C8EL zE6|t1tw)*=4u5OMp zeOTcfFaWFtxHR4+k0V*x z{&2i!^N=q6<2{}Jm+81G(?!GPMyw=oqFHGUP3!{3t*5IcdpxNN{VMVjQUUKC zgciZp-)7E6n|$$tS`x~fy6K}Up){cw4cGvlG?7^L_BDISgFEw?N0f?W*qA?<(p*B!tbp_G$ca5}n5{WF_wg_f3WEPYp=cb=J1ND>89G&bVF_HrZ$D=wkj#EG%{4+ zbkkLBLw76=o?DXqMjDr1wwgTKC*uxRRe&SC_QbnwivsBZ5&Os8KIw75bMx?OmE{-HQ;)~{zVjpD(jw_19^zzFBwa&Sc#OM2Vw91oU$yqbp*9mL^vG^g=kra7`? z7;@)Fv4t3?ZD|!@AVC1q>kFjc6*-9LHc*q^tfKg3AA&Hs@Pl*kG4dpZ2LrLexkcmz zH}4pCIvoxcUV=PpnUFp?;r>5eLEzwl*+H{=A`nrzI2G!#y@+Db9Vpt&(Fir`o-R}Z1wjOTwU&E`tafjU;;q8Ff;WJSXTy! zHqPo{(*WhVzaV*Z0;c+&5lER#4J9YTWAuYjnap3GhmyShet*N}DO)c0H*|VmrsFLv z@0`XvBUTEisdidJ3+IqIo1}c0^>n3VkC%0!-$#BzE8wrTLU+N@f6APVHu++dZ!zh| zsm0evkMDA!1eEev*P9D{Y>SUwkYf(C{Q({R+l#Z6+{Bp;P zK+!Qs@d;Ag8%pbT-rfbfnDi!{f4kiRV2?0O92ckdF2SIlpymgDe8J{GIY(wyJQ1W` z&E*NpyLro2UH79rome)W6=3s~#upBb8QYTHzAe23p4UtVDxV#;EPfo=x;%A1)#h;e z=_<`nwyQMKvKPCd!q%lhkjKeecJueF?K1po$1ol>)8{Y+0oj|4&)9R>LMe2m=ImdE zBC=(*EUgwwYRz2M_RdySkf+v1TOXgfc+h%BgKG*$@PS6*4ai}%3L`J^!+-;F+B;zv QJei&1A%dOJ5RX~tKb{$m{Qv*} diff --git a/sources/UFSCALLC.~1~ b/sources/UFSCALLC.~1~ deleted file mode 100644 index 25f680b7..00000000 --- a/sources/UFSCALLC.~1~ +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "31-May-90 12:17:51" {DSK}mitani>medley>system>UFSCALLC.;1 3546 changes to%: (FNS \UFSReadDir-C)) (* ; " Copyright (c) 1987, 1988, 1990 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)) (DECLARE%: DONTCOPY (FILEMAP (NIL (661 3448 (\UFSOpenFile-C 671 . 828) (\UFSCloseFile-C 830 . 981) (\UFSGetFileName-C 983 . 1136) (\DSKGetFileName-C 1138 . 1291) (\UFSDeleteFile-C 1293 . 1519) (\UFSRenameFile-C 1521 . 1780) (\UFSReadPages-C 1782 . 1933) (\UFSWritePages-C 1935 . 2098) (\UFSGetSize-C 2100 . 2230) ( \UFSReadDir-C 2232 . 2369) (\UFSDirectoryNameP-C 2371 . 2512) (\DSKDirectoryNameP-C 2514 . 2655) ( \UFSGetFileInfo-C 2657 . 2820) (\UFSCHDIR-C 2822 . 2920) (\UFSSetFileInfo-C 2922 . 3085) ( \UFSGetFreeBlock-C 3087 . 3205) (\UFSNextFile-C 3207 . 3326) (\UFSFinishFileInfo-C 3328 . 3446))))) STOP \ No newline at end of file diff --git a/sources/UFSCALLC.~2~ b/sources/UFSCALLC.~2~ deleted file mode 100644 index f6da74d5..00000000 --- a/sources/UFSCALLC.~2~ +++ /dev/null @@ -1 +0,0 @@ -(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/VMEM.LCOM.~2~ b/sources/VMEM.LCOM.~2~ deleted file mode 100644 index f02f2c8b2bdc56df931f46512a854d1a69ac853d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6514 zcmds6OK%(36&{jF?4)H&$pO;1ZF<5W37J+ZpCYLiHb>-09GjdO4M(&TxQS(vuwEt& zNl6ZB^zCZ%^1DB8Z|rVe;3jin zv%S05>uv8|*j~$C*xuN^wbt9|WT#W;U*B2XdFw)}VKkM->jW;^&?ao`2&Q0lW+~A4R)6;QkukK<0_;56xpUo6zbH(^+5i-6A zS;CZ5ZZDEr?&5hn0yTTkM#;G)A_1>H+fy~ToHZ`01H?~eEqo!qgj1?M!imhqawtI=rbZZk>R^-x#~U(@jW;4HUC<#y!Y z^5K~q{Gva_?R8E6?94Upt%cqF=i8x)kX8#l$pe3?g=%5dm8nPP!jZ!-g^)Bc^)03) zpd8yVECmbiFT53t)M5*CU~3KCp<cr;TWqovm=KSOi&l2vsmQxZxo zMIoJ{O5JW60ZFJhTM_|fgG`p#qNkfHO&~zI!57R+LRrj{Pf3t`IEKLKB}f}C>mLX% z?@24o_StVU5YG%6$eK~IHa&>eV21L8Z7G`?^p`1JB)eXvbe2rZ0ec0==+%U^R!d*V zDD5&&bsOqUQOyJ^-w!b>Cnx$bD`K<%$6EXG$cJrF$Zywq{|sH7f7NhpCmFTOI!oGG zFuXavX`}*@DRMj)#HPS_=o)h$Ie4ZlG~|s=)Z;i-z9*yQ?FV1|?Y0K;B988`&X{#* zsnuX&Q5HPV1Isq(pMt#wS;v@xf$H@oLqt?;rNEFf%gD!yt0P_5*nf7EAN>vtR#~YI z&T={5@4(X)xFKbjiGWp@1x(0;$BAhLOrK`XM+$s=1FYAk(*cIf!Jw%I?7mLHFNc2-eZ?|&94Lx^G_&>rR4RRi|Nkj}AB`%aV{ zN_?3dtcvAY*Ggt&I(~IFT@N@Vw$yKa6bNQO@lWi|1RRtu)x36<5DM2zy*aqvOjS&ivb`jj4v`BMYA5yfT;fnqZd(^v60S_4o- zdeee{W>v3N-P7*y0&BR3M%z&AiBKET%CHg=PLLtPb#0g6Y)G4q3*3M`o|f0r31Nx5 zh}7bMlqn#;cHdmx-e}WmyS>xd-Hjs}4aRgehQyGJDjI{(ULu1K8A<%jp&7h5l!x0b z;F(2?cbgv1$WUEZJ%kJN{P`()!E8ADM=aCLuiF#x$o7NHiODA#_4^;5JIms($FA|C zAyU64{rH~R-y8nynxk7enRg6C)iwxhkYXISC--YB}x{%fPJt`FmXLdjn`N^Wsn zbvM6Wdo0FjC0$4dpr(PNLOhMc?Dr6T{T?*s>jOH{=Lqhr-U|i4Gn4Tsq|6%ghQz^s@KZC2f2Uv4b4oQ|Sx8)(`yMF%s zd6s5I$_S*$L^>^b7ydX}5J;#PZV^yFU1M2#!@ypgM^PWh4#Vo;VZG=XOyxY9%g~jY zVM+M{w?4HuFdS~KFM55lf(R2)x!p?&%@$52w66qLw(olbrB;ds{Cp(N0%gE za3o0+*A)8W;7PnaY}W4o&W{GBi1X?-X1IUw1O6UGLz^O9s%!bqby&**W*6bf z;qpB$j3y>kdaNnH+QM@G(`Qv#Q0s;?;r~?y+9gw$4m(wT6fqb!BgXI%ylLKCc68U( zR|u(m2qo$-!H=yVh*GG-hM2bII2I1D6wrhtifQ6!r(~C$IpRKZD@Z6D%!bDXhdMJhD{d{kNi;CMrQ8?UT(U*4l%?riLJuerx_J3dAJeGZZV^Ci>wx4{-t6@H0 z9t#1s2c#=7z-JfiL^H}DBwghSI3)}Vmtpp@aC#jvk9>B3IU?GKRW#Uqogj|+M*KrY zNJ(-}NdbPO!@RHeS+OHbKnFuZ9HZ{7I7Zb!?*@CMDHvd-@C@i=8rUgs`BA(4w05M5 zLB_0Y-U%N~2IZhX5;+IRUo|iqT*!}6OHn{1q=;;`A4;UzK*n(FCTGQDbQpgIj`gpR;e|pW;kbt9 ztyFBkXyagjmnJ^Cj=s1kmdXQ^NX%PJk(uX=B}0<4aFP;o>49qtN(_PuMtR-vcso2> z4$i!C$O*>fWyFs_K<&?D#Aa~!Ff8owxoTAEx@+LlrfOSW#dcPBiG@sTc}2os7*@K&m@f0^qG%8H{VMs+m6~}y1gFqBT&C9Mk#th$zlo?pQ;~8?+&?~Opq*s8f z^swd;S5mx2h}3PpO1MLcCUBfdG!5MGd5e_LEsWwYjCOGecUdrf*{oq#A+Es2dk3!x zz3$mmO_G-+1ag)EUz>_Jx4b+_Q9R+Dwwq1?Gergp6(x>^kVkklRosOi}fMTnxd3yq(Fj$OpE+JPh-426P%ge$<#pqslNM447lSpmW$`C6GCh zK&A--eDJh_&K0bX(qvGh1RXVnzwsQ{Oigdr$n-lHisHUOjrkpsaem3Fc&2SpqOLdQ zsyZc>F;_8E!P%VOzBy-w=h&_4MF^|Qq!rc)|Dya)BFn`AI2ib;ZxmG>)iZKNAnwBz zAE-%PhcIxgA7vB?IMc|zE|OXhc7f#hrwk?LOazE&WM@(E*uw1C*Wm^^7T~`$P%%!= zhUo|h|7+v?zcLxzoiBL~Zc33uIPY+faLt99hyTiGb-HhK=p|b2?DT#`mEO*+-p=aY fMz70>yNGMVQZdI(o|_por4%>(p_GLlxzzp#T&WdL diff --git a/sources/XCLC-TOP-LEVEL.DFASL.~1~ b/sources/XCLC-TOP-LEVEL.DFASL.~1~ deleted file mode 100644 index fe4e6154f2f8e8f1f9dd42177137cd3cf2823504..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 40650 zcmdVD3w%`9c`v#jqbJfZk_K4_A&+@mVK6WAiXStQ24n0WQ@%{0h#7>$hZF0Hj_74wvcJ~i> z2K$Exx_dmk0rx!8nrJ_K*RJ&7-h1e0`8^Np8XW5H?;X6Sw|m7sz3IXI-TebSE0!$1 zN0b`82er0%JB*k&9M}{HFZt+-%7m@H?tz}Jp`Klyj^UocU0sJ3dzRnnF}jEPccKZ) z)~;Q-*t2Z)x@D`@ExmI|<$8Z2ELvfeiuCu1LaRJ&U46q{1Ba;48WdW&Zt2o>D^cj$ zXEUd@x%~?M?aBR2qfk|q%HT4JxD-vzJU`-G9|{Lr;sJk0pfzl?XiDbU5m!^9!yj$+ z$6LLjXsolNDKp|)<{9eW@9ph*sHc~PXrG2EGM^bKUEdjP=?EFo%qjJ#HX9YXS_A7t z(SVogMe+593pF~7SRkrRLxEzWvjbHYBUsiNiU+u`R+l;DAPCyg+Tm{w2Qni%h7q8W zn7^gnzafx0rDsl#l%sMBa3V8OwK)(sHhWu)NW_SG!=XehGg69J4DXIpiO-Daoe5Ot z5NTAWni(m6Bs$#Ndsx9hDYxavh{uKpD$BuJ#4zDC%O`YxkWx&Y`mDOp=MwZN7B^!0 zEJUgc=O4{U6a!pF1Ja6NPVlf7X3}air*5YPKR=>2;Ya)EM>8Y0bmT_7r*8-|y}v)* zH#F$UoYIh`Jkb&FZ0YEX2ND<ZTTCm9<57FRKf!ZcnLQIq_ z)nv{qNK3T%qgIU~ZDy{VnCG}XnHyGSEeU#!GuN&_JZ{8M{VB~{T#(?8#ll-CVVb!R z2{lcDP5!Vq84S>yc`C)5E1PILc!OA(;eY_Sns|M37oz@%ggPY@0~GK_M9zw)us`Ot zL)=Ya!{2JXfw{H&&EAZaDUy`h9RusMdehN2s+F~B0`Edr1?Y#0eFcOxE2h~yeM zM3g88Dc11n1aNYUE5(y*{*j${oN;HF7Z3kDhQiXX4FH#5cCTJ?>V8-e?qwP^68TIDg zmGsA>sE6JtdQ;yL479XUv%C{C^Sc|UgxBAUah;SQAsS9=V@4BpSqs`6XwAJWH|P^9 zmI>8OEuHarAli{DL6d=Y1+Df^_oKoH_C?%lU!*2FsGE)Et(g&byr*kdx^ItXDAnVc zyV$d@t9ziIii<|c`QxQR7z|zKcZlI}=GQZ=IPr3>c6MTT|Ni~~appAl_IK}c;i$+>OsFBipI11({Cx7dEwi2z1A=FO+^ zFw6cfj1Ba6_Y4kFm-}~5M1G!hpQnqDC2I&AF$`h8@)^J;v^_d#;{ZP;uzIIje_m`V zZ)<0SmL~dXZ37GHT~-LEbr|+Xnp^$!sv=&>bw;cs6baoI;JPCImbf7{D;KT5UaG9x zDe_vol*?4gB_?(>y-AGNjEH|rbHE!9M2t-V+J6zODem-iZpm#{^ZDSz@UHhJwnUnZ zaBkgk_3naf0zGWxl)8y2)+ll+#*}fPK-V;x{&-*=C(WLaRCxSymYD@v6oHvJO@_NRK2A`07#>tMT8Msy%_lo0?o}UNWBiW<$7)@$eG8* zoLD$Axrvn|3$jS`?0{0$9S$pc{f-27;E!oe82O?_rO953iH^#vAAx zN)PmS*Moqxwy~=T)dRl}>dK!L?xu*poltHffa%5%U?Yj`O}H)~n@kyE*#CS$ohsq= zmRk^v^rv1BGHHqhQCNEFIkS}(bCw%xPMI*)xhdns>ra{7PF0aWd;?L5@dPk44Tx<} zYl#T&X2P6M(5{}{>As$UL7FbYh-G}3uMf-P*wf_i>@aA(ws;eMrdta~9?@o{wHos0F`c57$U80W&k+RFOo4lH!y#)ZKqIpzRPUX*#61%; zOtCyqjx3y*>wN}RBJV~1fq|~RJ-EK`APx-lbPvhF#1&(x-?OvFGd$R{YYF-bs?dS= z#_%j9yw$NK7BFYiK=9&TY_E#WK3sLUx_w=HF(8;D zKDC?)_xqS|Puqxg25_8zdK(x}SwzHoHc#erNRas)*|h zO_2UY9k|&v=FtS<`~;sv*0B>$gpj2spT*xo)Qb^M++)_?j)gUAevXQlOE%!e9l=lY zKoop&VoRbU5UD^dZaT4J{y5P-xk9CeIltAMzZU5;sEnjk^BGp+3RG!J3B>O(=g&oU zSFR4P(cFe>ShYD{HRtOMnNv=h$@vPVu_R`MaGRj3lsRAH*?pVC4qLd`7B01g%WdHb zTi9s}yKLcVTi9(2*V@8$ws5@&-+~5<(Er}wlFX?(jFT2inDa4HIR4xD*yp?&%tBB}})U-WG5gA&;;> z6tMsncH>jp0#38=yakXgi(7H04M|zBnu&PHN|<3K!9L2cLMF0Jr;g0-L26@1X@#s(?{_>V34e`ffPE%;9? z_;(oolcQo3{~Tkh0cn(4s0!gSP$I3N7Vs{PVerpz{=We41lV5v3FFX4^{tZBxzzc` zy3VD~=OGtT7a!}okiM9QTuNPjtm{(xvIQwiT}f?sW}oP~lE%Y=PD^cfWmDU$vrl#* zkVe3k;zmj>rMQt&Yfq^|Nejpp~>@gCjwD-an`6lZLBd|?$WGLOCh(rJZscbsLoxHH5w_@ z;C5z>ITZ4^U0GuRh32`dvqlqz7P;M7V+n;8yKA$?atbYV*JX`W6k6%7&l+o7ikR=& zigx@O{_)wDIW--7)UlvFum$Vmde{$1Hr$8U1k4AB9q%DJ71jfIBF>|NHjGC(B%Ng8 zJIZ0hc8J<=9bywO9UxQTIe@3ea!9xd9H&gD9kP+m2Zx?(pgcP0P@Zefqa3Sggw=BT zna#m63NkgNmLjP9oS`KYYB-2{)=L)+EQ!fG*H4RPI!!h&rp!3LHQ&@A1CPJ3@!UOL!Nk;W2M6!JHDS| zC3`t`Y&XY>yEt}q8^?;0=Evh4azxA{K@RCH=HYudq^&g{UCAN!4)c*F4q=iW_E1Q< zHp@IDh@bbW%!7i2`mL%Ge#T8k-gL}G|7T6#?bn??zBk@r`gnw@Y!mnVloR({!NhqB zChfU`Njp_AX(w}&Mio5wz7t0|PUI$!VxP%PAeYWfBFAzQ$uaw6a-XWr+yBp+N63U0 zOuY>S;hMWIU2i8&n#$K{WNu;)ez9OWUn`i-FBDAY&F(>OZW_J0DZJqxl+)G(ddLe} z=+>SGe)am^R5|*fWK%tJwR4P2eL=oy;t=(!g$Jk(q1wbV0sFdW0T`wokXZTS8xq<~ zf-qCM1gD4-uui&3OFlIX*d;}+&Wx<=?CUwW9~XTH76sn~SN)!Wf&PIdU@7+v^&A}X zqz64m20dK^d+4VJVdV_nYf!GMZ&!}B<+a2yrk+E7nJPcQRs=mHGVmRyZ&t-=JUN0yNbph(rBy|B6LB+gz zg6~Gmq0C5)6}2%G9CYt3=1W0zC4v>WW)TaG1%^!kOanS0vNei759P(B7rZomGr}b# zt?-A#tvr!;@NH6EqTOK=o6Uz55?2*wH!R2>gJO>J@%#|D6iDr`{<-0K&H)c8Eeydo z&^%`SG~BLh_|hmlDS48PT4Kdup6Mo*s50*;=H@L>%{$atAl=a-qPeDAI%Nxp?_fmz zVJsgSH7?qi87Vh9f)H-diee0LP{mv<<=uV)FJlX8zP`|!P94&e_blzVL# zKid1tZ}C;}!=LLMN1GeWek92wi!5P#Cl`a+<}4g5DQqKbRc+ZyLzZsU7noS z-`)x4dZ{03>Q;zV$(@)WFunPHtf(+oP(S9chwR+b*R`*QMMGc;G9z$j5A{Xjo?Z5a zulVqzzcMp2!y0|jaBN_b>E3*^S5}xSso5V%3_gw&qPJyg(V7RZ37FQU$HcKi!>jt|X>hXA}ihksN2!a7fO9ySGDZ?&Le;;ov;Ew%0 z14D;A;42TIZeWjG{ixN3CRTm;!CIXenPUys^_2&1e#}-^n5(TZ`;-kI9!T}{K?MhF zeC#{h01kNerT3($dmeF~(|ECzdT@!y(@7`?13B1Fn|43YWBOr?8X=qB9!5U7CW!&^Pkf1eWv%}3gS93z;;{znIt;=Ou))_wYSPr!QX-_^+Xpx3ZM=Fbrj|;7SQ56G>xLA z0$Q4bPN#ayv-De${WR5Ho~4Wxg*lv@!zFS!IfpBkqbPO$Sl9XF5~`${GlFS|aBVik z4Ndd!0~JJ*2>{b{r4&!^px@-umr&106zY^{MM$k|vJu$SOb38vRD`t32%rO<69>ZC#1|7UwlL`k>bLM(J*=~g zMm?a<ci)X#ztL`&%?B~A~* z<)Q&HR?V>lG%vki3q?Xi2ZOE0T%m|R3NdEZhGOur z@Op~=HKNm?_SP9lc%iV^O0e${ET=~5jS=ik9=j(fc!GnE_w(biE&Mp%!jEHKejF7u z@^NB-sWUUDsWn=^UmCw+Bn9%tj)uT%6m zGUk&+*XvM4@mMo{Znlcz300syZd6h_h9P&qh`(etckPK}HD2iMu0~?To3%;j4r)Fp z^)9-KQsqc+y&fDdN7#vQ`N?GcIG#n_{ylnaF_yu^-ku$x>>ozW!U<>N*N zWYf%*Q7)B~C@MBZNlVyBK<|~53Gn|&@rISFmM&jCla@D0%B_ur>S=SSzcKHn$5nHP z9zQkjp~siel*&YVD3*Yd4e5R+2zm;|g`~GR4ouMEhjNOza!~3cCh^_X6f#xvevkP( zf^<#AmvrQpUbPT zAXfeIMuvPoz>ing;N?YpY^^X$xfdJ3qv`G6L$y0G*SmVV_ESZpnUQ53)@^yt5&s-w z$o2JuZ-;vc)Mq?IYnu!oo@g6K zHgujgbx5+)p4ZR-ZsX~~jj~2%?G5$wsD`R~9931LDn?Ymd6Hq7f$ny1PgkFJc)z$7 zgTuq3K$Yq{s?ts?qMaB}Np-)--)zJ?6s0~hQnZ9rcv$Rm6b-kyoKUeA`?i$^woB8?+qMqIY4_C)Gvnp+0^B`|)*3S<+aqgEngbi4B*`kpVx;ci$M|jh_!cYmsDI4bI_jTjC{Zp-5H1r16b;52 z_ro^ghGscO{72>=nbNT4h#wp0NF^~un6qP<&ItJY(#*)V|1B>dBtFF(6tTPhY!|lG zZXeILnDjg=T_rZU3O;&N+wM}K-C(%1?QRvy42D}%p}io8Aft|_nrQ&TX;kn1OIy4) z(jKbhiiznwjSNfZq{8j8a?-vpqgmw%E!rVwq!W{lR7GZ_L|Pt!Q@*}u=KvWYVbe#t2D(#t`u7i{dw~KYU4S~;hWmQ>(TiBI ze|XRE;813yEYY)nsAnHco=}@KenM^0{)Z&6w6&+3gTBnE5)>3>Psl8-rcgz)XICFv zP@!N)YItA}c2UT=ejv?((nQzL@PL3Nz)$Wvv^F!+c*MWhbEMUC#E)MJtvj-O@xrCn zL!h@mOY)%nl7Ihfp*$u9_XiG8BIZ};KJ8dFAm;`=c zGoU-|mp=W~v)a#n>SjjNSGSxD;W8n@_nm0_gbbb*8^I-`V~wfvJ`LJIZ714}KCN!` z^BO^(#mVZLx_>wQe z9p=YW3!NTYPqaS~(&<=vncD}rdi6x=H~`4@dlsx=%Zboaxrk6^Le>Tp&x3_V6M@mm zJorNU*d6H76Un+0p`)oP)sedF(=^s_ik^rbeFl48boFvnyE6Ju5m!F**nG|lq>#E| zI8PeRqtB`z<8^b{aB2XL{$m8#Jl|1YK}R!wU$5pLcQ~!llYruh0A(UTn+Pb)0qAD9 zUykI~lkKCsWSAy-vkc#VGBO&L;g6k+j{0PHyYrOc99?e3T&E1z=sYV{eafgFt+itA zlZM+`D6-k*xi&~Z#YBKJ2e2(Onc0;~lYr`p0JqbXtd)s%PL~Z$v#?X$@?yKSxPI#q zLrd9kS8|xkaGfE#>1kYPmYM!(nq6wiaETk*Yv=D>se+NXN?@#F^6e>*2#qlrmn;B;qC_Y;6c| z95q8_EvLRqup%DBml0%Ek7Z&&@qa>gW+_qR$EYk9c~?vw!M{atIqAy(g%U*@J8|o! zBonc+ocS0X+H^1CSz1aNackQUW$H?+t)*1U0#97OEtxW^Qin4mGef<-UJ{;y@tv!5 z9cU%KWbKEfGqk6Vr6Vvh?Ix`OSex>VbR;t}`$$4uScV{=?Csgp)hpx+ED7XHPeNEH zD;P@QZez7{366_q5JMmFG4dUo<5R`?u=zyrNh_QIE=4jh9Q~)5&A4r-QW*eOeBM@y z#-z43i}#;audo8cEfW==)ZUrAq)W+ zPPu920Mcsa>B}nz$mU|U?dk!%JnnR`){wfY%4}u1vIZ6XR?-82@<^qi+$GV+`623` zCZR0rC;g7Pg5jZ^WFMbe9v>bTaeC(UF|=jc2Ob=?7|ol8wh5zp5<(s6@{sJ}=7)$( zFYH5PYw``oC?LjYnQ8`TjA+>qLgZCaBZpyvG3#lig!?V-%-Y>}!v|asiV&Z)f;RQE z;x>O|K6iIce!&TfB_B`aF4!d77G1SB%ht;VD2hy63F}2K?^ezAV)5PB5JvDIKa?TN z?Pwwn53+Xva|sL=&qOm@uQc|}H@k>0bISP;HC?$trY;=1T)~ekFj@(;EYso2YBQvoA+kroZB;izWRFsc!-C0ChS&^JLVW2`-i9#0DL zmrOZ0^j$NAcg(w97YOMM4h;;$8^ZuwqtX8H(hd`b_GGIX+2RE!zr)KccI6Usl;y^T zZNy-iwfJ1agi_- z_60m~^q2re(5gAteOInp>Y^ywVU>)&f608$gtdSc`w2c@04Qv8- z(1N-3QkAPH+;>$8e^dD{sXylqX1z)yElqnGp)oF%UIsSKX>h<+QGh(3U-rEGrG($Jl zgyf$-23igJTfmfjAH^mbuxUIqf(g?nWn5qpiM84S3w0bozK1Z$23uUF!R) zHZDZy3+YzaV2k5k_9yr$$LfOTJ1+#ai=FMWPqZIzYp=f;YM-gOe4U^^ zI_kSii2~FeW=tHaJ5>A>}4I0iX@0sGUt&oIwUH>ivTV&YoCl;l(3IM7(Sj zBBq1qI)y9^cC=lR5HC$4Auf!DqG$NPwH22Kph4aF}DGKtr~R%fy3N%BaSnn3O2R zvc|F25FqOSOToHpa1iYF-a|N&a17qd+xUYYOV8)`o^>p7>mDxh@bi&bW*HWh++c85OH8(&XBn}i-ff| z1S{e9vB?=le>lbJEjC;(RkjM80Ofi4`bW5B*VPi=Qekc(Ek?gh*;6XNOHx9pDG&BT zyAi7HBn&2TF{#Ewy_Iw~Au=9lU8JRvtV-+1aQHUSs^zD@4EVb3dd*s}6`) z+=TMXBly1Zx7sFs(p9f`B68iz$W{4jwYgO_w-Rzidv$XwFJ`{K@$y#Qw%ysb0-w|f zm8+a*Fw2t?$ysx@4#0#*Gb7V;ye)2C4hMdNQ0Rm-cpjp8fjSmm(PG55cndQCOOdfT z+9($6H>J_E_BAR{n3t8yP#`n17Yf_BL=J=MJ223-e?QTUtW8S#sH~%Fw_51!?}8#K znJnZrb)l2$N$=a=+e3~uSozdawukpA(hY#hDy#P{;f?i2lW^#tU`Lhu-l4gXyp2CW z(8f_K7G56|Rm0%(IuR@jai`!VGchPDdYdX0mMlV-PdU%ZtI7q^BeFTW$XSg;HE?SM zPdIIMjJNg;G;c1yq~MmggQ~vuLg=|RGJI~6FZ_mHc(D_QFX;wKwqOk=V}?U7oDPYD z1-AU5_2O^i#VdU0#K@c&trwc0LK2Y@I{*@;(Z3Zf+3Xuv(2$^P$hQlbk`o+zsr6Wk z(}klmdN~vaLSYB5FYRw?%&nE?R);m#!Y+yjfVZF^DtQxVw((V60&B2_R#}b@ft{lY zJo;xebLx%Nka69~5p}}lS6-{}eYKFc+qHwY-{jkNU=vy-B)={3zVFy!f5(oSd`DMi zq}FI>&2W(=oVevwjX625hs@DJZD$7AG?#PKEHLP_{7ZBA`#rp`!UnhFZkYcA zcjpr&-o^k5ynW5W+rOc1<@0gl(GZbMSFCLR1KDbA*$TTUbE{VFe?jgVTW(9;I$yD7 zW&KxVb=$J$l!Ehlbt~`xi@bFc^IE#%`TPzm|Gy#s3|s!ZQh1Ko{w)}F7OPG#op?s* z#4DQmjOZ3;#4Yc4F#I~d+=ZEea$c;u3tELqYuZA>@8QLC>b^bs1js}FzwjNhgIatm z6mH;aqfYwTsFS`n>MUOyb(XJ$qw*8@ycA;_%lU(J{^V2NPxjnR}^?4C~%w5foIjoGT-^L6~-NQ$reyf}X zy$rLk=>s2yzHtrg*r0FR0d_1N#c)J|M=1b7Eb3>`J9*y?*;&9X# z)|lOuCh!?Ake!DSZf`^#)O!^AX^5rMfmpO2yO@pFU3X^Wso-}HYpH*Li$`z}b z%r`Kx^(Ym_YLL~y1xj7es27CuS#`Hj$5PB!&#ED#PTgM54Z6C$;iS>XZ-gwGr99@`; zHk>jVM(c7>YFobYS!kM&^uiI1W(f6mOvmW$T(|XVF`}bxJ5a!kTAHD=@9hlp4LCx4 ze-6<`6d}Wj^(KQZthsh>G3HbTYP0QQ!!q4%HK87}-iSYP2IPUKoX?|A5u;w+E+}8w zF!7kf6^b+8sO4d*r$UVxjIU<_>UhfVr0Taf&H$q$JqI+#hU!6$H3rl}y3o%$qzirIgSt?VJfP1YZe<)g3DJa3_TXhv1DwrvM9rS+ zB0GjIA}S+MOZ#Pnw!Hcg3O>O>F9q3ciAwT$Ele!pC>v&n*25EJAlgDo2HI-CosxB& z*O$=vX2B)ZUvqu$A+!2-`QSLp6~nYW5G8XJ^-)UEo}^$;K1dq2I^IcO)&|w@q#zmR z7eOmgC~(h53>Gr%ER~I5D2pJ5XCSCt;rclE46>59Z6aSOiR5J^P+X-r-!=7BY+s}a z?>6dFR7zu&88HeiW;a3RibtJzIK=}P2x;mV)d>yzct{upe1TrC({QTKbC8Bp{RDD> zOlfE1eoPI)gfEIg3U*Q@a@Hum0db(f_Hd{j{ns$|mQFi3EEF;s2M8p{Q2t?{yr_ZI3VI)s6?Sv% zA+N2ND2vu#&NJm>PLox{Zh8m6WSp zyEyt&OGRfdaI%e9LB%+t@ZCIz+NLM!iGWFjpj{jQ7Ha88 zu)|Ap9+4&cGN)Oj_n9h};-e$^g=QZ5t1tx^@+E5=5oI;ptmG3325DiYC;34oH+f zAW`~3iP8_jD6&ga%r3p$+%D7u)j@M#xu)n+hY1Qhf)*TcVBtg&gV*0yB6O5bnSJy) zX7=@)eY<#&+^lD(SI0T#Vnqtw`B9Elh;dvC4uDQ$)|WY5f%58CoBUtuupnJ%4JkXG)bCF zN|n8QDcKMf8nD^Xg%b86V1l554mQ8GnTvDZ#U~xao)$exHj-=)s=uGGMs5=qN;X~{ zYZCir%p;ym&U{XAq4^CbQlCgao?@#-w*ZTbqD#IozlU?WtOi%P${!GLr)yH{NaD#x zz2&5S9c$kJ=f)aY@-~p=tGISU+1J>!CP+>LnN=RCrFqWBauF{#|q~EVIM-RelSi`ev@tvd7 zEkMfX%=IGBYj|}9YiUHitz=C=mTx7kUKW*5hLhAzja}qD%_}=a&?n4#dK~4%hbfps z-NiWHv2Q4v%%>O>R9~YXaynDQrvkel;~2>Z zAA=^)a4C7vPXrC7#vaCqIiPMEr>1n9i|NryxH{qAM0BBgmq{A_>U648XA`!6=iq~g zD?j5z&D|6=8SvP4dj6=ju{Dq>w=g zGYS)60WA`gbFlI7@9ZCddn?Ka7t}Ims(E=j!Z2Hk`@>8- zL0e0>1cKduViVO3^x2P(<@m`cd2@CLYQ{HmG(V#Ofn8u&2X|ih)$EqbHZK4$M}wya zY&L4w8IAAQpoRN^n{5I)JMLF&X&w5*aOj@+ zC`>~L2ERLiIS2-~i++}qbRvNcZlwtgEVmjcuK((JT>qJdm-d2Gv?3k|2M9@s+K@q8 zKpj`vUM^=72y?jyF)b-b1fT2a)qj=Q+p7!2-m~`yyB@gurCzP;+}&&`kF5_Pt{y)QzV@j{l~U6B`VM}p+-CcT@!jfYCc$` z6}TpFNDX98h8@u~o8c>vnw+X4L7~4JH3!yk&UaUs1FQ<7&ZWg+4hW+e zCz8%{N!R%_9of3HVELp^CAx@W&x@}4)I2%2m9S+Mvu|?J{V|Ta1 z4R82F_}J(Q^)g1SSC2S9CeCRn_|!y25NBLezA4J%6xJ?{{;^LmMtI4uwiI(<`Yi@- zpyb0096MaN0&D@R>f8rByvv5DQten83x@{WD=nAJd2&p-*zW+1O$%)R@(FNZ6j7cx z)7`*172&{Ucr6Zl$!eD8MtdC7fa)x#cauK(j<)&54^Zw@wtH!v<`w9D> z;|a4Vm=E&W*T1NmgQPr-6>r&%K&`*oXx-vXhB|^!{sVT1kPkw!*e7fTEb<}YXhMD3 zmpWIq%#rl)cFfA>$+PNOEa;-7M_9=*!Bi~_Vy_~x!3WOTv>+2)Cxh@fDA%PK)YR@d z+0-#z1n;c!4Vg&5i?;9|+QOf=gs_QWAg< zf=6|`IW)aM?QSaHDP-S-D-T&Lu@zHkG>(to;bR2^=ro!Bg2fWW?iPc#wLFx`wOt2X1W90Fs%yQk3;5RFT1(^K97v+pNF{D7#F&E8>{@;k^ z{LNGP4;X-3d>G^x0hrICxhVJ&zdK7o)>PHMLczxv`qcycc>6w-FN(+f8#e|KazfhO z(XoZJK*)~>F2AOp^FxjIyjU>U3cShaWH>F{a`M$=rEjlqyxy7ZJna{o5Ig1qG=MMq z#%nM6#0G3v+xV1dYwvZ0VdCcR)qLZyb)!RZnR&3NK(EL$<lP=D2H zjb?L=2(gq}j}!X~8o6*l+J!D0LKn6tomQh{BmElGq3IY8z5)|absKyP@qP+x^~Z6N zUq+j+$TmmRu+U%*tC3zu)OisK1MLegJPt3T_rYK3xzQ^MPNrq%p^}?wz2@h}jx!aY z%~0oKI*Y}JrqngE-Efv_J`9?Kmcf&`7F+I7!7t$fJ|i!|966fGgyem6WD`R|Vq0^! z_(yo7vc++v;D17p3>4G0Ngzo&Zs@OGsNZ5w7n!Ri$?}N#aPdv`l{pT_Oh4Na>Tm4j z1$uEE_M)4PSZV9#^?QZz(40r=vTpXPO0I}(bdNcYKI6yV5d;0h%pSP6f(IjW9(@$f z#bM~ggj?y8gY@|?X3VPBW|(`61&6q*6B&!;n<``2=s0uO*p8eGl(1|xyd^+w)T(^^ z!0?|jAIY39qJ_4vXRja-&0Z}>A@*t@48H*S>D;mOxumm7RsB$(=kW*ksEx@dp!;{* z)U7QH2pOnBi4^OV*&2&mdu?Y@i#Uk4;j0z7lqcGhq|YF|q8`HqOQ}2f=$|3xdDO zWe~;$+6*#>cR&OY6LxuX$u?D8L_1jUh$+g<41w6$8JDH1M=sHj4xe5)8gS3yk5Lie z9{?!I#r`uTQ&Z`il$8870R)#iwuJy>R4The(ceeZK?NxCJR+=i=990rYI%whs20*& zvJxKw5FX&{p#1<<*a15MsAK?X!BKTdg5;_qXc&-bvL1^25NAtLAI11$4^JDL*W(*b zuw+ONr92_ndk&D}mMNqIgPwh4)Bx|2mR*A=vknHR^g$!wg`5{P&)uF5zRmmKZ^6dy zpUkr7Tu?<_mh2iJ2cPRaoSoR+!+rS7RR5kn_^I3ljc;Lq3-^@Bb0h(?i8JP-xJxaI zpFm{0u==wr2f z-PeCiIyrzrEg$vP5F-L9pxPZ~G1j;E%B)#xmY9UK4&&IXk9|?L*E(o(O%wXO%G2iI zLS5eLZ6oQ$=NgvS8S@A%HK-v!0cF5g=UlQ{V4ooTGpKI{RiTuBb!=8p+j=Ps*l1Y2 z9EymIPdB??2v2Ud9M4=Q$ID4qP~(E|4tG}FV-*YrrQG+HO=+U#qnoU370BibYU!&l zr-68Opvek+yPZ`R=ch~fNe8UXs;`k()HRS=84Y|{_Uyx)`5_wH4{KyzVKZydBRExhA zU-=|CwWw$(;DXqYhC0%4M<$aAVigx7Bc8%Ez8R?0T;Z)tUq!)-xt0s3i2AAr2%@hd zi;EhniqI5)9m}F>mRW7crC6WSm?v%@KjQn5dW~)a>c`PP`Jo#2Wlpe%04uc^Xav{` zK(Sy%P?TKELvG(8jFJe_${E;3iJ~m625pNVi`q4Ix;h7$iq?}(4<(RIzvbCX`3-mK z9>A5abB|d#{2B*8{SZG6ZRf{c@!Gb2kZ@vlvI>>0$T2hzLK>_<0WD^N9~`2R$XJuS}y3;}kWV>KqH z0mok6t=C!dXc%#q<;qgm-^z^KW)-zW;8T?(e{1=YK#?B@kCG~QlbOBb$rcRDz4)UW zl3&|GH>0i0Oih71)@C_vIX1cvUR(6BEx1;Xh490yfD8hf@EtQ&i`#d&{t_T!uSe=H zkFLybYQrgnLLyg+Qe_DWKV>*kmO|ta=0rGR^N$HGGZzIz_2Up(+4xJ>+tYNeD_^3c zep{=t1k<}=(*Uo5_qOrln!-6gFZjvY`Oqt)H6isr41zcZpt>^pi~O*V+W%bX3mMBr z(l6{KkhnnNOL*W_f!A&4^iDVZ0PM|-+}aGy_MPcI{&aG_0`?|C6TBPCpc%<5-G-pR z(s8$nKv_N-3iF-obKL%{xClRYhGNkDIIZC-EG}Ue<)ut|9EIt!^77~p+pnZ9lY^e8)%zvQOSAFI9MvF@!6O#CQ@s7=E|-qD>HnyO z(nxZbm+{P7#T7kCOnIm99~%t8HzqI^EEn&fM6Ip~jLahDY|=ST-99F6KgtNYE|;x( zsa=C39+R;8998Ws0QFrktS8N)5Fk#gM9f*sIixOiNuw2EXs zFJhxku3uR|5-eGn% zxFD63){Wg3z7iH3wWy0ZYH}@LX9GO?^TLq|wabAjPu7Zoa*KhAT#5e9 zvr!<8$x8`hbuq1`b0SD+cU%p;Mvj4Or2m)FXAg+w===?0B;P%)<`U znN6iNvy@X?_0b8#@EC?+U?a;59!QKecJR(f38!WCLUBNJXLN(zpBcl>#km)fG?B&= zQxp~11Zp9N=n!(lCHfi=-_-2G@XojvX1?reOnFQ#;4x0>a_Mf-wfoF{QJjh;lD)`W z0aY@d#+M*v8d>n-+tlRl>{fFhGol<32V0Zt4{ksX$=hKiRQ*9d?;VETMfGdV+!}4w zBA6FI!q_^&f&7tmF}aN3HB)nKw0KzlSiSr_*&6h48C9h`j+@3!;OqiAp2|Ien%8Z7 zxw(a>L{7pYVH4;V(SkIQB1XB{;wWNt;e4Lk@dVo8kZLGk>rWb4aQdZ7n4FG^_*NeK z`*85CQ^yyW`(}z6C^z?Mx0zrM>Y7)K8IQ5HN{-BvxaT|ocRuHQ#G%BGc7YWxF7ofC zPE^zLD@)K{g|YGd>Xit#8Ti=54JW6FoTWXCYn&lI85E2P78rLG&}t#PE9YiC z!hLic=zdDlS8`+3cZoOP;_7VcOAGYP1o1_Zef?k$5Lrpg z1biL_oPzzsgDFzh+YLtv>;PduJY(d);{(&h9LIs3Qo(qU+;zeT&c7R+2&M^krw35) zepsg>I?zA7CndqqI)q-|E@&JsW-ktK*&si6!O?!G%i;T1u(I>g7c&+~uEp)Li7EPk z$j+V~ww~u@9zpcn^7PAfHzJ4H5LZ3)X#j=OK$9BAP}0 zw|^vp2k$2BnJDkmwok5r9)ONd!Dr#~vnI?dRO@3yLSmvkZ8vV>`aZzBpRt*;PW9pW z8@>FQi7$UfqJz(5PP1F&&kAO(<5$G2bqI9T17=a;Ns#KiCA3RpGH(EAQb)vYo$DIyX&Ok`h<*-SWyO_2f24vby~T|&!Uy< zx%8#8%CBY0b16iADkEni+WmsG2k_6QE(>1mxm;O9-k4Mtz|&R^VjF)_Moy*9k3MRJ z(-%kgOTsE*F$1(Uhl4&OBGmGkrP7pU{{gEYBfY*Z)RuXQ+}D zK}OQb3m>JJ{&PDkIL@H|N_C2(op1E4D5d`+L902#|3kqd4*mi`2mc!dS%j$nih?gP^w$)8nuGtHb@BDzuv&xuKlU*2U$*e$UsdFT z65EI4h0;4tfFC-$fFCL)c{v7S0q>KGd@%keULq*ylTwZ4q(woKCaGXIR#g>;Kr53N zot>B-8*QQ!Jz}_Q_bBs^G@8TBsx|Bh(V*6r4ZbOcw<;d?8@^@8b3M#$xWT z|2B?YRNLvPkzy2%8?ww``m{lc%KJ5LdWFMI~DRFVUvSTqE?YCM;Q*))wPMu zniPV+6nZ@&2Q1|Zsbald{anyDQ+f-&FElfo0_PefM*md7<%3(#zc1(oWMdI|I7#RW zK?CB;JBbb#@L|ceD8!sC%Xxw6KZlMC1T3ViEA$Rq1+jKxOKf`SOTv7BDKq|@O?bom zS}k*#iRbG}tQIuEv(Q3|;PZEO82Hjns6}vVp#&wQD9pdSp;sV!;Tbv1FK14(KIxF% zKL_;iNXQB`ykn_zygnQCw~F|yOF=NvFZ z@Uv;YPfC66k%E}m>Rg-6%Ndl|q~0~ZJS1pto3|<9AWf_XWUlww((FZ2u7bCv#7#qZ z1xPlE8@>u9CQ@0NBP|VKc38@H8L(A+sro9lyvj8ViuDy$uF6oA>Xa&S;?|S(jjgry z;Y8|FVoZca(NxOgZF1;b@P8m~2FgoN-B}41%SLSYm{yK2ObNX9@QqB&gqjcVAbpLh zrYUIPYV41<1fdn%0(J2KzUL%VzG00fRK5>Nt2E{wC@)W+bi(u9g?0@c=WNWtTZr5- z=vd5dN@4!HQ0?9+^ttcHc5%Q?tCf;jw(IyZ1^rZ5Pg8KYNy@`2VqEf%cVd3dQjOgZ0r8PMXWIjU*RhXU%u9k~E~n_~>>xl41*LTSJRG;OV&ePq4>kz(!$L{Vz3-___xjp?=SLl7N_ z6kVV~^lehU$?WRco$kZeN%09q`4vUnRO8au%+R5GJ=81s)mt#Jpyhu!0oyXGihDg^ z1$(Ww!wnv{9PD5;BIi!8u+1>znh6swT)4V=$=gZpo<-k8k$CBIphE7&o#J9 z-Q$>A?OeQMqb&_ zykZqY01FU_Rn|zXGB5$FCG#K%S zsbI9HygIEwDlAvDjnPM+wvy;+9|d3H0UVF;JNiDtkA4pW->HOs1LgU&F#kBli9>_p z;h>b~auyo9LEX6^QxZ$>CcaR#Y}s1D6V+3wXe)}}jA=ooWm>?tM%)tGG0WIKgrkS0 z+6GyFXh{OW?0{3GJn0J%tQ`4|6sn|P)?TGmTA~-kl8qT5RY2IN#WYt!A^<4>rh7Gs zPq2&FltB4{^QM@|#d}QuWPu5F(&4{_`+8APCrU(K118;J-Q}b-#64CQz7l<9bi)Ke z#y?$02vYWbQjeN;Ucl?Hc-MlVAlTBcfmM4GR~5b8^m74qyb)3j6(8g-5a)amlh)rH zukUtbn-h#9`G@g*cX76ZmmM_GRW-yu1UlWWY;y~5>T|+0kHetLnmMba%S4g@NuIkf ze8_^uZXFj8WEi+d#300=)%1w4BXRHCBC(_QhYzF zN>$*Nn8&IEW7WySnGzqNsu#z~`4mR`fe`E%F&2DnL*F$BcI0^=#>4Tu7!T&TD6eBI z-tSVUOQLT+_c6k4bo^9fE{(%*GxTS|1C1~q<*BlpbTaZ}C<(2rR!orF3<4Ec*4Yh2 z>cNEo#N)996TObBe5-R@RdjYBJ{vh;!5rHX4{Zo`WKNZW9NE;qL zry78lXI6~BbdRt4#a&8A*JD*?)3_|mD4Pf(fD2##;W pVFraTo#HN>iJ<BiQGw{>XG-t<8Kuy<%|bnn=xcjwTs zcVuX6xUb*46L9b2ZHbP9_x6nR50BipyLazE@8Errp}yXM`}Xwj80bH+V#!_i4Wvi* z_6-g9-zVip?nAw;zV29;FB04kj4b)svZa*?N0oiU{k^08JG{$Q`x5Q5Nf;(~-gS65^cCCspHLqbh+a6=&C zONN5~SuW-%;76Fe>73z<7t5yVPhw;=@V{e5Mp($`xrjn;CMw<_<;r!+HWca#h zh+SNFez9~06A5fC&RQkSpjJD<6>U^u9>R;%g}e!x%DI@a`krVq8;!)H? zZt})XeHV4~sFUt-3)QVL?b#rS^ zJRXd8=St9Ipj{!m{WAlouoL?t?sG0u3mr7AChL~Wcx}ADcSm|~mv=PP@13{UyQjBr zc!-KiqtyKIQXve6uJb!&c-;B*Oe;=a&eh(W7~8vdXjqP#mVu$Z-RcnP9Ze4n(ri)v z)y*wH%pF+xn0H2wvYJW-uDUrh*G1@odt2A= zP+$MZ2z7aA=Tzk9O%Hl|`DC((z}1Bz%vU}O*o3x6H*Fl?rvz5-bnDNDP33Fr>7=EJ ze%jl>hWeHj!f72w0-Y^w0eV#tFXj4JS9iEG{6LWF>I}5TW3pMfXv4KqRn>0EYwuDn zQ>m7i>}YzEjM%Ksz^0a%^MkPS50)+-f(U4?YaLlerk$6ikyluWn3uenkF+453b>)o2Mid9>1Jrc0m?(g66Trlw|BNjB_68 z6eg>x;-G1|r)e6`ft@s6Z|M*K(kN&VVZ=5cMt+^3x%maD*TA-1&rJn6^SGE33r8k5 zv5I6t7KNVNt#MEpv<$fQTy{@k+!^Q~l$!`*x-kUUNV2^N*9BFRDMJ_bKOayhN_f5H76c>x z=@*1bnr1;1mY#mj9HnK>a%0UYQ^q4)k=#XuY=j5?#U8FvtfP4_?ANo;=Ynj+dy_ zf=XuE3r8K%R;9ff^5-#~qLs)yBOb^R1k_ByJ-OjfH58zcIa8|lO; zo0{uG238^OMSr%VRXp5z27@F(!XN~`U|Sih4*&hSxR`T zdsA1?x|s%o7x!XkRdn{@a>Lc_>D`Sv!KJ8w@X_?}(BK{rs8s4G=;Gf)Wwlt4;8228oo-}W@-=wPZ%t_DTjxcM~Y(FmOh2|lOnV=0~pBTG#_ zOQ4mgn^-(?pVe?X7T%l%IVxW*>7WmHhycwKQTWA)O^NPcX9a4hr4zj?5GUFwSEw{* zEoieAtVa4QDx)abe1?^{B2_w4g7G`81@n;IldHoQYiY+dt=d|kTMNv_%n3Km^a2gj zT+$T_~Vyv9pPF>xXux-cZ3@xd=nZh zq5rkNC7BcT7$>7EVJ*N+fjsD7vViZNI4SrRM##dA)SITG2YhSgu%k;YZp`cLxEpc% z?6+YvYy@uuYNU{m19Z){6J|P3cN;i^kV_;G?z90m_Ty9B2F|e00UMxN7PsSW2NJVk zHB<4HoiNKz$R8AT(p)>~8rV$oy*OTKul2)+GvgYN2T$Sm4rAPBqyK@PNOyiIgM8q{ zc=)h(m=~!myuUbn_)l&4pELZYHvDHc{M!uw*^+~p zU_;7M7gJl^*{6Firtz?$Gg4bU+0@qR?6bWHq!DnW)FP#hQfiS>=S-$9=DDYUY-Asbue(PX}F){LVc;2)oTnG-XyM_mg$f}5~D zu7&-O}z;W74+9B)dd~lh$2CAcj4&`~)e9CbTjj&!$KR0u*jDk#U>7@v2f5*@g3i2-2 ziz)aHLyIW*8V6kzJiSz11KTfDM6cfa|}zSN7d*yYr0LQ8Pqk4yZpUktlCn0l z2~K#Df-g{zr$PH9L!Tn(Qw%Np1Vf&FjANx^96P#~VqSBn?Np|n?#P~CX!>$$>cs&Tetu3HII-PEu4NE3gMc&FI{UVUNx0((a7Au z9{ftdbbh&DI=@sfoj1A%eYt7$<)-kudr(bVGw2~7XrWvBAO6)_yHn-pgO*M8&ofRl zGWCb}rinw;rxzZeCWLNN&jjr2qJ?0nc0-~Sh_6c+vkAgX>k^zIZoqozrmgtcG+^g7 zy*e|#vS+Y=|6VWxAZ!%A3RnUC!^1P?S$4~=+xhj-CWKf>DUbgx0V z-oYI?)|bx~*PPVSeq*D4CS*LIpKCX^9FORSQx_t}LpGfj=7WNJ$$iWp9y|yj+&U-g z`0$8%I#LY{9i1_E1O9oOFu)sx!q69@K0{F#U?Eh@pD%nlVjgA2YwW0l;ozcsZ!upA zqAL-sz%`3lY%EZ024Duz36ZT){CO!aF1_HjnHv!h8ehB*YKrLbyD#xU3J8& z!93GVEKz0MS8fb> zA^(ZCbxD`1%v%8}wPlu#*0Ks~nXxc4zP4p(Y;XrLvbw!H#)gSOxVJ!DLE`BV#pvpP zw0B^PW$e8a6i+()%Wv^l@gtDy97kIkt>qQg za_ZK~5VjdOYQ&mj*4@70^e78ppo<{9w;lb|t6pzTGr-x2H` zg|(8JeMe#x${2gRJBNq%c=x5!eJQ)KK5jn}cZ{&+!-%u-D?fVU?*h`Y8}ATK-+0sS zs<7^&rr)WWjPws}>zyxS$a>%r4f(;2 zV%ng|c&98C`Zc&xPxtbp0O}H`t1xe|K#TLxG>VoAv@{2uN%fXz>9->LX{xA1hbNb#D0SvY@0sKhs-&7Tf@z3wT{g@OP4n-=6-1K>fN8o?il?{HZ*pmJ zd2(g)?&PYf*Xw8?c&2N$P_40>gCQRj?CNl~%)+r)izB`U$hsO!vC4`W9;?fk3F3OT zLw^agpYYk#4n)9)8+1}7G(Q57wecWyNa6{j5+FD9ak|yTU~M#EQ~>58aXr-QULG%s zA{a5s?O?ztL$G{ZB-Rp$a2=(HmvOZmEkU%Dcm*6QMx#hGOw>0Lg*qoj5mGCg9RxNt z(*MO#DQ=(^Tou6ElfIu=1sg-51K5a(f66NIsT|Al=YZ7hvTDWBR@y1 zdv7W(;3$@XP|Z^(lu7#+@Y!Za{VWJUw3Log;`AU~E)7tzYK|qKj_Ctis54A-FxYy` z73vH`p#}vx2dLseH-T*l1#VN&QnYJykp>U5(f$wga3;%q@_IScq+eh-N*RuEV)mW( zGk_|Tct}Zw_3qQPz)XxUQf{`EkU@kHaz}pCAU9K09-=0#9QmEoQKlH)TVY zG^YC>INm-{iwG}k-UkBy!YS?P_C8Oxop%WT@I9|j@##6&q@+st-lUrY8TFi4q5@&U z6lwgrvW~qJw)axlcQkc4H90@&PNh=Z3=!JmP0!0_yQImbD|E@Q@W*eNSio&c)^aT0 zNP&7Pi!n&r4#ohSqpuEKc1`;6lfE)JpR;l8*C=`v8S_cf^?FoMJlTSu8?B;vN)>2N zEh;IU#E{p%ioawvckSt9HC|ZTSB=Dqx9gJbZPa{D8d!7%rOJ`uc`J0O9AP)Y<;Rl^ zN0N=)%LguL?U#)9OD_Ch+BcV~G_fWwF-S^-@YT%&z0 zq=Eu8fSYqODY_|uD+dtuG{Xd-tl7S3n;&sdJS$)r4vuXX8QD4+fLlbEC>A$k>r^hd>QF{E`x{n^e zkA_qxI>KEEXz7shXo8?8P+Ua8EpecV)&R6yfYw{w@cX5cHdJZ9v5(Yvq>S&UJp}<5ux}K+AzI zp&dua^cF;Cigu6PhD0T2eya{G(7#RZqKPGa%e;07CH*dvSWi0M*4;uK)E~7-s-Zt( zk(@){hRG`hX-I-!9`4Nm6oa4!ON`Pt(By6iLaiber8psY7YR}*vO=m_B2|eX<@YE- z4y3PAkR>1b*C;59_4g6fe#Wh*yxLDVNO`p%aFFt9EP~a4e?3FK6y(PjSK;MFd|<7x zO1T&7!JQcx+JzFj8$dO7a}NdP5-V#Vn-e+ku4RZpR+YE;E23fNAuDl^dP9_a5K^o{M63o&>*ECkf4zQa0cqZH8=3+klQ zUleGG#k)1FAv0dIge)Xj;BpuZxA~h;zLpJ1n(<{@y1L^bDD$pF6EIFE&5reqi%!ZT z8$XuDVK6JMT2*%}bvVr}1M(7FpRohkgp`zrC&eW9O49(wF|E6J2+ruHv+*TzLY}*q zR=RADF3EUqG3S4G9yVna_s+R1IqmbZX3hy;>0MpU*Ym(C)Rl71lcheE+kITN{B`TT zS28DyXtCSA8)Sx;)xirD2SU1-t zzmhfOW6WYOf?)_K7GQW{K!PHI1|7BUyghKH3&_04T4~*9xNN2+i6o(S0VbZ{ zk6{F>*O8KOG)y}ZI(bmk4fX>(lS!^*JlxI7Ou?;yl`}t+xv#Q|-fc%4X0!y?LG6;2 zlx2h$VDyv;Ne!(aJ|L(*Wx`U5Qsq*L5S$cJQqw;-!5DoIh8Nd0^*IzcwBXRRmO6(5 z*n5X6iJQV~A=@-Z;0ydpQu-nfx#IR?2N{OG=~(z_HMKUilHw^5V-rVS%KE%ywdV#C zF9gmsMG7WyN=AF%W9C-ySe!KUY4-lArFX5Ypb31Eh8Kq~j{7GNETUt7#Q>N5lbtqT z*#ivteu5wG$&UGtQvVNblQb4?>F)_@{nHW#{y;OgWyY)N>?#~QADF1qnML7fo_{0L zrL6*@!r6|03dNnFFuzn#5-sQ%yq<+Fpd^S!uro!p!@Dwvd6o+r{ONvFyVK8;#6J#c zhfb0X9ion?vDKqP0VU=!w$|#+A?ua>XPU zm_fEdL@R&+P;Gc8wVY?@I{FznX>&f zvnz9=A~Rmn-a9zfJA44bjJ5sShb36l**n~q0+tT!9ZnD6tm^DV23PyoU_U@D zF{r|&-Knu*0T-_wPIG#xZSO{Uj$rxs9$1|jZ#ooM>^;=xJruw%h1MKezWBDK_CqH9 zrz~;TKj5MH@i0GBBrK8Ft^2W6yW~hY{cwn<;e%HsK2a;PC$SK-0XRc`^0r~^$d+U) zF`=RPcv)fHpJ%6(wOf(3?@_+03RoSqm{D! z(ro{aE|q=k?72UgKxl zjk6QK4CgX^+z-UJV}<|9hrKEU-W$5KZDK(^ntVU0kb&*dVbZ-%UmD4qw4(iwr#$vpUM$K;*p z($mTMW8uT8D&3X3;5Q6bLW>@Y9)1CPUb=cAYFwQ7hfYsE^W*}~3#5>`7;_(wxevdn zKg8?iLd;eJ0^B)(W0|SUo?My&R8Ixex;@D{m00igIM6i9qxDU%cG!#S*IpS~$_DDj zWi7*{lTLu=aq(Pc1!fpd!7__Rr;(r%v&Ilg|9uL6%NoW*f1I{vEAy5p`VgWnviPFN zaw~v`cAU4Od%rdO2*36@K2f!2*I9wvIcX+c&5VCThm=FZ)~Y0^1!xKGJkSu13*0`adJ;NrZ4Y!CicvFZT-lmy}NuP`Ca! zh=R4}c%A+pK*BRqTm;JZM;6h^`a5*g$%w3{_?HkT?f0t;t|;*Y5^-e|b14EGMa|GE z%xPE?tcVAZuhGPfv#mssr2PZ3GuMwIKSg3L@}5i`!7meBO}h5)QKD#l5BLt0WFc0T zvjC(+n=Y_COG_yu?#=6>w{ler>nPPWq7){HE%rxM`dDUsc6eaGNAhjRCUTXo0Y%EU z;k}@v!n+1pfCW3@K2q#}!7%d##xvtLA43Ag98LX5j`ef#aSLNtTz0rZ1%Tf5BqjoJP2Rc4HU@mmj$UX13=K-cOondNOJ4@C`)CuiE1wSsrt|;7Qg;#Sd%XcX4>vvjV zVvdy9*58%YR#>;fWHJO-38ob$lc7=^7EF#Z#9=cO=1Z6MjhiR|?~;Q``v$+_8)R+6 zq3>E@ykq{gxCX>yiyi<1zSfIVFN1hb7Yhw!?24!8KoXRteEAsyM=?J?nn|`-x46t}4VBWOXTGj6A~Q5Br_RD_ zmGKVuvsL~ci2jFmV2DNg{fyWWs@n_8RW7+;(-JxsI+F6}DmknRFEVUQ?h6~nl|SeXt$JFbIpPyi*q?k>w%ZUwD4z$C*@*&-<;{GiLa+X}P&!tdbJ8ytf2%5eYvw+e4NLpRlgVst+V zbx#m4P}%S@Y$!9XFWHJ541&`aW3l&E5ImM+t15*t-3@)E zL;-?L+yyrAdb8MyK?X=`=y9vV3BD0VH3}SEC`an2pv^zVepG1v1Ab5GK87_ z6|)r`EpCf-;cB%K*~_{imr4++WX&gk0+4BmBM4k{7;#hYBiOogx>#ONlb?q!IlZZc zn$=}R@}?j<-Dq5Neii7>W3)$nQtu)-~c#g~o(;T8AY0sRcDf-L6t328FAw z*mM;V&BPT>#Y&0h>r~e@U3EmIa&=cZKe$$dnRf2@B6@>)J6bCH%Cf)!Yl4!FM zQ|XYzJRbJB)mB2c5;+1Sq4Cz+OcX}KL3$)^l=L8vMsub#_9}{l-?1Gzr;zuwNiaW^nkK!LSX1~!FHHZeU7g9s*nt+52YmD%25(uv+04~!E0}xT4~|MBS%F1zFp{d zQOJ9ZLbj0s+O9~5-@A&0`0Bqt3Bkk6{1oG>*CZPXrvRkGRTCf-M4ii=(%S;U;hYc- zXN7Q>I+|D03&zb|j4u2_B^c`I;xpR=B*2Y70Q5r`;ULGp4m9MrxJ*5Wl`!!#bjK2< zSk^e!8iQoOVe7#6j*NiaK5zg>5{|+9c^m)s$I_Scd(S?WxOJZ@^78Z3bF74%JYN^O za~vCtP;CM@ve~H&$Tlu{r0eHkNC_D=^k539M@)Vee(;#!9$c1NXa;W*eXg7#^GufA z8|Q?Ta2A`KQMCS%%oa8|aJkZ|EAZo#=jEGsaLcZ#$iJz=+C++`0f#=WvQJQ?glLkF z3_$@E)(9lJB)L9WFF*sC)N3KzABBG@htBaPp2s#GJfZ9yR0Xdw{uvM%{fFES>CmbN z;+30Fo_PfKWq~%wq+fN_E1rs6H#2h8{-E00tXrE2xuU(MwV4+)-`{w7YtB2{X5f<= z(Tce9 z@l{7JhlWQu;^OsX{6mekxzgI~vd3CX*LVPU3kp%mo4|04ukNAI(*3MQSC->LVCU$9 zM}JB)r(a)F9M_#3Q72y8@`|S)swlqIsldJU2H&;~o6sg9`E7|0eaANEJGR~6J9;zY zb@n@KGL_%;p|9$7zN(j({q@mf1<%uU&?6agDfB10|7qN!Z~gr;pW!7_F)tQs!E}4n|oY_LQh7=exrUBfy!h ziU=f5Yojb_hLNE5CxbbL+%I2}NkwI*oBU@oNRqiS~H|Y)4IC9$>@%f6Y z?W|?UTIzn>o6DGiX)fiX(7e;0 z1t{%n8-DAf(0|DQJ2vFMPhE#Na=ApMz>qz-8O0W&U7`_H7#hL44ho-!tM$mV%{bTI$vd~$x3UX)x|r59Iu zN|KAJ^wN%Gb8;~!HbAQ?1t&fone;`TRF2Ug;RPsRB<#nCL)xJL8LX#@9JTT0gPhhHh;-5o?;b zEf;M(5o?^N&qb+i`O4>@X(H)`uOK5P76_P*iQBnu`_(d{6SYpDz+!bYL#KYTJ;FEO zPU8D>h&G~xVs5NA74%@ub#RL@rz%jF?U)=>>9uwf8Zhfk_#=N!UN|%QBKp)BYtXj} z<*OPdkGWi-ocXaj9;OB=)Re*adKaRO=VIPe!`4Qcp#}pEp(ZAlk){ z!6&i4&ycIo~73Verj@OX~kf^%hBPRBD%hnT=MTp@A2x=F(J`TQstmH7A$X7}td07cGg(=Q=O>-@q zfSGQ_cKUO(kjr3|85xCEtB)Y_*G>kfu*kov?9;hs7-8OWf{{Q_{;EWD|~O zkPBo=2m4>Z)KIdx3mKtc4^^UOjpFMN2MX+ngj?c)_$Gj~Us+A`U{w&E)Pb~1RK32B zg70u}KLy|7;DH1`KHX05g~gXmWUz{Wc_)cNjQtR8+)05)5ZHo%{)^1`BB*_^z6MOW z_mJgnua{4cHE@mEH_$uG*UL2!eo+3ug*AUpi34{~M^Q@tL1z4}o)?%fW9 zR)|gLnhK$aSOQO1KNbEixFwFd$EMUni&Wp28Na8{M$y(f84-8a@`|fFz=|sRgK!)} z@)|U0C)go$17~vx@4yh8n&OiTb|p)g_Fu)=TWL>oSQIiD2M7{mDE}}}UDUv81-%c+ z3VW*dlH*-Wluhd|=b7@0l}HuQl9jaW?Cf1uWs%6TTIN~lYAao7rFAQ9K$CeXtf_a7 z@kbK8aDp(99-`?1`+yh%L)#xs4~>m@9~m2B*!HnqOYrRj1NFmMzchv3tev;gxM%Oi z`Tl@NZ=h-8QQ9}_{Q9Q6%;o`g=1eYW7bXyNE&ay1)cKBM9nYq=Jb0}0NZO-s;h}gl z<>@faO}uZb=9Ql4aO#-FTZjC?q?X|g+f zw#s8dkCMcw=lp{I=fI(iaoB%BVjvLgK#3hFwF70HffhM-2zQh4^c}x~cya+)cJY+% zQz(5{q4fOy< za#gD8P@!tSeTN;Z*f530Y<*dw=r3niPbOg78D zne@t&$(hdy7nuyUXkm1s5ywNy332~leZmW=qE2h<>2mA#E&SnJsq zXG(_dm~D_V19p=Ykgirj(&~m)(@g7blNnCt9+NqG5H1YPD7nrWzM0VWX*%74q>Rp7 zF9LlTZL44{ji|4UtO>~Wu%yk$q7uq*oR+h33k9F&l}(48{>G+E^C>Y3>R+KB@(WbNrvk>2WFXdELMaRX@q z4VThK5E7vnQ)7=|#9UCfjZ;(lti|+bBV3&bY+xGgUW+vR^_f(sc^E(1zi^NZ1^<>4 zwJ%siHE0=>D~^)+J83R!pW=K^k$*9>H4v{wDmj*dfQqoY{x&&JGIMq5UQ)=Qgjt0N zFjAKU?KCVx0^5g%;em`Y!b|vg@u7ueXtgWznw)@5V#AeJRP*t4L|`Wt4@8)Dg0_}; zZ88>Gi49aY(B}}ocN7rYxoxN!pE)uDj0Oa|uq7SYK^jiua)+Y^*bTxN2R0kE>vcn@ z&L^xP;AV$F&WZc=I$DQ;2z>JAzDNPV9Lk$_(uQ_7M|+?_hIM5-MYszm`2yQ~k5Nnh zhiuS|tZk}Awdm8EXs%v<*9sSL%B#A9!LAV0ynVLTgEgOcYnAJQ&=My*BHFFid}38q z2BI(xAsAdE0Y?5BD&ZM3z;covB+$XFHKT#$b_3=5ub;v7pJ{ky*hxhz;=xFekc8BR z444XPa#qIeuV1$w!F;433Vf-5!2DHa_kbxFy?^%)cRYOMYXe5_>D@nk_{vuX%-%Ck z_MF}T?m+6CKO|NkJStoCvk^nz{AGV?zHWHhr%5_C@%Qa%O4OiWLT`T@N+$Gt!g{30 zC~zC$QmV(C3j|M&!bgg4U4sm_J`N)*jv=G zr<3l}Nza)yozgaP=F7kh zmwc3gV`mr_fhJ(kp8NQUZ`mkSY8*>r#n6EJl+m~~UyUgj`#kX1jPN>Oogf!R5$$Cw z-3Me-5eaUDN9l-2ORQ~^FB$F*LF*4_p_BYW%3`0g8L-GlGbhQ) zMStF(I$gEQmGts<%&O<{Q~GKw=%S=o%;T6+s@}+hdj*M&ez4SLgqYGg9)dSWwJxoY zq4&+rrcP-;SIcv<4xr@RD;-6`!`Dv^Na9N~ZK2!GKLeno|e{0ouMmGTKr zJj0m#i!fFijk#fwDU2+CtPVUv*&QchbrZ{DjtIDh`ILG)0@mUuV?tgZiPcf9o=mJd zR=W_Ku;*g6U>#NCmCCg1Md`*v$@zlqo(m;y9^P-x`X`sA)osOa3k6ATGGp#HCvKuP zdhEQavcIiKHeG7Cm~7e|bz`@>t*xSuraceF(E0dwkhYjkFTzTI?wZFtH@*i?zlmrA2?e60{4lAxu~WA)Pmrb_hqxIFHn~Qi-kYB5y=xw%3dVzgZ(Jz;qwJ1{jMICkn(Iv(N14 ze?>I+EdWaYAp>xIkAUtX05ez&F9l!YcmEj$Sw+?Sa|%Am&~NYK$A5YN<%{B7f%WS{ z2)QBV?(W`1>L29h1h;s&F}Rg;eh<6iQOIXSeb5hU!!BiN#@d6Z+4zC=C|F%nuhBXq zI`gv5$D;Y4=nR29vA!c<=%)kF-#sG>23vtQ8J!F##bqkrNmlxI`!6-PvppvRvI((c z&O-I~oc~hYdB1GH4!xaEiS~{GR|K|gfdRvR2}W*oC@!=17ZoTJ+0GVnj(63$SR^F) z;7Y?8cTa#|PQL2#v1A5SOjECNY?Wev4{-1b1 zMT~}{ILR-d%@prwn3029XIsXAbPjh(?!-jie!1*daU?{`pT?^BUXTw z-psSRd4XPDgS}WwN31e(^96h&HMHiFo@^~tE!+4Lqz<~rnopl#3T*5aTt}U;LG3#oznhU#kL%a*m+(`pE;%dje@_FLgf1@ z@_IX58uLp5{DbLAo`$h;t|TI_UsV#oXBF`6gI8Dab~-6`!0pOhU}7V8q8;|kulw8e z(0~cK94vY2D$-?*d(s!yI`-J2^)Bh7tn5O=b)Q{!gOQP zfxpaU5Gw*>0olR3AbaQ%gS>fUl&UWRLM|5OFh!Y*A&8wFrP(@q`*TXBrqcIBDft@&5cYJ}CIXN(sp<|z{|%xpDnOB!5n+8Zzk01*%X5@K zwUEM+o%lF_@XqH1?FFd93D^!mB?CzPjjBr$Bv%zdBY@0M^-$c8IGd3ADaJQ?eA0H~ zT6}*CCJgD(ls61R&tY<{GmTha#Jh*A8Q}TTHfWGCYhZawADe;?rksa6@5jB}bUWAm zaJ1my^Iy%Y=UmW1U6$+}Cg-bbyqul*++&0IMA*=-LHH2e0ab6YyoKvfS(JG{u>jL{1aeYDW_RhFg8%8ZfRi9>hNW<(s}}ZOdLe}wbrZX-y1Vw zX@YK<=jcPje9t$pkTMQ+wc0|xHN=5H3aECMRgCp5UkJ8JtrCl{)96S9{(%Sg6E%&1NwLXUxPBd)+z&6Afy}&p;V4);XQ57VHy(V+Q^0kS^NzS0?9# zjLqjGfK5d73*k=L_;j=Tg?QO>AKhSQ zt3Wn?$Vgv#BMro}4NcbIckh(GI6qzD!yd4DySjF}y4guL)u;U?>9#9GVeOZyLbs|A zFVTKUtGCmilx!WM9W&3v-*J$u=Sv!8|9Zaj};R=rUna98h=f{R$QDQ=ai2w+8FS??64@y&pnEB@3>Vg+mGaxE8!mFC)q z31Y4#Q;Qm^iqI5)xy+_&mf3B{rP!Z3nJ>4G|E_kIhkEh}^iO?6i2ckH>`}lj0lR7`+o@RyTuxbAZ?t1jgu(KVrrwAf-GYuJ*WK- z?i3$D-=v_wtX9=K~UCpY0*JsHLivjQ>*7~(W$vJSWJNW*zRWUqHN zT$osy-_$X;NP{F-ic(bx3O^Tfqb!BU70j_nr^6W=*vniLoYYT1>UIN16`kwa*XXF< z(iU5S>0P&BnAU*d-olTW8t3?;Fp`Zk;WsC0!ukUk1UUzwvoi6E{IHO||2*ZV8p}n| zFYKU^xIpriLh!1<3ugyx`%)WK%cqjFfmQYY>eA>CVJDrz10losM%a6ltQYCZ;JW z*#xzavwBFk;jVrah;M54LHN&H4f|epGNwJL7w{Ob>T>B$>DmLeF$n(8Fa^mG%^F8aIHm#b2tTl_lt}#@P5l{bDD!8Ti=54JU7ioTVdzYg|k|=M;(x3yix8XtfCM%DGvB zl%FlXnu}WWAZ0MyxUu^C#2aw)H;zfR&zN-|uk+E@Ocp7w#qFwzDf+m} z_Wpi0o9yd{(JLG@^m<3YasV;Hud{ox2R3$i54md~XIA`u7xcOpW_@_)0h=Ep&7%H0 zKj6WGcY}sZl=peZ=Wsv|K)J`4fH;G{HFWzf|Cj2&tM z6cpgGJ-=kcs6)5ELM7rF?S-i?e?g&x&ty)rOXf`DXQvcAf21&j-wyt`g)KPg;X93!1J7x(>6T?q)q(O{jD=WX>Ik9nR^5fUq^ z;L9NQPU&tt7dcq8bG?*4e@gpDmGV*wk@r>P^-kkKA?*SD&h%x$t3917i^%U?RTjXL zb`D}2e^NzGq|Qt{VTaS_CiW`As?%l$Y-L2)3HI%0{hd0b^)6xSuFJt+?bMBAZ9`ve zc4B$tl}>4EHZ-{)JUP3{Q`VVd#2$xZL%7~2cIMhBw9lZ) zxJ}3t*R$m4(5CGODQcf7FJ$@_O?$fJ>~i%y)0d>nF=nuqqayv7uz#8MGusGqP#`Ry zFqk2%&LMj5KhxV8s%0g}NLqX4V-z$0$;k?iGw6R(opQ93d{1W$Df9oPU^Qp>X9^Z^ z@Lv$ru5j?z6#N?w{)U3z=imnvyhK44-zfhb2X%t72oZyV;HwPf`_}Uubg>e?tBBPa zT*bQ>Sh9&9rBoW)YafjlO0PQxe(22w{7@yy%P|-Wc%NM4x8r}}B|!H zNQK>4RaG1YtxRHc_Fj5qqM1(g&X~t>|B88>7cfO#f2RZa=ri3h+PX(3;0M_zpvf(= zCp+=C(epJCCRpp`qz%hmr=ej$M3$sH$;>e+G3Y%P`QL}=w8H<>KLkG4D&r_oa_W@V*Rogo(+ccWN)=&mjlD zidsdoY7|`F>#GwR4J8DBE&NtO4Oq$()@8k2`CQ09J1a`L4}@oDQ{Y^q#KfOzxO{Ny z`S%sGfNU%x*Cq+`Hqe0hDpI1`1AJJrC5n@{bvZ9E^Piw20|AS}X}l0?*EhkYm%b); z15BCmr-mZyu6w?|HuZdcjn#stxD>k0Cint9-7$QHDBLRCS|~w@6ovVh*L4R(jeK1V z^Bb9ytVlZQbj$%gJQA`(4evSn zDR^5-ZW`haAlW20d>u+mq_Q+unHa*}u$1pIV5|7)3ku~`o*B@nuc-1=hO2b9QjwEe zPu4%V+R=w&sZYt6h(^(LTI20%=sa+IAU6Z;HK^{a1dC-oHhh;+j<0_SUVH3%wq>H` z13XAy3ae=j#c(wa#9Kp9hi!$Pco5&(5?ybYpNX#ber1lv+ym{6nOB|ge0QN;L&rH= zG4K{5KMW=ob1kJX|6O#tw~He8gV-)E7-;d~&az$C1cJvHC2heU8$eqoC{JL3)@6SoMLJ zCWz^mnFr^(a3|VVx*;6Lry|xyh0QmQWgAH@bd>Vm%i7V97UR=i-Eb@eTOQ|FB8&Du zS4y`e?J@;jXDRrHxjMAp$p>G_XE<&x-ft~lPXIl8ADU7`OpGq(P`J+Wf%L=7_hd;iJNL%Ihh$fa6juv!J*#5sReDv!wDFb z*;U-{1uNKRw;lfPxaD96qY*hjdWCI<{nl*QZsEe!J3wwua`!CyYK_86p92+gKkgL2 zGhjF^w-^tdKGG{#NzhQ$t)@R9TrA$ve2iwvjkk%9=^3DSbsl;l6Fvv=+0hU1FV8cv z^|nbaLpenS-gVY>569kIjwu5Jp&QtDF4y!)zQXJCj7E-*3)yg1hgKMUZ3jy7q#kfY zb>&T<*nLj)Dj3xOM$PwxVbgz3FqCXeHbJBEOx3yy!7j-LMk3tNGqKvwCL4Aq8zATq z03)w#cz&^tA%N+J!YZp2RvDgxRr2OdOjQ9Jxwu!4VfbjpJ}zqS`V+VuG=u3&umeye zr00HxUId-ISy_lq$Q+8@?>WY_Y`}^LukU@PQuOz`tU#D5GcWUS>(9wm;FGuU8$P9W ztBVnbKF%bJ{`?$He1TcfE^@j>aqSDrvTTCHEDw+w6jlZg6=XiiI;Jk`BFg&dc(U$D zvR<$;A5bC_g2j{e6A+|PBiR7tUnZ1XJAG@%A-sY60QvAryYE40d8+T(!5peahdGq+ zzplJ}TdbCk!O5CrBflc1n8>hxs*T##Po0=1M)>9)nHqBtLl3ha9+e@vpJ}h*euh38 z2jq?h>m8X2Mtj;9W)w(;)rxj7`sk}-3O%u%%4O6U z_i=<1pBj;ei&9?7nP%(+b?1RhNtWJqzah1J>0L`#3s2PCkBT;<_>I^URN6KLY-GeO z*@xoG*f4~n&nvYJ17;sal0Xi718Vb^AXqu{uPIbX!JfU!sI)~dh$WjcB2_>*R)=Y> zghT*R08IBiBtF3|Vp9U`OYR$DCgWBaxLROBeRXx+#G`Oo)2B*Az6?yd&A!ViX-Ms4 zedJ>F&53nW1R4Ku4IxO`heT{85x*Q3m$pKMu=}= z`0kajp{{1Nk5bz`i0csNt?DX9iIR?eg_+7E|ez=*NnYa9A*K(M3E0~rt3 zf53P!&qaF+WAR~^I#UsS3%HM4xQ(v=VKA4*^-wKC|1WVpBUYn4Rr1lRsX-E2SFM;L zw;92N*k;*{MC!qJ09c$|2_|}7AMmZt^?_!x=kS}61E$Meo8sYhq3+BHd^L9VhW^2^ ze(yr>#{S`<{rLFTFx)${Vg#n6{QCbzVW2!S3!K*pW|Rby!I+;ESmYj2mcQ% CFpQ@F diff --git a/sources/XCLC-TOP-LEVEL.~10~ b/sources/XCLC-TOP-LEVEL.~10~ deleted file mode 100644 index e38913ca..00000000 --- a/sources/XCLC-TOP-LEVEL.~10~ +++ /dev/null @@ -1,4 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "19-Sep-2020 22:02:59"  IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;10| 78326 IL:|changes| IL:|to:| (IL:FUNCTIONS START-COMPILATION) IL:|previous| IL:|date:| "19-Sep-2020 21:33:34" IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1994, 2020 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS) (IL:RPAQQ IL:XCLC-TOP-LEVELCOMS ( (IL:* IL:|;;| "Top-level entry points ") (IL: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:\; "Edited 19-Sep-2020 22:02 by rmk:") (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*)) (FILECREATED (IL:READ-FILECREATED *INPUT-STREAM*))) (IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around") (IL:PRINTOUT FASL-STREAM "XCL Compiler output for source file " IL:\# (IL:PRIN3 (OR (CADDR FILECREATED) (NAMESTRING *INPUT-FILENAME*)) FASL-STREAM) T "Source file created " IL:\# (IL:PRIN3 (OR (CADR FILECREATED) (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*))) FASL-STREAM) T "FASL file created " IL:\# (IL:PRIN3 (DATE-STRING (GET-UNIVERSAL-TIME)) FASL-STREAM) T)) (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 2020)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (7050 7194 (COMPILER-ERROR 7050 . 7194)) (8749 17618 (COMPILE-FILE 8749 . 17618)) ( 17620 20017 (START-COMPILATION 17620 . 20017)) (20019 21292 (FINISH-COMPILATION 20019 . 21292)) (21294 26872 (SCAN-ONE-FORM 21294 . 26872)) (26874 27071 (FUNCTION-P 26874 . 27071)) (28998 29614 ( CHECK-FOR-UNKNOWN-FUNCTION 28998 . 29614)) (29616 29870 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29616 . 29870)) (31345 31475 (ASSEMBLER-ERROR 31345 . 31475)) (33238 38333 (SET-UP-BLOCK-DECLS 33238 . 38333)) (38481 39021 (CONSTANT-EXPRESSION-P 38481 . 39021)) (39023 40665 (COMPILE-AND-DUMP 39023 . 40665)) (40667 42619 (COMPILE-AND-DUMP-1 40667 . 42619)) (42621 43312 (COMPILE-ONE-LAMBDA 42621 . 43312)) (43314 44035 (OPTIMIZE-AND-MACROEXPAND 43314 . 44035)) (44037 45685 (OPTIMIZE-AND-MACROEXPAND-1 44037 . 45685 )) (45893 49547 (PROCESS-FORMS 45893 . 49547)) (49549 49684 (MAYBE-REMOVE-COMMENTS 49549 . 49684)) ( 49686 50599 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49686 . 50599)) (50601 51400 (COMPILE-FILE-DEFINEQ 50601 . 51400)) (51402 52329 (COMPILE-FILE-DEFCONSTANT 51402 . 52329)) (52331 54264 ( COMPILE-FILE-DECLARE\: 52331 . 54264)) (54266 54828 (COMPILE-FILE-DEFINE-FILE-INFO 54266 . 54828)) ( 54830 55074 (COMPILE-FILE-PACKAGE-FORM 54830 . 55074)) (55076 57795 (COMPILE-FILE-PROCLAMATION 55076 . 57795)) (57797 59208 (COMPILE-FILE-COMPILER-LET 57797 . 59208)) (59210 59890 (COMPILE-FILE-MACROLET 59210 . 59890)) (59892 60882 (COMPILE-FILE-DEFINER 59892 . 60882)) (60884 61812 ( COMPILE-FILE-NAMED-PROGN 60884 . 61812)) (61814 62464 (COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61814 . 62464)) (62466 62608 (COMPILE-FILE-LOOSE-FORM 62466 . 62608)) (62610 62929 ( COMPILE-FILE-PROCESS-FUNCTION 62610 . 62929)) (62931 63608 (CRACK-DEFMACRO 62931 . 63608)) (63610 63893 (ESTABLISH-MACRO-IN-COMPILER 63610 . 63893)) (64587 66834 (COMPILE-SCAN-DECLARE\: 64587 . 66834) ) (66836 67198 (COMPILE-SCAN-DEFINE-FILE-INFO 66836 . 67198)) (67200 68114 (COMPILE-SCAN-MACROLET 67200 . 68114)) (68116 68751 (COMPILE-SCAN-DEFINER 68116 . 68751)) (68753 68886 ( COMPILE-SCAN-LOOSE-FORM 68753 . 68886)) (68888 68962 (COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68888 . 68962)) (68964 69412 (MERGE-FIRST-FORMS 68964 . 69412)) (69537 71788 (COMPILE 69537 . 71788)) (71790 72043 (COMPILE-DEFINER 71790 . 72043)) (72045 73084 (COMPILE-FORM 72045 . 73084)) (73086 73958 ( RAW-COMPILE 73086 . 73958)) (73960 75059 (COMPILE-DEFINER-DEFINER 73960 . 75059)) (75061 75899 ( COMPILE-DEFINER-NAMED-PROGN 75061 . 75899)) (75901 76736 (COMPILE-DEFINER-PROCESS-FUNCTION 75901 . 76736)) (76738 77694 (COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76738 . 77694))))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-TOP-LEVEL.~1~ b/sources/XCLC-TOP-LEVEL.~1~ deleted file mode 100644 index e60f79ae..00000000 --- a/sources/XCLC-TOP-LEVEL.~1~ +++ /dev/null @@ -1,1557 +0,0 @@ -(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